diff --git a/.circleci/config.yml b/.circleci/config.yml old mode 100644 new mode 100755 diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS old mode 100644 new mode 100755 diff --git a/.github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md b/.github/PULL_REQUEST_TEMPLATE/auto_pr_to_mapl3.md old mode 100644 new mode 100755 diff --git a/.github/workflows/enforce-labels.yml b/.github/workflows/enforce-labels.yml old mode 100644 new mode 100755 diff --git a/.github/workflows/push-to-develop.yml b/.github/workflows/push-to-develop.yml old mode 100644 new mode 100755 diff --git a/.gitignore b/.gitignore old mode 100644 new mode 100755 diff --git a/CMakeLists.txt b/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md old mode 100644 new mode 100755 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md old mode 100644 new mode 100755 diff --git a/COPYRIGHT b/COPYRIGHT old mode 100644 new mode 100755 diff --git a/GCM_Preamble.tex b/GCM_Preamble.tex old mode 100644 new mode 100755 diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/.gitignore b/GEOSagcm_GridComp/GEOSphysics_GridComp/.gitignore old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOS_PhysicsGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_GridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_GridComp.rc old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/gw_drag.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/gw_drag.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/gwdc.f b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/gwdc.f old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/gwdps.f b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/gwdps.f old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/machine.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/machine.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/coords_1d.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/coords_1d.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_common.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_oro.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_rdg.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_utils.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_utils.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/interpolate_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/interpolate_data.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/linear_1d_operators.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/linear_1d_operators.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/vdiff_lu_solver.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/vdiff_lu_solver.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF_GEOS5.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF_GEOS5.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF_Shared.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF_Shared.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_RAS_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_RAS_InterfaceMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/RASPARAMS.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/RASPARAMS.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.rc old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/WSUB_ExtData.yaml old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cldwat2m_micro.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cloudnew.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/cloudnew.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ddf.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ddf.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_cloud_microphys.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/isccp_call.code b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/isccp_call.code old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/isccp_decls.code b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/isccp_decls.code old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/micro_mg3_0.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/micro_mg3_0.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/micro_mg_utils.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/micro_mg_utils.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_gate.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/module_gate.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/qsat.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/qsat.h old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ras.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ras.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/rascnvv2_v.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/rascnvv2_v.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/wv_saturation.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/wv_saturation.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 old mode 100644 new mode 100755 index a5aa010e1..a2872549f --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 @@ -253,10 +253,10 @@ subroutine SetServices ( GC, RC ) call MAPL_GetResource (SCF, landicegoswim, label='N_CONST_LANDICE4SNWALB:', DEFAULT=0, __RC__ ) if (LSM_CHOICE.eq.1) then call MAPL_GetResource (SCF, LAND_PARAMS, label='LAND_PARAMS:', DEFAULT="NRv7.2", __RC__ ) - elseif (LSM_CHOICE.eq.2) then - call MAPL_GetResource (SCF, LAND_PARAMS, label='LAND_PARAMS:', DEFAULT="CN_CLM40", __RC__ ) -! elseif (LSM_CHOICE.eq.3) then -! call MAPL_GetResource (SCF, LAND_PARAMS, label='LAND_PARAMS:', DEFAULT="CN_CLM45", __RC__ ) + elseif (LSM_CHOICE.eq.2) then + call MAPL_GetResource (SCF, LAND_PARAMS, label='LAND_PARAMS:', DEFAULT="CN_CLM40", __RC__ ) + elseif (LSM_CHOICE.eq.4) then + call MAPL_GetResource (SCF, LAND_PARAMS, label='LAND_PARAMS:', DEFAULT="CN_CLM51", __RC__ ) else _ASSERT(.FALSE.,'unknown LSM_CHOICE') end if @@ -3001,7 +3001,7 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - if (LSM_CHOICE == 3) then + if (LSM_CHOICE >= 3) then call MAPL_AddExportSpec(GC ,& LONG_NAME = 'CN_fine_root_carbon' ,& UNITS = 'kg m-2' ,& @@ -3039,6 +3039,24 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_autotrophic_respiration' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNAR' ,& + DIMS = MAPL_DimsHorzOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_heterotrophic_respiration' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNHR' ,& + DIMS = MAPL_DimsHorzOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'CN_net_ecosystem_exchange' ,& UNITS = 'kg m-2 s-1' ,& @@ -5643,6 +5661,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: CNNPP => NULL() real, pointer, dimension(:,:) :: CNGPP => NULL() real, pointer, dimension(:,:) :: CNSR => NULL() + real, pointer, dimension(:,:) :: CNAR => NULL() + real, pointer, dimension(:,:) :: CNHR => NULL() real, pointer, dimension(:,:) :: CNNEE => NULL() real, pointer, dimension(:,:) :: CNXSMR => NULL() real, pointer, dimension(:,:) :: CNADD => NULL() @@ -5948,6 +5968,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:) :: CNNPPTILE => NULL() real, pointer, dimension(:) :: CNGPPTILE => NULL() real, pointer, dimension(:) :: CNSRTILE => NULL() + real, pointer, dimension(:) :: CNARTILE => NULL() + real, pointer, dimension(:) :: CNHRTILE => NULL() real, pointer, dimension(:) :: CNNEETILE => NULL() real, pointer, dimension(:) :: CNXSMRTILE => NULL() real, pointer, dimension(:) :: CNADDTILE => NULL() @@ -6832,8 +6854,10 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT , CNTOTC , 'CNTOTC' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , CNVEGC , 'CNVEGC' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , CNROOT , 'CNROOT' , RC=STATUS); VERIFY_(STATUS) - if (LSM_CHOICE == 3) then + if (LSM_CHOICE >= 3) then call MAPL_GetPointer(EXPORT , CNFROOTC, 'CNFROOTC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT , CNAR, 'CNAR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT , CNHR, 'CNHR' ,RC=STATUS); VERIFY_(STATUS) endif call MAPL_GetPointer(EXPORT , CNNPP , 'CNNPP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , CNGPP , 'CNGPP' , RC=STATUS); VERIFY_(STATUS) @@ -7466,8 +7490,10 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MKTILE(CNTOTC ,CNTOTCTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(CNVEGC ,CNVEGCTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(CNROOT ,CNROOTTILE ,NT,RC=STATUS); VERIFY_(STATUS) - if (LSM_CHOICE == 3) then - call MKTILE(CNFROOTC,CNFROOTCTILE ,NT,RC=STATUS);VERIFY_(STATUS) + if (LSM_CHOICE >= 3) then + call MKTILE(CNFROOTC,CNFROOTCTILE ,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(CNAR ,CNARTILE ,NT,RC=STATUS); VERIFY_(STATUS) + call MKTILE(CNHR ,CNHRTILE ,NT,RC=STATUS); VERIFY_(STATUS) endif call MKTILE(CNNPP ,CNNPPTILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(CNGPP ,CNGPPTILE ,NT,RC=STATUS); VERIFY_(STATUS) @@ -8404,6 +8430,14 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_LocStreamTransform( LOCSTREAM,CNSR ,CNSRTILE , RC=STATUS) VERIFY_(STATUS) endif + if(associated(CNAR)) then + call MAPL_LocStreamTransform( LOCSTREAM,CNAR ,CNARTILE , RC=STATUS) + VERIFY_(STATUS) + endif + if(associated(CNHR)) then + call MAPL_LocStreamTransform( LOCSTREAM,CNHR ,CNHRTILE , RC=STATUS) + VERIFY_(STATUS) + endif if(associated(CNNEE)) then call MAPL_LocStreamTransform( LOCSTREAM,CNNEE ,CNNEETILE , RC=STATUS) VERIFY_(STATUS) @@ -9039,6 +9073,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(CNNPPTILE )) deallocate(CNNPPTILE ) if(associated(CNGPPTILE )) deallocate(CNGPPTILE ) if(associated(CNSRTILE )) deallocate(CNSRTILE ) + if(associated(CNARTILE )) deallocate(CNARTILE ) + if(associated(CNHRTILE )) deallocate(CNHRTILE ) if(associated(CNNEETILE )) deallocate(CNNEETILE ) if(associated(CNXSMRTILE )) deallocate(CNXSMRTILE ) if(associated(CNADDTILE )) deallocate(CNADDTILE ) @@ -9416,8 +9452,13 @@ subroutine DOTYPE(type,RC) VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'CNROOT' , ALLOC=associated(CNROOTTILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) - if (LSM_CHOICE == 3) then + if (LSM_CHOICE >= 3) then call MAPL_GetPointer(GEX(type), dum, 'CNFROOTC' , ALLOC=associated(CNFROOTCTILE), notFoundOK=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(GEX(type), dum, 'CNAR' , ALLOC=associated(CNARTILE ), notFoundOK=.true., RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(GEX(type), dum, 'CNHR' , ALLOC=associated(CNHRTILE ), notFoundOK=.true., RC=STATUS) + VERIFY_(STATUS) endif VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'CNNPP' , ALLOC=associated(CNNPPTILE ), notFoundOK=.true., RC=STATUS) @@ -10085,6 +10126,14 @@ subroutine DOTYPE(type,RC) call FILLOUT_TILE(GEX(type), 'CNSR' , CNSRTILE , XFORM, RC=STATUS) VERIFY_(STATUS) end if + if(associated(CNARTILE)) then + call FILLOUT_TILE(GEX(type), 'CNAR' , CNARTILE , XFORM, RC=STATUS) + VERIFY_(STATUS) + end if + if(associated(CNHRTILE)) then + call FILLOUT_TILE(GEX(type), 'CNHR' , CNHRTILE , XFORM, RC=STATUS) + VERIFY_(STATUS) + end if if(associated(CNNEETILE)) then call FILLOUT_TILE(GEX(type), 'CNNEE' , CNNEETILE , XFORM, RC=STATUS) VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlake_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlake_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlake_GridComp/GEOS_LakeGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlake_GridComp/GEOS_LakeGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 old mode 100644 new mode 100755 index 69d73008e..58744cb9a --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 @@ -177,7 +177,7 @@ subroutine SetServices ( GC, RC ) end do end if - CASE (2,3) + CASE (2,3,4) allocate (CATCHCN(NUM_CATCH), stat=status) VERIFY_(STATUS) @@ -972,7 +972,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'ROC002', CHILD_ID = CATCH(1), RC=STATUS) ; VERIFY_(STATUS) end if - CASE (2,3) ! CatchmentCN model + CASE (2,3,4) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'LST', CHILD_ID = CATCHCN(1), RC=STATUS ) VERIFY_(STATUS) @@ -1244,9 +1244,13 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNROOT' , CHILD_ID = CATCHCN(1), RC=STATUS ) VERIFY_(STATUS) - if (LSM_CHOICE == 3) then + if (LSM_CHOICE >= 3) then call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNFROOTC' , CHILD_ID = CATCHCN(1), RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNAR' , CHILD_ID = CATCHCN(1), RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNHR' , CHILD_ID = CATCHCN(1), RC=STATUS ) + VERIFY_(STATUS) endif call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNNPP' , CHILD_ID = CATCHCN(1), RC=STATUS ) VERIFY_(STATUS) @@ -1464,7 +1468,7 @@ subroutine SetServices ( GC, RC ) ! VERIFY_(STATUS) ! ENDIF - CASE (2,3) + CASE (2,3,4) call MAPL_AddConnectivity ( & GC , & SHORT_NAME = (/'LAI ', 'GRN ', 'ROOTL ', 'Z2CH ', & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/CMakeLists.txt old mode 100644 new mode 100755 index 5eb959f4d..20df6805e --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/CMakeLists.txt @@ -2,6 +2,7 @@ esma_set_this () add_subdirectory (GEOScatchCNCLM40_GridComp) add_subdirectory (GEOScatchCNCLM45_GridComp) +add_subdirectory (GEOScatchCNCLM51_GridComp) esma_add_library (${this} SRCS GEOS_CatchCNGridComp.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 old mode 100644 new mode 100755 index 05b20561d..24077c5c3 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOS_CatchCNGridComp.F90 @@ -113,11 +113,11 @@ subroutine SetServices ( GC, RC ) if ( LSM_CHOICE == 2 ) then CATCHCN = MAPL_AddChild('CATCHCNCLM40'//trim(tmp), 'setservices_', parentGC=GC, sharedObj='libGEOScatchCNCLM40_GridComp.so', RC=STATUS) VERIFY_(STATUS) -! else if ( LSM_CHOICE == 3 ) then -! CATCHCN = MAPL_AddChild('CATCHCNCLM45'//trim(tmp), 'setservices_', parentGC=GC, sharedObj='libGEOScatchCNCLM45_GridComp.so', RC=STATUS) -! VERIFY_(STATUS) + else if ( LSM_CHOICE == 4 ) then + CATCHCN = MAPL_AddChild('CATCHCNCLM51'//trim(tmp), 'setservices_', parentGC=GC, sharedObj='libGEOScatchCNCLM51_GridComp.so', RC=STATUS) + VERIFY_(STATUS) else - _ASSERT( .false., " LSM_CHOICE should equal 2 (CLM40)") + _ASSERT( .false., " LSM_CHOICE should equal 2 (CLM40) or 4 (CLM51)") endif wrap%ptr =>CATCHCN_INTERNAL_STATE @@ -936,9 +936,13 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNROOT' , CHILD_ID = CATCHCN, RC=STATUS ) VERIFY_(STATUS) - if (LSM_CHOICE == 3) then + if (LSM_CHOICE >= 3) then ! jkolassa: needed for CNCLM51 call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNFROOTC' , CHILD_ID = CATCHCN, RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNAR' , CHILD_ID = CATCHCN, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNHR' , CHILD_ID = CATCHCN, RC=STATUS ) + VERIFY_(STATUS) endif call MAPL_AddExportSpec ( GC, SHORT_NAME = 'CNNPP' , CHILD_ID = CATCHCN, RC=STATUS ) VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNAllocationMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNAllocationMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNAnnualUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNAnnualUpdateMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNBalanceCheckMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNBalanceCheckMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate1Mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate2Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate2Mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate3Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate3Mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNDecompCascadeMod_BGC.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNDecompCascadeMod_BGC.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNDecompMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNDecompMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNEcosystemDynMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNEcosystemDynMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNGRespMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNGRespMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNGapMortalityMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNGapMortalityMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNMRespMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNMRespMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNDynamicsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNDynamicsMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate1Mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate2Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate2Mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate3Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate3Mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNitrifDenitrifMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNitrifDenitrifMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNPhenologyMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNPhenologyMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNPrecisionControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNPrecisionControlMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSetValueMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSetValueMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSoilLittVertTranspMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSoilLittVertTranspMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSummaryMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSummaryMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNVegStructUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNVegStructUpdateMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNVerticalProfileMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNVerticalProfileMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNWoodProductsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNWoodProductsMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CN_DriverMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CN_DriverMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNiniTimeVar.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNiniTimeVar.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/TridiagonalMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/TridiagonalMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_time_manager.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_time_manager.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varcon.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varctl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varctl.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varpar.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varpar.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clmtype.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clmtype.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clmtypeInitMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clmtypeInitMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/compute_rc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/compute_rc.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/getco2.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/getco2.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/pftvarcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/pftvarcon.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/shr_const_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/shr_const_mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/subgridAveMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/subgridAveMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/update_model_para4cn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/update_model_para4cn.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/AnnualFluxDribbler.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/AnnualFluxDribbler.F90 new file mode 100755 index 000000000..5729551a7 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/AnnualFluxDribbler.F90 @@ -0,0 +1,679 @@ +module AnnualFluxDribbler + +#include "shr_assert.h" + + !--------------------------------------------------------------------------- + ! !DESCRIPTION: + ! + ! Defines a class for handling fluxes that are generated once per year (e.g., due to + ! transient landcover changes that happen at the year boundary), but are meant to be + ! dribbled in evenly throughout the year. + ! + ! This assumes that the once-per-year fluxes are generated on the first timestep of the + ! year. Any flux given on the first timestep of the year is dribbled evenly for every + ! timestep of the coming year. Any flux given on other timesteps is applied entirely in + ! the current timestep. (Note that, if there is a combination of an annual flux and an + ! every-time-step flux, with both combined in the same delta term, then, on the first + ! timestep of the year, the every-time-step flux generated on that timestep will be + ! dribbled over the year rather than applied in that timestep.) + ! + ! NOTE(wjs, 2016-08-30) If we change the glc coupling time to be more frequent, then + ! we'll need to make this more dynamic: e.g., for coupling every 73 days (5 times per + ! year), we'd need to dribble fluxes over the next 73 days. + ! + ! Typical usage: + ! + ! - call mydribbler%set_curr_delta every time step + ! + ! This must be called every timestep, even if the delta is currently zero, in order + ! to zero out any existing stored delta. This can (and generally should) even be + ! called when it isn't the first timestep of the year. For deltas that are non-zero + ! at times other than the first timestep of the year, they will simply be passed on + ! to the output flux in get_curr_flux, making for easier handling by the client. + ! + ! - call mydribbler%get_curr_flux every time step, AFTER set_curr_delta + ! + ! This will get the current flux for this timestep, which is the sum of (1) the + ! dribbled flux from the last start-of-year timestep, and (2) the current timestep's + ! flux, based on the delta passed in to set_curr_delta in this timestep, if this is + ! not the start-of-year timestep. + ! + ! Alternatively, you can call mydribbler%get_dribbled_delta, if you need the result as + ! a delta over the time step rather than as a per-second flux. + ! + ! And, for the sake of checking conservation: + ! + ! - To get gridcell water (or whatever) content at the start of the time step: + ! + ! call mydribbler%get_amount_left_to_dribble_beg + ! + ! - To get gridcell water (or whatever) content at the end of the time step: + ! + ! call mydribbler%get_amount_left_to_dribble_end + ! + ! These both return the pseudo-state representing how much of the original delta + ! still needs to be dribbled. The 'beg' version includes the amount left to dribble + ! in the current time step; the 'end' version does not. + ! + ! + ! !USES: + use clm_varctl , only : iulog + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type, get_beg, get_end + use decompMod , only : BOUNDS_SUBGRID_GRIDCELL, BOUNDS_SUBGRID_PATCH + use clm_varcon , only : secspday, nameg, namep + use clm_time_manager , only : get_days_per_year, get_step_size_real, is_beg_curr_year + use clm_time_manager , only : get_curr_yearfrac, get_prev_yearfrac, get_prev_date + use clm_time_manager , only : is_first_step + ! + implicit none + private + + ! Compiler support for allocatable characters isn't fully robust (particularly for + ! pgi), so using a max lengths for now + ! + ! (If we used allocatable characters, these max lengths could be removed + integer, parameter :: name_maxlen = 128 + integer, parameter :: units_maxlen = 64 + integer, parameter :: subgrid_maxlen = 64 + + ! !PUBLIC TYPES: + + type, public :: annual_flux_dribbler_type + private + ! Metadata + character(len=name_maxlen) :: name + character(len=units_maxlen) :: units + + ! Whether this dribbler allows non-zero deltas on time steps other than the first + ! time step of the year + logical :: allows_non_annual_delta + + ! Which subgrid level this dribbler is operating at, stored in various ways + character(len=subgrid_maxlen) :: dim1name + character(len=subgrid_maxlen) :: name_subgrid + integer :: bounds_subgrid_level + + ! Annual amount to dribble in over the year + real(r8), pointer :: amount_to_dribble(:) + + ! Amount from the current timestep to pass through to the flux, if this isn't the + ! first timestep of the year + real(r8), pointer :: amount_from_this_timestep(:) + contains + ! Public infrastructure methods + ! procedure, public :: Restart + ! procedure, public :: Clean + + ! Public science methods + procedure, public :: set_curr_delta ! Set the delta state for this time step + procedure, public :: get_curr_flux ! Get the current flux for this time step + ! procedure, public :: get_dribbled_delta ! Similar to get_curr_flux, but gets result as a delta rather than a per-second flux + procedure, public :: get_amount_left_to_dribble_beg ! Get the pseudo-state representing the amount that still needs to be dribbled in this and future time steps + procedure, public :: get_amount_left_to_dribble_end ! Get the pseudo-state representing the amount that still needs to be dribbled in just future time steps + + ! Private methods + procedure, private :: allocate_and_initialize_data + procedure, private :: set_metadata + procedure, private :: get_amount_left_to_dribble + end type annual_flux_dribbler_type + + public :: annual_flux_dribbler_gridcell ! Creates an annual_flux_dribbler_type object at the gridcell-level + public :: annual_flux_dribbler_patch ! Creates an annual_flux_dribbler_type object at the patch-level + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + ! ======================================================================== + ! Factory methods + ! + ! For now, there are only factory methods for gridcell-level and patch-level. But + ! adding the ability to work at other levels is as easy as adding another factory + ! method like this (along with some variables in the 'only' clauses of the 'use' + ! statements). + ! ======================================================================== + + !----------------------------------------------------------------------- + function annual_flux_dribbler_gridcell(bounds, name, units, allows_non_annual_delta) & + result(this) + ! + ! !DESCRIPTION: + ! Creates an annual_flux_dribbler_type object at the gridcell-level + ! + ! !USES: + ! + ! !ARGUMENTS: + type(annual_flux_dribbler_type) :: this ! function result + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: name ! name of this object, used for i/o + character(len=*) , intent(in) :: units ! units metadata - should be state units, not flux (i.e., NOT per-second) + + ! If allows_non_annual_delta is .false., then an error check is performed for each + ! call to set_curr_delta, ensuring that the delta is 0 at all times other than the + ! first time step of the year. This is just provided as a convenient sanity check - + ! to ensure that the code is behaving as expected. (However, non-zero deltas are + ! always allowed on the first step of the run.) + ! + ! If allows_non_annual_delta is not provided, it is assumed to be .true. + logical, intent(in), optional :: allows_non_annual_delta + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'annual_flux_dribbler_gridcell' + !----------------------------------------------------------------------- + + this%dim1name = 'gridcell' + this%name_subgrid = nameg + this%bounds_subgrid_level = BOUNDS_SUBGRID_GRIDCELL + + call this%allocate_and_initialize_data(bounds) + call this%set_metadata(name, units, allows_non_annual_delta) + + end function annual_flux_dribbler_gridcell + + !----------------------------------------------------------------------- + function annual_flux_dribbler_patch(bounds, name, units, allows_non_annual_delta) & + result(this) + ! + ! !DESCRIPTION: + ! Creates an annual_flux_dribbler_type object at the patch-level + ! + ! !USES: + ! + ! !ARGUMENTS: + type(annual_flux_dribbler_type) :: this ! function result + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: name ! name of this object, used for i/o + character(len=*) , intent(in) :: units ! units metadata - should be state units, not flux (i.e., NOT per-second) + + ! If allows_non_annual_delta is .false., then an error check is performed for each + ! call to set_curr_delta, ensuring that the delta is 0 at all times other than the + ! first time step of the year. This is just provided as a convenient sanity check - + ! to ensure that the code is behaving as expected. + ! + ! If allows_non_annual_delta is not provided, it is assumed to be .true. + logical, intent(in), optional :: allows_non_annual_delta + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'annual_flux_dribbler_patch' + !----------------------------------------------------------------------- + + this%dim1name = 'pft' + this%name_subgrid = namep + this%bounds_subgrid_level = BOUNDS_SUBGRID_PATCH + + call this%allocate_and_initialize_data(bounds) + call this%set_metadata(name, units, allows_non_annual_delta) + + end function annual_flux_dribbler_patch + + ! ======================================================================== + ! Public methods + ! ======================================================================== + + !----------------------------------------------------------------------- + subroutine set_curr_delta(this, bounds, delta) + ! + ! !DESCRIPTION: + ! Sets the delta state for this time step. Note that the delta is specified just as + ! the change in state - NOT as a flux (per-second) quantity. + ! + ! This must be called every timestep, even if the deltas are currently 0, in order to + ! zero out any existing stored delta. This can (and generally should) even be called + ! when it isn't the first timestep of the year. For deltas that are non-zero at times + ! other than the first timestep of the year, they will simply be passed on to the + ! output flux in get_curr_flux, making for easier handling by the client. (i.e., this + ! class handles the addition of the dribbled flux and the current flux for you.) + ! + ! !USES: + ! + ! !ARGUMENTS: + class(annual_flux_dribbler_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + real(r8), intent(in) :: delta( get_beg(bounds, this%bounds_subgrid_level) : ) + ! + ! !LOCAL VARIABLES: + integer :: beg_index, end_index + integer :: i + integer :: yr, mon, day, tod + + character(len=*), parameter :: subname = 'set_curr_delta' + !----------------------------------------------------------------------- + + beg_index = lbound(delta, 1) + end_index = get_end(bounds, this%bounds_subgrid_level) + SHR_ASSERT_ALL_FL((ubound(delta) == (/end_index/)), sourcefile, __LINE__) + + if (is_beg_curr_year()) then + do i = beg_index, end_index + this%amount_to_dribble(i) = delta(i) + + ! On the first timestep of the year, we don't have any pass-through flux. Need + ! to zero out any previously-set amount_from_this_timestep. + this%amount_from_this_timestep(i) = 0._r8 + end do + else + do i = beg_index, end_index + this%amount_from_this_timestep(i) = delta(i) + end do + if (.not. this%allows_non_annual_delta .and. .not. is_first_step()) then + do i = beg_index, end_index + if (this%amount_from_this_timestep(i) /= 0._r8) then + write(iulog,*) subname//' ERROR: found unexpected non-zero delta mid-year' + write(iulog,*) 'Dribbler name: ', trim(this%name) + write(iulog,*) 'i, delta = ', i, this%amount_from_this_timestep(i) + call get_prev_date(yr, mon, day, tod) + write(iulog,*) 'Start of time step date (yr, mon, day, tod) = ', & + yr, mon, day, tod + write(iulog,*) 'This indicates that some non-zero flux was generated at a time step' + write(iulog,*) 'other than the first time step of the year, which this dribbler was told not to expect.' + write(iulog,*) 'If this non-zero mid-year delta is expected, then you can suppress this error' + write(iulog,*) 'by setting allows_non_annual_delta to .true. when constructing this dribbler.' + call endrun(decomp_index=i, clmlevel=this%name_subgrid, & + msg=subname//': found unexpected non-zero delta mid-year: ' // & + errMsg(sourcefile, __LINE__)) + end if + end do + end if + end if + + end subroutine set_curr_delta + +! !----------------------------------------------------------------------- + subroutine get_curr_flux(this, bounds, flux) + ! + ! !DESCRIPTION: + ! Gets the current flux for this timestep, and stores it in the flux argument. + ! + ! This should be called AFTER set_curr_delta is called for the given timestep. + ! + ! This will get the current flux for this timestep, which is the sum of (1) the + ! dribbled flux from the last start-of-year timestep, and (2) the current timestep's + ! flux, based on the delta passed in to set_curr_delta in this timestep, if this is + ! not the start-of-year timestep. + ! + ! !USES: + ! + ! !ARGUMENTS: + class(annual_flux_dribbler_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8), intent(out) :: flux( get_beg(bounds, this%bounds_subgrid_level) : ) + ! + ! !LOCAL VARIABLES: + integer :: beg_index, end_index + integer :: i + real(r8) :: secs_per_year + real(r8) :: dtime + real(r8) :: flux_from_dribbling + real(r8) :: flux_from_this_timestep + + character(len=*), parameter :: subname = 'get_curr_flux' + !----------------------------------------------------------------------- + + beg_index = lbound(flux, 1) + end_index = get_end(bounds, this%bounds_subgrid_level) + SHR_ASSERT_ALL_FL((ubound(flux) == (/end_index/)), sourcefile, __LINE__) + + secs_per_year = get_days_per_year() * secspday + dtime = get_step_size_real() + + do i = beg_index, end_index + flux_from_dribbling = this%amount_to_dribble(i) / secs_per_year + flux_from_this_timestep = this%amount_from_this_timestep(i) / dtime + flux(i) = flux_from_dribbling + flux_from_this_timestep + end do + + end subroutine get_curr_flux +! +! !----------------------------------------------------------------------- +! subroutine get_dribbled_delta(this, bounds, delta) +! ! +! ! !DESCRIPTION: +! ! Gets the current delta for this timestep, and stores it in the delta argument. +! ! +! ! This is similar to get_curr_flux, but returns the total, dribbled delta over this +! ! timestep, rather than a per-second flux. See documentation in get_curr_flux for +! ! more usage details. +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(annual_flux_dribbler_type), intent(in) :: this +! type(bounds_type), intent(in) :: bounds +! real(r8), intent(out) :: delta( get_beg(bounds, this%bounds_subgrid_level) : ) +! ! +! ! !LOCAL VARIABLES: +! integer :: beg_index, end_index +! integer :: i +! real(r8) :: dtime +! real(r8), allocatable :: flux(:) +! +! character(len=*), parameter :: subname = 'get_dribbled_delta' +! !----------------------------------------------------------------------- +! +! beg_index = lbound(delta, 1) +! end_index = get_end(bounds, this%bounds_subgrid_level) +! SHR_ASSERT_ALL_FL((ubound(delta) == (/end_index/)), sourcefile, __LINE__) +! +! allocate(flux(beg_index:end_index)) +! +! call this%get_curr_flux(bounds, flux(beg_index:end_index)) +! +! dtime = get_step_size_real() +! do i = beg_index, end_index +! delta(i) = flux(i) * dtime +! end do +! +! end subroutine get_dribbled_delta +! +! +! !----------------------------------------------------------------------- +! subroutine get_amount_left_to_dribble_beg(this, bounds, amount_left_to_dribble) +! ! +! ! !DESCRIPTION: +! ! Get the pseudo-state representing the amount that still needs to be dribbled in +! ! this and future time steps. This represents the pseudo-state before this time +! ! step's dribbling flux has been removed. (This behavior is regardless of whether +! ! get_curr_flux has been called already this time step.) +! ! +! ! As a special case, this returns 0 in the first time step of the year, because we +! ! haven't created this year's dribbling pool as of the beginning of this time step. +! ! +! ! i.e., if we imagined that the total amount to dribble was added to a state +! ! variable, and then this state variable was updated each time step as the flux +! ! dribbles out, then this subroutine gives the amount left in that state. (However, +! ! the actual implementation doesn't explicitly track this state, which is why we +! ! refer to it as a pseudo-state.) +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(annual_flux_dribbler_type), intent(in) :: this +! type(bounds_type), intent(in) :: bounds +! real(r8), intent(out) :: amount_left_to_dribble( get_beg(bounds, this%bounds_subgrid_level) : ) +! ! +! ! !LOCAL VARIABLES: +! real(r8) :: yearfrac +! +! character(len=*), parameter :: subname = 'get_amount_left_to_dribble_beg' +! !----------------------------------------------------------------------- +! +! yearfrac = get_prev_yearfrac() +! call this%get_amount_left_to_dribble(bounds, yearfrac, amount_left_to_dribble) +! +! end subroutine get_amount_left_to_dribble_beg +! +! +! !----------------------------------------------------------------------- +! subroutine get_amount_left_to_dribble_end(this, bounds, amount_left_to_dribble) +! ! +! ! !DESCRIPTION: +! ! Gets the pseudo-state representing the amount that still needs to be dribbled in +! ! future time steps. This represents the pseudo-state after this time step's dribbling +! ! flux has been removed. i.e., this includes the amount that will be dribbled starting +! ! with the *next* time step, through the end of this year. So this will return 0 on +! ! the last time step of the year. (This behavior is regardless of whether +! ! get_curr_flux has been called already this time step.) +! ! +! ! See documentation of get_amount_left_to_dribble_beg for more details. +! ! +! ! !ARGUMENTS: +! class(annual_flux_dribbler_type), intent(in) :: this +! type(bounds_type), intent(in) :: bounds +! real(r8), intent(out) :: amount_left_to_dribble( get_beg(bounds, this%bounds_subgrid_level) : ) +! ! +! ! !LOCAL VARIABLES: +! real(r8) :: yearfrac +! +! character(len=*), parameter :: subname = 'get_amount_left_to_dribble_end' +! !----------------------------------------------------------------------- +! +! yearfrac = get_curr_yearfrac() +! call this%get_amount_left_to_dribble(bounds, yearfrac, amount_left_to_dribble) +! +! end subroutine get_amount_left_to_dribble_end +! +! +! !----------------------------------------------------------------------- +! subroutine Restart(this, bounds, ncid, flag) +! ! +! ! !USES: +! use ncdio_pio, only : file_desc_t, ncd_double +! use restUtilMod +! ! +! ! !ARGUMENTS: +! class(annual_flux_dribbler_type), intent(inout) :: this +! type(bounds_type), intent(in) :: bounds +! type(file_desc_t), intent(inout) :: ncid ! netcdf id +! character(len=*) , intent(in) :: flag ! 'read' or 'write' +! ! +! ! !LOCAL VARIABLES: +! character(len=:), allocatable :: restname ! name of field on restart file +! logical :: readvar +! +! character(len=*), parameter :: subname = 'Restart' +! !----------------------------------------------------------------------- +! +! restname = trim(this%name) // '_amt_to_dribble' +! call restartvar(ncid=ncid, flag=flag, varname=restname, xtype=ncd_double, & +! dim1name = this%dim1name, & +! long_name = 'total amount to dribble over the year for ' // trim(this%name), & +! units = trim(this%units), & +! interpinic_flag = 'interp', & +! readvar = readvar, & +! data = this%amount_to_dribble) +! +! end subroutine Restart +! +! !----------------------------------------------------------------------- +! subroutine Clean(this) +! ! +! ! !DESCRIPTION: +! ! Deallocate memory associated with this object +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(annual_flux_dribbler_type), intent(inout) :: this +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'Clean' +! !----------------------------------------------------------------------- +! +! deallocate(this%amount_to_dribble) +! deallocate(this%amount_from_this_timestep) +! +! end subroutine Clean +! +! ! ======================================================================== +! ! Private methods +! ! ======================================================================== +! + !----------------------------------------------------------------------- + subroutine allocate_and_initialize_data(this, bounds) + ! + ! !DESCRIPTION: + ! Allocate arrays in this object and set them to initial values + ! + ! Assumes this%bounds_subgrid_level is already set + ! + ! !ARGUMENTS: + class(annual_flux_dribbler_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: beg_index, end_index + + character(len=*), parameter :: subname = 'allocate_and_initialize_data' + !----------------------------------------------------------------------- + + beg_index = get_beg(bounds, this%bounds_subgrid_level) + end_index = get_end(bounds, this%bounds_subgrid_level) + + allocate(this%amount_to_dribble(beg_index:end_index)) + this%amount_to_dribble(beg_index:end_index) = 0._r8 + + allocate(this%amount_from_this_timestep(beg_index:end_index)) + this%amount_from_this_timestep(beg_index:end_index) = 0._r8 + + end subroutine allocate_and_initialize_data + + !----------------------------------------------------------------------- + subroutine set_metadata(this, name, units, allows_non_annual_delta) + ! + ! !DESCRIPTION: + ! Set metadata in this object + ! + ! !ARGUMENTS: + class(annual_flux_dribbler_type), intent(inout) :: this + character(len=*) , intent(in) :: name ! name of this object, used for i/o + character(len=*) , intent(in) :: units ! units metadata - should be state units, not flux (i.e., NOT per-second) + + ! If allows_non_annual_delta is .false., then an error check is performed for each + ! call to set_curr_delta, ensuring that the delta is 0 at all times other than the + ! first time step of the year. This is just provided as a convenient sanity check - + ! to ensure that the code is behaving as expected. + ! + ! If allows_non_annual_delta is not provided, it is assumed to be .true. + logical, intent(in), optional :: allows_non_annual_delta + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'set_metadata' + !----------------------------------------------------------------------- + + if (len_trim(name) > name_maxlen) then + write(iulog,*) subname // ': name too long' + write(iulog,*) trim(name) // ' exceeds max length: ', name_maxlen + call endrun(msg=subname // ': name too long: ' // & + errMsg(sourcefile, __LINE__)) + end if + this%name = trim(name) + + if (len_trim(units) > units_maxlen) then + write(iulog,*) subname // ': units too long' + write(iulog,*) trim(units) // ' exceeds max length: ', units_maxlen + call endrun(msg=subname // ': units too long: ' // & + errMsg(sourcefile, __LINE__)) + end if + this%units = trim(units) + + if (present(allows_non_annual_delta)) then + this%allows_non_annual_delta = allows_non_annual_delta + else + this%allows_non_annual_delta = .true. + end if + + end subroutine set_metadata + + !----------------------------------------------------------------------- + subroutine get_amount_left_to_dribble(this, bounds, yearfrac, amount_left_to_dribble) + ! + ! !DESCRIPTION: + ! Helper method shared by get_amount_left_to_dribble_beg and + ! get_amount_left_to_dribble_end. Returns amount left to dribble as of a given + ! yearfrac. + ! + ! !USES: + ! + ! !ARGUMENTS: + class(annual_flux_dribbler_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8), intent(in) :: yearfrac + real(r8), intent(out) :: amount_left_to_dribble( get_beg(bounds, this%bounds_subgrid_level) : ) + ! + ! !LOCAL VARIABLES: + integer :: beg_index, end_index + integer :: i + + character(len=*), parameter :: subname = 'get_amount_left_to_dribble' + !----------------------------------------------------------------------- + + beg_index = lbound(amount_left_to_dribble, 1) + end_index = get_end(bounds, this%bounds_subgrid_level) + SHR_ASSERT_ALL_FL((ubound(amount_left_to_dribble) == (/end_index/)), sourcefile, __LINE__) + + do i = beg_index, end_index + if (yearfrac < 1.e-15_r8) then + ! last time step of year; we'd like this to be given a yearfrac of 1 rather than + ! 0 in this case; since it's given as 0, we need to handle it specially + amount_left_to_dribble(i) = 0._r8 + else + amount_left_to_dribble(i) = this%amount_to_dribble(i) * (1._r8 - yearfrac) + end if + end do + + end subroutine get_amount_left_to_dribble +! + + !----------------------------------------------------------------------- + subroutine get_amount_left_to_dribble_beg(this, bounds, amount_left_to_dribble) + ! + ! !DESCRIPTION: + ! Get the pseudo-state representing the amount that still needs to be dribbled in + ! this and future time steps. This represents the pseudo-state before this time + ! step's dribbling flux has been removed. (This behavior is regardless of whether + ! get_curr_flux has been called already this time step.) + ! + ! As a special case, this returns 0 in the first time step of the year, because we + ! haven't created this year's dribbling pool as of the beginning of this time step. + ! + ! i.e., if we imagined that the total amount to dribble was added to a state + ! variable, and then this state variable was updated each time step as the flux + ! dribbles out, then this subroutine gives the amount left in that state. (However, + ! the actual implementation doesn't explicitly track this state, which is why we + ! refer to it as a pseudo-state.) + ! + ! !USES: + ! + ! !ARGUMENTS: + class(annual_flux_dribbler_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8), intent(out) :: amount_left_to_dribble( get_beg(bounds, this%bounds_subgrid_level) : ) + ! + ! !LOCAL VARIABLES: + real(r8) :: yearfrac + + character(len=*), parameter :: subname = 'get_amount_left_to_dribble_beg' + !----------------------------------------------------------------------- + + yearfrac = get_prev_yearfrac() + call this%get_amount_left_to_dribble(bounds, yearfrac, amount_left_to_dribble) + + end subroutine get_amount_left_to_dribble_beg + + !----------------------------------------------------------------------- + subroutine get_amount_left_to_dribble_end(this, bounds, amount_left_to_dribble) + ! + ! !DESCRIPTION: + ! Gets the pseudo-state representing the amount that still needs to be dribbled in + ! future time steps. This represents the pseudo-state after this time step's dribbling + ! flux has been removed. i.e., this includes the amount that will be dribbled starting + ! with the *next* time step, through the end of this year. So this will return 0 on + ! the last time step of the year. (This behavior is regardless of whether + ! get_curr_flux has been called already this time step.) + ! + ! See documentation of get_amount_left_to_dribble_beg for more details. + ! + ! !ARGUMENTS: + class(annual_flux_dribbler_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8), intent(out) :: amount_left_to_dribble( get_beg(bounds, this%bounds_subgrid_level) : ) + ! + ! !LOCAL VARIABLES: + real(r8) :: yearfrac + + character(len=*), parameter :: subname = 'get_amount_left_to_dribble_end' + !----------------------------------------------------------------------- + + yearfrac = get_curr_yearfrac() + call this%get_amount_left_to_dribble(bounds, yearfrac, amount_left_to_dribble) + + end subroutine get_amount_left_to_dribble_end +end module AnnualFluxDribbler diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CMakeLists.txt new file mode 100755 index 000000000..c3d07faae --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CMakeLists.txt @@ -0,0 +1,157 @@ +esma_set_this () +string (REPLACE GEOScatchCN_GridComp_ "" is_openmp ${this}) + +list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake") +include(genf90_utils) + +find_program(GENF90 genf90.pl PATHS ${CMAKE_CURRENT_LIST_DIR}) + +set(genf90_files shr_infnan_mod.F90.in shr_assert_mod.F90.in) + +process_genf90_source_list("${genf90_files}" ${CMAKE_CURRENT_BINARY_DIR} + share_genf90_sources) + +set (srcs + abortutils.F90 + AnnualFluxDribbler.F90 + clm_time_manager.F90 + clm_varcon.F90 + clm_varctl.F90 + clm_varpar.F90 + CN2CLMType.F90 + CNAnnualUpdateMod.F90 + CNBalanceCheckMod.F90 + CNCLM51_Photosynthesis.F90 + CNCLM_ActiveLayerMod.F90 + CNCLM_atm2lndType.F90 + CNCLM_CanopyStateType.F90 + CNCLM_ch4Mod.F90 + CNCLM_CNDVType.F90 + CNCLM_CNFireBaseMod.F90 + CNCLM_CNProductsMod.F90 + CNCLM_CNVegCarbonFluxType.F90 + CNCLM_CNVegCarbonStateType.F90 + CNCLM_CNVegNitrogenFluxType.F90 + CNCLM_CNVegNitrogenStateType.F90 + CNCLM_CNVegStateType.F90 + CNCLM_ColumnType.F90 + CNCLM_CropType.F90 + CNCLM_decompMod.F90 + CNCLM_DriverMod.F90 + CNCLM_dynSubgridControlMod.F90 + CNCLM_EnergyFluxType.F90 + CNCLM_filterMod.F90 + CNCLM_FireDataBaseType.F90 + CNCLM_FrictionVelocityMod.F90 + CNCLM_GridcellType.F90 + CNCLM_initVerticalMod.F90 + CNCLM_LandunitType.F90 + CNCLM_OzoneBaseMod.F90 + CNCLM_PatchType.F90 + CNCLM_pftconMod.F90 + CNCLM_SaturatedExcessRunoffMod.F90 + CNCLM_SoilBiogeochemCarbonFluxType.F90 + CNCLM_SoilBiogeochemCarbonStateType.F90 + CNCLM_SoilBiogeochemCompetitionMod.F90 + CNCLM_SoilBiogeochemDecompCascadeConType.F90 + CNCLM_SoilBiogeochemNitrogenFluxType.F90 + CNCLM_SoilBiogeochemNitrogenStateType.F90 + CNCLM_SoilBiogeochemStateType.F90 + CNCLM_SoilStateType.F90 + CNCLM_SolarAbsorbedType.F90 + CNCLM_SurfaceAlbedoType.F90 + CNCLM_TemperatureType.F90 + CNCLM_Wateratm2lndBulkType.F90 + CNCLM_Wateratm2lndType.F90 + CNCLM_WaterDiagnosticType.F90 + CNCLM_WaterDiagnosticBulkType.F90 + CNCLM_WaterFluxBulkType.F90 + CNCLM_WaterFluxType.F90 + CNCLM_WaterStateBulkType.F90 + CNCLM_WaterStateType.F90 + CNCLM_WaterType.F90 + CNCStateUpdate1Mod.F90 + CNCStateUpdate2Mod.F90 + CNCStateUpdate3Mod.F90 + CNDriverMod.F90 + CNFireEmissionsMod.F90 + CNFireFactoryMod.F90 + CNFireLi2014Mod.F90 + CNFireLi2016Mod.F90 + CNFireLi2021Mod.F90 + CNFireNoFireMod.F90 + CNFUNMod.F90 + CNGapMortalityMod.F90 + CNGRespMod.F90 + CN_init_mod.F90 + CNMRespMod.F90 + CNNDynamicsMod.F90 + CNNStateUpdate1Mod.F90 + CNNStateUpdate2Mod.F90 + CNNStateUpdate3Mod.F90 + CNPhenologyMod.F90 + CNPrecisionControlMod.F90 + CNRootDynMod.F90 + CNSharedParamsMod.F90 + CNVegetationFacade.F90 + CNVegStructUpdateMod.F90 + column_varcon.F90 + fileutils.F90 + filterColMod.F90 + FireMethodType.F90 + initSubgridMod.F90 + landunit_varcon.F90 + ncdio_pio.F90 + NutrientCompetitionCLM45defaultMod.F90 + NutrientCompetitionFactoryMod.F90 + NutrientCompetitionFlexibleCNMod.F90 + NutrientCompetitionMethodMod.F90 + paramUtilMod.F90 + perf_mod.F90 + PhotosynthesisMod.F90 + QSatMod.F90 + quadraticMod.F90 + RootBiophysMod.F90 + shr_abort_mod.F90 + shr_assert.h + shr_const_mod.F90 + shr_file_mod.F90 + shr_fire_emis_mod.F90 + shr_kind_mod.F90 + shr_log_mod.F90 + shr_mpi_mod.F90 + shr_nl_mod.F90 + shr_sys_mod.F90 + SoilBiogeochemDecompCascadeBGCMod.F90 + SoilBiogeochemDecompCascadeCNMod.F90 + SoilBiogeochemDecompMod.F90 + SoilBiogeochemLittVertTranspMod.F90 + SoilBiogeochemNitrifDenitrifMod.F90 + SoilBiogeochemNLeachingMod.F90 + SoilBiogeochemNStateUpdate1Mod.F90 + SoilBiogeochemPotentialMod.F90 + SoilBiogeochemPrecisionControlMod.F90 + SoilBiogeochemVerticalProfileMod.F90 + SoilStateInitTimeConstMod.F90 + SoilWaterRetentionCurveMod.F90 + spmdMod.F90 + subgridAveMod.F90 + SurfaceAlbedoMod.F90 + SurfaceRadiationMod.F90 + TridiagonalMod.F90 + update_model_para4cn.F90 + ) + +list(APPEND srcs + ${share_genf90_sources}) + +esma_add_library (${this} + SRCS ${srcs} + DEPENDENCIES MAPL GEOS_LandShared GEOS_CatchCNShared esmf NetCDF::NetCDF_Fortran + TYPE SHARED) +target_include_directories (${this} PUBLIC ${INC_ESMF} ${INC_NETCDF}) + +if (is_openmp) + target_compile_options(${this} PRIVATE ${OpenMP_Fortran_FLAGS}) +endif () + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CN2CLMType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CN2CLMType.F90 new file mode 100755 index 000000000..27d17a222 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CN2CLMType.F90 @@ -0,0 +1,61 @@ +#include "MAPL_Generic.h" + +module CN2CLMType + + use shr_kind_mod , only : r8 => shr_kind_r8 + use nanMod , only : nan + use decompMod , only : bounds_type + use MAPL_ExceptionHandling + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: cn2clm_type + + real(r8), pointer :: forc_hdm_cn2clm(:) ! Human population density + real(r8), pointer :: forc_lnfm_cn2clm(:) ! Lightning frequency + real(r8), pointer :: btran2_patch_cn2clm(:) ! patch root zone soil wetness factor (0 to 1) + contains + + procedure, public :: Init + + end type cn2clm_type + type(cn2clm_type), public, target, save :: cn2clm_inst + +contains + +!-------------------------------------------------------------- + subroutine Init(this, bounds) + + ! !DESCRIPTION: + ! Initialize CTSM canopy state type needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + ! INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(cn2clm_type) :: this + + ! LOCAL + integer :: begp, endp + integer :: begg, endg + + !--------------------------------- + + begp = bounds%begp ; endp = bounds%endp + begg = bounds%begg ; endg = bounds%endg + + + allocate(this%forc_hdm_cn2clm (begg:endg)) ; this%forc_hdm_cn2clm (:) = nan + allocate(this%forc_lnfm_cn2clm (begg:endg)) ; this%forc_lnfm_cn2clm (:) = nan + allocate(this%btran2_patch_cn2clm (begp:endp)) ; this%btran2_patch_cn2clm (:) = nan + + end subroutine Init + +end module CN2CLMType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNAnnualUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNAnnualUpdateMod.F90 new file mode 100755 index 000000000..7e1d34464 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNAnnualUpdateMod.F90 @@ -0,0 +1,113 @@ +module CNAnnualUpdateMod + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for updating annual summation variables + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNvegStateType , only : cnveg_state_type + use PatchType , only : patch + use filterColMod , only : filter_col_type, col_filter_from_filter_and_logical_array + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: CNAnnualUpdate + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CNAnnualUpdate(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_state_inst, cnveg_carbonflux_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update annual summation variables + ! + ! !USES: + use clm_time_manager, only: get_step_size_real, get_days_per_year + use clm_varcon , only: secspday + use SubgridAveMod , only: p2c + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p ! indices + integer :: fp,fc ! lake filter indices + real(r8):: secspyear + real(r8):: dt ! radiation time step (seconds) + logical :: end_of_year(bounds%begc:bounds%endc) ! whether each column has reached the end of the year, according to its own annsum_counter + type(filter_col_type) :: filter_endofyear_c + !----------------------------------------------------------------------- + + dt = get_step_size_real() + secspyear = get_days_per_year() * secspday + + do fc = 1,num_soilc + c = filter_soilc(fc) + cnveg_state_inst%annsum_counter_col(c) = cnveg_state_inst%annsum_counter_col(c) + dt + if (cnveg_state_inst%annsum_counter_col(c) >= secspyear) then + end_of_year(c) = .true. + cnveg_state_inst%annsum_counter_col(c) = 0._r8 + else + end_of_year(c) = .false. + end if + end do + + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + if (end_of_year(c)) then + + ! update annual plant ndemand accumulator + cnveg_state_inst%annsum_potential_gpp_patch(p) = cnveg_state_inst%tempsum_potential_gpp_patch(p) + cnveg_state_inst%tempsum_potential_gpp_patch(p) = 0._r8 + + ! update annual total N retranslocation accumulator + cnveg_state_inst%annmax_retransn_patch(p) = cnveg_state_inst%tempmax_retransn_patch(p) + cnveg_state_inst%tempmax_retransn_patch(p) = 0._r8 + + ! update annual average 2m air temperature accumulator + cnveg_state_inst%annavg_t2m_patch(p) = cnveg_state_inst%tempavg_t2m_patch(p) + cnveg_state_inst%tempavg_t2m_patch(p) = 0._r8 + + ! update annual NPP accumulator, convert to annual total + cnveg_carbonflux_inst%annsum_npp_patch(p) = cnveg_carbonflux_inst%tempsum_npp_patch(p) * dt + cnveg_carbonflux_inst%tempsum_npp_patch(p) = 0._r8 + + ! update annual litfall accumulator, convert to annual total + cnveg_carbonflux_inst%annsum_litfall_patch(p) = cnveg_carbonflux_inst%tempsum_litfall_patch(p) * dt + cnveg_carbonflux_inst%tempsum_litfall_patch(p) = 0._r8 + + end if + end do + + ! Get column-level averages, just for the columns that have reached their personal end-of-year + filter_endofyear_c = col_filter_from_filter_and_logical_array( & + bounds = bounds, & + num_orig = num_soilc, & + filter_orig = filter_soilc, & + logical_col = end_of_year(bounds%begc:bounds%endc)) + + call p2c(bounds, filter_endofyear_c%num, filter_endofyear_c%indices, & + cnveg_carbonflux_inst%annsum_npp_patch(bounds%begp:bounds%endp), & + cnveg_carbonflux_inst%annsum_npp_col(bounds%begc:bounds%endc)) + + call p2c(bounds, filter_endofyear_c%num, filter_endofyear_c%indices, & + cnveg_state_inst%annavg_t2m_patch(bounds%begp:bounds%endp), & + cnveg_state_inst%annavg_t2m_col(bounds%begc:bounds%endc)) + + end subroutine CNAnnualUpdate + +end module CNAnnualUpdateMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNBalanceCheckMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNBalanceCheckMod.F90 new file mode 100755 index 000000000..cbd132b38 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNBalanceCheckMod.F90 @@ -0,0 +1,629 @@ +module CNBalanceCheckMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for carbon/nitrogen mass balance checking. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use nanMod , only : nan + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun + use clm_varctl , only : iulog, use_nitrif_denitrif + use clm_time_manager , only : get_step_size_real + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use SoilBiogeochemNitrogenfluxType , only : soilbiogeochem_nitrogenflux_type + use SoilBiogeochemCarbonfluxType , only : soilbiogeochem_carbonflux_type + use CNProductsMod , only : cn_products_type + use ColumnType , only : col + use GridcellType , only : grc + use CNSharedParamsMod , only : use_fun + + ! + implicit none + private + ! + ! !PUBLIC TYPES: + type, public :: cn_balance_type + private + real(r8), pointer :: begcb_col(:) ! (gC/m2) column carbon mass, beginning of time step + real(r8), pointer :: endcb_col(:) ! (gC/m2) column carbon mass, end of time step + real(r8), pointer :: begnb_col(:) ! (gN/m2) column nitrogen mass, beginning of time step + real(r8), pointer :: endnb_col(:) ! (gN/m2) column nitrogen mass, end of time step + real(r8), pointer :: begcb_grc(:) ! (gC/m2) gridcell carbon mass, beginning of time step + real(r8), pointer :: endcb_grc(:) ! (gC/m2) gridcell carbon mass, end of time step + real(r8), pointer :: begnb_grc(:) ! (gN/m2) gridcell nitrogen mass, beginning of time step + real(r8), pointer :: endnb_grc(:) ! (gN/m2) gridcell nitrogen mass, end of time step + real(r8) :: cwarning ! (gC/m2) For a Carbon balance warning + real(r8) :: nwarning ! (gN/m2) For a Nitrogen balance warning + real(r8) :: cerror ! (gC/m2) For a Carbon balance error + real(r8) :: nerror ! (gN/m2) For a Nitrogen balance error + contains + procedure , public :: Init + procedure , public :: BeginCNGridcellBalance + procedure , public :: BeginCNColumnBalance + procedure , public :: CBalanceCheck + procedure , public :: NBalanceCheck + end type cn_balance_type + type(cn_balance_type), public, target, save :: cn_balance_inst + ! + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine Init(this, bounds) + use clm_varctl , only : use_matrixcn, use_soil_matrixcn + class(cn_balance_type) :: this + type(bounds_type) , intent(in) :: bounds + + integer :: begc, endc + integer :: begg, endg + !------------------------------------------- + + begg = bounds%begg; endg = bounds%endg + + allocate(this%begcb_grc(begg:endg)) ; this%begcb_grc(:) = nan + allocate(this%endcb_grc(begg:endg)) ; this%endcb_grc(:) = nan + allocate(this%begnb_grc(begg:endg)) ; this%begnb_grc(:) = nan + allocate(this%endnb_grc(begg:endg)) ; this%endnb_grc(:) = nan + + begc = bounds%begc; endc= bounds%endc + + allocate(this%begcb_col(begc:endc)) ; this%begcb_col(:) = nan + allocate(this%endcb_col(begc:endc)) ; this%endcb_col(:) = nan + allocate(this%begnb_col(begc:endc)) ; this%begnb_col(:) = nan + allocate(this%endnb_col(begc:endc)) ; this%endnb_col(:) = nan + + this%cwarning = 1.e-8_r8 + this%nwarning = 1.e-7_r8 + this%nerror = 1.e-3_r8 + this%cerror = 1.e-7_r8 + end subroutine Init + + !----------------------------------------------------------------------- + subroutine BeginCNGridcellBalance(this, bounds, cnveg_carbonflux_inst, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, & + c_products_inst, n_products_inst) + ! + ! !DESCRIPTION: + ! Calculate beginning gridcell-level carbon/nitrogen balance + ! for mass conservation check + ! + ! Should be called after CN state summaries have been computed + ! and before the dynamic landunit area updates + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_balance_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cn_products_type) , intent(in) :: c_products_inst + type(cn_products_type) , intent(in) :: n_products_inst + ! + ! !LOCAL VARIABLES: + integer :: g + integer :: begg, endg + real(r8) :: hrv_xsmrpool_amount_left_to_dribble(bounds%begg:bounds%endg) + real(r8) :: dwt_conv_cflux_amount_left_to_dribble(bounds%begg:bounds%endg) + !----------------------------------------------------------------------- + + associate( & + begcb => this%begcb_grc , & ! Output: [real(r8) (:)] (gC/m2) gridcell carbon mass, beginning of time step + begnb => this%begnb_grc , & ! Output: [real(r8) (:)] (gN/m2) gridcell nitrogen mass, beginning of time step + totc => cnveg_carbonstate_inst%totc_grc , & ! Input: [real(r8) (:)] (gC/m2) total gridcell carbon, incl veg and cpool + totn => cnveg_nitrogenstate_inst%totn_grc, & ! Input: [real(r8) (:)] (gN/m2) total gridcell nitrogen, incl veg + c_cropprod1 => c_products_inst%cropprod1_grc , & ! Input: [real(r8) (:)] (gC/m2) carbon in crop products + n_cropprod1 => n_products_inst%cropprod1_grc , & ! Input: [real(r8) (:)] (gC/m2) nitrogen in crop products + c_tot_woodprod => c_products_inst%tot_woodprod_grc , & ! Input: [real(r8) (:)] (gC/m2) total carbon in wood products + n_tot_woodprod => n_products_inst%tot_woodprod_grc & ! Input: [real(r8) (:)] (gC/m2) total nitrogen in wood products + ) + + begg = bounds%begg; endg = bounds%endg + + call cnveg_carbonflux_inst%hrv_xsmrpool_to_atm_dribbler%get_amount_left_to_dribble_beg( & + bounds, hrv_xsmrpool_amount_left_to_dribble(bounds%begg:bounds%endg)) + call cnveg_carbonflux_inst%dwt_conv_cflux_dribbler%get_amount_left_to_dribble_beg( & + bounds, dwt_conv_cflux_amount_left_to_dribble(bounds%begg:bounds%endg)) + + do g = begg, endg + begcb(g) = totc(g) + c_tot_woodprod(g) + c_cropprod1(g) + & + hrv_xsmrpool_amount_left_to_dribble(g) + & + dwt_conv_cflux_amount_left_to_dribble(g) + begnb(g) = totn(g) + n_tot_woodprod(g) + n_cropprod1(g) + end do + + end associate + + end subroutine BeginCNGridcellBalance + + !----------------------------------------------------------------------- + subroutine BeginCNColumnBalance(this, bounds, num_soilc, filter_soilc, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! Calculate beginning column-level carbon/nitrogen balance, for mass conservation check + ! + ! Should be called after CN state summaries have been recomputed for this time step + ! (which should be after the dynamic landunit area updates and the associated filter + ! updates - i.e., using the new version of the filters) + ! + ! !ARGUMENTS: + class(cn_balance_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: fc,c + !----------------------------------------------------------------------- + + associate( & + col_begcb => this%begcb_col , & ! Output: [real(r8) (:)] (gC/m2) column carbon mass, beginning of time step + col_begnb => this%begnb_col , & ! Output: [real(r8) (:)] (gN/m2) column nitrogen mass, beginning of time step + totcolc => cnveg_carbonstate_inst%totc_col , & ! Input: [real(r8) (:)] (gC/m2) total column carbon, incl veg and cpool + totcoln => cnveg_nitrogenstate_inst%totn_col & ! Input: [real(r8) (:)] (gN/m2) total column nitrogen, incl veg + ) + + do fc = 1,num_soilc + c = filter_soilc(fc) + col_begcb(c) = totcolc(c) + col_begnb(c) = totcoln(c) + end do + + end associate + + end subroutine BeginCNColumnBalance + + !----------------------------------------------------------------------- + subroutine CBalanceCheck(this, bounds, num_soilc, filter_soilc, & + soilbiogeochem_carbonflux_inst, cnveg_carbonflux_inst, & + cnveg_carbonstate_inst, c_products_inst) + ! + ! !USES: + use subgridAveMod, only: c2g + ! + ! !DESCRIPTION: + ! Perform carbon mass conservation check for column and patch + ! + ! !ARGUMENTS: + class(cn_balance_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cn_products_type) , intent(in) :: c_products_inst + ! + ! !LOCAL VARIABLES: + integer :: c, g, err_index ! indices + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8) :: dt ! radiation time step (seconds) + real(r8) :: col_cinputs, grc_cinputs + real(r8) :: col_coutputs, grc_coutputs + real(r8) :: col_errcb(bounds%begc:bounds%endc) + real(r8) :: grc_errcb(bounds%begg:bounds%endg) + real(r8) :: som_c_leached_grc(bounds%begg:bounds%endg) + real(r8) :: hrv_xsmrpool_amount_left_to_dribble(bounds%begg:bounds%endg) + real(r8) :: dwt_conv_cflux_amount_left_to_dribble(bounds%begg:bounds%endg) + !----------------------------------------------------------------------- + + associate( & + grc_begcb => this%begcb_grc , & ! Input: [real(r8) (:) ] (gC/m2) gridcell-level carbon mass, beginning of time step + grc_endcb => this%endcb_grc , & ! Output: [real(r8) (:) ] (gC/m2) gridcell-level carbon mass, end of time step + totgrcc => cnveg_carbonstate_inst%totc_grc , & ! Input: [real(r8) (:)] (gC/m2) total gridcell carbon, incl veg and cpool + nbp_grc => cnveg_carbonflux_inst%nbp_grc , & ! Input: [real(r8) (:) ] (gC/m2/s) net biome production (positive for sink) + cropprod1_grc => c_products_inst%cropprod1_grc , & ! Input: [real(r8) (:)] (gC/m2) carbon in crop products + tot_woodprod_grc => c_products_inst%tot_woodprod_grc , & ! Input: [real(r8) (:)] (gC/m2) total carbon in wood products + dwt_seedc_to_leaf_grc => cnveg_carbonflux_inst%dwt_seedc_to_leaf_grc , & ! Input: [real(r8) (:)] (gC/m2/s) seed source sent to leaf + dwt_seedc_to_deadstem_grc => cnveg_carbonflux_inst%dwt_seedc_to_deadstem_grc , & ! Input: [real(r8) (:)] (gC/m2/s) seed source sent to deadstem + col_begcb => this%begcb_col , & ! Input: [real(r8) (:) ] (gC/m2) carbon mass, beginning of time step + col_endcb => this%endcb_col , & ! Output: [real(r8) (:) ] (gC/m2) carbon mass, end of time step + wood_harvestc => cnveg_carbonflux_inst%wood_harvestc_col , & ! Input: [real(r8) (:) ] (gC/m2/s) wood harvest (to product pools) + grainc_to_cropprodc => cnveg_carbonflux_inst%grainc_to_cropprodc_col , & ! Input: [real(r8) (:) ] (gC/m2/s) grain C to 1-year crop product pool + gpp => cnveg_carbonflux_inst%gpp_col , & ! Input: [real(r8) (:) ] (gC/m2/s) gross primary production + er => cnveg_carbonflux_inst%er_col , & ! Input: [real(r8) (:) ] (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic + col_fire_closs => cnveg_carbonflux_inst%fire_closs_col , & ! Input: [real(r8) (:) ] (gC/m2/s) total column-level fire C loss + col_hrv_xsmrpool_to_atm => cnveg_carbonflux_inst%hrv_xsmrpool_to_atm_col , & ! Input: [real(r8) (:) ] (gC/m2/s) excess MR pool harvest mortality + col_xsmrpool_to_atm => cnveg_carbonflux_inst%xsmrpool_to_atm_col , & ! Input: [real(r8) (:) ] (gC/m2/s) excess MR pool crop harvest loss to atm + som_c_leached => soilbiogeochem_carbonflux_inst%som_c_leached_col , & ! Input: [real(r8) (:) ] (gC/m2/s) total SOM C loss from vertical transport + + totcolc => cnveg_carbonstate_inst%totc_col & ! Input: [real(r8) (:) ] (gC/m2) total column carbon, incl veg and cpool + ) + + ! set time steps + dt = get_step_size_real() + + err_found = .false. + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate the total column-level carbon storage, for mass conservation check + col_endcb(c) = totcolc(c) + + ! calculate total column-level inputs + col_cinputs = gpp(c) + + ! calculate total column-level outputs + ! er = ar + hr, col_fire_closs includes patch-level fire losses + col_coutputs = er(c) + col_fire_closs(c) + col_hrv_xsmrpool_to_atm(c) + & + col_xsmrpool_to_atm(c) + + ! Fluxes to product pools are included in column-level outputs: the product + ! pools are not included in totcolc, so are outside the system with respect to + ! these balance checks. (However, the dwt flux to product pools is NOT included, + ! since col_begcb is initialized after the dynamic area adjustments - i.e., + ! after the dwt term has already been taken out.) + col_coutputs = col_coutputs + & + wood_harvestc(c) + & + grainc_to_cropprodc(c) + + ! subtract leaching flux + col_coutputs = col_coutputs - som_c_leached(c) + + ! calculate the total column-level carbon balance error for this time step + col_errcb(c) = (col_cinputs - col_coutputs)*dt - & + (col_endcb(c) - col_begcb(c)) + + ! check for significant errors + if (abs(col_errcb(c)) > this%cerror) then + err_found = .true. + err_index = c + end if + if (abs(col_errcb(c)) > this%cwarning) then + write(iulog,*) 'cbalance warning at c =', c, col_errcb(c), col_endcb(c) + end if + + end do ! end of columns loop + + if (err_found) then + c = err_index + write(iulog,*)'column cbalance error = ', col_errcb(c), c + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(col%gridcell(c)),grc%londeg(col%gridcell(c)) + write(iulog,*)'begcb = ',col_begcb(c) + write(iulog,*)'endcb = ',col_endcb(c) + write(iulog,*)'delta store = ',col_endcb(c)-col_begcb(c) + write(iulog,*)'--- Inputs ---' + write(iulog,*)'gpp = ',gpp(c)*dt + write(iulog,*)'--- Outputs ---' + write(iulog,*)'er = ',er(c)*dt + write(iulog,*)'col_fire_closs = ',col_fire_closs(c)*dt + write(iulog,*)'col_hrv_xsmrpool_to_atm = ',col_hrv_xsmrpool_to_atm(c)*dt + write(iulog,*)'col_xsmrpool_to_atm = ',col_xsmrpool_to_atm(c)*dt + write(iulog,*)'wood_harvestc = ',wood_harvestc(c)*dt + write(iulog,*)'grainc_to_cropprodc = ',grainc_to_cropprodc(c)*dt + write(iulog,*)'-1*som_c_leached = ',som_c_leached(c)*dt + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Repeat error check at the gridcell level + call c2g( bounds = bounds, & + carr = totcolc(bounds%begc:bounds%endc), & + garr = totgrcc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + call c2g( bounds = bounds, & + carr = som_c_leached(bounds%begc:bounds%endc), & + garr = som_c_leached_grc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + err_found = .false. + do g = bounds%begg, bounds%endg + ! calculate gridcell-level carbon storage for mass conservation check + ! Notes: + ! totgrcc = totcolc = totc_p2c_col(c) + soilbiogeochem_cwdc_col(c) + soilbiogeochem_totlitc_col(c) + soilbiogeochem_totsomc_col(c) + soilbiogeochem_ctrunc_col(c) + ! totc_p2c_col = totc_patch = totvegc_patch(p) + xsmrpool_patch(p) + ctrunc_patch(p) + cropseedc_deficit_patch(p) + ! Not including seedc_grc in grc_begcb and grc_endcb because + ! seedc_grc forms out of thin air, for now, and equals + ! -1 * (dwt_seedc_to_leaf_grc(g) + dwt_seedc_to_deadstem_grc(g)) + ! We account for the latter fluxes as inputs below; the same + ! fluxes have entered the pools earlier in the timestep. For true + ! conservation we would need to add a flux out of npp into seed. + call cnveg_carbonflux_inst%hrv_xsmrpool_to_atm_dribbler%get_amount_left_to_dribble_end( & + bounds, hrv_xsmrpool_amount_left_to_dribble(bounds%begg:bounds%endg)) + call cnveg_carbonflux_inst%dwt_conv_cflux_dribbler%get_amount_left_to_dribble_end( & + bounds, dwt_conv_cflux_amount_left_to_dribble(bounds%begg:bounds%endg)) + grc_endcb(g) = totgrcc(g) + tot_woodprod_grc(g) + cropprod1_grc(g) + & + hrv_xsmrpool_amount_left_to_dribble(g) + & + dwt_conv_cflux_amount_left_to_dribble(g) + + ! calculate total gridcell-level inputs + ! slevis notes: + ! nbp_grc = nep_grc - fire_closs_grc - hrv_xsmrpool_to_atm_dribbled_grc - dwt_conv_cflux_dribbled_grc - product_closs_grc + grc_cinputs = nbp_grc(g) + & + dwt_seedc_to_leaf_grc(g) + dwt_seedc_to_deadstem_grc(g) + + ! calculate total gridcell-level outputs + grc_coutputs = - som_c_leached_grc(g) + + ! calculate the total gridcell-level carbon balance error + ! for this time step + grc_errcb(g) = (grc_cinputs - grc_coutputs) * dt - & + (grc_endcb(g) - grc_begcb(g)) + + ! check for significant errors + if (abs(grc_errcb(g)) > this%cerror) then + err_found = .true. + err_index = g + end if + if (abs(grc_errcb(g)) > this%cwarning) then + write(iulog,*) 'cbalance warning at g =', g, grc_errcb(g), grc_endcb(g) + end if + end do ! end of gridcell loop + + if (err_found) then + g = err_index + write(iulog,*)'gridcell cbalance error =', grc_errcb(g), g + write(iulog,*)'latdeg, londeg =', grc%latdeg(g), grc%londeg(g) + write(iulog,*)'begcb =', grc_begcb(g) + write(iulog,*)'endcb =', grc_endcb(g) + write(iulog,*)'delta store =', grc_endcb(g) - grc_begcb(g) + write(iulog,*)'--- Inputs ---' + write(iulog,*)'nbp_grc =', nbp_grc(g) * dt + write(iulog,*)'dwt_seedc_to_leaf_grc =', dwt_seedc_to_leaf_grc(g) * dt + write(iulog,*)'dwt_seedc_to_deadstem_grc =', dwt_seedc_to_deadstem_grc(g) * dt + write(iulog,*)'--- Outputs ---' + write(iulog,*)'-1*som_c_leached_grc = ', som_c_leached_grc(g) * dt + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end associate + + end subroutine CBalanceCheck + + !----------------------------------------------------------------------- + subroutine NBalanceCheck(this, bounds, num_soilc, filter_soilc, & + soilbiogeochem_nitrogenflux_inst, cnveg_nitrogenflux_inst, & + cnveg_nitrogenstate_inst, n_products_inst, atm2lnd_inst) + ! + ! !DESCRIPTION: + ! Perform nitrogen mass conservation check + ! + ! !USES: + use clm_varctl, only : use_crop + use subgridAveMod, only: c2g + use atm2lndType, only: atm2lnd_type + ! + ! !ARGUMENTS: + class(cn_balance_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc (:) ! filter for soil columns + type(soilbiogeochem_nitrogenflux_type) , intent(in) :: soilbiogeochem_nitrogenflux_inst + type(cnveg_nitrogenflux_type) , intent(in) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cn_products_type) , intent(in) :: n_products_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + ! + ! !LOCAL VARIABLES: + integer :: c,err_index,j ! indices + integer :: g ! gridcell index + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8):: dt ! radiation time step (seconds) + real(r8):: col_ninputs(bounds%begc:bounds%endc) + real(r8):: col_noutputs(bounds%begc:bounds%endc) + real(r8):: col_errnb(bounds%begc:bounds%endc) + real(r8):: col_ninputs_partial(bounds%begc:bounds%endc) + real(r8):: col_noutputs_partial(bounds%begc:bounds%endc) + real(r8):: grc_ninputs_partial(bounds%begg:bounds%endg) + real(r8):: grc_noutputs_partial(bounds%begg:bounds%endg) + real(r8):: grc_ninputs(bounds%begg:bounds%endg) + real(r8):: grc_noutputs(bounds%begg:bounds%endg) + real(r8):: grc_errnb(bounds%begg:bounds%endg) + !----------------------------------------------------------------------- + + associate( & + grc_begnb => this%begnb_grc , & ! Input: [real(r8) (:) ] (gN/m2) gridcell nitrogen mass, beginning of time step + grc_endnb => this%endnb_grc , & ! Output: [real(r8) (:) ] (gN/m2) gridcell nitrogen mass, end of time step + totgrcn => cnveg_nitrogenstate_inst%totn_grc , & ! Input: [real(r8) (:) ] (gN/m2) total gridcell nitrogen, incl veg + cropprod1_grc => n_products_inst%cropprod1_grc , & ! Input: [real(r8) (:)] (gN/m2) nitrogen in crop products + product_loss_grc => n_products_inst%product_loss_grc , & ! Input: [real(r8) (:)] (gN/m2) losses from wood & crop products + tot_woodprod_grc => n_products_inst%tot_woodprod_grc , & ! Input: [real(r8) (:)] (gN/m2) total nitrogen in wood products + dwt_seedn_to_leaf_grc => cnveg_nitrogenflux_inst%dwt_seedn_to_leaf_grc , & ! Input: [real(r8) (:)] (gN/m2/s) seed source sent to leaf + dwt_seedn_to_deadstem_grc => cnveg_nitrogenflux_inst%dwt_seedn_to_deadstem_grc , & ! Input: [real(r8) (:)] (gN/m2/s) seed source sent to deadstem + dwt_conv_nflux_grc => cnveg_nitrogenflux_inst%dwt_conv_nflux_grc , & ! Input: [real(r8) (:)] (gN/m2/s) dwt_conv_nflux_patch summed to the gridcell-level + col_begnb => this%begnb_col , & ! Input: [real(r8) (:) ] (gN/m2) column nitrogen mass, beginning of time step + col_endnb => this%endnb_col , & ! Output: [real(r8) (:) ] (gN/m2) column nitrogen mass, end of time step + ndep_to_sminn => soilbiogeochem_nitrogenflux_inst%ndep_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) atmospheric N deposition to soil mineral N + nfix_to_sminn => soilbiogeochem_nitrogenflux_inst%nfix_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) symbiotic/asymbiotic N fixation to soil mineral N + ffix_to_sminn => soilbiogeochem_nitrogenflux_inst%ffix_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) free living N fixation to soil mineral N + fert_to_sminn => soilbiogeochem_nitrogenflux_inst%fert_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) + soyfixn_to_sminn => soilbiogeochem_nitrogenflux_inst%soyfixn_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) + supplement_to_sminn => soilbiogeochem_nitrogenflux_inst%supplement_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) supplemental N supply + denit => soilbiogeochem_nitrogenflux_inst%denit_col , & ! Input: [real(r8) (:) ] (gN/m2/s) total rate of denitrification + sminn_leached => soilbiogeochem_nitrogenflux_inst%sminn_leached_col , & ! Input: [real(r8) (:) ] (gN/m2/s) soil mineral N pool loss to leaching + smin_no3_leached => soilbiogeochem_nitrogenflux_inst%smin_no3_leached_col , & ! Input: [real(r8) (:) ] (gN/m2/s) soil mineral NO3 pool loss to leaching + smin_no3_runoff => soilbiogeochem_nitrogenflux_inst%smin_no3_runoff_col , & ! Input: [real(r8) (:) ] (gN/m2/s) soil mineral NO3 pool loss to runoff + f_n2o_nit => soilbiogeochem_nitrogenflux_inst%f_n2o_nit_col , & ! Input: [real(r8) (:) ] (gN/m2/s) flux of N2o from nitrification + som_n_leached => soilbiogeochem_nitrogenflux_inst%som_n_leached_col , & ! Input: [real(r8) (:) ] (gN/m2/s) total SOM N loss from vertical transport + + col_fire_nloss => cnveg_nitrogenflux_inst%fire_nloss_col , & ! Input: [real(r8) (:) ] (gN/m2/s) total column-level fire N loss + wood_harvestn => cnveg_nitrogenflux_inst%wood_harvestn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) wood harvest (to product pools) + grainn_to_cropprodn => cnveg_nitrogenflux_inst%grainn_to_cropprodn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) grain N to 1-year crop product pool + + totcoln => cnveg_nitrogenstate_inst%totn_col & ! Input: [real(r8) (:) ] (gN/m2) total column nitrogen, incl veg + ) + + ! set time steps + dt = get_step_size_real() + + ! initialize local arrays + col_ninputs_partial(:) = 0._r8 + col_noutputs_partial(:) = 0._r8 + + err_found = .false. + do fc = 1,num_soilc + c=filter_soilc(fc) + + ! calculate the total column-level nitrogen storage, for mass conservation check + col_endnb(c) = totcoln(c) + + ! calculate total column-level inputs + col_ninputs(c) = ndep_to_sminn(c) + nfix_to_sminn(c) + supplement_to_sminn(c) + + if(use_fun)then + col_ninputs(c) = col_ninputs(c) + ffix_to_sminn(c) ! for FUN, free living fixation is a seprate flux. RF. + endif + + if (use_crop) then + col_ninputs(c) = col_ninputs(c) + fert_to_sminn(c) + soyfixn_to_sminn(c) + end if + + col_ninputs_partial(c) = col_ninputs(c) + + ! calculate total column-level outputs + col_noutputs(c) = denit(c) + col_fire_nloss(c) + + ! Fluxes to product pools are included in column-level outputs: the product + ! pools are not included in totcoln, so are outside the system with respect to + ! these balance checks. (However, the dwt flux to product pools is NOT included, + ! since col_begnb is initialized after the dynamic area adjustments - i.e., + ! after the dwt term has already been taken out.) + col_noutputs(c) = col_noutputs(c) + & + wood_harvestn(c) + & + grainn_to_cropprodn(c) + + if (.not. use_nitrif_denitrif) then + col_noutputs(c) = col_noutputs(c) + sminn_leached(c) + else + col_noutputs(c) = col_noutputs(c) + f_n2o_nit(c) + + col_noutputs(c) = col_noutputs(c) + smin_no3_leached(c) + smin_no3_runoff(c) + end if + + col_noutputs(c) = col_noutputs(c) - som_n_leached(c) + + col_noutputs_partial(c) = col_noutputs(c) - & + wood_harvestn(c) - & + grainn_to_cropprodn(c) + + ! calculate the total column-level nitrogen balance error for this time step + col_errnb(c) = (col_ninputs(c) - col_noutputs(c))*dt - & + (col_endnb(c) - col_begnb(c)) + + if (abs(col_errnb(c)) > this%nerror) then + err_found = .true. + err_index = c + end if + + if (abs(col_errnb(c)) > this%nwarning) then + write(iulog,*) 'nbalance warning at c =', c, col_errnb(c), col_endnb(c) + write(iulog,*)'inputs,ffix,nfix,ndep = ',ffix_to_sminn(c)*dt,nfix_to_sminn(c)*dt,ndep_to_sminn(c)*dt + write(iulog,*)'outputs,lch,roff,dnit = ',smin_no3_leached(c)*dt, smin_no3_runoff(c)*dt,f_n2o_nit(c)*dt + end if + + end do ! end of columns loop + + if (err_found) then + c = err_index + write(iulog,*)'column nbalance error = ',col_errnb(c), c + write(iulog,*)'Latdeg,Londeg = ',grc%latdeg(col%gridcell(c)),grc%londeg(col%gridcell(c)) + write(iulog,*)'begnb = ',col_begnb(c) + write(iulog,*)'endnb = ',col_endnb(c) + write(iulog,*)'delta store = ',col_endnb(c)-col_begnb(c) + write(iulog,*)'input mass = ',col_ninputs(c)*dt + write(iulog,*)'output mass = ',col_noutputs(c)*dt + write(iulog,*)'net flux = ',(col_ninputs(c)-col_noutputs(c))*dt + write(iulog,*)'inputs,ffix,nfix,ndep = ',ffix_to_sminn(c)*dt,nfix_to_sminn(c)*dt,ndep_to_sminn(c)*dt + write(iulog,*)'outputs,ffix,nfix,ndep = ',smin_no3_leached(c)*dt, smin_no3_runoff(c)*dt,f_n2o_nit(c)*dt + + + + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Repeat error check at the gridcell level + call c2g( bounds = bounds, & + carr = totcoln(bounds%begc:bounds%endc), & + garr = totgrcn(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + call c2g( bounds = bounds, & + carr = col_ninputs_partial(bounds%begc:bounds%endc), & + garr = grc_ninputs_partial(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + call c2g( bounds = bounds, & + carr = col_noutputs_partial(bounds%begc:bounds%endc), & + garr = grc_noutputs_partial(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + err_found = .false. + do g = bounds%begg, bounds%endg + ! calculate the total gridcell-level nitrogen storage, for mass conservation check + ! Notes: + ! Not including seedn_grc in grc_begnb and grc_endnb because + ! seedn_grc forms out of thin air, for now, and equals + ! -1 * (dwt_seedn_to_leaf_grc(g) + dwt_seedn_to_deadstem_grc(g)) + ! We account for the latter fluxes as inputs below; the same + ! fluxes have entered the pools earlier in the timestep. For true + ! conservation we would need to add a flux out of nfix into seed. + grc_endnb(g) = totgrcn(g) + tot_woodprod_grc(g) + cropprod1_grc(g) + + ! calculate total gridcell-level inputs + grc_ninputs(g) = grc_ninputs_partial(g) + & + dwt_seedn_to_leaf_grc(g) + & + dwt_seedn_to_deadstem_grc(g) + + ! calculate total gridcell-level outputs + grc_noutputs(g) = grc_noutputs_partial(g) + & + dwt_conv_nflux_grc(g) + & + product_loss_grc(g) + + ! calculate the total gridcell-level nitrogen balance error for this time step + grc_errnb(g) = (grc_ninputs(g) - grc_noutputs(g)) * dt - & + (grc_endnb(g) - grc_begnb(g)) + + if (abs(grc_errnb(g)) > this%nerror) then + err_found = .true. + err_index = g + end if + + if (abs(grc_errnb(g)) > this%nwarning) then + write(iulog,*) 'nbalance warning at g =', g, grc_errnb(g), grc_endnb(g) + end if + end do + + if (err_found) then + g = err_index + write(iulog,*) 'gridcell nbalance error =', grc_errnb(g), g + write(iulog,*) 'latdeg, londeg =', grc%latdeg(g), grc%londeg(g) + write(iulog,*) 'begnb =', grc_begnb(g) + write(iulog,*) 'endnb =', grc_endnb(g) + write(iulog,*) 'delta store =', grc_endnb(g) - grc_begnb(g) + write(iulog,*) 'input mass =', grc_ninputs(g) * dt + write(iulog,*) 'output mass =', grc_noutputs(g) * dt + write(iulog,*) 'net flux =', (grc_ninputs(g) - grc_noutputs(g)) * dt + write(iulog,*) '--- Inputs ---' + write(iulog,*) 'grc_ninputs_partial =', grc_ninputs_partial(g) * dt + write(iulog,*) 'dwt_seedn_to_leaf_grc =', dwt_seedn_to_leaf_grc(g) * dt + write(iulog,*) 'dwt_seedn_to_deadstem_grc =', dwt_seedn_to_deadstem_grc(g) * dt + write(iulog,*) '--- Outputs ---' + write(iulog,*) 'grc_noutputs_partial =', grc_noutputs_partial(g) * dt + write(iulog,*) 'dwt_conv_nflux_grc =', dwt_conv_nflux_grc(g) * dt + write(iulog,*) 'product_loss_grc =', product_loss_grc(g) * dt + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end associate + + end subroutine NBalanceCheck + +end module CNBalanceCheckMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM51_Photosynthesis.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM51_Photosynthesis.F90 new file mode 100755 index 000000000..30c5900c1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM51_Photosynthesis.F90 @@ -0,0 +1,541 @@ + module CNCLM_Photosynthesis + + use MAPL_ConstantsMod + use clm_varpar, only : numpft, numrad, num_veg, num_zon, & + nlevcan + use decompMod + use PatchType + use filterMod + + use CNVegNitrogenstateType + use CNVegCarbonstateType + use atm2lndType + use TemperatureType + use SoilStateType + use pftconMod + use WaterDiagnosticBulkType + use SurfaceAlbedoType + use SolarAbsorbedType + use CanopyStateType + use OzoneBaseMod + use PhotosynthesisMod + use WaterFluxBulkType + use WaterStateType + use WaterType + use CNVegetationFacade + + implicit none + + private + public catchcn_calc_rc + + contains + +!--------------------------------------------------- + subroutine catchcn_calc_rc(nch,fveg,tc,qa,pbot,co2v,dayl_factor, & + t10,tm,cond,psis,wet3,bee,capac,fwet,coszen,ityp,& + pardir,pardif,albdir,albdif,dtc,dea,water_inst,bgc_vegetation_inst,rc,rc_dea,rc_dt,& + laisun_out,laisha_out,psnsun_out,psnsha_out,lmrsun_out,& + lmrsha_out,parabs,btran_out) + + use MAPL_SatVaporMod + use QSatMod , only : QSat + use SurfaceAlbedoMod , only : TwoStream + use SurfaceRadiationMod , only : CanopySunShadeFracs + ! INPUTS + integer, intent(in) :: nch ! vector length + + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! catchment vegetation fractions + real, intent(in) :: tc(nch,num_zon) ! canopy temperature (K) + real, intent(in) :: qa(nch,num_zon) ! canopy air specific humidity (kg/kg) + real, intent(in) :: pbot(nch) ! surface pressure (Pa) + real, intent(in) :: co2v(nch) ! atmospheric carbon dioxide concentration + real, intent(in) :: dayl_factor(nch) ! daylength factor (0-1) + real, intent(in) :: t10(nch) ! 10-day "running mean" of the 2 m temperature (K) + real, intent(in) :: tm(nch) ! air temperature at agcm reference height (K) + real, intent(in) :: cond(nch) ! saturated hydraulic conductivity (m/s) + real, intent(in) :: psis(nch) ! saturated matric potential [m] + real, intent(in) :: wet3(nch,num_zon) ! average soil profile wetness [-] + real, intent(in) :: bee(nch) ! Clapp-Hornberger 'b' [-] + real, intent(in) :: capac(nch) ! interception reservoir capacity [kg m^-2] + real, intent(in) :: fwet(nch) ! fraction of canopy that is wet (0-1) + real, intent(in) :: coszen(nch) ! cosine solar zenith angle + integer, intent(in) :: ityp(nch,num_veg,num_zon) ! canopy vegetation index (PFT) + real, intent(in) :: pardir(nch) ! direct PAR (W/m2) + real, intent(in) :: pardif(nch) ! diffuse PAR (W/m2) + real, intent(in) :: albdir(nch,num_veg,num_zon,numrad) ! direct albedo + real, intent(in) :: albdif(nch,num_veg,num_zon,numrad) ! diffuse albedo + real, intent(in) :: dtc ! canopy temperature perturbation (K) [approx 1:10000] + real, intent(in) :: dea ! vapor pressure perturbation (Pa) [approx 1:10000] + type(water_type),intent(in) :: water_inst + type(cn_vegetation_type), intent(in) :: bgc_vegetation_inst + + ! OUTPUTS + real, dimension(nch,num_zon), intent(out) :: rc ! unperturbed canopy stomatal resistance [s/m] + real, dimension(nch,num_zon), intent(out) :: rc_dea ! canopy stomatal resistance with vapor pressure pertubation [s/m] + real, dimension(nch,num_zon), intent(out) :: rc_dt ! canopy stomatal resistance with canopy temperature pertubation [s/m] + real, dimension(nch,num_veg,num_zon), intent(out) :: laisun_out + real, dimension(nch,num_veg,num_zon), intent(out) :: laisha_out + real, dimension(nch,num_veg,num_zon), intent(out) :: psnsun_out + real, dimension(nch,num_veg,num_zon), intent(out) :: psnsha_out + real, dimension(nch,num_veg,num_zon), intent(out) :: lmrsun_out + real, dimension(nch,num_veg,num_zon), intent(out) :: lmrsha_out + real, dimension(nch,num_veg,num_zon), intent(out) :: parabs + real, dimension(nch,num_veg,num_zon), intent(out) :: btran_out + +! LOCAL + + ! CLM variables +! type(bounds_type) :: bounds +! type(atm2lnd_type) :: atm2lnd_inst +! type(temperature_type) :: temperature_inst +! type(soilstate_type) :: soilstate_inst +! type(waterdiagnosticbulk_type) :: waterdiagnosticbulk_inst +! type(surfalb_type) :: surfalb_inst +! type(solarabs_type) :: solarabs_inst +! type(canopystate_type) :: canopystate_inst +! type(ozone_base_type) :: ozone_inst +! type(photosyns_type) :: photosyns_inst +! type(waterfluxbulk_type) :: waterfluxbulk_inst +! type(cnveg_nitrogenstate_type) :: cnveg_nitrogenstate_inst +! type(cnveg_carbonstate_type) :: cnveg_carbonstate_inst +! type(waterstate_type) :: waterstate_inst +! type(clumpfilter) :: filter + + ! temporary and loop variables + integer :: n, p, pft_num, nv, nc, nz, np, ib, nl, iv + real :: bare, tmp_albgrd_vis,tmp_albgrd_nir,& + tmp_albgri_vis,tmp_albgri_nir, & + tmp_parsun, tmp_parsha + + ! filter variables + integer, allocatable, save :: filter_vegsol(:), filter_novegsol(:) + integer :: num_vegsol, num_novegsol + + ! constants and parameters + real :: rair = MAPL_RDRY + real :: extkn = 0.30_r8 ! nitrogen allocation coefficient + integer, parameter :: npft = numpft+1 + + ! local variables for stomatal resistance calculations + real :: rs, rs_dea, rs_dt, rcs, rcs_dea, rcs_dt + real, dimension(nch*NUM_ZON*(numpft+1)) :: laisun, laisha, rssun, rssha + real, dimension(nch*NUM_ZON*(numpft+1)) :: laisun_dea, laisha_dea, rssun_dea, rssha_dea + real, dimension(nch*NUM_ZON*(numpft+1)) :: laisun_dt, laisha_dt, rssun_dt, rssha_dt + + ! local variables to compute Photosynthesis inputs + real :: ws, wl + real(r8), allocatable, dimension(:,:) :: rho, tau + real, dimension (nch, NUM_ZON) :: esat_tv ! vapor pressure inside leaf (sat vapor press at tc) (Pa) + real, dimension (nch, NUM_ZON) :: eair ! vapor pressure of canopy air + real, dimension (nch) :: oair ! Atmospheric O2 partial pressure (Pa) + real, dimension (nch) :: deldT ! d(es)/d(T) + real, dimension (nch) :: cair ! compute CO2 partial pressure + real(r8), dimension (nch) :: rb ! boundary layer resistance (s/m) + real(r8), dimension (nch) :: el ! vapor pressure on leaf surface [pa] + real(r8), dimension (nch, NUM_ZON) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), dimension (nch, NUM_ZON) :: qsatldT ! derivative of "qsatl" on "t_veg" + real, dimension (nch, NUM_ZON) :: qaf ! canopy air humidity [kg/kg] + real(r8), dimension(nch,num_zon) :: tc_in + real(r8), dimension(nch) :: pbot_in + + ! local inputs to Photosynthesis in CLM space + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: coszen_clm ! cosine solar zenith angle for next time step in CLM dimensions + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: esat_tv_clm + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: eair_clm + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: cair_clm + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: oair_clm + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: rb_clm + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: dayl_factor_clm + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: qsatl_clm + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: qaf_clm + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: deldT_clm + + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: eair_pert + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: esat_tv_pert + real(r8), dimension(nch*NUM_ZON*(numpft+1)) :: temp_unpert + + ! local pointers for Photosynthesis inputs + real, pointer :: leafn(:) ! leaf N (gN/m2) + real, pointer :: froot_carbon(:) ! fine root carbon (gC/m2) [pft] + real, pointer :: croot_carbon(:) ! live coarse root carbon (gC/m2) [pft] + integer, pointer :: filter_nourbanp + integer, pointer :: filter_num_nourbanp + integer, pointer :: filter_exposedvegp + integer, pointer :: filter_num_exposedvegp + + ! local outputs from Photosynthesis routine + real(r8) , allocatable, dimension(:) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , allocatable, dimension(:) :: bsha ! shaded canopy transpiration wetness factor (0 to 1) + real(r8) , allocatable, dimension(:) :: btran ! transpiration wetness factor (0 to 1) [pft] + + ! associate variables + + associate(& + rhol => pftcon%rhol , & ! Input: leaf reflectance: 1=vis, 2=nir + rhos => pftcon%rhos , & ! Input: stem reflectance: 1=vis, 2=nir + taul => pftcon%taul , & ! Input: leaf transmittance: 1=vis, 2=nir + taus => pftcon%taus , & ! Input: stem transmittance: 1=vis, 2=nir + xl => pftcon%xl , & + leafn => bgc_vegetation_inst%cnveg_nitrogenstate_inst%leafn_patch , & + froot_carbon => bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_patch , & + croot_carbon => bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_patch, & + elai => canopystate_inst%elai_patch , & + esai => canopystate_inst%esai_patch , & + filter_nourbanp => filter(1)%nourbanp , & + filter_num_nourbanp => filter(1)%num_nourbanp , & + filter_exposedvegp => filter(1)%exposedvegp , & + filter_num_exposedvegp => filter(1)%num_exposedvegp & + ) + +! allocate filters +!----------------------------- + + allocate (filter_vegsol(bounds%endp-bounds%begp+1)) + allocate (filter_novegsol(bounds%endp-bounds%begp+1)) + num_vegsol = 0 + num_novegsol = 0 + +! allocate variables for radiation calculations +!--------------------------------- + + allocate(rho(bounds%begp:bounds%endp,numrad)) + allocate(tau(bounds%begp:bounds%endp,numrad)) + +! allocate Photosynthesis outputs +!-------------------------------- + + allocate(bsun(bounds%begp:bounds%endp)) + allocate(bsha(bounds%begp:bounds%endp)) + allocate(btran(bounds%begp:bounds%endp)) + +! compute saturation vapor pressure +! --------------------------------- + do n = 1,nch + do nz = 1,NUM_ZON + esat_tv(n,nz) = MAPL_EQsat(tc(n,nz),DQ=deldT(n)) + end do + end do + + ! compute canopy air vapor pressure + !---------------------------------- + do n = 1,nch + do nz = 1,NUM_ZON + eair(n,nz) = pbot(n) * qa(n,nz) / (0.622 + qa(n,nz)) ! canopy air vapor pressure (Pa); jk: this is different from the formulation in the CLM code, which is different from the formulation in the CLM documentation + end do + end do + ! compute atmospheric O2 partial pressure + !----------------------------------------- + oair(:) = 0.20946*pbot + + ! compute CO2 partial pressure constant ratio [internal leaf CO2 partial pressure] + !------------------------------- + cair(:) = co2v(:)*pbot + + ! leaf boundary layer resistance + !-------------------------------- + rb = 10. ! jk: in the original Catchment-CN this was arbitrarily set to 10 by gkw, not sure why + + ! leaf specific humidity + !------------------------ + + tc_in = tc + pbot_in = pbot + + do n = 1,nch + do nz = 1,NUM_ZON + call QSat(tc_in(n,nz), pbot_in(n), qsatl(n,nz), & + el(n), & + qsatldT(n,nz)) + end do + end do + + ! canopy air humidity + !-------------------- + + do n = 1,nch + do nz = 1,NUM_ZON + qaf(n,nz) = qa(n,nz) + end do + end do + + ! atmospheric pressure and density downscaled to column level + ! vegetation temperature, 2m 10-day running mean temperature, temperature at AGCM ref. height + !------------------------------------------------ + p = 0 + n = 0 + + do nc = 1,nch + atm2lnd_inst%forc_solad_grc (nc,1) = pardir(nc) + atm2lnd_inst%forc_solai_grc (nc,1) = pardif(nc) + do nz = 1,num_zon + n = n + 1 + atm2lnd_inst%forc_pbot_downscaled_col (n) = pbot(nc) + atm2lnd_inst%forc_rho_downscaled_col (n) = (pbot(nc)-0.378*eair(nc,nz))/(rair*tc(nc,nz)) + + soilstate_inst%hksat_col (n,1:nlevgrnd) = 1000.*COND(nc) ! saturated hydraulic conductivity mapped to CLM space + ! and converted to [mm/s] + soilstate_inst%hk_l_col (n,1:nlevgrnd) = 1000.*COND(nc)*(wet3(nc,nz)**(2*bee(nc)+3)) ! actual hydraulic conductivity mapped to CLM space + ! and converted to [mm/s] + soilstate_inst%smp_l_col (n,1:nlevgrnd) = 1000.*PSIS(nc)*(max(1.e-06_r8,wet3(nc,nz))**(-bee(nc))) ! actual soil matric potential mapped to CLM space + ! and converted to [mm] + soilstate_inst%bsw_col (n,1:nlevgrnd) = bee(nc) ! Clapp-Hornberger 'b' + soilstate_inst%sucsat_col (n,1:nlevgrnd) = 1000.*psis(nc)*(-1) ! minimum soil suction [mm] + + ! compute column level direct and diffuse albedos (vis and nir) from pft level quantities + tmp_albgrd_vis = 0. + tmp_albgrd_nir = 0. + tmp_albgri_vis = 0. + tmp_albgri_nir = 0. + + do nv = 1,num_veg + tmp_albgrd_vis = tmp_albgrd_vis + albdir(nc,nv,nz,1)*fveg(nc,nv,nz) + tmp_albgrd_nir = tmp_albgrd_nir + albdir(nc,nv,nz,2)*fveg(nc,nv,nz) + + tmp_albgri_vis = tmp_albgri_vis + albdif(nc,nv,nz,1)*fveg(nc,nv,nz) + tmp_albgri_nir = tmp_albgri_nir + albdif(nc,nv,nz,2)*fveg(nc,nv,nz) + end do + + surfalb_inst%albgrd_col (n,1) = tmp_albgrd_vis + surfalb_inst%albgrd_col (n,2) = tmp_albgrd_nir + surfalb_inst%albgri_col (n,1) = tmp_albgri_vis + surfalb_inst%albgri_col (n,2) = tmp_albgri_nir + + do np = 0,numpft + p = p + 1 + + ! initialize temperature_inst here and not in its own F90 file, because values of tc, t10, and tm are computed in GridComp + temperature_inst%t_veg_patch(p) = tc(nc,nz) + temperature_inst%t_a10_patch(p) = t10(nc) + temperature_inst%thm_patch(p) = tm(nc) + + ! map Photosynthesis inputs to CLM space + esat_tv_clm (p) = esat_tv(nc,nz) + oair_clm (p) = oair(nc) + cair_clm (p) = cair(nc) + rb_clm (p) = rb(nc) + qsatl_clm (p) = qsatl(nc,nz) + qaf_clm (p) = qaf(nc,nz) + dayl_factor_clm(p) = dayl_factor(nc) + coszen_clm (p) = coszen(nc) + deldT_clm (p) = deldT(nc) + + ! compute canopy air vapor pressure (in CLM space) + eair_clm (p) = eair(nc,nz) + + if (coszen_clm(p)>0. .and. (elai(p) + esai(p))>0.) then + ! calculate solar vegetated filter + num_vegsol = num_vegsol + 1 + filter_vegsol(num_vegsol) = p + + ! calculate rho (weighted reflectance) and tau (weighted transmittance) needed for call to TwoStream later + wl = elai(p) / max( elai(p)+esai(p), 1.e-06_r8 ) + ws = esai(p) / max( elai(p)+esai(p), 1.e-06_r8 ) + + do ib = 1, numrad + rho(p,ib) = max( rhol(np,ib)*wl + rhos(np,ib)*ws, 1.e-06_r8 ) + tau(p,ib) = max( taul(np,ib)*wl + taus(np,ib)*ws, 1.e-06_r8 ) + end do + else + num_novegsol = num_novegsol + 1 + filter_novegsol(num_novegsol) = p + end if + + if (nlevcan == 1) then ! jk: currently only coded for one canopy layer + surfalb_inst%tlai_z_patch(p,1) = elai(p) + surfalb_inst%tsai_z_patch(p,1) = esai(p) + end if + + do iv = 1, surfalb_inst%nrad_patch(p) + surfalb_inst%fabd_sun_z_patch(p,iv) = 0._r8 + surfalb_inst%fabd_sha_z_patch(p,iv) = 0._r8 + surfalb_inst%fabi_sun_z_patch(p,iv) = 0._r8 + surfalb_inst%fabi_sha_z_patch(p,iv) = 0._r8 + surfalb_inst%fsun_z_patch(p,iv) = 0._r8 + end do + + if (nlevcan == 1) then + surfalb_inst%vcmaxcintsun_patch(p) = 0._r8 + surfalb_inst%vcmaxcintsha_patch(p) = (1._r8 - exp(-extkn*elai(p))) / extkn + if (elai(p) > 0._r8) then + surfalb_inst%vcmaxcintsha_patch(p) = surfalb_inst%vcmaxcintsha_patch(p) / elai(p) + else + surfalb_inst%vcmaxcintsha_patch(p) = 0._r8 + end if + else if (nlevcan > 1) then + surfalb_inst%vcmaxcintsun_patch(p) = 0._r8 + surfalb_inst%vcmaxcintsha_patch(p) = 0._r8 + end if + + water_inst%waterdiagnosticbulk_inst%fdry_patch(p) = (1-fwet(nc))*elai(p)/max( elai(p)+esai(p), 1.e-06_r8 ) + water_inst%waterdiagnosticbulk_inst%fwet_patch(p) = fwet(nc) + water_inst%waterdiagnosticbulk_inst%fcansno_patch(p) = fwet(nc) !jk: This is not a mistake, see notes on why we set fcansno = fwet + end do + end do + end do + + + ! call TwoStream subroutine which computes surface albedo variables needed for the subsequent calls; + ! jk Jan 2022: In older versions of CatchCN, the calculations were copy and pasted prior to the Photsynthesis calls; + ! In CLM this subroutine is called *after* the canopy flux calculations, but I decided to add it here to + ! have all required inputs on first time step (similar to how it was done in older CatchCN versions) + + call TwoStream(bounds, & + filter_vegsol, num_vegsol, & + coszen_clm, rho, tau, & + canopystate_inst, temperature_inst, water_inst%waterdiagnosticbulk_inst, surfalb_inst) + + ! compute canopy shaded and sunlit variables (jk: needed to fill solarabs_inst before PHS call) + call CanopySunShadeFracs(filter_nourbanp, filter_num_nourbanp, & + atm2lnd_inst, surfalb_inst, & + canopystate_inst, solarabs_inst) + +! jkolassa: Below are three calls to the photosynthesis subroutine, one unperturbed, +! one with perturbed vapor pressure and one with perturbed canopy temperature. +! The unperturbed call is issued last, so that CLM objects have unperturbed values +! going forward. + +! compute resistance with small delta ea + call photosyns_inst%TimeStepInit(bounds) + eair_pert(:) = eair_clm(:) + dea + + call PhotosynthesisHydraulicStress ( bounds, filter(1)%num_exposedvegp, filter(1)%exposedvegp, & + esat_tv_clm, eair_pert, oair_clm, cair_clm, rb_clm, bsun, bsha, btran, dayl_factor_clm, leafn, & + qsatl_clm, qaf_clm, & + atm2lnd_inst, temperature_inst, soilstate_inst, water_inst%waterdiagnosticbulk_inst, & + surfalb_inst, solarabs_inst, canopystate_inst, ozone_inst, & + photosyns_inst, water_inst%waterfluxbulk_inst, froot_carbon, croot_carbon) + + laisun_dea = canopystate_inst%laisun_patch + laisha_dea = canopystate_inst%laisha_patch + rssun_dea = photosyns_inst%rssun_patch + rssha_dea = photosyns_inst%rssha_patch + +! compute resistance with small delta Tc + + call photosyns_inst%TimeStepInit(bounds) + temp_unpert = temperature_inst%t_veg_patch + temperature_inst%t_veg_patch = temperature_inst%t_veg_patch + dtc + esat_tv_pert(:) = esat_tv_clm(:) + deldT_clm(:)*dtc + + call PhotosynthesisHydraulicStress ( bounds, filter(1)%num_exposedvegp, filter(1)%exposedvegp, & + esat_tv_pert, eair_clm, oair_clm, cair_clm, rb_clm, bsun, bsha, btran, dayl_factor_clm, leafn, & + qsatl_clm, qaf_clm, & + atm2lnd_inst, temperature_inst, soilstate_inst, water_inst%waterdiagnosticbulk_inst, & + surfalb_inst, solarabs_inst, canopystate_inst, ozone_inst, & + photosyns_inst, water_inst%waterfluxbulk_inst, froot_carbon, croot_carbon) + + laisun_dt = canopystate_inst%laisun_patch + laisha_dt = canopystate_inst%laisha_patch + rssun_dt = photosyns_inst%rssun_patch + rssha_dt = photosyns_inst%rssha_patch + +! compute unperturbed resistance + + call photosyns_inst%TimeStepInit(bounds) + + temperature_inst%t_veg_patch = temp_unpert ! reset canopy temperature to unperturbed value + + call PhotosynthesisHydraulicStress ( bounds, filter(1)%num_exposedvegp, filter(1)%exposedvegp, & + esat_tv_clm, eair_clm, oair_clm, cair_clm, rb_clm, bsun, bsha, btran, dayl_factor_clm, leafn, & + qsatl_clm, qaf_clm, & + atm2lnd_inst, temperature_inst, soilstate_inst, water_inst%waterdiagnosticbulk_inst, & + surfalb_inst, solarabs_inst, canopystate_inst, ozone_inst, & + photosyns_inst, water_inst%waterfluxbulk_inst, froot_carbon, croot_carbon) + + laisun = canopystate_inst%laisun_patch + laisha = canopystate_inst%laisha_patch + rssun = photosyns_inst%rssun_patch + rssha = photosyns_inst%rssha_patch + + call PhotosynthesisTotal (filter(1)%num_exposedvegp, filter(1)%exposedvegp, & + atm2lnd_inst, canopystate_inst, photosyns_inst) + + laisun_out = 0. + laisha_out = 0. + psnsun_out = 0. + psnsha_out = 0. + lmrsun_out = 0. + lmrsha_out = 0. + + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + + rcs = 0. + rcs_dea = 0. + rcs_dt = 0. + + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + + ! stomatal resistances + rs = laisun(np)/max(rssun(np), 1.e-06_r8 ) + laisha(np)/max(rssha(np), 1.e-06_r8 ) + rcs = rcs + fveg(nc,nv,nz)*rs + + rs_dea = laisun_dea(np)/max(rssun_dea(np), 1.e-06_r8 ) + laisha_dea(np)/max(rssha_dea(np), 1.e-06_r8 ) + rcs_dea = rcs_dea + fveg(nc,nv,nz)*rs_dea + + rs_dt = laisun_dt(np)/max(rssun_dt(np), 1.e-06_r8 ) + laisha_dt(np)/max(rssha_dt(np), 1.e-06_r8 ) + rcs_dt = rcs_dt + fveg(nc,nv,nz)*rs_dt + + ! LAI + laisun_out(nc,nv,nz) = laisun(np) + laisha_out(nc,nv,nz) = laisha(np) + + if (isnan(laisun(np))) laisun_out(nc,nv,nz) = 0. + if (isnan(laisha(np))) laisha_out(nc,nv,nz) = 0. + + ! Photosynthesis + psnsun_out(nc,nv,nz) = photosyns_inst%psnsun_patch(np) + psnsha_out(nc,nv,nz) = photosyns_inst%psnsha_patch(np) + + if (isnan(psnsun_out(nc,nv,nz))) psnsun_out(nc,nv,nz) = 0. + if (isnan(psnsha_out(nc,nv,nz))) psnsha_out(nc,nv,nz) = 0. + + ! Leaf maintenance respiration + lmrsun_out(nc,nv,nz) = photosyns_inst%lmrsun_patch(np) + lmrsha_out(nc,nv,nz) = photosyns_inst%lmrsha_patch(np) + + if (isnan(lmrsun_out(nc,nv,nz))) lmrsun_out(nc,nv,nz) = 0. + if (isnan(lmrsha_out(nc,nv,nz))) lmrsha_out(nc,nv,nz) = 0. + + ! total absorbed PAR + tmp_parsun = 0. + tmp_parsha = 0. + do nl = 1,nlevcan + tmp_parsun = tmp_parsun + solarabs_inst%parsun_z_patch(np,nl) + tmp_parsha = tmp_parsha + solarabs_inst%parsha_z_patch(np,nl) + end do + + parabs(nc,nv,nz) = tmp_parsun * laisun(np) + tmp_parsha * laisha(np) + + ! transpiration wetness factor / water stress + + btran_out(nc,nv,nz) = btran(np) + + end if ! ityp = p + end do !nv + end do ! p + rc(nc,nz) = 1./max(rcs,5.e-5) + rb(nc) ! rc: unperturbed stomatal resistance (rs is stomatal conductance) + rc_dea(nc,nz) = 1./max(rcs_dea,5.e-5) + rb(nc) ! rc_dea: stomatal resistance with vapor pressure perturbation + rc_dt(nc,nz) = 1./max(rcs_dt,5.e-5) + rb(nc) ! rc_dt: stomatal resistance with canopy temperature perturbation + end do ! nz + end do ! nc + + end associate + + deallocate(filter_vegsol) + deallocate(filter_novegsol) + deallocate(rho) + deallocate(tau) + deallocate(bsun) + deallocate(bsha) + deallocate(btran) + + end subroutine catchcn_calc_rc + +end module CNCLM_Photosynthesis + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ActiveLayerMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ActiveLayerMod.F90 new file mode 100755 index 000000000..84b3bc687 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ActiveLayerMod.F90 @@ -0,0 +1,203 @@ +module ActiveLayerMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module holding routines for calculation of active layer dynamics + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use shr_const_mod , only : SHR_CONST_TKFRZ + use clm_varctl , only : iulog, use_cn + use clm_varcon , only : spval + use TemperatureType , only : temperature_type + use ColumnType , only : col + use GridcellType , only : grc + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + ! !PUBLIC TYPES: + type, public :: active_layer_type + private + ! Public data members: + real(r8) , pointer, public :: altmax_col (:) ! col maximum annual depth of thaw + real(r8) , pointer, public :: altmax_lastyear_col (:) ! col prior year maximum annual depth of thaw + integer , pointer, public :: altmax_indx_col (:) ! col maximum annual depth of thaw + integer , pointer, public :: altmax_lastyear_indx_col (:) ! col prior year maximum annual depth of thaw + + ! Private data members: + real(r8) , pointer :: alt_col (:) ! col current depth of thaw + integer , pointer :: alt_indx_col (:) ! col current depth of thaw + + contains + procedure , public :: alt_calc + procedure , public :: Init + + end type active_layer_type + type(active_layer_type), public, target, save :: active_layer_inst + +!--------------------------------------- + +contains + +!--------------------------------------- + subroutine Init(this, bounds) + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + class(active_layer_type) :: this + ! + !----------------------------------------------------------------------- + + associate( & + begc => bounds%begc, & + endc => bounds%endc & + ) + + allocate(this%alt_col (begc:endc)) ; this%alt_col (:) = spval + allocate(this%altmax_col (begc:endc)) ; this%altmax_col (:) = spval + allocate(this%altmax_lastyear_col (begc:endc)) ; this%altmax_lastyear_col (:) = spval + allocate(this%alt_indx_col (begc:endc)) ; this%alt_indx_col (:) = huge(1) + allocate(this%altmax_indx_col (begc:endc)) ; this%altmax_indx_col (:) = huge(1) + allocate(this%altmax_lastyear_indx_col (begc:endc)) ; this%altmax_lastyear_indx_col (:) = huge(1) + + end associate + + end subroutine Init + +!----------------------------------------- + subroutine alt_calc(this, num_soilc, filter_soilc, & + temperature_inst) + ! + ! !DESCRIPTION: + ! define active layer thickness similarly to frost_table, except set as deepest thawed layer and define on nlevgrnd + ! also update annual maxima, and keep track of prior year for rooting memory + ! + ! BUG(wjs, 2014-12-15, bugz 2107) Because of this routine's placement in the driver + ! sequence (it is called very early in each timestep, before weights are adjusted and + ! filters are updated), it may be necessary for this routine to compute values over + ! inactive as well as active points (since some inactive points may soon become + ! active) - so that's what is done now. Currently, it seems to be okay to do this, + ! because the variables computed here seem to only depend on quantities that are valid + ! over inactive as well as active points. + ! + ! !USES: + use shr_const_mod , only : SHR_CONST_TKFRZ + use clm_varpar , only : nlevgrnd + use clm_time_manager , only : get_curr_date, get_step_size + use clm_varctl , only : iulog + use clm_varcon , only : zsoi + ! + ! !ARGUMENTS: + class(active_layer_type), intent(inout) :: this + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(temperature_type) , intent(in) :: temperature_inst + ! + ! !LOCAL VARIABLES: + integer :: c, j, fc, g ! counters + integer :: alt_ind ! index of base of activel layer + integer :: year ! year (0, ...) for nstep+1 + integer :: mon ! month (1, ..., 12) for nstep+1 + integer :: day ! day of month (1, ..., 31) for nstep+1 + integer :: sec ! seconds into current date for nstep+1 + integer :: dtime ! time step length in seconds + integer :: k_frz ! index of first nonfrozen soil layer + logical :: found_thawlayer ! used to break loop when first unfrozen layer reached + real(r8) :: t1, t2, z1, z2 ! temporary variables + !----------------------------------------------------------------------- + + + associate( & + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + + alt => this%alt_col , & ! Output: [real(r8) (:) ] current depth of thaw + altmax => this%altmax_col , & ! Output: [real(r8) (:) ] maximum annual depth of thaw + altmax_lastyear => this%altmax_lastyear_col , & ! Output: [real(r8) (:) ] prior year maximum annual depth of thaw + alt_indx => this%alt_indx_col , & ! Output: [integer (:) ] current depth of thaw + altmax_indx => this%altmax_indx_col , & ! Output: [integer (:) ] maximum annual depth of thaw + altmax_lastyear_indx => this%altmax_lastyear_indx_col & ! Output: [integer (:) ] prior year maximum annual depth of thaw + ) + + ! on a set annual timestep, update annual maxima + ! make this 1 January for NH columns, 1 July for SH columns + call get_curr_date(year, mon, day, sec) + dtime = get_step_size() + if ( (mon .eq. 1) .and. (day .eq. 1) .and. ( sec / dtime .eq. 1) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + if ( grc%lat(g) > 0. ) then + altmax_lastyear(c) = altmax(c) + altmax_lastyear_indx(c) = altmax_indx(c) + altmax(c) = 0. + altmax_indx(c) = 0 + endif + end do + endif + if ( (mon .eq. 7) .and. (day .eq. 1) .and. ( sec / dtime .eq. 1) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + if ( grc%lat(g) <= 0. ) then + altmax_lastyear(c) = altmax(c) + altmax_lastyear_indx(c) = altmax_indx(c) + altmax(c) = 0. + altmax_indx(c) = 0 + endif + end do + endif + + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate alt for a given timestep + ! start from base of soil and search upwards for first thawed layer. + ! note that this will put talik in with active layer + ! a different way of doing this could be to keep track of how long a given layer has ben frozen for, and define ALT as the first layer that has been frozen for less than 2 years. + if (t_soisno(c,nlevgrnd) > SHR_CONST_TKFRZ ) then + alt(c) = zsoi(nlevgrnd) + alt_indx(c) = nlevgrnd + else + k_frz=0 + found_thawlayer = .false. + do j=nlevgrnd-1,1,-1 + if ( ( t_soisno(c,j) > SHR_CONST_TKFRZ ) .and. .not. found_thawlayer ) then + k_frz=j + found_thawlayer = .true. + endif + end do + + if ( k_frz > 0 ) then + ! define active layer as the depth at which the linearly interpolated temperature line intersects with zero + z1 = zsoi(k_frz) + z2 = zsoi(k_frz+1) + t1 = t_soisno(c,k_frz) + t2 = t_soisno(c,k_frz+1) + alt(c) = z1 + (t1-SHR_CONST_TKFRZ)*(z2-z1)/(t1-t2) + alt_indx(c) = k_frz + else + alt(c)=0._r8 + alt_indx(c) = 0 + endif + endif + + + ! if appropriate, update maximum annual active layer thickness + if (alt(c) > altmax(c)) then + altmax(c) = alt(c) + altmax_indx(c) = alt_indx(c) + endif + + end do + + end associate + + end subroutine alt_calc + +end module ActiveLayerMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNDVType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNDVType.F90 new file mode 100755 index 000000000..d9f528bbf --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNDVType.F90 @@ -0,0 +1,131 @@ +module CNDVType + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing routines to drive the annual dynamic vegetation + ! that works with CN, reset related variables, + ! and initialize/reset time invariant variables + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use decompMod , only : bounds_type + use clm_varctl , only : use_cndv, iulog + + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + ! !PUBLIC DATA TYPES: + ! + ! DGVM-specific ecophysiological constants structure (patch-level) + type, public :: dgv_ecophyscon_type + real(r8), pointer :: crownarea_max(:) ! patch tree maximum crown area [m2] + real(r8), pointer :: tcmin(:) ! patch minimum coldest monthly mean temperature [units?] + real(r8), pointer :: tcmax(:) ! patch maximum coldest monthly mean temperature [units?] + real(r8), pointer :: gddmin(:) ! patch minimum growing degree days (at or above 5 C) + real(r8), pointer :: twmax(:) ! patch upper limit of temperature of the warmest month [units?] + real(r8), pointer :: reinickerp(:) ! patch parameter in allometric equation + real(r8), pointer :: allom1(:) ! patch parameter in allometric + real(r8), pointer :: allom2(:) ! patch parameter in allometric + real(r8), pointer :: allom3(:) ! patch parameter in allometric + end type dgv_ecophyscon_type + type(dgv_ecophyscon_type), public :: dgv_ecophyscon + + ! DGVM state variables structure + type, public :: dgvs_type + real(r8), pointer, public :: agdd_patch (:) ! patch accumulated growing degree days above 5 + real(r8), pointer, public :: agddtw_patch (:) ! patch accumulated growing degree days above twmax + real(r8), pointer, public :: agdd20_patch (:) ! patch 20-yr running mean of agdd + real(r8), pointer, public :: tmomin20_patch (:) ! patch 20-yr running mean of tmomin + logical , pointer, public :: present_patch (:) ! patch whether PATCH present in patch + logical , pointer, public :: pftmayexist_patch (:) ! patch if .false. then exclude seasonal decid patches from tropics + real(r8), pointer, public :: nind_patch (:) ! patch number of individuals (#/m**2) + real(r8), pointer, public :: lm_ind_patch (:) ! patch individual leaf mass + real(r8), pointer, public :: lai_ind_patch (:) ! patch LAI per individual + real(r8), pointer, public :: fpcinc_patch (:) ! patch foliar projective cover increment (fraction) + real(r8), pointer, public :: fpcgrid_patch (:) ! patch foliar projective cover on gridcell (fraction) + real(r8), pointer, public :: fpcgridold_patch (:) ! patch last yr's fpcgrid + real(r8), pointer, public :: crownarea_patch (:) ! patch area that each individual tree takes up (m^2) + real(r8), pointer, public :: greffic_patch (:) + real(r8), pointer, public :: heatstress_patch (:) + + contains + + procedure , public :: Init + + end type dgvs_type + type(dgvs_type), public, target, save :: dgvs_inst + +contains + +!------------------------------------------------------ + subroutine Init(this, bounds) + + use nanMod , only : nan + use clm_varpar , only : maxveg + use pftconMod , only : allom1s, allom2s, allom1, allom2, allom3, reinickerp + use pftconMod , only : nbrdlf_dcd_brl_shrub + use pftconMod , only : pftcon + + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(dgvs_type) :: this + + !LOCAL + integer :: begp, endp + integer :: m + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + allocate(this%agdd_patch (begp:endp)) ; this%agdd_patch (:) = nan + allocate(this%agddtw_patch (begp:endp)) ; this%agddtw_patch (:) = nan + allocate(this%agdd20_patch (begp:endp)) ; this%agdd20_patch (:) = nan + allocate(this%tmomin20_patch (begp:endp)) ; this%tmomin20_patch (:) = nan + allocate(this%present_patch (begp:endp)) ; this%present_patch (:) = .false. + allocate(this%pftmayexist_patch (begp:endp)) ; this%pftmayexist_patch (:) = .true. + allocate(this%nind_patch (begp:endp)) ; this%nind_patch (:) = nan + allocate(this%lm_ind_patch (begp:endp)) ; this%lm_ind_patch (:) = nan + allocate(this%lai_ind_patch (begp:endp)) ; this%lai_ind_patch (:) = nan + allocate(this%fpcinc_patch (begp:endp)) ; this%fpcinc_patch (:) = nan + allocate(this%fpcgrid_patch (begp:endp)) ; this%fpcgrid_patch (:) = nan + allocate(this%fpcgridold_patch (begp:endp)) ; this%fpcgridold_patch (:) = nan + allocate(this%crownarea_patch (begp:endp)) ; this%crownarea_patch (:) = nan + allocate(this%greffic_patch (begp:endp)) ; this%greffic_patch (:) = nan + allocate(this%heatstress_patch (begp:endp)) ; this%heatstress_patch (:) = nan + + + allocate(dgv_ecophyscon%crownarea_max (0:maxveg)) + allocate(dgv_ecophyscon%tcmin (0:maxveg)) + allocate(dgv_ecophyscon%tcmax (0:maxveg)) + allocate(dgv_ecophyscon%gddmin (0:maxveg)) + allocate(dgv_ecophyscon%twmax (0:maxveg)) + allocate(dgv_ecophyscon%reinickerp (0:maxveg)) + allocate(dgv_ecophyscon%allom1 (0:maxveg)) + allocate(dgv_ecophyscon%allom2 (0:maxveg)) + allocate(dgv_ecophyscon%allom3 (0:maxveg)) + + do m = 0,maxveg + dgv_ecophyscon%crownarea_max(m) = pftcon%pftpar20(m) + dgv_ecophyscon%tcmin(m) = pftcon%pftpar28(m) + dgv_ecophyscon%tcmax(m) = pftcon%pftpar29(m) + dgv_ecophyscon%gddmin(m) = pftcon%pftpar30(m) + dgv_ecophyscon%twmax(m) = pftcon%pftpar31(m) + dgv_ecophyscon%reinickerp(m) = reinickerp + dgv_ecophyscon%allom1(m) = allom1 + dgv_ecophyscon%allom2(m) = allom2 + dgv_ecophyscon%allom3(m) = allom3 + ! modification for shrubs by X.D.Z + if (pftcon%is_shrub(m)) then + dgv_ecophyscon%allom1(m) = allom1s + dgv_ecophyscon%allom2(m) = allom2s + end if + end do + end subroutine Init + +end module CNDVType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNFireBaseMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNFireBaseMod.F90 new file mode 100755 index 000000000..0b70acadc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNFireBaseMod.F90 @@ -0,0 +1,1294 @@ +module CNFireBaseMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! module for fire dynamics + ! created in Nov, 2012 and revised in Apr, 2013 by F. Li and S. Levis + ! based on Li et al. (2012a,b; 2013) + ! revised in Apr, 2014 according Li et al.(2014) + ! Fire-related parameters were calibrated or tuned in Apr, 2013 based on the + ! 20th Century transient simulations at f19_g16 with (newfire05_clm45sci15_clm4_0_58) + ! a CLM4.5 version, Qian et al. (2006) atmospheric forcing, and + ! climatological lightning data. + ! + ! !USES: + use nanMod , only : nan + use shr_kind_mod , only : r8 => shr_kind_r8, CL => shr_kind_CL + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog + use clm_varpar , only : nlevgrnd + use pftconMod , only : noveg, pftcon + use abortutils , only : endrun + use decompMod , only : bounds_type + use atm2lndType , only : atm2lnd_type + use CNDVType , only : dgvs_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type, spinup_factor_deadwood + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use EnergyFluxType , only : energyflux_type + use SaturatedExcessRunoffMod , only : saturated_excess_runoff_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use SoilStateType , only : soilstate_type + use SoilWaterRetentionCurveMod , only : soil_water_retention_curve_type + use GridcellType , only : grc + use ColumnType , only : col + use PatchType , only : patch + use FireMethodType , only : fire_method_type + use FireDataBaseType , only : fire_base_type + ! + implicit none + private + ! + ! !PUBLIC TYPES: + public :: cnfire_base_type + + type, public :: cnfire_const_type + ! !PRIVATE MEMBER DATA: + real(r8) :: borealat = 40._r8 ! Latitude for boreal peat fires + real(r8) :: lfuel=75._r8 ! lower threshold of fuel mass (gC/m2) for ignition, Li et al.(2014) + real(r8) :: ufuel=650._r8 ! upper threshold of fuel mass(gC/m2) for ignition + real(r8) :: g0=0.05_r8 ! g(W) when W=0 m/s + real(r8) :: rh_low=30.0_r8 ! Relative humidty low (%) + real(r8) :: rh_hgh=80.0_r8 ! Relative humidty high (%) + real(r8) :: bt_min=0.3_r8 ! btran minimum (fraction) + real(r8) :: bt_max=0.7_r8 ! btran maximum (fraction) + real(r8) :: cli_scale=0.035_r8 ! global constant for deforestation fires (/d) + real(r8) :: boreal_peatfire_c = 4.2e-5_r8 ! c parameter for boreal peatland fire in Li et. al. (2013) (/hr) + real(r8) :: pot_hmn_ign_counts_alpha=0.0035_r8 ! Potential human ignition counts (alpha in Li et. al. 2012) (/person/month) + real(r8) :: non_boreal_peatfire_c = 0.001_r8 ! c parameter for non-boreal peatland fire in Li et. al. (2013) (/hr) + real(r8) :: cropfire_a1 = 0.3_r8 ! a1 parameter for cropland fire in (Li et. al., 2014) (/hr) + real(r8) :: occur_hi_gdp_tree = 0.39_r8 ! fire occurance for high GDP areas that are tree dominated (fraction) + + real(r8) :: cmb_cmplt_fact_litter = 0.5_r8 ! combustion completion factor for litter (unitless) + real(r8) :: cmb_cmplt_fact_cwd = 0.25_r8 ! combustion completion factor for CWD (unitless) + end type + + type, public :: params_type + real(r8) :: prh30 ! Factor related to dependence of fuel combustibility on 30-day running mean of relative humidity (unitless) + real(r8) :: ignition_efficiency ! Ignition efficiency of cloud-to-ground lightning (unitless) + end type params_type + + ! + type, abstract, extends(fire_base_type) :: cnfire_base_type + private + ! !PRIVATE MEMBER DATA: + ! !PUBLIC MEMBER DATA (used by extensions of the base class): + real(r8), public, pointer :: btran2_patch (:) ! patch root zone soil wetness factor (0 to 1) + + contains + ! + ! !PUBLIC MEMBER FUNCTIONS: + procedure, public :: FireInit => CNFireInit ! Initialization of Fire + procedure, public :: FireReadNML ! Read in namelist for CNFire + procedure, public :: CNFireReadParams ! Read in constant parameters from the paramsfile + procedure, public :: CNFireFluxes ! Calculate fire fluxes + procedure, public :: CNFire_calc_fire_root_wetness_Li2014 ! Calculate CN-fire specific root wetness: original version + procedure, public :: CNFire_calc_fire_root_wetness_Li2021 ! Calculate CN-fire specific root wetness: 2021 version + ! !PRIVATE MEMBER FUNCTIONS: + procedure, private :: InitAllocate ! Memory allocation of Fire + ! procedure, private :: InitHistory ! History file assignment of fire + ! + end type cnfire_base_type + + !----------------------------------------------------------------------- + + abstract interface + !----------------------------------------------------------------------- + function need_lightning_and_popdens_interface(this) result(need_lightning_and_popdens) + ! + ! !DESCRIPTION: + ! Returns true if need lightning and popdens, false otherwise + ! + ! USES + import :: cnfire_base_type + ! + ! !ARGUMENTS: + class(cnfire_base_type), intent(in) :: this + logical :: need_lightning_and_popdens ! function result + !----------------------------------------------------------------------- + end function need_lightning_and_popdens_interface + end interface + + type(cnfire_const_type), public, protected :: cnfire_const ! Fire constants shared by Li versons + type(params_type) , public, protected :: cnfire_params ! Fire parameters shared by Li versions + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + subroutine CNFireInit( this, bounds ) + ! + ! !DESCRIPTION: + ! Initialize CN Fire module + ! !ARGUMENTS: + class(cnfire_base_type) :: this + type(bounds_type), intent(in) :: bounds + !----------------------------------------------------------------------- + ! Call the base-class Initialization method + call this%BaseFireInit( bounds ) + + ! Allocate memory + call this%InitAllocate( bounds ) + ! History file + ! call this%InitHistory( bounds ) + end subroutine CNFireInit + !---------------------------------------------------------------------- + + subroutine InitAllocate( this, bounds ) + ! + ! Initiaze memory allocate's + ! use shr_infnan_mod , only : nan => shr_infnan_nan + ! + ! !ARGUMENTS: + class(cnfire_base_type) :: this + type(bounds_type), intent(in) :: bounds + !----------------------------------------------------------------------- + integer :: begp, endp + !------------------------------------------------------------------------ + begp = bounds%begp; endp= bounds%endp + + allocate(this%btran2_patch (begp:endp)) ; this%btran2_patch (:) = nan + + end subroutine InitAllocate + + !---------------------------------------------------------------------- + subroutine CNFire_calc_fire_root_wetness_Li2014( this, bounds, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + waterstatebulk_inst, soilstate_inst, soil_water_retention_curve ) + ! + ! Calculate the root wetness term that will be used by the fire model + ! + class(cnfire_base_type) :: this + type(bounds_type) , intent(in) :: bounds !bounds + integer , intent(in) :: num_exposedvegp !number of filters + integer , intent(in) :: filter_exposedvegp(:) !filter array + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + type(waterstatebulk_type), intent(in) :: waterstatebulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + class(soil_water_retention_curve_type), intent(in) :: soil_water_retention_curve + ! !LOCAL VARIABLES: + real(r8) :: smp_node, s_node !temporary variables + real(r8) :: smp_node_lf !temporary variable + integer :: p, fp, j, c, l !indices + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(filter_exposedvegp) >= (/num_exposedvegp/)), sourcefile, __LINE__) + + associate( & + smpso => pftcon%smpso , & ! Input: soil water potential at full stomatal opening (mm) + smpsc => pftcon%smpsc , & ! Input: soil water potential at full stomatal closure (mm) + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation + btran2 => this%btran2_patch , & ! Output: [real(r8) (:) ] integrated soil water stress square + rootfr => soilstate_inst%rootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (porosity) (constant) + ) + + do fp = 1, num_noexposedvegp + p = filter_noexposedvegp(fp) + ! Set for the sake of history diagnostics. The "normal" btran is set to 0 over + ! this filter, so we do the same for btran2. + btran2(p) = 0._r8 + end do + + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + btran2(p) = 0._r8 + end do + do j = 1,nlevgrnd + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + c = patch%column(p) + l = patch%landunit(p) + s_node = max(h2osoi_vol(c,j)/watsat(c,j), 0.01_r8) + + call soil_water_retention_curve%soil_suction(c, j, s_node, soilstate_inst, smp_node_lf) + + smp_node_lf = max(smpsc(patch%itype(p)), smp_node_lf) + btran2(p) = btran2(p) +rootfr(p,j)*max(0._r8,min((smp_node_lf - smpsc(patch%itype(p))) / & + (smpso(patch%itype(p)) - smpsc(patch%itype(p))), 1._r8)) + end do + end do + + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + if (btran2(p) > 1._r8) then + btran2(p) = 1._r8 + end if + end do + + end associate + + end subroutine CNFire_calc_fire_root_wetness_Li2014 + + !---------------------------------------------------------------------- + subroutine CNFire_calc_fire_root_wetness_Li2021( this, bounds, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + waterstatebulk_inst, soilstate_inst, soil_water_retention_curve ) + ! + ! Calculate the root wetness term that will be used by the fire model + ! + use pftconMod , only : pftcon + use PatchType , only : patch + class(cnfire_base_type) :: this + type(bounds_type) , intent(in) :: bounds !bounds + integer , intent(in) :: num_exposedvegp !number of filters + integer , intent(in) :: filter_exposedvegp(:) !filter array + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + type(waterstatebulk_type), intent(in) :: waterstatebulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + class(soil_water_retention_curve_type), intent(in) :: soil_water_retention_curve + ! !LOCAL VARIABLES: + real(r8) :: s_node !temporary variables + integer :: p, fp, j, c !indices + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(filter_exposedvegp) >= (/num_exposedvegp/)), sourcefile, __LINE__) + + associate( & + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation + btran2 => this%btran2_patch , & ! Output: [real(r8) (:) ] integrated soil water stress square + rootfr => soilstate_inst%rootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (porosity) (constant) + ) + + do fp = 1, num_noexposedvegp + p = filter_noexposedvegp(fp) + ! Set for the sake of history diagnostics. The "normal" btran is set to 0 over + ! this filter, so we do the same for btran2. + btran2(p) = 0._r8 + end do + + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + btran2(p) = 0._r8 + end do + do j = 1,nlevgrnd + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + c = patch%column(p) + s_node = max(h2osoi_vol(c,j)/watsat(c,j), 0.01_r8) + + btran2(p) = btran2(p) + rootfr(p,j)*s_node + end do + end do + + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + if (btran2(p) > 1._r8) then + btran2(p) = 1._r8 + end if + end do + + end associate + + end subroutine CNFire_calc_fire_root_wetness_Li2021 + !---------------------------------------------------------------------- + + !---------------------------------------------------------------------- + subroutine FireReadNML( this, NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for CNFire + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + + ! + ! !ARGUMENTS: + class(cnfire_base_type) :: this + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'FireReadNML' + character(len=*), parameter :: nmlname = 'lifire_inparm' + !----------------------------------------------------------------------- + real(r8) :: cli_scale, boreal_peatfire_c, pot_hmn_ign_counts_alpha + real(r8) :: non_boreal_peatfire_c, cropfire_a1 + real(r8) :: rh_low, rh_hgh, bt_min, bt_max, occur_hi_gdp_tree + real(r8) :: lfuel, ufuel, cmb_cmplt_fact_litter, cmb_cmplt_fact_cwd + + namelist /lifire_inparm/ cli_scale, boreal_peatfire_c, pot_hmn_ign_counts_alpha, & + non_boreal_peatfire_c, cropfire_a1, & + rh_low, rh_hgh, bt_min, bt_max, occur_hi_gdp_tree, & + lfuel, ufuel, cmb_cmplt_fact_litter, cmb_cmplt_fact_cwd + + if ( this%need_lightning_and_popdens() ) then + cli_scale = cnfire_const%cli_scale + boreal_peatfire_c = cnfire_const%boreal_peatfire_c + non_boreal_peatfire_c = cnfire_const%non_boreal_peatfire_c + pot_hmn_ign_counts_alpha = cnfire_const%pot_hmn_ign_counts_alpha + cropfire_a1 = cnfire_const%cropfire_a1 + rh_low = cnfire_const%rh_low + rh_hgh = cnfire_const%rh_hgh + lfuel = cnfire_const%lfuel + ufuel = cnfire_const%ufuel + bt_min = cnfire_const%bt_min + bt_max = cnfire_const%bt_max + occur_hi_gdp_tree = cnfire_const%occur_hi_gdp_tree + cmb_cmplt_fact_litter = cnfire_const%cmb_cmplt_fact_litter + cmb_cmplt_fact_cwd = cnfire_const%cmb_cmplt_fact_cwd + ! Initialize options to default values, in case they are not specified in + ! the namelist + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=lifire_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (cli_scale , mpicom) + call shr_mpi_bcast (boreal_peatfire_c , mpicom) + call shr_mpi_bcast (pot_hmn_ign_counts_alpha, mpicom) + call shr_mpi_bcast (non_boreal_peatfire_c , mpicom) + call shr_mpi_bcast (cropfire_a1 , mpicom) + call shr_mpi_bcast (rh_low , mpicom) + call shr_mpi_bcast (rh_hgh , mpicom) + call shr_mpi_bcast (lfuel , mpicom) + call shr_mpi_bcast (ufuel , mpicom) + call shr_mpi_bcast (bt_min , mpicom) + call shr_mpi_bcast (bt_max , mpicom) + call shr_mpi_bcast (occur_hi_gdp_tree , mpicom) + call shr_mpi_bcast (cmb_cmplt_fact_litter , mpicom) + call shr_mpi_bcast (cmb_cmplt_fact_cwd , mpicom) + + cnfire_const%cli_scale = cli_scale + cnfire_const%boreal_peatfire_c = boreal_peatfire_c + cnfire_const%non_boreal_peatfire_c = non_boreal_peatfire_c + cnfire_const%pot_hmn_ign_counts_alpha = pot_hmn_ign_counts_alpha + cnfire_const%cropfire_a1 = cropfire_a1 + cnfire_const%rh_low = rh_low + cnfire_const%rh_hgh = rh_hgh + cnfire_const%lfuel = lfuel + cnfire_const%ufuel = ufuel + cnfire_const%bt_min = bt_min + cnfire_const%bt_max = bt_max + cnfire_const%occur_hi_gdp_tree = occur_hi_gdp_tree + cnfire_const%cmb_cmplt_fact_litter = cmb_cmplt_fact_litter + cnfire_const%cmb_cmplt_fact_cwd = cmb_cmplt_fact_cwd + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=lifire_inparm) + write(iulog,*) ' ' + end if + end if + + + end subroutine FireReadNML + + !----------------------------------------------------------------------- + subroutine CNFireFluxes (this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_actfirec, filter_actfirec, num_actfirep, filter_actfirep, & + dgvs_inst, cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, & + leaf_prof_patch, froot_prof_patch, croot_prof_patch, stem_prof_patch, & + totsomc_col, decomp_cpools_vr_col, decomp_npools_vr_col, somc_fire_col) + ! + ! !DESCRIPTION: + ! Fire effects routine for coupled carbon-nitrogen code (CN). + ! Relies primarily on estimate of fractional area burned, from CNFireArea(). + ! + ! Total fire carbon emissions (g C/m2 land area/yr) + ! =avg(COL_FIRE_CLOSS)*seconds_per_year + avg(SOMC_FIRE)*seconds_per_year + + ! avg(LF_CONV_CFLUX)*seconds_per_year*min(1.0,avg(LFC2)*seconds_per_year)*0.8 + ! where avg means the temporal average in a year + ! seconds_per_year is the number of seconds in a year. + ! + ! !USES: + use clm_time_manager , only: get_step_size_real,get_days_per_year,get_curr_date + use clm_varctl , only: use_cndv, use_soil_matrixcn, use_matrixcn + use clm_varcon , only: secspday + use pftconMod , only: nc3crop + use dynSubgridControlMod , only: run_has_transient_landcover + use clm_varpar , only: nlevdecomp_full, ndecomp_pools, nlevdecomp + use clm_varpar , only: ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,iretransn,ioutc,ioutn + ! use CNVegMatrixMod , only: matrix_update_fic, matrix_update_fin + ! + ! !ARGUMENTS: + class(cnfire_base_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(out) :: num_actfirep ! number of active patches on fire in filter + integer , intent(out) :: filter_actfirep(:) ! filter for soil patches + integer , intent(out) :: num_actfirec ! number of active columns on fire in filter + integer , intent(out) :: filter_actfirec(:) ! filter for soil columns + type(dgvs_type) , intent(inout) :: dgvs_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst ! only for matrix_decomp_fire_k: (gC/m3/step) VR deomp. C fire loss in matrix representation + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + real(r8) , intent(in) :: leaf_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: froot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: croot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: stem_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: totsomc_col(bounds%begc:) ! (gC/m2) total soil organic matter C + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,1:,1:) ! (gC/m3) VR decomp. (litter, cwd, soil) + real(r8) , intent(in) :: decomp_npools_vr_col(bounds%begc:,1:,1:) ! (gC/m3) VR decomp. (litter, cwd, soil) + real(r8) , intent(out) :: somc_fire_col(bounds%begc:) ! (gC/m2/s) fire C emissions due to peat burning + ! + ! !LOCAL VARIABLES: + integer :: g,c,p,j,l,kyr, kmo, kda, mcsec ! indices + integer :: fp,fc ! filter indices + real(r8):: f ! rate for fire effects (1/s) + real(r8):: m ! acceleration factor for fuel carbon + real(r8):: dt ! time step variable (s) + real(r8):: dayspyr ! days per year + logical :: transient_landcover ! whether this run has any prescribed transient landcover + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(leaf_prof_patch) == (/bounds%endp,nlevdecomp_full/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(froot_prof_patch) == (/bounds%endp,nlevdecomp_full/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(croot_prof_patch) == (/bounds%endp,nlevdecomp_full/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(stem_prof_patch) == (/bounds%endp,nlevdecomp_full/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(totsomc_col) == (/bounds%endc/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_cpools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_npools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(somc_fire_col) == (/bounds%endc/)) , sourcefile, __LINE__) + + ! NOTE: VR = Vertically Resolved + ! conv. = conversion + ! frac. = fraction + ! BAF = Burned Area Fraction + ! ann. = annual + ! GC = gridcell + ! dt = timestep + ! C = Carbon + ! N = Nitrogen + ! emis. = emissions + ! decomp. = decomposing + + associate( & + croot_prof => croot_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of coarse roots + stem_prof => stem_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of stems + froot_prof => froot_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of fine roots + leaf_prof => leaf_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of leaves + totsomc => totsomc_col , & ! Input: [real(r8) (:) ] (gC/m2) total soil organic matter C + decomp_cpools_vr => decomp_cpools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) VR decomp. (litter, cwd, soil) + decomp_npools_vr => decomp_npools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) VR decomp. (litter, cwd, soil) + somc_fire => somc_fire_col , & ! Output: [real(r8) (:) ] (gC/m2/s) fire C emissions due to peat burning + + is_cwd => decomp_cascade_con%is_cwd , & ! Input: [logical (:) ] TRUE => pool is a cwd pool + is_litter => decomp_cascade_con%is_litter , & ! Input: [logical (:) ] TRUE => pool is a litter pool + + woody => pftcon%woody , & ! Input: woody lifeform (1=woody, 0=not woody) + cc_leaf => pftcon%cc_leaf , & ! Input: + cc_lstem => pftcon%cc_lstem , & ! Input: + cc_dstem => pftcon%cc_dstem , & ! Input: + cc_other => pftcon%cc_other , & ! Input: + fm_leaf => pftcon%fm_leaf , & ! Input: + fm_lstem => pftcon%fm_lstem , & ! Input: + fm_other => pftcon%fm_other , & ! Input: + fm_root => pftcon%fm_root , & ! Input: + fm_lroot => pftcon%fm_lroot , & ! Input: + fm_droot => pftcon%fm_droot , & ! Input: + lf_flab => pftcon%lf_flab , & ! Input: + lf_fcel => pftcon%lf_fcel , & ! Input: + lf_flig => pftcon%lf_flig , & ! Input: + fr_flab => pftcon%fr_flab , & ! Input: + fr_fcel => pftcon%fr_fcel , & ! Input: + fr_flig => pftcon%fr_flig , & ! Input: + + cmb_cmplt_fact_litter => cnfire_const%cmb_cmplt_fact_litter , & ! Input: [real(r8) (:) ] Combustion completion factor for litter (unitless) + cmb_cmplt_fact_cwd => cnfire_const%cmb_cmplt_fact_cwd , & ! Input: [real(r8) (:) ] Combustion completion factor for CWD (unitless) + + nind => dgvs_inst%nind_patch , & ! Input: [real(r8) (:) ] number of individuals (#/m2) + + cropf_col => cnveg_state_inst%cropf_col , & ! Input: [real(r8) (:) ] cropland fraction in veg column + farea_burned => cnveg_state_inst%farea_burned_col , & ! Input: [real(r8) (:) ] fractional area burned (/sec) + fbac1 => cnveg_state_inst%fbac1_col , & ! Input: [real(r8) (:) ] burned area out of conv. region due to LU fire + fbac => cnveg_state_inst%fbac_col , & ! Input: [real(r8) (:) ] total burned area out of conversion (/sec) + baf_crop => cnveg_state_inst%baf_crop_col , & ! Input: [real(r8) (:) ] BAF for cropland + baf_peatf => cnveg_state_inst%baf_peatf_col , & ! Input: [real(r8) (:) ] BAF for peatlabd + trotr1_col => cnveg_state_inst%trotr1_col , & ! Input: [real(r8) (:) ] patch weight of BET on the column (0-1) + trotr2_col => cnveg_state_inst%trotr2_col , & ! Input: [real(r8) (:) ] patch weight of BDT on the column (0-1) + dtrotr_col => cnveg_state_inst%dtrotr_col , & ! Input: [real(r8) (:) ] ann. decreased frac. coverage of BET+BDT (0-1) on GC + lfc => cnveg_state_inst%lfc_col , & ! Input: [real(r8) (:) ] conv. area frac. of BET+BDT that haven't burned before + lfc2 => cnveg_state_inst%lfc2_col , & ! Output: [real(r8) (:) ] conv. area frac. of BET+BDT burned this dt (/sec) + + leafcmax => cnveg_carbonstate_inst%leafcmax_patch , & ! Output: [real(r8) (:) ] (gC/m2) ann max leaf C + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C storage + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C transfer + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C + livestemc_storage => cnveg_carbonstate_inst%livestemc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C storage + livestemc_xfer => cnveg_carbonstate_inst%livestemc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C transfer + deadstemc => cnveg_carbonstate_inst%deadstemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C + deadstemc_storage => cnveg_carbonstate_inst%deadstemc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C storage + deadstemc_xfer => cnveg_carbonstate_inst%deadstemc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C transfer + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C storage + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C transfer + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C storage + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C transfer + deadcrootc => cnveg_carbonstate_inst%deadcrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C + deadcrootc_storage => cnveg_carbonstate_inst%deadcrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C storage + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + gresp_storage => cnveg_carbonstate_inst%gresp_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) growth respiration storage + gresp_xfer => cnveg_carbonstate_inst%gresp_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) growth respiration transfer + + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N + leafn_storage => cnveg_nitrogenstate_inst%leafn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N storage + leafn_xfer => cnveg_nitrogenstate_inst%leafn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N transfer + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N + livestemn_storage => cnveg_nitrogenstate_inst%livestemn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N storage + livestemn_xfer => cnveg_nitrogenstate_inst%livestemn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N transfer + deadstemn => cnveg_nitrogenstate_inst%deadstemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N + deadstemn_storage => cnveg_nitrogenstate_inst%deadstemn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N storage + deadstemn_xfer => cnveg_nitrogenstate_inst%deadstemn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N transfer + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N + frootn_storage => cnveg_nitrogenstate_inst%frootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N storage + frootn_xfer => cnveg_nitrogenstate_inst%frootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N transfer + livecrootn => cnveg_nitrogenstate_inst%livecrootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N + livecrootn_storage => cnveg_nitrogenstate_inst%livecrootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N storage + livecrootn_xfer => cnveg_nitrogenstate_inst%livecrootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N transfer + deadcrootn => cnveg_nitrogenstate_inst%deadcrootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N + deadcrootn_storage => cnveg_nitrogenstate_inst%deadcrootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N storage + deadcrootn_xfer => cnveg_nitrogenstate_inst%deadcrootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N transfer + retransn => cnveg_nitrogenstate_inst%retransn_patch , & ! Input: [real(r8) (:) ] (gN/m2) plant pool of retranslocated N + + fire_mortality_c_to_cwdc => cnveg_carbonflux_inst%fire_mortality_c_to_cwdc_col , & ! Input: [real(r8) (:,:) ] C flux fire mortality to CWD (gC/m3/s) + m_leafc_to_fire => cnveg_carbonflux_inst%m_leafc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) fire C emis. from leafc + m_leafc_storage_to_fire => cnveg_carbonflux_inst%m_leafc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) fire C emis. from leafc_storage + m_leafc_xfer_to_fire => cnveg_carbonflux_inst%m_leafc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) fire C emis. from leafc_xfer + m_livestemc_to_fire => cnveg_carbonflux_inst%m_livestemc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) fire C emis. from livestemc + m_livestemc_storage_to_fire => cnveg_carbonflux_inst%m_livestemc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livestemc_storage + m_livestemc_xfer_to_fire => cnveg_carbonflux_inst%m_livestemc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livestemc_xfer + m_deadstemc_to_fire => cnveg_carbonflux_inst%m_deadstemc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadstemc_xfer + m_deadstemc_storage_to_fire => cnveg_carbonflux_inst%m_deadstemc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadstemc_storage + m_deadstemc_xfer_to_fire => cnveg_carbonflux_inst%m_deadstemc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadstemc_xfer + m_frootc_to_fire => cnveg_carbonflux_inst%m_frootc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. frootc + m_frootc_storage_to_fire => cnveg_carbonflux_inst%m_frootc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. frootc_storage + m_frootc_xfer_to_fire => cnveg_carbonflux_inst%m_frootc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. frootc_xfer + m_livecrootc_to_fire => cnveg_carbonflux_inst%m_livecrootc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livecrootc + m_livecrootc_storage_to_fire => cnveg_carbonflux_inst%m_livecrootc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livecrootc_storage + m_livecrootc_xfer_to_fire => cnveg_carbonflux_inst%m_livecrootc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livecrootc_xfer + m_deadcrootc_to_fire => cnveg_carbonflux_inst%m_deadcrootc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadcrootc + m_deadcrootc_storage_to_fire => cnveg_carbonflux_inst%m_deadcrootc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadcrootc_storage + m_deadcrootc_xfer_to_fire => cnveg_carbonflux_inst%m_deadcrootc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadcrootc_xfer + m_gresp_storage_to_fire => cnveg_carbonflux_inst%m_gresp_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. gresp_storage + m_gresp_xfer_to_fire => cnveg_carbonflux_inst%m_gresp_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. gresp_xfer + m_leafc_to_litter_fire => cnveg_carbonflux_inst%m_leafc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_leafc_storage_to_litter_fire => cnveg_carbonflux_inst%m_leafc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_leafc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_leafc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemc_to_litter_fire => cnveg_carbonflux_inst%m_livestemc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemc_storage_to_litter_fire => cnveg_carbonflux_inst%m_livestemc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_livestemc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemc_to_deadstemc_fire => cnveg_carbonflux_inst%m_livestemc_to_deadstemc_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemc_to_litter_fire => cnveg_carbonflux_inst%m_deadstemc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemc_storage_to_litter_fire => cnveg_carbonflux_inst%m_deadstemc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_deadstemc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootc_to_litter_fire => cnveg_carbonflux_inst%m_frootc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootc_storage_to_litter_fire => cnveg_carbonflux_inst%m_frootc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_frootc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootc_to_litter_fire => cnveg_carbonflux_inst%m_livecrootc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootc_storage_to_litter_fire => cnveg_carbonflux_inst%m_livecrootc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_livecrootc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootc_to_deadcrootc_fire => cnveg_carbonflux_inst%m_livecrootc_to_deadcrootc_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootc_to_litter_fire => cnveg_carbonflux_inst%m_deadcrootc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootc_storage_to_litter_fire => cnveg_carbonflux_inst%m_deadcrootc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_deadcrootc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_gresp_storage_to_litter_fire => cnveg_carbonflux_inst%m_gresp_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_gresp_xfer_to_litter_fire => cnveg_carbonflux_inst%m_gresp_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_decomp_cpools_to_fire_vr => cnveg_carbonflux_inst%m_decomp_cpools_to_fire_vr_col , & ! Output: [real(r8) (:,:,:) ] (gC/m3/s) VR decomp. C fire loss + m_c_to_litr_met_fire => cnveg_carbonflux_inst%m_c_to_litr_met_fire_col , & ! Output: [real(r8) (:,:) ] + m_c_to_litr_cel_fire => cnveg_carbonflux_inst%m_c_to_litr_cel_fire_col , & ! Output: [real(r8) (:,:) ] + m_c_to_litr_lig_fire => cnveg_carbonflux_inst%m_c_to_litr_lig_fire_col , & ! Output: [real(r8) (:,:) ] + + fire_mortality_n_to_cwdn => cnveg_nitrogenflux_inst%fire_mortality_n_to_cwdn_col , & ! Input: [real(r8) (:,:) ] N flux fire mortality to CWD (gN/m3/s) + m_leafn_to_fire => cnveg_nitrogenflux_inst%m_leafn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. leafn + m_leafn_storage_to_fire => cnveg_nitrogenflux_inst%m_leafn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. leafn_storage + m_leafn_xfer_to_fire => cnveg_nitrogenflux_inst%m_leafn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. leafn_xfer + m_livestemn_to_fire => cnveg_nitrogenflux_inst%m_livestemn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livestemn + m_livestemn_storage_to_fire => cnveg_nitrogenflux_inst%m_livestemn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livestemn_s + m_livestemn_xfer_to_fire => cnveg_nitrogenflux_inst%m_livestemn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livestemn_xfer + m_deadstemn_to_fire => cnveg_nitrogenflux_inst%m_deadstemn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadstemn + m_deadstemn_storage_to_fire => cnveg_nitrogenflux_inst%m_deadstemn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadstemn_storage + m_deadstemn_xfer_to_fire => cnveg_nitrogenflux_inst%m_deadstemn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadstemn_xfer + m_frootn_to_fire => cnveg_nitrogenflux_inst%m_frootn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. frootn + m_frootn_storage_to_fire => cnveg_nitrogenflux_inst%m_frootn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. frootn_storage + m_frootn_xfer_to_fire => cnveg_nitrogenflux_inst%m_frootn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. frootn_xfer + m_livecrootn_to_fire => cnveg_nitrogenflux_inst%m_livecrootn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. m_livecrootn_to_fire + m_livecrootn_storage_to_fire => cnveg_nitrogenflux_inst%m_livecrootn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livecrootn_storage + m_livecrootn_xfer_to_fire => cnveg_nitrogenflux_inst%m_livecrootn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livecrootn_xfer + m_deadcrootn_to_fire => cnveg_nitrogenflux_inst%m_deadcrootn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadcrootn + m_deadcrootn_storage_to_fire => cnveg_nitrogenflux_inst%m_deadcrootn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadcrootn_storage + m_deadcrootn_xfer_to_fire => cnveg_nitrogenflux_inst%m_deadcrootn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadcrootn_xfer + m_retransn_to_fire => cnveg_nitrogenflux_inst%m_retransn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. retransn + m_leafn_to_litter_fire => cnveg_nitrogenflux_inst%m_leafn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_leafn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_leafn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_leafn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_leafn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemn_to_litter_fire => cnveg_nitrogenflux_inst%m_livestemn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_livestemn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_livestemn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemn_to_deadstemn_fire => cnveg_nitrogenflux_inst%m_livestemn_to_deadstemn_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemn_to_litter_fire => cnveg_nitrogenflux_inst%m_deadstemn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_deadstemn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_deadstemn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootn_to_litter_fire => cnveg_nitrogenflux_inst%m_frootn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_frootn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_frootn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootn_to_litter_fire => cnveg_nitrogenflux_inst%m_livecrootn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_livecrootn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_livecrootn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootn_to_deadcrootn_fire => cnveg_nitrogenflux_inst%m_livecrootn_to_deadcrootn_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootn_to_litter_fire => cnveg_nitrogenflux_inst%m_deadcrootn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_deadcrootn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_deadcrootn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_retransn_to_litter_fire => cnveg_nitrogenflux_inst%m_retransn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_decomp_npools_to_fire_vr => cnveg_nitrogenflux_inst%m_decomp_npools_to_fire_vr_col , & ! Output: [real(r8) (:,:,:) ] VR decomp. N fire loss (gN/m3/s) + m_n_to_litr_met_fire => cnveg_nitrogenflux_inst%m_n_to_litr_met_fire_col , & ! Output: [real(r8) (:,:) ] + m_n_to_litr_cel_fire => cnveg_nitrogenflux_inst%m_n_to_litr_cel_fire_col , & ! Output: [real(r8) (:,:) ] + m_n_to_litr_lig_fire => cnveg_nitrogenflux_inst%m_n_to_litr_lig_fire_col , & ! Output: [real(r8) (:,:) ] + ileaf_to_iout_fic => cnveg_carbonflux_inst%ileaf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from leaf pool to outside of vegetation pools + ileafst_to_iout_fic => cnveg_carbonflux_inst%ileafst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from leaf storage pool to outside of vegetation pools + ileafxf_to_iout_fic => cnveg_carbonflux_inst%ileafxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from leaf transfer pool to outside of vegetation pools + ifroot_to_iout_fic => cnveg_carbonflux_inst%ifroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from fine root pool to outside of vegetation pools + ifrootst_to_iout_fic => cnveg_carbonflux_inst%ifrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from fine root storage pool to outside of vegetation pools + ifrootxf_to_iout_fic => cnveg_carbonflux_inst%ifrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from fine root transfer pool to outside of vegetation pools + ilivestem_to_iout_fic => cnveg_carbonflux_inst%ilivestem_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live stem pool to outside of vegetation pools + ilivestemst_to_iout_fic => cnveg_carbonflux_inst%ilivestemst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live stem storage pool to outside of vegetation pools + ilivestemxf_to_iout_fic => cnveg_carbonflux_inst%ilivestemxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live stem transfer pool to outside of vegetation pools + ideadstem_to_iout_fic => cnveg_carbonflux_inst%ideadstem_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead stem pool to outside of vegetation pools + ideadstemst_to_iout_fic => cnveg_carbonflux_inst%ideadstemst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead stem storage pool to outside of vegetation pools + ideadstemxf_to_iout_fic => cnveg_carbonflux_inst%ideadstemxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead stem transfer pool to outside of vegetation pools + ilivecroot_to_iout_fic => cnveg_carbonflux_inst%ilivecroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live coarse root pool to outside of vegetation pools + ilivecrootst_to_iout_fic => cnveg_carbonflux_inst%ilivecrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live coarse root storage pool to outside of vegetation pools + ilivecrootxf_to_iout_fic => cnveg_carbonflux_inst%ilivecrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live coarse root transfer pool to outside of vegetation pools + ideadcroot_to_iout_fic => cnveg_carbonflux_inst%ideadcroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead coarse root pool to outside of vegetation pools + ideadcrootst_to_iout_fic => cnveg_carbonflux_inst%ideadcrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead coarse root storage pool to outside of vegetation pools + ideadcrootxf_to_iout_fic => cnveg_carbonflux_inst%ideadcrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead coarse root transfer pool to outside of vegetation pools + ilivestem_to_ideadstem_fic => cnveg_carbonflux_inst%ilivestem_to_ideadstem_fi , & ! Input: [integer (:)] Index of fire related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_fic => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_fi , & ! Input: [integer (:)] Index of fire related C transfer from live coarse root pool to dead coarse root pool + ileaf_to_iout_fin => cnveg_nitrogenflux_inst%ileaf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from leaf pool to outside of vegetation pools + ileafst_to_iout_fin => cnveg_nitrogenflux_inst%ileafst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from leaf storage pool to outside of vegetation pools + ileafxf_to_iout_fin => cnveg_nitrogenflux_inst%ileafxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from leaf transfer pool to outside of vegetation pools + ifroot_to_iout_fin => cnveg_nitrogenflux_inst%ifroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from fine root pool to outside of vegetation pools + ifrootst_to_iout_fin => cnveg_nitrogenflux_inst%ifrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from fine root storage pool to outside of vegetation pools + ifrootxf_to_iout_fin => cnveg_nitrogenflux_inst%ifrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from fine transfer pool to outside of vegetation pools + ilivestem_to_iout_fin => cnveg_nitrogenflux_inst%ilivestem_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live stem pool to outside of vegetation pools + ilivestemst_to_iout_fin => cnveg_nitrogenflux_inst%ilivestemst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live stem storage pool to outside of vegetation pools + ilivestemxf_to_iout_fin => cnveg_nitrogenflux_inst%ilivestemxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live stem transfer pool to outside of vegetation pools + ideadstem_to_iout_fin => cnveg_nitrogenflux_inst%ideadstem_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead stem pool to outside of vegetation pools + ideadstemst_to_iout_fin => cnveg_nitrogenflux_inst%ideadstemst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead stem storage pool to outside of vegetation pools + ideadstemxf_to_iout_fin => cnveg_nitrogenflux_inst%ideadstemxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead stem transfer pool to outside of vegetation pools + ilivecroot_to_iout_fin => cnveg_nitrogenflux_inst%ilivecroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live coarse root pool to outside of vegetation pools + ilivecrootst_to_iout_fin => cnveg_nitrogenflux_inst%ilivecrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live coarse root storage pool to outside of vegetation pools + ilivecrootxf_to_iout_fin => cnveg_nitrogenflux_inst%ilivecrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live coarse root transfer pool to outside of vegetation pools + ideadcroot_to_iout_fin => cnveg_nitrogenflux_inst%ideadcroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead coarse root pool to outside of vegetation pools + ideadcrootst_to_iout_fin => cnveg_nitrogenflux_inst%ideadcrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead coarse root storage pool to outside of vegetation pools + ideadcrootxf_to_iout_fin => cnveg_nitrogenflux_inst%ideadcrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead coarse root transfer pool to outside of vegetation pools + ilivestem_to_ideadstem_fin => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_fi , & ! Input: [integer (:)] Index of fire related N transfer from live stem to dead stem pool + ilivecroot_to_ideadcroot_fin => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_fi , & ! Input: [integer (:)] Index of fire related N transfer from live coarse root pool to dead coarse root pool + iretransn_to_iout_fin => cnveg_nitrogenflux_inst%iretransn_to_iout_fi & ! Input: [integer (:)] Index of fire related N transfer from retranslocated N pool to outside of vegetation pools + ) + + transient_landcover = run_has_transient_landcover() + + ! Get model step size + ! calculate burned area fraction per sec + dt = get_step_size_real() + + dayspyr = get_days_per_year() + ! + ! patch loop + ! + num_actfirep = 0 + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + if( patch%itype(p) < nc3crop .and. cropf_col(c) < 1.0_r8)then + ! For non-crop (bare-soil and natural vegetation) + if (transient_landcover) then + f = (fbac(c)-baf_crop(c))/(1.0_r8-cropf_col(c)) + else + f = (farea_burned(c)-baf_crop(c))/(1.0_r8-cropf_col(c)) + end if + else + ! For crops + if(cropf_col(c) > 0._r8)then + f = baf_crop(c) /cropf_col(c) + else + f = 0._r8 + end if + end if + + ! apply this rate to the patch state variables to get flux rates + ! biomass burning + ! carbon fluxes + m = spinup_factor_deadwood + + if(f /= 0)then + num_actfirep = num_actfirep + 1 + filter_actfirep(num_actfirep) = p + end if + m_gresp_storage_to_fire(p) = gresp_storage(p) * f * cc_other(patch%itype(p)) + m_gresp_xfer_to_fire(p) = gresp_xfer(p) * f * cc_other(patch%itype(p)) + if ( .not. use_matrixcn )then + ! NOTE: The non matrix version of this is in CNCStateUpdate3::CStateUpdate3 EBK (11/26/2019) + ! and CNNStateUpdate3::NStateUpdate3 + m_leafc_to_fire(p) = leafc(p) * f * cc_leaf(patch%itype(p)) + m_leafc_storage_to_fire(p) = leafc_storage(p) * f * cc_other(patch%itype(p)) + m_leafc_xfer_to_fire(p) = leafc_xfer(p) * f * cc_other(patch%itype(p)) + m_livestemc_to_fire(p) = livestemc(p) * f * cc_lstem(patch%itype(p)) + m_livestemc_storage_to_fire(p) = livestemc_storage(p) * f * cc_other(patch%itype(p)) + m_livestemc_xfer_to_fire(p) = livestemc_xfer(p) * f * cc_other(patch%itype(p)) + m_deadstemc_to_fire(p) = deadstemc(p) * f * cc_dstem(patch%itype(p)) * m + m_deadstemc_storage_to_fire(p) = deadstemc_storage(p) * f * cc_other(patch%itype(p)) + m_deadstemc_xfer_to_fire(p) = deadstemc_xfer(p) * f * cc_other(patch%itype(p)) + m_frootc_to_fire(p) = frootc(p) * f * 0._r8 + m_frootc_storage_to_fire(p) = frootc_storage(p) * f * cc_other(patch%itype(p)) + m_frootc_xfer_to_fire(p) = frootc_xfer(p) * f * cc_other(patch%itype(p)) + m_livecrootc_to_fire(p) = livecrootc(p) * f * 0._r8 + m_livecrootc_storage_to_fire(p) = livecrootc_storage(p) * f * cc_other(patch%itype(p)) + m_livecrootc_xfer_to_fire(p) = livecrootc_xfer(p) * f * cc_other(patch%itype(p)) + m_deadcrootc_to_fire(p) = deadcrootc(p) * f * 0._r8 + m_deadcrootc_storage_to_fire(p) = deadcrootc_storage(p) * f* cc_other(patch%itype(p)) + m_deadcrootc_xfer_to_fire(p) = deadcrootc_xfer(p) * f * cc_other(patch%itype(p)) + + + ! nitrogen fluxes + m_leafn_to_fire(p) = leafn(p) * f * cc_leaf(patch%itype(p)) + m_leafn_storage_to_fire(p) = leafn_storage(p) * f * cc_other(patch%itype(p)) + m_leafn_xfer_to_fire(p) = leafn_xfer(p) * f * cc_other(patch%itype(p)) + m_livestemn_to_fire(p) = livestemn(p) * f * cc_lstem(patch%itype(p)) + m_livestemn_storage_to_fire(p) = livestemn_storage(p) * f * cc_other(patch%itype(p)) + m_livestemn_xfer_to_fire(p) = livestemn_xfer(p) * f * cc_other(patch%itype(p)) + m_deadstemn_to_fire(p) = deadstemn(p) * f * cc_dstem(patch%itype(p)) * m + m_deadstemn_storage_to_fire(p) = deadstemn_storage(p) * f * cc_other(patch%itype(p)) + m_deadstemn_xfer_to_fire(p) = deadstemn_xfer(p) * f * cc_other(patch%itype(p)) + m_frootn_to_fire(p) = frootn(p) * f * 0._r8 + m_frootn_storage_to_fire(p) = frootn_storage(p) * f * cc_other(patch%itype(p)) + m_frootn_xfer_to_fire(p) = frootn_xfer(p) * f * cc_other(patch%itype(p)) + m_livecrootn_to_fire(p) = livecrootn(p) * f * 0._r8 + m_livecrootn_storage_to_fire(p) = livecrootn_storage(p) * f * cc_other(patch%itype(p)) + m_livecrootn_xfer_to_fire(p) = livecrootn_xfer(p) * f * cc_other(patch%itype(p)) + m_deadcrootn_to_fire(p) = deadcrootn(p) * f * 0._r8 + m_deadcrootn_xfer_to_fire(p) = deadcrootn_xfer(p) * f * cc_other(patch%itype(p)) + m_deadcrootn_storage_to_fire(p) = deadcrootn_storage(p) * f * cc_other(patch%itype(p)) + m_retransn_to_fire(p) = retransn(p) * f * cc_other(patch%itype(p)) + + else +! m_leafc_to_fire(p) = leafc(p) * matrix_update_fic(p,ileaf_to_iout_fic ,f * cc_leaf(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_leafc_storage_to_fire(p) = leafc_storage(p) * matrix_update_fic(p,ileafst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_leafc_xfer_to_fire(p) = leafc_xfer(p) * matrix_update_fic(p,ileafxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_to_fire(p) = livestemc(p) * matrix_update_fic(p,ilivestem_to_iout_fic ,f * cc_lstem(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_storage_to_fire(p) = livestemc_storage(p) * matrix_update_fic(p,ilivestemst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_xfer_to_fire(p) = livestemc_xfer(p) * matrix_update_fic(p,ilivestemxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_to_fire(p) = deadstemc(p) * matrix_update_fic(p,ideadstem_to_iout_fic ,f * cc_dstem(patch%itype(p))*m,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_storage_to_fire(p) = deadstemc_storage(p) * matrix_update_fic(p,ideadstemst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_xfer_to_fire(p) = deadstemc_xfer(p) * matrix_update_fic(p,ideadstemxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_to_fire(p) = frootc(p) * matrix_update_fic(p,ifroot_to_iout_fic ,f * 0._r8 ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_storage_to_fire(p) = frootc_storage(p) * matrix_update_fic(p,ifrootst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_xfer_to_fire(p) = frootc_xfer(p) * matrix_update_fic(p,ifrootxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_to_fire(p) = livecrootc(p) * matrix_update_fic(p,ilivecroot_to_iout_fic ,f * 0._r8 ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_storage_to_fire(p) = livecrootc_storage(p) * matrix_update_fic(p,ilivecrootst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_xfer_to_fire(p) = livecrootc_xfer(p) * matrix_update_fic(p,ilivecrootxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_to_fire(p) = deadcrootc(p) * matrix_update_fic(p,ideadcroot_to_iout_fic ,f * 0._r8 ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_storage_to_fire(p) = deadcrootc_storage(p) * matrix_update_fic(p,ideadcrootst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_xfer_to_fire(p) = deadcrootc_xfer(p) * matrix_update_fic(p,ideadcrootxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! +! m_leafn_to_fire(p) = leafn(p) * matrix_update_fin(p,ileaf_to_iout_fin ,f * cc_leaf(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_leafn_storage_to_fire(p) = leafn_storage(p) * matrix_update_fin(p,ileafst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_leafn_xfer_to_fire(p) = leafn_xfer(p) * matrix_update_fin(p,ileafxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_to_fire(p) = livestemn(p) * matrix_update_fin(p,ilivestem_to_iout_fin ,f * cc_lstem(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_storage_to_fire(p) = livestemn_storage(p) * matrix_update_fin(p,ilivestemst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_xfer_to_fire(p) = livestemn_xfer(p) * matrix_update_fin(p,ilivestemxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_to_fire(p) = deadstemn(p) * matrix_update_fin(p,ideadstem_to_iout_fin ,f * cc_dstem(patch%itype(p))*m,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_storage_to_fire(p) = deadstemn_storage(p) * matrix_update_fin(p,ideadstemst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_xfer_to_fire(p) = deadstemn_xfer(p) * matrix_update_fin(p,ideadstemxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_to_fire(p) = frootn(p) * matrix_update_fin(p,ifroot_to_iout_fin ,f * 0._r8 ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_storage_to_fire(p) = frootn_storage(p) * matrix_update_fin(p,ifrootst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_xfer_to_fire(p) = frootn_xfer(p) * matrix_update_fin(p,ifrootxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_to_fire(p) = livecrootn(p) * matrix_update_fin(p,ilivecroot_to_iout_fin ,f * 0._r8 ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_storage_to_fire(p) = livecrootn_storage(p) * matrix_update_fin(p,ilivecrootst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_xfer_to_fire(p) = livecrootn_xfer(p) * matrix_update_fin(p,ilivecrootxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_to_fire(p) = deadcrootn(p) * matrix_update_fin(p,ideadcroot_to_iout_fin ,f * 0._r8 ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_storage_to_fire(p) = deadcrootn_storage(p) * matrix_update_fin(p,ideadcrootst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_xfer_to_fire(p) = deadcrootn_xfer(p) * matrix_update_fin(p,ideadcrootxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_retransn_to_fire(p) = retransn(p) * matrix_update_fin(p,iretransn_to_iout_fin ,f * 0._r8 ,dt,cnveg_nitrogenflux_inst,.True.,.True.) + end if + ! mortality due to fire + ! carbon pools + if ( .not. use_matrixcn )then + ! NOTE: The non matrix version of this is in CNCStateUpdate3::CStateUpdate3 EBK (11/26/2019) + ! and CNNStateUpdate3::NStateUpdate3 + m_leafc_to_litter_fire(p) = leafc(p) * f * & + (1._r8 - cc_leaf(patch%itype(p))) * & + fm_leaf(patch%itype(p)) + m_leafc_storage_to_litter_fire(p) = leafc_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_leafc_xfer_to_litter_fire(p) = leafc_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from livestem/livecroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_livestemc_to_litter_fire(p) = livestemc(p) * f * & + (1._r8 - cc_lstem(patch%itype(p))) * & + fm_droot(patch%itype(p)) + m_livestemc_storage_to_litter_fire(p) = livestemc_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livestemc_xfer_to_litter_fire(p) = livestemc_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent the fraction of plant-tissue mortality for deadstem/deadcroot + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 + m_livestemc_to_deadstemc_fire(p) = livestemc(p) * f * & + (1._r8 - cc_lstem(patch%itype(p))) * & + (fm_lstem(patch%itype(p))-fm_droot(patch%itype(p))) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from deadstem/deadcroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_deadstemc_to_litter_fire(p) = deadstemc(p) * f * m * & + (1._r8 - cc_dstem(patch%itype(p))) * & + fm_droot(patch%itype(p)) + m_deadstemc_storage_to_litter_fire(p) = deadstemc_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_deadstemc_xfer_to_litter_fire(p) = deadstemc_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_frootc_to_litter_fire(p) = frootc(p) * f * & + fm_root(patch%itype(p)) + m_frootc_storage_to_litter_fire(p) = frootc_storage(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_frootc_xfer_to_litter_fire(p) = frootc_xfer(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from livestem/livecroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_livecrootc_to_litter_fire(p) = livecrootc(p) * f * & + fm_droot(patch%itype(p)) + m_livecrootc_storage_to_litter_fire(p) = livecrootc_storage(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livecrootc_xfer_to_litter_fire(p) = livecrootc_xfer(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livecrootc_to_deadcrootc_fire(p) = livecrootc(p) * f * & + (fm_lroot(patch%itype(p))-fm_droot(patch%itype(p))) + m_deadcrootc_to_litter_fire(p) = deadcrootc(p) * f * m * & + fm_droot(patch%itype(p)) + m_deadcrootc_storage_to_litter_fire(p) = deadcrootc_storage(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_deadcrootc_xfer_to_litter_fire(p) = deadcrootc_xfer(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_gresp_storage_to_litter_fire(p) = gresp_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_gresp_xfer_to_litter_fire(p) = gresp_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + + + ! nitrogen pools + m_leafn_to_litter_fire(p) = leafn(p) * f * & + (1._r8 - cc_leaf(patch%itype(p))) * & + fm_leaf(patch%itype(p)) + m_leafn_storage_to_litter_fire(p) = leafn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_leafn_xfer_to_litter_fire(p) = leafn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from livestem/livecroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_livestemn_to_litter_fire(p) = livestemn(p) * f * & + (1._r8 - cc_lstem(patch%itype(p))) * & + fm_droot(patch%itype(p)) + m_livestemn_storage_to_litter_fire(p) = livestemn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livestemn_xfer_to_litter_fire(p) = livestemn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent the fraction of plant-tissue mortality for deadstem/deadcroot + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 + m_livestemn_to_deadstemn_fire(p) = livestemn(p) * f * & + (1._r8 - cc_lstem(patch%itype(p))) * & + (fm_lstem(patch%itype(p))-fm_droot(patch%itype(p))) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from deadstem/deadcroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_deadstemn_to_litter_fire(p) = deadstemn(p) * f * m * & + (1._r8 - cc_dstem(patch%itype(p))) * & + fm_droot(patch%itype(p)) + m_deadstemn_storage_to_litter_fire(p) = deadstemn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_deadstemn_xfer_to_litter_fire(p) = deadstemn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_frootn_to_litter_fire(p) = frootn(p) * f * & + fm_root(patch%itype(p)) + m_frootn_storage_to_litter_fire(p) = frootn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_frootn_xfer_to_litter_fire(p) = frootn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from livestem/livecroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_livecrootn_to_litter_fire(p) = livecrootn(p) * f * & + fm_droot(patch%itype(p)) + m_livecrootn_storage_to_litter_fire(p) = livecrootn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livecrootn_xfer_to_litter_fire(p) = livecrootn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livecrootn_to_deadcrootn_fire(p) = livecrootn(p) * f * & + (fm_lroot(patch%itype(p))-fm_droot(patch%itype(p))) + m_deadcrootn_to_litter_fire(p) = deadcrootn(p) * f * m * & + fm_droot(patch%itype(p)) + m_deadcrootn_storage_to_litter_fire(p) = deadcrootn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_deadcrootn_xfer_to_litter_fire(p) = deadcrootn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_retransn_to_litter_fire(p) = retransn(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + + else +! m_leafc_to_litter_fire(p) = leafc(p) * matrix_update_fic(p,ileaf_to_iout_fic, & +! f * (1._r8 - cc_leaf(patch%itype(p))) * fm_leaf(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_leafc_storage_to_litter_fire(p) = leafc_storage(p) * matrix_update_fic(p,ileafst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_leafc_xfer_to_litter_fire(p) = leafc_xfer(p) * matrix_update_fic(p,ileafxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_to_litter_fire(p) = livestemc(p) * matrix_update_fic(p,ilivestem_to_iout_fic, & +! f * (1._r8 - cc_lstem(patch%itype(p))) * fm_droot(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_storage_to_litter_fire(p) = livestemc_storage(p) * matrix_update_fic(p,ilivestemst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_xfer_to_litter_fire(p) = livestemc_xfer(p) * matrix_update_fic(p,ilivestemxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_to_deadstemc_fire(p) = livestemc(p) * matrix_update_fic(p,ilivestem_to_ideadstem_fic,& +! f * (1._r8 - cc_lstem(patch%itype(p))) * (fm_lstem(patch%itype(p))-fm_droot(patch%itype(p))),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_to_litter_fire(p) = deadstemc(p) * matrix_update_fic(p,ideadstem_to_iout_fic, & +! f * (1._r8 - cc_dstem(patch%itype(p))) * fm_droot(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_storage_to_litter_fire(p) = deadstemc_storage(p) * matrix_update_fic(p,ideadstemst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_xfer_to_litter_fire(p) = deadstemc_xfer(p) * matrix_update_fic(p,ideadstemxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_to_litter_fire(p) = frootc(p) * matrix_update_fic(p,ifroot_to_iout_fic, & +! f * fm_root(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_storage_to_litter_fire(p) = frootc_storage(p) * matrix_update_fic(p,ifrootst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_xfer_to_litter_fire(p) = frootc_xfer(p) * matrix_update_fic(p,ifrootxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_to_litter_fire(p) = livecrootc(p) * matrix_update_fic(p,ilivecroot_to_iout_fic, & +! f * fm_droot(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_storage_to_litter_fire(p) = livecrootc_storage(p) * matrix_update_fic(p,ilivecrootst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_xfer_to_litter_fire(p) = livecrootc_xfer(p) * matrix_update_fic(p,ilivecrootxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_to_deadcrootc_fire(p) = livecrootc(p) * matrix_update_fic(p,ilivecroot_to_ideadcroot_fic,& +! f * (fm_lroot(patch%itype(p))-fm_droot(patch%itype(p))),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_to_litter_fire(p) = deadcrootc(p) * matrix_update_fic(p,ideadcroot_to_iout_fic, & +! f * m * fm_droot(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_storage_to_litter_fire(p) = deadcrootc_storage(p) * matrix_update_fic(p,ideadcrootst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_xfer_to_litter_fire(p) = deadcrootc_xfer(p) * matrix_update_fic(p,ideadcrootxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! +! m_leafn_to_litter_fire(p) = leafn(p) * matrix_update_fin(p,ileaf_to_iout_fin, & +! f * (1._r8 - cc_leaf(patch%itype(p))) * fm_leaf(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_leafn_storage_to_litter_fire(p) = leafn_storage(p) * matrix_update_fin(p,ileafst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_leafn_xfer_to_litter_fire(p) = leafn_xfer(p) * matrix_update_fin(p,ileafxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_to_litter_fire(p) = livestemn(p) * matrix_update_fin(p,ilivestem_to_iout_fin, & +! f * (1._r8 - cc_lstem(patch%itype(p))) * fm_droot(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_storage_to_litter_fire(p) = livestemn_storage(p) * matrix_update_fin(p,ilivestemst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_xfer_to_litter_fire(p) = livestemn_xfer(p) * matrix_update_fin(p,ilivestemxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_to_deadstemn_fire(p) = livestemn(p) * matrix_update_fin(p,ilivestem_to_ideadstem_fin,& +! f * (1._r8 - cc_lstem(patch%itype(p))) * (fm_lstem(patch%itype(p))-fm_droot(patch%itype(p))),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_to_litter_fire(p) = deadstemn(p) * matrix_update_fin(p,ideadstem_to_iout_fin, & +! f * (1._r8 - cc_dstem(patch%itype(p))) * fm_droot(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_storage_to_litter_fire(p) = deadstemn_storage(p) * matrix_update_fin(p,ideadstemst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_xfer_to_litter_fire(p) = deadstemn_xfer(p) * matrix_update_fin(p,ideadstemxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_to_litter_fire(p) = frootn(p) * matrix_update_fin(p,ifroot_to_iout_fin, & +! f * fm_root(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_storage_to_litter_fire(p) = frootn_storage(p) * matrix_update_fin(p,ifrootst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_xfer_to_litter_fire(p) = frootn_xfer(p) * matrix_update_fin(p,ifrootxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_to_litter_fire(p) = livecrootn(p) * matrix_update_fin(p,ilivecroot_to_iout_fin, & +! f * fm_droot(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_storage_to_litter_fire(p) = livecrootn_storage(p) * matrix_update_fin(p,ilivecrootst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_xfer_to_litter_fire(p) = livecrootn_xfer(p) * matrix_update_fin(p,ilivecrootxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_to_deadcrootn_fire(p) = livecrootn(p) * matrix_update_fin(p,ilivecroot_to_ideadcroot_fin,& +! f * (fm_lroot(patch%itype(p))-fm_droot(patch%itype(p))),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_to_litter_fire(p) = deadcrootn(p) * matrix_update_fin(p,ideadcroot_to_iout_fin, & +! f * m * fm_droot(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_storage_to_litter_fire(p) = deadcrootn_storage(p) * matrix_update_fin(p,ideadcrootst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_xfer_to_litter_fire(p) = deadcrootn_xfer(p) * matrix_update_fin(p,ideadcrootxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) + end if + + if (use_cndv) then + if ( woody(patch%itype(p)) == 1._r8 )then + if ( livestemc(p)+deadstemc(p) > 0._r8 )then + nind(p) = nind(p)*(1._r8-1._r8*fm_droot(patch%itype(p))*f) + else + nind(p) = 0._r8 + end if + end if + leafcmax(p) = max(leafc(p)-m_leafc_to_fire(p)*dt, leafcmax(p)) + if (patch%itype(p) == noveg) leafcmax(p) = 0._r8 + end if + + end do ! end of patches loop + + ! fire-induced transfer of carbon and nitrogen pools to litter and cwd + + do j = 1,nlevdecomp + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & + m_deadstemc_to_litter_fire(p) * patch%wtcol(p) * stem_prof(p,j) + fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & + m_deadcrootc_to_litter_fire(p) * patch%wtcol(p) * croot_prof(p,j) + fire_mortality_n_to_cwdn(c,j) = fire_mortality_n_to_cwdn(c,j) + & + m_deadstemn_to_litter_fire(p) * patch%wtcol(p) * stem_prof(p,j) + fire_mortality_n_to_cwdn(c,j) = fire_mortality_n_to_cwdn(c,j) + & + m_deadcrootn_to_litter_fire(p) * patch%wtcol(p) * croot_prof(p,j) + + + fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & + m_livestemc_to_litter_fire(p) * patch%wtcol(p) * stem_prof(p,j) + fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & + m_livecrootc_to_litter_fire(p) * patch%wtcol(p) * croot_prof(p,j) + fire_mortality_n_to_cwdn(c,j) = fire_mortality_n_to_cwdn(c,j) + & + m_livestemn_to_litter_fire(p) * patch%wtcol(p) * stem_prof(p,j) + fire_mortality_n_to_cwdn(c,j) = fire_mortality_n_to_cwdn(c,j) + & + m_livecrootn_to_litter_fire(p) * patch%wtcol(p) * croot_prof(p,j) + + + m_c_to_litr_met_fire(c,j)=m_c_to_litr_met_fire(c,j) + & + ((m_leafc_to_litter_fire(p)*lf_flab(patch%itype(p)) & + +m_leafc_storage_to_litter_fire(p) + & + m_leafc_xfer_to_litter_fire(p) + & + m_gresp_storage_to_litter_fire(p) & + +m_gresp_xfer_to_litter_fire(p))*leaf_prof(p,j) + & + (m_frootc_to_litter_fire(p)*fr_flab(patch%itype(p)) & + +m_frootc_storage_to_litter_fire(p) + & + m_frootc_xfer_to_litter_fire(p))*froot_prof(p,j) & + +(m_livestemc_storage_to_litter_fire(p) + & + m_livestemc_xfer_to_litter_fire(p) & + +m_deadstemc_storage_to_litter_fire(p) + & + m_deadstemc_xfer_to_litter_fire(p))* stem_prof(p,j)& + +(m_livecrootc_storage_to_litter_fire(p) + & + m_livecrootc_xfer_to_litter_fire(p) & + +m_deadcrootc_storage_to_litter_fire(p) + & + m_deadcrootc_xfer_to_litter_fire(p))* croot_prof(p,j))* patch%wtcol(p) + m_c_to_litr_cel_fire(c,j)=m_c_to_litr_cel_fire(c,j) + & + (m_leafc_to_litter_fire(p)*lf_fcel(patch%itype(p))*leaf_prof(p,j) + & + m_frootc_to_litter_fire(p)*fr_fcel(patch%itype(p))*froot_prof(p,j))* patch%wtcol(p) + m_c_to_litr_lig_fire(c,j)=m_c_to_litr_lig_fire(c,j) + & + (m_leafc_to_litter_fire(p)*lf_flig(patch%itype(p))*leaf_prof(p,j) + & + m_frootc_to_litter_fire(p)*fr_flig(patch%itype(p))*froot_prof(p,j))* patch%wtcol(p) + + m_n_to_litr_met_fire(c,j)=m_n_to_litr_met_fire(c,j) + & + ((m_leafn_to_litter_fire(p)*lf_flab(patch%itype(p)) & + +m_leafn_storage_to_litter_fire(p) + & + m_leafn_xfer_to_litter_fire(p)+m_retransn_to_litter_fire(p)) & + *leaf_prof(p,j) +(m_frootn_to_litter_fire(p)*fr_flab(patch%itype(p)) & + +m_frootn_storage_to_litter_fire(p) + & + m_frootn_xfer_to_litter_fire(p))*froot_prof(p,j) & + +(m_livestemn_storage_to_litter_fire(p) + & + m_livestemn_xfer_to_litter_fire(p) & + +m_deadstemn_storage_to_litter_fire(p) + & + m_deadstemn_xfer_to_litter_fire(p))* stem_prof(p,j)& + +(m_livecrootn_storage_to_litter_fire(p) + & + m_livecrootn_xfer_to_litter_fire(p) & + +m_deadcrootn_storage_to_litter_fire(p) + & + m_deadcrootn_xfer_to_litter_fire(p))* croot_prof(p,j))* patch%wtcol(p) + m_n_to_litr_cel_fire(c,j)=m_n_to_litr_cel_fire(c,j) + & + (m_leafn_to_litter_fire(p)*lf_fcel(patch%itype(p))*leaf_prof(p,j) + & + m_frootn_to_litter_fire(p)*fr_fcel(patch%itype(p))*froot_prof(p,j))* patch%wtcol(p) + m_n_to_litr_lig_fire(c,j)=m_n_to_litr_lig_fire(c,j) + & + (m_leafn_to_litter_fire(p)*lf_flig(patch%itype(p))*leaf_prof(p,j) + & + m_frootn_to_litter_fire(p)*fr_flig(patch%itype(p))*froot_prof(p,j))* patch%wtcol(p) + end do + end do + ! + ! vertically-resolved decomposing C/N fire loss + ! column loop + ! + num_actfirec = 0 + do fc = 1,num_soilc + c = filter_soilc(fc) + + f = farea_burned(c) + + if(f /= 0 .or. f /= baf_crop(c))then + num_actfirec = num_actfirec + 1 + filter_actfirec(num_actfirec) = c + end if + do j = 1, nlevdecomp + ! carbon fluxes + do l = 1, ndecomp_pools + if ( is_litter(l) ) then + m_decomp_cpools_to_fire_vr(c,j,l) = decomp_cpools_vr(c,j,l) * f * & + cmb_cmplt_fact_litter + if(use_soil_matrixcn)then! matrix is the same for C and N in the fire. + associate( & + matrix_decomp_fire_k => soilbiogeochem_carbonflux_inst%matrix_decomp_fire_k_col & ! Output: [real(r8) (:,:) ] (gC/m3/step) VR deomp. C fire loss in matrix representation + ) + matrix_decomp_fire_k(c,j+nlevdecomp*(l-1)) = matrix_decomp_fire_k(c,j+nlevdecomp*(l-1)) & + - f * cmb_cmplt_fact_litter * dt + end associate + end if + end if + if ( is_cwd(l) ) then + m_decomp_cpools_to_fire_vr(c,j,l) = decomp_cpools_vr(c,j,l) * & + (f-baf_crop(c)) * cmb_cmplt_fact_cwd + if(use_soil_matrixcn)then + associate( & + matrix_decomp_fire_k => soilbiogeochem_carbonflux_inst%matrix_decomp_fire_k_col & ! Output: [real(r8) (:,:) ] (gC/m3/step) VR deomp. C fire loss in matrix representation + ) + matrix_decomp_fire_k(c,j+nlevdecomp*(l-1)) = matrix_decomp_fire_k(c,j+nlevdecomp*(l-1)) & + - (f-baf_crop(c)) * cmb_cmplt_fact_cwd * dt + end associate + end if + end if + end do + + ! nitrogen fluxes + do l = 1, ndecomp_pools + if ( is_litter(l) ) then + m_decomp_npools_to_fire_vr(c,j,l) = decomp_npools_vr(c,j,l) * f * & + cmb_cmplt_fact_litter + end if + if ( is_cwd(l) ) then + m_decomp_npools_to_fire_vr(c,j,l) = decomp_npools_vr(c,j,l) * & + (f-baf_crop(c)) * cmb_cmplt_fact_cwd + end if + end do + + end do + end do ! end of column loop + + ! carbon loss due to deforestation fires + + if (transient_landcover) then + call get_curr_date (kyr, kmo, kda, mcsec) + do fc = 1,num_soilc + c = filter_soilc(fc) + lfc2(c)=0._r8 + if( .not. (kmo == 1 .and. kda == 1 .and. mcsec == 0) )then + if( trotr1_col(c)+trotr2_col(c) > 0.6_r8 .and. dtrotr_col(c) > 0._r8 .and. & + lfc(c) > 0._r8 .and. fbac1(c) == 0._r8) then + lfc2(c) = max(0._r8, min(lfc(c), (farea_burned(c)-baf_crop(c) - & + baf_peatf(c))/2.0*dt))/(dtrotr_col(c)*dayspyr*secspday/dt)/dt + lfc(c) = lfc(c) - max(0._r8, min(lfc(c), (farea_burned(c)-baf_crop(c) - & + baf_peatf(c))*dt/2.0_r8)) + end if + end if + end do + end if + ! + ! Carbon loss due to peat fires + ! + ! somc_fire is not connected to clm45 soil carbon pool, ie does not decrease + ! soil carbon b/c clm45 soil carbon was very low in several peatland grids + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + if( grc%latdeg(g) < cnfire_const%borealat)then + somc_fire(c)= totsomc(c)*baf_peatf(c)*6.0_r8/33.9_r8 + else + somc_fire(c)= baf_peatf(c)*2.2e3_r8 + end if + end do + + ! Fang Li has not added aerosol and trace gas emissions due to fire, yet + ! They will be added here in proportion to the carbon emission + ! Emission factors differ for various fire types + + end associate + + end subroutine CNFireFluxes + + !----------------------------------------------------------------------- + subroutine CNFireReadParams( this, ncid ) + ! + ! Read in the constant parameters from the input NetCDF parameter file + ! !USES: + use ncdio_pio , only: file_desc_t + use paramUtilMod, only: readNcdioScalar + ! + ! !ARGUMENTS: + implicit none + class(cnfire_base_type) :: this + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'CNFireReadParams' + !-------------------------------------------------------------------- + + ! Factor related to dependence of fuel combustibility on 30-day running mean of relative humidity (unitless) + call readNcdioScalar(ncid, 'prh30', subname, cnfire_params%prh30) + ! Ignition efficiency of cloud-to-ground lightning (unitless) + call readNcdioScalar(ncid, 'ignition_efficiency', subname, cnfire_params%ignition_efficiency) + + end subroutine CNFireReadParams + +end module CNFireBaseMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNProductsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNProductsMod.F90 new file mode 100755 index 000000000..61fb40c82 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNProductsMod.F90 @@ -0,0 +1,482 @@ +module CNProductsMod + +#include "MAPL_Generic.h" +#include "shr_assert.h" + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use MAPL_ExceptionHandling + use nanMod , only : nan + use decompMod , only : bounds_type + use clm_varpar , only : num_zon, var_col, cn_zone_weight, numpft + use clm_time_manager , only : get_step_size_real + use PatchType , only : patch + use clm_varcon , only : spval + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + ! !PUBLIC TYPES: + type, public :: cn_products_type + + ! ------------------------------------------------------------------------ + ! Public instance variables + ! ------------------------------------------------------------------------ + + real(r8), pointer, public :: product_loss_grc(:) ! (g[C or N]/m2/s) total decomposition loss from ALL product pools + real(r8), pointer, public :: cropprod1_grc(:) ! (g[C or N]/m2) crop product pool (grain + biofuel), 1-year lifespan + real(r8), pointer, public :: tot_woodprod_grc(:) ! (g[C or N]/m2) total wood product pool + + ! ------------------------------------------------------------------------ + ! Private instance variables + ! ------------------------------------------------------------------------ + + ! class(species_base_type), allocatable :: species ! C, N, C13, C14, etc. + + ! States + real(r8), pointer :: prod10_grc(:) ! (g[C or N]/m2) wood product pool, 10-year lifespan + real(r8), pointer :: prod100_grc(:) ! (g[C or N]/m2) wood product pool, 100-year lifespan + + ! Fluxes: gains + real(r8), pointer :: dwt_prod10_gain_grc(:) ! (g[C or N]/m2/s) dynamic landcover addition to 10-year wood product pool + real(r8), pointer :: dwt_prod100_gain_grc(:) ! (g[C or N]/m2/s) dynamic landcover addition to 100-year wood product pool + real(r8), pointer :: dwt_woodprod_gain_grc(:) ! (g[C or N]/m2/s) dynamic landcover addition to wood product pools + real(r8), pointer :: dwt_cropprod1_gain_grc(:) ! (g[C or N]/m2/s) dynamic landcover addition to 1-year crop product pool + real(r8), pointer :: hrv_deadstem_to_prod10_patch(:) ! (g[C or N]/m2/s) dead stem harvest to 10-year wood product pool + real(r8), pointer :: hrv_deadstem_to_prod10_grc(:) ! (g[C or N]/m2/s) dead stem harvest to 10-year wood product pool + real(r8), pointer :: hrv_deadstem_to_prod100_patch(:) ! (g[C or N]/m2/s) dead stem harvest to 100-year wood product pool + real(r8), pointer :: hrv_deadstem_to_prod100_grc(:) ! (g[C or N]/m2/s) dead stem harvest to 100-year wood product pool + real(r8), pointer :: grain_to_cropprod1_patch(:) ! (g[C or N]/m2/s) grain to 1-year crop product pool + real(r8), pointer :: grain_to_cropprod1_grc(:) ! (g[C or N]/m2/s) grain to 1-year crop product pool + + ! Fluxes: losses + real(r8), pointer :: cropprod1_loss_grc(:) ! (g[C or N]/m2/s) decomposition loss from 1-yr crop product pool + real(r8), pointer :: prod10_loss_grc(:) ! (g[C or N]/m2/s) decomposition loss from 10-yr wood product pool + real(r8), pointer :: prod100_loss_grc(:) ! (g[C or N]/m2/s) decomposition loss from 100-yr wood product pool + real(r8), pointer :: tot_woodprod_loss_grc(:) ! (g[C or N]/m2/s) decompomposition loss from all wood product pools + + contains + + ! Science routines + procedure, public :: UpdateProducts + procedure, private :: PartitionWoodFluxes + procedure, private :: PartitionGrainFluxes + procedure, private :: ComputeSummaryVars + procedure, public :: Init + + end type cn_products_type + type(cn_products_type), public, target, save :: cn_products_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + +!-------------------------------------------------------------- + subroutine Init(this, bounds, nch, cncol, species, rc) + + ! !DESCRIPTION: + ! Initialize CTSM wood products type needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + ! INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + real, dimension(nch,num_zon,var_col), intent(in) :: cncol ! column-level restart variable array + character(*), intent(in) :: species ! C or N + class(cn_products_type) :: this + integer, optional, intent(out) :: rc + + ! LOCAL + integer :: begp, endp + integer :: begg, endg + integer :: nc, nz, p, np + !--------------------------------- + + begp = bounds%begp ; endp = bounds%endp + begg = bounds%begg ; endg = bounds%endg + + allocate(this%cropprod1_grc(begg:endg)) ; this%cropprod1_grc(:) = nan + allocate(this%prod10_grc(begg:endg)) ; this%prod10_grc(:) = nan + allocate(this%prod100_grc(begg:endg)) ; this%prod100_grc(:) = nan + allocate(this%tot_woodprod_grc(begg:endg)) ; this%tot_woodprod_grc(:) = nan + + allocate(this%dwt_prod10_gain_grc(begg:endg)) ; this%dwt_prod10_gain_grc(:) = nan + allocate(this%dwt_prod100_gain_grc(begg:endg)) ; this%dwt_prod100_gain_grc(:) = nan + allocate(this%dwt_woodprod_gain_grc(begg:endg)) ; this%dwt_woodprod_gain_grc(:) = nan + + allocate(this%dwt_cropprod1_gain_grc(begg:endg)) ; this%dwt_cropprod1_gain_grc(:) = nan + + allocate(this%hrv_deadstem_to_prod10_patch(begp:endp)) ; this%hrv_deadstem_to_prod10_patch(:) = spval + allocate(this%hrv_deadstem_to_prod10_grc(begg:endg)) ; this%hrv_deadstem_to_prod10_grc(:) = nan + + allocate(this%hrv_deadstem_to_prod100_patch(begp:endp)) ; this%hrv_deadstem_to_prod100_patch(:) = spval + allocate(this%hrv_deadstem_to_prod100_grc(begg:endg)) ; this%hrv_deadstem_to_prod100_grc(:) = nan + + allocate(this%grain_to_cropprod1_patch(begp:endp)) ; this%grain_to_cropprod1_patch(:) = nan + allocate(this%grain_to_cropprod1_grc(begg:endg)) ; this%grain_to_cropprod1_grc(:) = nan + + allocate(this%cropprod1_loss_grc(begg:endg)) ; this%cropprod1_loss_grc(:) = nan + allocate(this%prod10_loss_grc(begg:endg)) ; this%prod10_loss_grc(:) = nan + allocate(this%prod100_loss_grc(begg:endg)) ; this%prod100_loss_grc(:) = nan + allocate(this%tot_woodprod_loss_grc(begg:endg)) ; this%tot_woodprod_loss_grc(:) = nan + allocate(this%product_loss_grc(begg:endg)) ; this%product_loss_grc(:) = nan + + this%dwt_cropprod1_gain_grc(begg:endg) = 0._r8 + this%dwt_prod10_gain_grc(begg:endg) = 0._r8 + this%dwt_prod100_gain_grc(begg:endg) = 0._r8 + this%grain_to_cropprod1_grc(begg:endg) = 0._r8 + + + ! initialize variables from restart file or set to cold start value + + np = 0 + do nc = 1,nch ! catchment tile loop + + this%prod100_grc(nc) = 0._r8 + this%prod10_grc(nc) = 0._r8 + this%cropprod1_grc(nc) = 0._r8 + this%tot_woodprod_grc(nc) = 0._r8 + + do nz = 1,num_zon ! CN zone loop + + if (trim(species) == 'C') then + this%prod100_grc(nc) = this%prod100_grc(nc) + cncol(nc,nz,7)*CN_zone_weight(nz) + this%prod10_grc(nc) = this%prod10_grc(nc) + cncol(nc,nz,8)*CN_zone_weight(nz) + elseif (trim(species) == 'N') then + this%prod100_grc(nc) = this%prod100_grc(nc) + cncol(nc,nz,21)*CN_zone_weight(nz) + this%prod10_grc(nc) = this%prod10_grc(nc) + cncol(nc,nz,22)*CN_zone_weight(nz) + else + _ASSERT(.FALSE.,'unknown species') + end if + + do p = 0,numpft ! PFT index loop + np = np + 1 + this%hrv_deadstem_to_prod10_patch(np) = 0._r8 + this%hrv_deadstem_to_prod100_patch(np) = 0._r8 + this%grain_to_cropprod1_patch(np) = 0._r8 + end do ! p + end do ! nz + end do ! nc + end subroutine Init + + !----------------------------------------------------------------------- + subroutine UpdateProducts(this, bounds, & + num_soilp, filter_soilp, & + dwt_wood_product_gain_patch, & + wood_harvest_patch, & + dwt_crop_product_gain_patch, & + grain_to_cropprod_patch) + ! + ! !DESCRIPTION: + ! Update all loss fluxes from wood and grain product pools, and update product pool + ! state variables for both loss and gain terms + ! + ! !ARGUMENTS: + class(cn_products_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + + ! dynamic landcover addition to wood product pools (g/m2/s) [patch]; although this is + ! a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), intent(in) :: dwt_wood_product_gain_patch( bounds%begp: ) + + ! wood harvest addition to wood product pools (g/m2/s) [patch] + real(r8), intent(in) :: wood_harvest_patch( bounds%begp: ) + + ! dynamic landcover addition to crop product pools (g/m2/s) [patch]; although this is + ! a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), intent(in) :: dwt_crop_product_gain_patch( bounds%begp: ) + + ! grain to crop product pool (g/m2/s) [patch] + real(r8), intent(in) :: grain_to_cropprod_patch( bounds%begp: ) + ! + ! !LOCAL VARIABLES: + integer :: g ! indices + real(r8) :: dt ! time step (seconds) + real(r8) :: kprod1 ! decay constant for 1-year product pool + real(r8) :: kprod10 ! decay constant for 10-year product pool + real(r8) :: kprod100 ! decay constant for 100-year product pool + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(dwt_wood_product_gain_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(wood_harvest_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_crop_product_gain_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(grain_to_cropprod_patch) == (/bounds%endp/)), sourcefile, __LINE__) + + call this%PartitionWoodFluxes(bounds, & + num_soilp, filter_soilp, & + dwt_wood_product_gain_patch(bounds%begp:bounds%endp), & + wood_harvest_patch(bounds%begp:bounds%endp)) + + call this%PartitionGrainFluxes(bounds, & + num_soilp, filter_soilp, & + dwt_crop_product_gain_patch(bounds%begp:bounds%endp), & + grain_to_cropprod_patch(bounds%begp:bounds%endp)) + + ! calculate losses from product pools + ! the following (1/s) rate constants result in ~90% loss of initial state over 1, 10 and 100 years, + ! respectively, using a discrete-time fractional decay algorithm. + kprod1 = 7.2e-8 + kprod10 = 7.2e-9 + kprod100 = 7.2e-10 + + do g = bounds%begg, bounds%endg + ! calculate fluxes out of product pools (1/sec) + this%cropprod1_loss_grc(g) = this%cropprod1_grc(g) * kprod1 + this%prod10_loss_grc(g) = this%prod10_grc(g) * kprod10 + this%prod100_loss_grc(g) = this%prod100_grc(g) * kprod100 + end do + + ! set time steps + dt = get_step_size_real() + + ! update product state variables + do g = bounds%begg, bounds%endg + + ! fluxes into wood & crop product pools, from landcover change + this%cropprod1_grc(g) = this%cropprod1_grc(g) + this%dwt_cropprod1_gain_grc(g)*dt + this%prod10_grc(g) = this%prod10_grc(g) + this%dwt_prod10_gain_grc(g)*dt + this%prod100_grc(g) = this%prod100_grc(g) + this%dwt_prod100_gain_grc(g)*dt + + ! fluxes into wood & crop product pools, from harvest + this%cropprod1_grc(g) = this%cropprod1_grc(g) + this%grain_to_cropprod1_grc(g)*dt + this%prod10_grc(g) = this%prod10_grc(g) + this%hrv_deadstem_to_prod10_grc(g)*dt + this%prod100_grc(g) = this%prod100_grc(g) + this%hrv_deadstem_to_prod100_grc(g)*dt + + ! fluxes out of wood & crop product pools, from decomposition + this%cropprod1_grc(g) = this%cropprod1_grc(g) - this%cropprod1_loss_grc(g)*dt + this%prod10_grc(g) = this%prod10_grc(g) - this%prod10_loss_grc(g)*dt + this%prod100_grc(g) = this%prod100_grc(g) - this%prod100_loss_grc(g)*dt + + end do + + call this%ComputeSummaryVars(bounds) + + end subroutine UpdateProducts + + !----------------------------------------------------------------------- + subroutine PartitionWoodFluxes(this, bounds, & + num_soilp, filter_soilp, & + dwt_wood_product_gain_patch, & + wood_harvest_patch) + ! + ! !DESCRIPTION: + ! Partition input wood fluxes into 10 and 100 year product pools + ! + ! !USES: + use pftconMod , only : pftcon + use subgridAveMod, only : p2g + ! + ! !ARGUMENTS: + class(cn_products_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + + ! dynamic landcover addition to wood product pools (g/m2/s) [patch]; although this is + ! a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), intent(in) :: dwt_wood_product_gain_patch( bounds%begp: ) + + ! wood harvest addition to wood product pools (g/m2/s) [patch] + real(r8), intent(in) :: wood_harvest_patch( bounds%begp: ) + + ! + ! !LOCAL VARIABLES: + integer :: fp + integer :: p + integer :: g + real(r8) :: pprod10 ! PFT proportion of deadstem to 10-year product pool + real(r8) :: pprod100 ! PFT proportion of deadstem to 100-year product pool + real(r8) :: pprod_tot ! PFT proportion of deadstem to any product pool + real(r8) :: pprod10_frac ! PFT fraction of deadstem to product pool that goes to 10-year product pool + real(r8) :: pprod100_frac ! PFT fraction of deadstem to product pool that goes to 100-year product pool + + character(len=*), parameter :: subname = 'PartitionWoodFluxes' + !----------------------------------------------------------------------- + + ! Partition patch-level harvest fluxes to 10 and 100-year product pools + do fp = 1, num_soilp + p = filter_soilp(fp) + this%hrv_deadstem_to_prod10_patch(p) = & + wood_harvest_patch(p) * pftcon%pprodharv10(patch%itype(p)) + this%hrv_deadstem_to_prod100_patch(p) = & + wood_harvest_patch(p) * (1.0_r8 - pftcon%pprodharv10(patch%itype(p))) + end do + + ! Average harvest fluxes from patch to gridcell + call p2g(bounds, & + this%hrv_deadstem_to_prod10_patch(bounds%begp:bounds%endp), & + this%hrv_deadstem_to_prod10_grc(bounds%begg:bounds%endg), & + p2c_scale_type = 'unity', & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + call p2g(bounds, & + this%hrv_deadstem_to_prod100_patch(bounds%begp:bounds%endp), & + this%hrv_deadstem_to_prod100_grc(bounds%begg:bounds%endg), & + p2c_scale_type = 'unity', & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + ! Zero the dwt gains + do g = bounds%begg, bounds%endg + this%dwt_prod10_gain_grc(g) = 0._r8 + this%dwt_prod100_gain_grc(g) = 0._r8 + end do + + + ! Partition dynamic land cover fluxes to 10 and 100-year product pools. + do p = bounds%begp, bounds%endp + g = patch%gridcell(p) + + ! Note that pprod10 + pprod100 do NOT sum to 1: some fraction of the dwt changes + ! was lost to other fluxes. dwt_wood_product_gain_patch gives the amount that goes + ! to all product pools, so we need to determine the fraction of that flux that + ! goes to each pool. + pprod10 = pftcon%pprod10(patch%itype(p)) + pprod100 = pftcon%pprod100(patch%itype(p)) + pprod_tot = pprod10 + pprod100 + if (pprod_tot > 0) then + pprod10_frac = pprod10 / pprod_tot + pprod100_frac = pprod100 / pprod_tot + else + ! Avoid divide by 0 + pprod10_frac = 0._r8 + pprod100_frac = 0._r8 + end if + + ! Note that the patch-level fluxes are expressed per unit gridcell area. So, to go + ! from patch-level fluxes to gridcell-level fluxes, we simply add up the various + ! patch contributions, without having to multiply by any area weightings. + this%dwt_prod10_gain_grc(g) = this%dwt_prod10_gain_grc(g) + & + dwt_wood_product_gain_patch(p) * pprod10_frac + this%dwt_prod100_gain_grc(g) = this%dwt_prod100_gain_grc(g) + & + dwt_wood_product_gain_patch(p) * pprod100_frac + end do + + end subroutine PartitionWoodFluxes + + !----------------------------------------------------------------------- + subroutine PartitionGrainFluxes(this, bounds, & + num_soilp, filter_soilp, & + dwt_crop_product_gain_patch, & + grain_to_cropprod_patch) + ! + ! !DESCRIPTION: + ! Partition input grain fluxes into crop product pools + ! + ! For now this doesn't do much, since there is just a single (1-year) crop product + ! pool. But this provides the capability to add different crop product pools in the + ! future, without requiring any changes to code outside of this class. It also gives + ! symmetry with the wood fluxes. + ! + ! !USES: + use subgridAveMod, only : p2g + ! + ! !ARGUMENTS: + class(cn_products_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + + ! dynamic landcover addition to crop product pool (g/m2/s) [patch]; although this is + ! a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), intent(in) :: dwt_crop_product_gain_patch( bounds%begp: ) + + ! grain to crop product pool(s) (g/m2/s) [patch] + real(r8) , intent(in) :: grain_to_cropprod_patch( bounds%begp: ) + ! + ! !LOCAL VARIABLES: + integer :: fp + integer :: p + integer :: g + + character(len=*), parameter :: subname = 'PartitionGrainFluxes' + !----------------------------------------------------------------------- + + ! Determine gains from crop harvest + + do fp = 1, num_soilp + p = filter_soilp(fp) + + ! For now all crop product is put in the 1-year crop product pool + this%grain_to_cropprod1_patch(p) = grain_to_cropprod_patch(p) + end do + + call p2g(bounds, & + this%grain_to_cropprod1_patch(bounds%begp:bounds%endp), & + this%grain_to_cropprod1_grc(bounds%begg:bounds%endg), & + p2c_scale_type = 'unity', & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + ! Determine gains from dynamic landcover + + do g = bounds%begg, bounds%endg + this%dwt_cropprod1_gain_grc(g) = 0._r8 + end do + + do p = bounds%begp, bounds%endp + g = patch%gridcell(p) + + ! Note that the patch-level fluxes are expressed per unit gridcell area. So, to go + ! from patch-level fluxes to gridcell-level fluxes, we simply add up the various + ! patch contributions, without having to multiply by any area weightings. + this%dwt_cropprod1_gain_grc(g) = this%dwt_cropprod1_gain_grc(g) + & + dwt_crop_product_gain_patch(p) + end do + + end subroutine PartitionGrainFluxes + + !----------------------------------------------------------------------- + subroutine ComputeSummaryVars(this, bounds) + ! + ! !DESCRIPTION: + ! Compute summary variables in this object: sums across multiple product pools + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_products_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g ! indices + + character(len=*), parameter :: subname = 'ComputeSummaryVars' + !----------------------------------------------------------------------- + + do g = bounds%begg, bounds%endg + + ! total wood products + this%tot_woodprod_grc(g) = & + this%prod10_grc(g) + & + this%prod100_grc(g) + + ! total loss from wood products + this%tot_woodprod_loss_grc(g) = & + this%prod10_loss_grc(g) + & + this%prod100_loss_grc(g) + + ! total loss from ALL products + this%product_loss_grc(g) = & + this%cropprod1_loss_grc(g) + & + this%prod10_loss_grc(g) + & + this%prod100_loss_grc(g) + + this%dwt_woodprod_gain_grc(g) = & + this%dwt_prod100_gain_grc(g) + & + this%dwt_prod10_gain_grc(g) + end do + + end subroutine ComputeSummaryVars + +end module CNProductsMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegCarbonFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegCarbonFluxType.F90 new file mode 100755 index 000000000..00ab7d811 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegCarbonFluxType.F90 @@ -0,0 +1,2270 @@ +module CNVegCarbonFluxType + +#include "MAPL_Generic.h" +#include "shr_assert.h" + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use decompMod , only : bounds_type + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools,& + nvegcpool,ncphtrans,ncgmtrans,ncfitrans,& + ncphouttrans,ncgmouttrans,ncfiouttrans + use clm_varpar , only : nlevdecomp_full, nlevgrnd,nlevdecomp + use clm_varpar , only : ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,& + igrain,igrain_st,igrain_xf,ioutc + use clm_varpar , only : numpft, num_zon, num_veg, & + var_col, var_pft, CN_zone_weight + use clm_varctl , only : use_crop, use_matrixcn, use_cndv, use_grainproduct, iulog + use clm_varcon , only : dzsoi_decomp + use pftconMod , only : npcropmin + use clm_varcon , only : spval + use ColumnType , only : col + use PatchType , only : patch + use AnnualFluxDribbler , only : annual_flux_dribbler_type, annual_flux_dribbler_gridcell + use MAPL_ExceptionHandling + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg +! use SPMMod , only : sparse_matrix_type, diag_matrix_type, vector_type + + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: cnveg_carbonflux_type + + ! gap mortality fluxes + real(r8), pointer :: m_leafc_to_litter_patch (:) ! leaf C mortality (gC/m2/s) + real(r8), pointer :: m_leafc_storage_to_litter_patch (:) ! leaf C storage mortality (gC/m2/s) + real(r8), pointer :: m_leafc_xfer_to_litter_patch (:) ! leaf C transfer mortality (gC/m2/s) + real(r8), pointer :: m_frootc_to_litter_patch (:) ! fine root C mortality (gC/m2/s) + real(r8), pointer :: m_frootc_storage_to_litter_patch (:) ! fine root C storage mortality (gC/m2/s) + real(r8), pointer :: m_frootc_xfer_to_litter_patch (:) ! fine root C transfer mortality (gC/m2/s) + real(r8), pointer :: m_livestemc_to_litter_patch (:) ! live stem C mortality (gC/m2/s) + real(r8), pointer :: m_livestemc_storage_to_litter_patch (:) ! live stem C storage mortality (gC/m2/s) + real(r8), pointer :: m_livestemc_xfer_to_litter_patch (:) ! live stem C transfer mortality (gC/m2/s) + real(r8), pointer :: m_deadstemc_to_litter_patch (:) ! dead stem C mortality (gC/m2/s) + real(r8), pointer :: m_deadstemc_storage_to_litter_patch (:) ! dead stem C storage mortality (gC/m2/s) + real(r8), pointer :: m_deadstemc_xfer_to_litter_patch (:) ! dead stem C transfer mortality (gC/m2/s) + real(r8), pointer :: m_livecrootc_to_litter_patch (:) ! live coarse root C mortality (gC/m2/s) + real(r8), pointer :: m_livecrootc_storage_to_litter_patch (:) ! live coarse root C storage mortality (gC/m2/s) + real(r8), pointer :: m_livecrootc_xfer_to_litter_patch (:) ! live coarse root C transfer mortality (gC/m2/s) + real(r8), pointer :: m_deadcrootc_to_litter_patch (:) ! dead coarse root C mortality (gC/m2/s) + real(r8), pointer :: m_deadcrootc_storage_to_litter_patch (:) ! dead coarse root C storage mortality (gC/m2/s) + real(r8), pointer :: m_deadcrootc_xfer_to_litter_patch (:) ! dead coarse root C transfer mortality (gC/m2/s) + real(r8), pointer :: m_gresp_storage_to_litter_patch (:) ! growth respiration storage mortality (gC/m2/s) + real(r8), pointer :: m_gresp_xfer_to_litter_patch (:) ! growth respiration transfer mortality (gC/m2/s) + + ! harvest mortality fluxes + real(r8), pointer :: hrv_leafc_to_litter_patch (:) ! leaf C harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_leafc_storage_to_litter_patch (:) ! leaf C storage harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_leafc_xfer_to_litter_patch (:) ! leaf C transfer harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_frootc_to_litter_patch (:) ! fine root C harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_frootc_storage_to_litter_patch (:) ! fine root C storage harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_frootc_xfer_to_litter_patch (:) ! fine root C transfer harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_livestemc_to_litter_patch (:) ! live stem C harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_livestemc_storage_to_litter_patch (:) ! live stem C storage harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_livestemc_xfer_to_litter_patch (:) ! live stem C transfer harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_deadstemc_storage_to_litter_patch (:) ! dead stem C storage harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_deadstemc_xfer_to_litter_patch (:) ! dead stem C transfer harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_livecrootc_to_litter_patch (:) ! live coarse root C harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_livecrootc_storage_to_litter_patch (:) ! live coarse root C storage harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_livecrootc_xfer_to_litter_patch (:) ! live coarse root C transfer harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_deadcrootc_to_litter_patch (:) ! dead coarse root C harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_deadcrootc_storage_to_litter_patch (:) ! dead coarse root C storage harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_deadcrootc_xfer_to_litter_patch (:) ! dead coarse root C transfer harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_gresp_storage_to_litter_patch (:) ! growth respiration storage harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_gresp_xfer_to_litter_patch (:) ! growth respiration transfer harvest mortality (gC/m2/s) + real(r8), pointer :: hrv_xsmrpool_to_atm_patch (:) ! excess MR pool harvest mortality (gC/m2/s) + + ! fire fluxes + real(r8), pointer :: m_leafc_to_fire_patch (:) ! (gC/m2/s) fire C emissions from leafc + real(r8), pointer :: m_leafc_storage_to_fire_patch (:) ! (gC/m2/s) fire C emissions from leafc_storage + real(r8), pointer :: m_leafc_xfer_to_fire_patch (:) ! (gC/m2/s) fire C emissions from leafc_xfer + real(r8), pointer :: m_livestemc_to_fire_patch (:) ! (gC/m2/s) fire C emissions from livestemc + real(r8), pointer :: m_livestemc_storage_to_fire_patch (:) ! (gC/m2/s) fire C emissions from livestemc_storage + real(r8), pointer :: m_livestemc_xfer_to_fire_patch (:) ! (gC/m2/s) fire C emissions from livestemc_xfer + real(r8), pointer :: m_deadstemc_to_fire_patch (:) ! (gC/m2/s) fire C emissions from deadstemc_xfer + real(r8), pointer :: m_deadstemc_storage_to_fire_patch (:) ! (gC/m2/s) fire C emissions from deadstemc_storage + real(r8), pointer :: m_deadstemc_xfer_to_fire_patch (:) ! (gC/m2/s) fire C emissions from deadstemc_xfer + real(r8), pointer :: m_frootc_to_fire_patch (:) ! (gC/m2/s) fire C emissions from frootc + real(r8), pointer :: m_frootc_storage_to_fire_patch (:) ! (gC/m2/s) fire C emissions from frootc_storage + real(r8), pointer :: m_frootc_xfer_to_fire_patch (:) ! (gC/m2/s) fire C emissions from frootc_xfer + real(r8), pointer :: m_livecrootc_to_fire_patch (:) ! (gC/m2/s) fire C emissions from livecrootc + real(r8), pointer :: m_livecrootc_storage_to_fire_patch (:) ! (gC/m2/s) fire C emissions from livecrootc_storage + real(r8), pointer :: m_livecrootc_xfer_to_fire_patch (:) ! (gC/m2/s) fire C emissions from livecrootc_xfer + real(r8), pointer :: m_deadcrootc_to_fire_patch (:) ! (gC/m2/s) fire C emissions from deadcrootc + real(r8), pointer :: m_deadcrootc_storage_to_fire_patch (:) ! (gC/m2/s) fire C emissions from deadcrootc_storage + real(r8), pointer :: m_deadcrootc_xfer_to_fire_patch (:) ! (gC/m2/s) fire C emissions from deadcrootc_xfer + real(r8), pointer :: m_gresp_storage_to_fire_patch (:) ! (gC/m2/s) fire C emissions from gresp_storage + real(r8), pointer :: m_gresp_xfer_to_fire_patch (:) ! (gC/m2/s) fire C emissions from gresp_xfer + real(r8), pointer :: m_leafc_to_litter_fire_patch (:) ! (gC/m2/s) from leafc to litter c due to fire + real(r8), pointer :: m_leafc_storage_to_litter_fire_patch (:) ! (gC/m2/s) from leafc_storage to litter C due to fire + real(r8), pointer :: m_leafc_xfer_to_litter_fire_patch (:) ! (gC/m2/s) from leafc_xfer to litter C due to fire + real(r8), pointer :: m_livestemc_to_litter_fire_patch (:) ! (gC/m2/s) from livestemc to litter C due to fire + real(r8), pointer :: m_livestemc_storage_to_litter_fire_patch (:) ! (gC/m2/s) from livestemc_storage to litter C due to fire + real(r8), pointer :: m_livestemc_xfer_to_litter_fire_patch (:) ! (gC/m2/s) from livestemc_xfer to litter C due to fire + real(r8), pointer :: m_livestemc_to_deadstemc_fire_patch (:) ! (gC/m2/s) from livestemc to deadstemc due to fire + real(r8), pointer :: m_deadstemc_to_litter_fire_patch (:) ! (gC/m2/s) from deadstemc to litter C due to fire + real(r8), pointer :: m_deadstemc_storage_to_litter_fire_patch (:) ! (gC/m2/s) from deadstemc_storage to litter C due to fire + real(r8), pointer :: m_deadstemc_xfer_to_litter_fire_patch (:) ! (gC/m2/s) from deadstemc_xfer to litter C due to fire + real(r8), pointer :: m_frootc_to_litter_fire_patch (:) ! (gC/m2/s) from frootc to litter C due to fire + real(r8), pointer :: m_frootc_storage_to_litter_fire_patch (:) ! (gC/m2/s) from frootc_storage to litter C due to fire + real(r8), pointer :: m_frootc_xfer_to_litter_fire_patch (:) ! (gC/m2/s) from frootc_xfer to litter C due to fire + real(r8), pointer :: m_livecrootc_to_litter_fire_patch (:) ! (gC/m2/s) from livecrootc to litter C due to fire + real(r8), pointer :: m_livecrootc_storage_to_litter_fire_patch (:) ! (gC/m2/s) from livecrootc_storage to litter C due to fire + real(r8), pointer :: m_livecrootc_xfer_to_litter_fire_patch (:) ! (gC/m2/s) from livecrootc_xfer to litter C due to fire + real(r8), pointer :: m_livecrootc_to_deadcrootc_fire_patch (:) ! (gC/m2/s) from livecrootc to deadstemc due to fire + real(r8), pointer :: m_deadcrootc_to_litter_fire_patch (:) ! (gC/m2/s) from deadcrootc to litter C due to fire + real(r8), pointer :: m_deadcrootc_storage_to_litter_fire_patch (:) ! (gC/m2/s) from deadcrootc_storage to litter C due to fire + real(r8), pointer :: m_deadcrootc_xfer_to_litter_fire_patch (:) ! (gC/m2/s) from deadcrootc_xfer to litter C due to fire + real(r8), pointer :: m_gresp_storage_to_litter_fire_patch (:) ! (gC/m2/s) from gresp_storage to litter C due to fire + real(r8), pointer :: m_gresp_xfer_to_litter_fire_patch (:) ! (gC/m2/s) from gresp_xfer to litter C due to fire + + ! phenology fluxes from transfer pools + real(r8), pointer :: grainc_xfer_to_grainc_patch (:) ! grain C growth from storage for prognostic crop(gC/m2/s) + real(r8), pointer :: leafc_xfer_to_leafc_patch (:) ! leaf C growth from storage (gC/m2/s) + real(r8), pointer :: frootc_xfer_to_frootc_patch (:) ! fine root C growth from storage (gC/m2/s) + real(r8), pointer :: livestemc_xfer_to_livestemc_patch (:) ! live stem C growth from storage (gC/m2/s) + real(r8), pointer :: deadstemc_xfer_to_deadstemc_patch (:) ! dead stem C growth from storage (gC/m2/s) + real(r8), pointer :: livecrootc_xfer_to_livecrootc_patch (:) ! live coarse root C growth from storage (gC/m2/s) + real(r8), pointer :: deadcrootc_xfer_to_deadcrootc_patch (:) ! dead coarse root C growth from storage (gC/m2/s) + + ! leaf and fine root litterfall fluxes + real(r8), pointer :: leafc_to_litter_patch (:) ! leaf C litterfall (gC/m2/s) + real(r8), pointer :: leafc_to_litter_fun_patch (:) ! leaf C litterfall used by FUN (gC/m2/s) + real(r8), pointer :: frootc_to_litter_patch (:) ! fine root C litterfall (gC/m2/s) + real(r8), pointer :: livestemc_to_litter_patch (:) ! live stem C litterfall (gC/m2/s) + real(r8), pointer :: grainc_to_food_patch (:) ! grain C to food for prognostic crop(gC/m2/s) + + real(r8), pointer :: leafc_to_biofuelc_patch (:) ! leaf C to biofuel C (gC/m2/s) + real(r8), pointer :: livestemc_to_biofuelc_patch (:) ! livestem C to biofuel C (gC/m2/s) + real(r8), pointer :: grainc_to_seed_patch (:) ! grain C to seed for prognostic crop(gC/m2/s) + + ! maintenance respiration fluxes + real(r8), pointer :: cpool_to_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: cpool_to_leafc_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: cpool_to_leafc_storage_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: cpool_to_frootc_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: cpool_to_frootc_storage_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: cpool_to_livecrootc_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: cpool_to_livecrootc_storage_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: cpool_to_livestemc_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: cpool_to_livestemc_storage_resp_patch (:) ! CNflex excess C maintenance respiration (gC/m2/s) + real(r8), pointer :: leaf_mr_patch (:) ! leaf maintenance respiration (gC/m2/s) + real(r8), pointer :: froot_mr_patch (:) ! fine root maintenance respiration (gC/m2/s) + real(r8), pointer :: livestem_mr_patch (:) ! live stem maintenance respiration (gC/m2/s) + real(r8), pointer :: livecroot_mr_patch (:) ! live coarse root maintenance respiration (gC/m2/s) + real(r8), pointer :: grain_mr_patch (:) ! crop grain or organs maint. respiration (gC/m2/s) + real(r8), pointer :: leaf_curmr_patch (:) ! leaf maintenance respiration from current GPP (gC/m2/s) + real(r8), pointer :: froot_curmr_patch (:) ! fine root maintenance respiration from current GPP (gC/m2/s) + real(r8), pointer :: livestem_curmr_patch (:) ! live stem maintenance respiration from current GPP (gC/m2/s) + real(r8), pointer :: livecroot_curmr_patch (:) ! live coarse root maintenance respiration from current GPP (gC/m2/s) + real(r8), pointer :: grain_curmr_patch (:) ! crop grain or organs maint. respiration from current GPP (gC/m2/s) + real(r8), pointer :: leaf_xsmr_patch (:) ! leaf maintenance respiration from storage (gC/m2/s) + real(r8), pointer :: froot_xsmr_patch (:) ! fine root maintenance respiration from storage (gC/m2/s) + real(r8), pointer :: livestem_xsmr_patch (:) ! live stem maintenance respiration from storage (gC/m2/s) + real(r8), pointer :: livecroot_xsmr_patch (:) ! live coarse root maintenance respiration from storage (gC/m2/s) + real(r8), pointer :: grain_xsmr_patch (:) ! crop grain or organs maint. respiration from storage (gC/m2/s) + + ! photosynthesis fluxes + real(r8), pointer :: psnsun_to_cpool_patch (:) ! C fixation from sunlit canopy (gC/m2/s) + real(r8), pointer :: psnshade_to_cpool_patch (:) ! C fixation from shaded canopy (gC/m2/s) + + ! allocation fluxes, from current GPP + real(r8), pointer :: cpool_to_xsmrpool_patch (:) ! allocation to maintenance respiration storage pool (gC/m2/s) + real(r8), pointer :: cpool_to_grainc_patch (:) ! allocation to grain C for prognostic crop(gC/m2/s) + real(r8), pointer :: cpool_to_grainc_storage_patch (:) ! allocation to grain C storage for prognostic crop(gC/m2/s) + real(r8), pointer :: cpool_to_leafc_patch (:) ! allocation to leaf C (gC/m2/s) + real(r8), pointer :: cpool_to_leafc_storage_patch (:) ! allocation to leaf C storage (gC/m2/s) + real(r8), pointer :: cpool_to_frootc_patch (:) ! allocation to fine root C (gC/m2/s) + real(r8), pointer :: cpool_to_frootc_storage_patch (:) ! allocation to fine root C storage (gC/m2/s) + real(r8), pointer :: cpool_to_livestemc_patch (:) ! allocation to live stem C (gC/m2/s) + real(r8), pointer :: cpool_to_livestemc_storage_patch (:) ! allocation to live stem C storage (gC/m2/s) + real(r8), pointer :: cpool_to_deadstemc_patch (:) ! allocation to dead stem C (gC/m2/s) + real(r8), pointer :: cpool_to_deadstemc_storage_patch (:) ! allocation to dead stem C storage (gC/m2/s) + real(r8), pointer :: cpool_to_livecrootc_patch (:) ! allocation to live coarse root C (gC/m2/s) + real(r8), pointer :: cpool_to_livecrootc_storage_patch (:) ! allocation to live coarse root C storage (gC/m2/s) + real(r8), pointer :: cpool_to_deadcrootc_patch (:) ! allocation to dead coarse root C (gC/m2/s) + real(r8), pointer :: cpool_to_deadcrootc_storage_patch (:) ! allocation to dead coarse root C storage (gC/m2/s) + real(r8), pointer :: cpool_to_gresp_storage_patch (:) ! allocation to growth respiration storage (gC/m2/s) + + + ! growth respiration fluxes + real(r8), pointer :: xsmrpool_to_atm_patch (:) ! excess MR pool harvest mortality (gC/m2/s) + real(r8), pointer :: xsmrpool_to_atm_col (:) ! excess MR pool harvest mortality (gC/m2/s) (p2c) + real(r8), pointer :: xsmrpool_to_atm_grc (:) ! excess MR pool harvest mortality (gC/m2/s) (p2g) + real(r8), pointer :: cpool_leaf_gr_patch (:) ! leaf growth respiration (gC/m2/s) + real(r8), pointer :: cpool_leaf_storage_gr_patch (:) ! leaf growth respiration to storage (gC/m2/s) + real(r8), pointer :: transfer_leaf_gr_patch (:) ! leaf growth respiration from storage (gC/m2/s) + real(r8), pointer :: cpool_froot_gr_patch (:) ! fine root growth respiration (gC/m2/s) + real(r8), pointer :: cpool_froot_storage_gr_patch (:) ! fine root growth respiration to storage (gC/m2/s) + real(r8), pointer :: transfer_froot_gr_patch (:) ! fine root growth respiration from storage (gC/m2/s) + real(r8), pointer :: cpool_livestem_gr_patch (:) ! live stem growth respiration (gC/m2/s) + real(r8), pointer :: cpool_livestem_storage_gr_patch (:) ! live stem growth respiration to storage (gC/m2/s) + real(r8), pointer :: transfer_livestem_gr_patch (:) ! live stem growth respiration from storage (gC/m2/s) + real(r8), pointer :: cpool_deadstem_gr_patch (:) ! dead stem growth respiration (gC/m2/s) + real(r8), pointer :: cpool_deadstem_storage_gr_patch (:) ! dead stem growth respiration to storage (gC/m2/s) + real(r8), pointer :: transfer_deadstem_gr_patch (:) ! dead stem growth respiration from storage (gC/m2/s) + real(r8), pointer :: cpool_livecroot_gr_patch (:) ! live coarse root growth respiration (gC/m2/s) + real(r8), pointer :: cpool_livecroot_storage_gr_patch (:) ! live coarse root growth respiration to storage (gC/m2/s) + real(r8), pointer :: transfer_livecroot_gr_patch (:) ! live coarse root growth respiration from storage (gC/m2/s) + real(r8), pointer :: cpool_deadcroot_gr_patch (:) ! dead coarse root growth respiration (gC/m2/s) + real(r8), pointer :: cpool_deadcroot_storage_gr_patch (:) ! dead coarse root growth respiration to storage (gC/m2/s) + real(r8), pointer :: transfer_deadcroot_gr_patch (:) ! dead coarse root growth respiration from storage (gC/m2/s) + + ! growth respiration for prognostic crop model + real(r8), pointer :: cpool_grain_gr_patch (:) ! grain growth respiration (gC/m2/s) + real(r8), pointer :: cpool_grain_storage_gr_patch (:) ! grain growth respiration to storage (gC/m2/s) + real(r8), pointer :: transfer_grain_gr_patch (:) ! grain growth respiration from storage (gC/m2/s) + + ! annual turnover of storage to transfer pools + real(r8), pointer :: grainc_storage_to_xfer_patch (:) ! grain C shift storage to transfer for prognostic crop model (gC/m2/s) + real(r8), pointer :: leafc_storage_to_xfer_patch (:) ! leaf C shift storage to transfer (gC/m2/s) + real(r8), pointer :: frootc_storage_to_xfer_patch (:) ! fine root C shift storage to transfer (gC/m2/s) + real(r8), pointer :: livestemc_storage_to_xfer_patch (:) ! live stem C shift storage to transfer (gC/m2/s) + real(r8), pointer :: deadstemc_storage_to_xfer_patch (:) ! dead stem C shift storage to transfer (gC/m2/s) + real(r8), pointer :: livecrootc_storage_to_xfer_patch (:) ! live coarse root C shift storage to transfer (gC/m2/s) + real(r8), pointer :: deadcrootc_storage_to_xfer_patch (:) ! dead coarse root C shift storage to transfer (gC/m2/s) + real(r8), pointer :: gresp_storage_to_xfer_patch (:) ! growth respiration shift storage to transfer (gC/m2/s) + + ! turnover of livewood to deadwood + real(r8), pointer :: livestemc_to_deadstemc_patch (:) ! live stem C turnover (gC/m2/s) + real(r8), pointer :: livecrootc_to_deadcrootc_patch (:) ! live coarse root C turnover (gC/m2/s) + + ! phenology: litterfall and crop fluxes + real(r8), pointer :: phenology_c_to_litr_met_c_col (:,:) ! C fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gC/m3/s) + real(r8), pointer :: phenology_c_to_litr_cel_c_col (:,:) ! C fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gC/m3/s) + real(r8), pointer :: phenology_c_to_litr_lig_c_col (:,:) ! C fluxes associated with phenology (litterfall and crop) to litter lignin pool (gC/m3/s) + + ! gap mortality + real(r8), pointer :: gap_mortality_c_to_litr_met_c_col (:,:) ! C fluxes associated with gap mortality to litter metabolic pool (gC/m3/s) + real(r8), pointer :: gap_mortality_c_to_litr_cel_c_col (:,:) ! C fluxes associated with gap mortality to litter cellulose pool (gC/m3/s) + real(r8), pointer :: gap_mortality_c_to_litr_lig_c_col (:,:) ! C fluxes associated with gap mortality to litter lignin pool (gC/m3/s) + real(r8), pointer :: gap_mortality_c_to_cwdc_col (:,:) ! C fluxes associated with gap mortality to CWD pool (gC/m3/s) + + ! fire + real(r8), pointer :: fire_mortality_c_to_cwdc_col (:,:) ! C fluxes associated with fire mortality to CWD pool (gC/m3/s) + + + ! harvest + real(r8), pointer :: harvest_c_to_litr_met_c_col (:,:) ! C fluxes associated with harvest to litter metabolic pool (gC/m3/s) + real(r8), pointer :: harvest_c_to_litr_cel_c_col (:,:) ! C fluxes associated with harvest to litter cellulose pool (gC/m3/s) + real(r8), pointer :: harvest_c_to_litr_lig_c_col (:,:) ! C fluxes associated with harvest to litter lignin pool (gC/m3/s) + real(r8), pointer :: harvest_c_to_cwdc_col (:,:) ! C fluxes associated with harvest to CWD pool (gC/m3/s) + real(r8), pointer :: grainc_to_cropprodc_patch (:) ! grain C to crop product pool (gC/m2/s) + real(r8), pointer :: grainc_to_cropprodc_col (:) ! grain C to crop product pool (gC/m2/s) + + ! fire fluxes + real(r8), pointer :: m_decomp_cpools_to_fire_vr_col (:,:,:) ! vertically-resolved decomposing C fire loss (gC/m3/s) + real(r8), pointer :: m_decomp_cpools_to_fire_col (:,:) ! vertically-integrated (diagnostic) decomposing C fire loss (gC/m2/s) + real(r8), pointer :: m_c_to_litr_met_fire_col (:,:) ! C from leaf, froot, xfer and storage C to litter labile C by fire (gC/m3/s) + real(r8), pointer :: m_c_to_litr_cel_fire_col (:,:) ! C from leaf, froot, xfer and storage C to litter cellulose C by fire (gC/m3/s) + real(r8), pointer :: m_c_to_litr_lig_fire_col (:,:) ! C from leaf, froot, xfer and storage C to litter lignin C by fire (gC/m3/s) + + ! dynamic landcover fluxes + real(r8), pointer :: dwt_seedc_to_leaf_patch (:) ! (gC/m2/s) seed source to patch-level; although this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_seedc_to_leaf_grc (:) ! (gC/m2/s) dwt_seedc_to_leaf_patch summed to the gridcell-level + real(r8), pointer :: dwt_seedc_to_deadstem_patch (:) ! (gC/m2/s) seed source to patch-level; although this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_seedc_to_deadstem_grc (:) ! (gC/m2/s) dwt_seedc_to_leaf_patch summed to the gridcell-level + real(r8), pointer :: dwt_conv_cflux_patch (:) ! (gC/m2/s) conversion C flux (immediate loss to atm); although this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_conv_cflux_grc (:) ! (gC/m2/s) dwt_conv_cflux_patch summed to the gridcell-level + real(r8), pointer :: dwt_conv_cflux_dribbled_grc (:) ! (gC/m2/s) dwt_conv_cflux_grc dribbled evenly throughout the year + real(r8), pointer :: dwt_wood_productc_gain_patch (:) ! (gC/m2/s) addition to wood product pools from landcover change; although this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_crop_productc_gain_patch (:) ! (gC/m2/s) addition to crop product pools from landcover change; although this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_slash_cflux_patch (:) ! (gC/m2/s) conversion slash flux due to landcover change + real(r8), pointer :: dwt_slash_cflux_grc (:) ! (gC/m2/s) dwt_slash_cflux_patch summed to the gridcell-level + real(r8), pointer :: dwt_frootc_to_litr_met_c_col (:,:) ! (gC/m3/s) fine root to litter due to landcover change + real(r8), pointer :: dwt_frootc_to_litr_cel_c_col (:,:) ! (gC/m3/s) fine root to litter due to landcover change + real(r8), pointer :: dwt_frootc_to_litr_lig_c_col (:,:) ! (gC/m3/s) fine root to litter due to landcover change + real(r8), pointer :: dwt_livecrootc_to_cwdc_col (:,:) ! (gC/m3/s) live coarse root to CWD due to landcover change + real(r8), pointer :: dwt_deadcrootc_to_cwdc_col (:,:) ! (gC/m3/s) dead coarse root to CWD due to landcover change + + ! crop fluxes + real(r8), pointer :: crop_seedc_to_leaf_patch (:) ! (gC/m2/s) seed source to leaf, for crops + + ! summary (diagnostic) flux variables, not involved in mass balance + real(r8), pointer :: gpp_before_downreg_patch (:) ! (gC/m2/s) gross primary production before down regulation + real(r8), pointer :: current_gr_patch (:) ! (gC/m2/s) growth resp for new growth displayed in this timestep + real(r8), pointer :: transfer_gr_patch (:) ! (gC/m2/s) growth resp for transfer growth displayed in this timestep + real(r8), pointer :: storage_gr_patch (:) ! (gC/m2/s) growth resp for growth sent to storage for later display + real(r8), pointer :: plant_calloc_patch (:) ! (gC/m2/s) total allocated C flux + real(r8), pointer :: excess_cflux_patch (:) ! (gC/m2/s) C flux not allocated due to downregulation + real(r8), pointer :: prev_leafc_to_litter_patch (:) ! (gC/m2/s) previous timestep leaf C litterfall flux + real(r8), pointer :: prev_frootc_to_litter_patch (:) ! (gC/m2/s) previous timestep froot C litterfall flux + real(r8), pointer :: availc_patch (:) ! (gC/m2/s) C flux available for allocation + real(r8), pointer :: xsmrpool_recover_patch (:) ! (gC/m2/s) C flux assigned to recovery of negative cpool + real(r8), pointer :: xsmrpool_c13ratio_patch (:) ! C13/C(12+13) ratio for xsmrpool (proportion) + + real(r8), pointer :: cwdc_hr_col (:) ! (gC/m2/s) col-level coarse woody debris C heterotrophic respiration + real(r8), pointer :: cwdc_loss_col (:) ! (gC/m2/s) col-level coarse woody debris C loss + real(r8), pointer :: litterc_loss_col (:) ! (gC/m2/s) col-level litter C loss + real(r8), pointer :: frootc_alloc_patch (:) ! (gC/m2/s) patch-level fine root C alloc + real(r8), pointer :: frootc_loss_patch (:) ! (gC/m2/s) patch-level fine root C loss + real(r8), pointer :: leafc_alloc_patch (:) ! (gC/m2/s) patch-level leaf C alloc + real(r8), pointer :: leafc_loss_patch (:) ! (gC/m2/s) patch-level leaf C loss + real(r8), pointer :: woodc_alloc_patch (:) ! (gC/m2/s) patch-level wood C alloc + real(r8), pointer :: woodc_loss_patch (:) ! (gC/m2/s + + + real(r8), pointer :: gpp_patch (:) ! (gC/m2/s) patch gross primary production + real(r8), pointer :: gpp_col (:) ! (gC/m2/s) column GPP flux before downregulation (p2c) + real(r8), pointer :: rr_patch (:) ! (gC/m2/s) root respiration (fine root MR + total root GR) + real(r8), pointer :: rr_col (:) ! (gC/m2/s) root respiration (fine root MR + total root GR) (p2c) + real(r8), pointer :: mr_patch (:) ! (gC/m2/s) maintenance respiration + real(r8), pointer :: gr_patch (:) ! (gC/m2/s) total growth respiration + real(r8), pointer :: ar_patch (:) ! (gC/m2/s) patch autotrophic respiration (MR + GR) + real(r8), pointer :: ar_col (:) ! (gC/m2/s) column autotrophic respiration (MR + GR) (p2c) + real(r8), pointer :: npp_patch (:) ! (gC/m2/s) patch net primary production + real(r8), pointer :: npp_col (:) ! (gC/m2/s) column net primary production (p2c) + real(r8), pointer :: agnpp_patch (:) ! (gC/m2/s) aboveground NPP + real(r8), pointer :: bgnpp_patch (:) ! (gC/m2/s) belowground NPP + real(r8), pointer :: litfall_patch (:) ! (gC/m2/s) patch litterfall (leaves and fine roots) + real(r8), pointer :: wood_harvestc_patch (:) ! (gC/m2/s) patch-level wood harvest (to product pools) + real(r8), pointer :: wood_harvestc_col (:) ! (gC/m2/s) column-level wood harvest (to product pools) (p2c) + real(r8), pointer :: slash_harvestc_patch (:) ! (gC/m2/s) patch-level slash from harvest (to litter) + real(r8), pointer :: cinputs_patch (:) ! (gC/m2/s) patch-level carbon inputs (for balance checking) + real(r8), pointer :: coutputs_patch (:) ! (gC/m2/s) patch-level carbon outputs (for balance checking) + real(r8), pointer :: sr_col (:) ! (gC/m2/s) total soil respiration (HR + root resp) + real(r8), pointer :: er_col (:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic + real(r8), pointer :: litfire_col (:) ! (gC/m2/s) litter fire losses + real(r8), pointer :: somfire_col (:) ! (gC/m2/s) soil organic matter fire losses + real(r8), pointer :: totfire_col (:) ! (gC/m2/s) total ecosystem fire losses + real(r8), pointer :: hrv_xsmrpool_to_atm_col (:) ! (gC/m2/s) excess MR pool harvest mortality (p2c) + + ! fire code + real(r8), pointer :: fire_closs_patch (:) ! (gC/m2/s) total fire C loss + real(r8), pointer :: fire_closs_p2c_col (:) ! (gC/m2/s) patch2col averaged column-level fire C loss (p2c) + real(r8), pointer :: fire_closs_col (:) ! (gC/m2/s) total patch-level fire C loss + + + ! temporary and annual sums + real(r8), pointer :: tempsum_litfall_patch (:) ! (gC/m2/yr) temporary annual sum of litfall (CNDV only for now) + real(r8), pointer :: annsum_litfall_patch (:) ! (gC/m2/yr) annual sum of litfall (CNDV only for now) + real(r8), pointer :: tempsum_npp_patch (:) ! (gC/m2/yr) temporary annual sum of NPP + real(r8), pointer :: annsum_npp_patch (:) ! (gC/m2/yr) annual sum of NPP + real(r8), pointer :: annsum_npp_col (:) ! (gC/m2/yr) annual sum of NPP, averaged from patch-level + real(r8), pointer :: lag_npp_col (:) ! (gC/m2/yr) lagged net primary production + + ! Summary C fluxes. + real(r8), pointer :: nep_col (:) ! (gC/m2/s) net ecosystem production, excludes fire, landuse, and harvest flux, positive for sink + real(r8), pointer :: nbp_grc (:) ! (gC/m2/s) net biome production, includes fire, landuse, harvest and hrv_xsmrpool flux, positive for sink (same as net carbon exchange between land and atmosphere) + real(r8), pointer :: nee_grc (:) ! (gC/m2/s) net ecosystem exchange of carbon, includes fire and hrv_xsmrpool, excludes landuse and harvest flux, positive for source + + ! Dynamic landcover fluxnes + real(r8), pointer :: landuseflux_grc(:) ! (gC/m2/s) dwt_conv_cflux+product_closs + real(r8), pointer :: npp_Nactive_patch (:) ! C used by mycorrhizal uptake (gC/m2/s) + real(r8), pointer :: npp_burnedoff_patch (:) ! C that cannot be used for N uptake (gC/m2/s) + real(r8), pointer :: npp_Nnonmyc_patch (:) ! C used by non-myc uptake (gC/m2/s) + real(r8), pointer :: npp_Nam_patch (:) ! C used by AM plant (gC/m2/s) + real(r8), pointer :: npp_Necm_patch (:) ! C used by ECM plant (gC/m2/s) + real(r8), pointer :: npp_Nactive_no3_patch (:) ! C used by mycorrhizal uptake (gC/m2/s) + real(r8), pointer :: npp_Nactive_nh4_patch (:) ! C used by mycorrhizal uptake (gC/m2/s) + real(r8), pointer :: npp_Nnonmyc_no3_patch (:) ! C used by non-myc (gC/m2/s) + real(r8), pointer :: npp_Nnonmyc_nh4_patch (:) ! C used by non-myc (gC/m2/s) + real(r8), pointer :: npp_Nam_no3_patch (:) ! C used by AM plant (gC/m2/s) + real(r8), pointer :: npp_Nam_nh4_patch (:) ! C used by AM plant (gC/m2/s) + real(r8), pointer :: npp_Necm_no3_patch (:) ! C used by ECM plant (gC/m2/s) + real(r8), pointer :: npp_Necm_nh4_patch (:) ! C used by ECM plant (gC/m2/s) + real(r8), pointer :: npp_Nfix_patch (:) ! C used by Symbiotic BNF (gC/m2/s) + real(r8), pointer :: npp_Nretrans_patch (:) ! C used by retranslocation (gC/m2/s) + real(r8), pointer :: npp_Nuptake_patch (:) ! Total C used by N uptake in FUN (gC/m2/s) + real(r8), pointer :: npp_growth_patch (:) ! Total C u for growth in FUN (gC/m2/s) + real(r8), pointer :: leafc_change_patch (:) ! Total used C from leaves (gC/m2/s) + real(r8), pointer :: soilc_change_patch (:) ! Total used C from soil (gC/m2/s) + + ! Matrix for C flux index + real(r8), pointer :: matrix_Cinput_patch (:) ! I-matrix for carbon input + real(r8), pointer :: matrix_C13input_patch (:) ! I-matrix for C13 input + real(r8), pointer :: matrix_C14input_patch (:) ! I-matrix for C14 input + real(r8), pointer :: matrix_alloc_patch (:,:) ! B-matrix for carbon allocation + + real(r8), pointer :: matrix_phtransfer_patch (:,:) ! A-matrix_phenology + real(r8), pointer :: matrix_phturnover_patch (:,:) ! K-matrix_phenology + integer, pointer :: matrix_phtransfer_doner_patch (:) ! A-matrix_phenology non-zero indices (column indices) + integer, pointer :: matrix_phtransfer_receiver_patch (:) ! A-matrix_phenology non-zero indices (row indices) + integer, pointer :: actpatch_fire (:) ! Patch indices with fire in current time step + integer :: num_actpatch_fire ! Number of patches with fire in current time step + + real(r8), pointer :: matrix_gmtransfer_patch (:,:) ! A-matrix_gap mortality + real(r8), pointer :: matrix_gmturnover_patch (:,:) ! K-matrix_gap mortality + integer, pointer :: matrix_gmtransfer_doner_patch (:) ! A-matrix_gap mortality non-zero indices (column indices) + integer, pointer :: matrix_gmtransfer_receiver_patch (:) ! A-matrix_gap mortality non-zero indices (row indices) + + real(r8), pointer :: matrix_fitransfer_patch (:,:) ! A-matrix_fire + real(r8), pointer :: matrix_fiturnover_patch (:,:) ! K-matrix_fire + integer, pointer :: matrix_fitransfer_doner_patch (:) ! A-matrix_fire non-zero indices (column indices) + integer, pointer :: matrix_fitransfer_receiver_patch (:) ! A-matrix_fire non-zero indices (row indices) + +! real(r8), pointer :: soilc_change_col (:) ! Total used C from soil (gC/m2/s) +! matrix variables + integer ileafst_to_ileafxf_ph ! Index of phenology related C transfer from leaf storage pool to leaf transfer pool + integer ileafxf_to_ileaf_ph ! Index of phenology related C transfer from leaf transfer pool to leaf pool + integer ifrootst_to_ifrootxf_ph ! Index of phenology related C transfer from fine root storage pool to fine root transfer pool + integer ifrootxf_to_ifroot_ph ! Index of phenology related C transfer from fine root transfer pool to fine root pool + integer ilivestemst_to_ilivestemxf_ph ! Index of phenology related C transfer from live stem storage pool to live stem transfer pool + integer ilivestemxf_to_ilivestem_ph ! Index of phenology related C transfer from live stem transfer pool to live stem pool + integer ideadstemst_to_ideadstemxf_ph ! Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + integer ideadstemxf_to_ideadstem_ph ! Index of phenology related C transfer from dead stem transfer pool to dead stem pool + integer ilivecrootst_to_ilivecrootxf_ph ! Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + integer ilivecrootxf_to_ilivecroot_ph ! Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + integer ideadcrootst_to_ideadcrootxf_ph ! Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + integer ideadcrootxf_to_ideadcroot_ph ! Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + integer ilivestem_to_ideadstem_ph ! Index of phenology related C transfer from live stem pool to dead stem pool + integer ilivecroot_to_ideadcroot_ph ! Index of phenology related C transfer from live coarse root pool to dead coarse root pool + integer ileaf_to_iout_ph ! Index of phenology related C transfer from leaf pool to outside of vegetation pools + integer ifroot_to_iout_ph ! Index of phenology related C transfer from fine root pool to outside of vegetation pools + integer ilivestem_to_iout_ph ! Index of phenology related C transfer from live stem pool to outside of vegetation pools + integer igrain_to_iout_ph ! Index of phenology related C transfer from grain pool to outside of vegetation pools + integer ileaf_to_iout_gm ! Index of gap mortality related C transfer from leaf pool to outside of vegetation pools + integer ileafst_to_iout_gm ! Index of gap mortality related C transfer from leaf storage pool to outside of vegetation pools + integer ileafxf_to_iout_gm ! Index of gap mortality related C transfer from leaf transfer pool to outside of vegetation pools + integer ifroot_to_iout_gm ! Index of gap mortality related C transfer from fine root pool to outside of vegetation pools + integer ifrootst_to_iout_gm ! Index of gap mortality related C transfer from fine root storage pool to outside of vegetation pools + integer ifrootxf_to_iout_gm ! Index of gap mortality related C transfer from fine root transfer pool to outside of vegetation pools + integer ilivestem_to_iout_gm ! Index of gap mortality related C transfer from live stem pool to outside of vegetation pools + integer ilivestemst_to_iout_gm ! Index of gap mortality related C transfer from live stem storage pool to outside of vegetation pools + integer ilivestemxf_to_iout_gm ! Index of gap mortality related C transfer from live stem transfer pool to outside of vegetation pools + integer ideadstem_to_iout_gm ! Index of gap mortality related C transfer from dead stem pool to outside of vegetation pools + integer ideadstemst_to_iout_gm ! Index of gap mortality related C transfer from dead stem storage pool to outside of vegetation pools + integer ideadstemxf_to_iout_gm ! Index of gap mortality related C transfer from dead stem transfer pool to outside of vegetation pools + integer ilivecroot_to_iout_gm ! Index of gap mortality related C transfer from live coarse root pool to outside of vegetation pools + integer ilivecrootst_to_iout_gm ! Index of gap mortality related C transfer from live coarse root storage pool to outside of vegetation pools + integer ilivecrootxf_to_iout_gm ! Index of gap mortality related C transfer from live coarse root transfer pool to outside of vegetation pools + integer ideadcroot_to_iout_gm ! Index of gap mortality related C transfer from dead coarse root pool to outside of vegetation pools + integer ideadcrootst_to_iout_gm ! Index of gap mortality related C transfer from dead coarse root storage pool to outside of vegetation pools + integer ideadcrootxf_to_iout_gm ! Index of gap mortality related C transfer from dead coarse root transfer pool to outside of vegetation pools + integer ileaf_to_iout_fi ! Index of fire related C transfer from leaf pool to outside of vegetation pools + integer ileafst_to_iout_fi ! Index of fire related C transfer from leaf storage pool to outside of vegetation pools + integer ileafxf_to_iout_fi ! Index of fire related C transfer from leaf transfer pool to outside of vegetation pools + integer ifroot_to_iout_fi ! Index of fire related C transfer from fine root pool to outside of vegetation pools + integer ifrootst_to_iout_fi ! Index of fire related C transfer from fine root storage pool to outside of vegetation pools + integer ifrootxf_to_iout_fi ! Index of fire related C transfer from fine root transfer pool to outside of vegetation pools + integer ilivestem_to_iout_fi ! Index of fire related C transfer from live stem pool to outside of vegetation pools + integer ilivestemst_to_iout_fi ! Index of fire related C transfer from live stem storage pool to outside of vegetation pools + integer ilivestemxf_to_iout_fi ! Index of fire related C transfer from live stem transfer pool to outside of vegetation pools + integer ideadstem_to_iout_fi ! Index of fire related C transfer from dead stem pool to outside of vegetation pools + integer ideadstemst_to_iout_fi ! Index of fire related C transfer from dead stem storage pool to outside of vegetation pools + integer ideadstemxf_to_iout_fi ! Index of fire related C transfer from dead stem transfer pool to outside of vegetation pools + integer ilivecroot_to_iout_fi ! Index of fire related C transfer from live coarse root pool to outside of vegetation pools + integer ilivecrootst_to_iout_fi ! Index of fire related C transfer from live coarse root storage pool to outside of vegetation pools + integer ilivecrootxf_to_iout_fi ! Index of fire related C transfer from live coarse root transfer pool to outside of vegetation pools + integer ideadcroot_to_iout_fi ! Index of fire related C transfer from dead coarse root pool to outside of vegetation pools + integer ideadcrootst_to_iout_fi ! Index of fire related C transfer from dead coarse root storage pool to outside of vegetation pools + integer ideadcrootxf_to_iout_fi ! Index of fire related C transfer from dead coarse root transfer pool to outside of vegetation pools + integer ilivestem_to_ideadstem_fi ! Index of fire related C transfer from live stem pool to dead stem pools + integer ilivecroot_to_ideadcroot_fi ! Index of fire related C transfer from live coarse root pool to dead coarse root pools + + integer,pointer :: list_phc_phgmc (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKphc to AKphc+AKgmc + integer,pointer :: list_gmc_phgmc (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKgmc to AKphc+AKgmc + integer,pointer :: list_phc_phgmfic (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKphc to AKphc+AKgmc+AKfic + integer,pointer :: list_gmc_phgmfic (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKgmc to AKphc+AKgmc+AKfic + integer,pointer :: list_fic_phgmfic (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKfic to AKphc+AKgmc+AKfic + integer,pointer :: list_aphc (:) ! Indices of non-diagnoal entries in full sparse matrix Aph for C cycle + integer,pointer :: list_agmc (:) ! Indices of non-diagnoal entries in full sparse matrix Agm for C cycle + integer,pointer :: list_afic (:) ! Indices of non-diagnoal entries in full sparse matrix Afi for C cycle + +! type(sparse_matrix_type) :: AKphvegc ! Aph*Kph for C cycle in sparse matrix format +! type(sparse_matrix_type) :: AKgmvegc ! Agm*Kgm for C cycle in sparse matrix format +! type(sparse_matrix_type) :: AKfivegc ! Afi*Kfi for C cycle in sparse matrix format +! type(sparse_matrix_type) :: AKallvegc ! Aph*Kph + Agm*Kgm + Afi*Kfi for C cycle in sparse matrix format +! +! type(vector_type) :: Xvegc ! Vegetation C of each compartment in a vector format +! type(vector_type) :: Xveg13c ! Vegetation C13 of each compartment in a vector format +! type(vector_type) :: Xveg14c ! Vegetation C14 of each compartment in a vector format + + ! Objects that help convert once-per-year dynamic land cover changes into fluxes + ! that are dribbled throughout the year + type(annual_flux_dribbler_type) :: dwt_conv_cflux_dribbler + type(annual_flux_dribbler_type) :: hrv_xsmrpool_to_atm_dribbler + logical, private :: dribble_crophrv_xsmrpool_2atm + + contains + + procedure , public :: SetValues + procedure , public :: Summary => Summary_carbonflux + procedure , public :: ZeroDWT + procedure , public :: Init + + end type cnveg_carbonflux_type + +type(cnveg_carbonflux_type), public, target, save :: cnveg_carbonflux_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + +!--------------------------------------- + subroutine Init(this, bounds, nch, ityp, fveg, cncol, cnpft, carbon_type, cn5_cold_start, rc) + +! !DESCRIPTION: +! Initialize CTSM carbon fluxes +! jk Apr 2021: type is allocated and initialized to NaN; +! if data arrays from restart file are passed (cncol and cnpft), the type is then initialized with these values +! +! !ARGUMENTS: + implicit none + + ! INPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: ityp ! PFT index + real, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: fveg ! PFT fraction + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + real, dimension(nch,NUM_ZON,NUM_VEG,VAR_PFT), intent(in) :: cnpft ! gkw: PFT CN restart + character(len=*) , intent(in) :: carbon_type ! one of ['c12', c13','c14'] + logical, optional, intent(in) :: cn5_cold_start + class(cnveg_carbonflux_type) :: this + integer, optional, intent(out) :: rc + + ! LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + integer :: np, nc, nz, p, nv, n, nl + logical :: cold_start = .false. + logical :: allows_non_annual_delta + character(len=:), allocatable :: carbon_type_suffix + !-------------------------------------------------------- + + ! check whether a cn5_cold_start option was set and change cold_start accordingly + if (present(cn5_cold_start) .and. (cn5_cold_start.eqv..true.)) then + cold_start = .true. + end if + + ! jkolassa: if cold_start is false, check that both CNCOL and CNPFT have the expected size for CNCLM50, else abort + if ((cold_start.eqv..false.) .and. ((size(cncol,3).ne.var_col) .or. & + (size(cnpft,4).ne.var_pft))) then + _ASSERT(.FALSE.,'option CNCLM50_cold_start = .FALSE. requires a CNCLM50 restart file') + end if + + allocate(this%matrix_phtransfer_doner_patch(1:18)) + allocate(this%matrix_phtransfer_receiver_patch(1:18)) + + this%ileafst_to_ileafxf_ph = 1 + this%matrix_phtransfer_doner_patch(this%ileafst_to_ileafxf_ph) = ileaf_st + this%matrix_phtransfer_receiver_patch(this%ileafst_to_ileafxf_ph) = ileaf_xf + + this%ileafxf_to_ileaf_ph = 2 + this%matrix_phtransfer_doner_patch(this%ileafxf_to_ileaf_ph) = ileaf_xf + this%matrix_phtransfer_receiver_patch(this%ileafxf_to_ileaf_ph) = ileaf + + this%ifrootst_to_ifrootxf_ph = 3 + this%matrix_phtransfer_doner_patch(this%ifrootst_to_ifrootxf_ph) = ifroot_st + this%matrix_phtransfer_receiver_patch(this%ifrootst_to_ifrootxf_ph) = ifroot_xf + + this%ifrootxf_to_ifroot_ph = 4 + this%matrix_phtransfer_doner_patch(this%ifrootxf_to_ifroot_ph) = ifroot_xf + this%matrix_phtransfer_receiver_patch(this%ifrootxf_to_ifroot_ph) = ifroot + + this%ilivestem_to_ideadstem_ph = 5 + this%matrix_phtransfer_doner_patch(this%ilivestem_to_ideadstem_ph) = ilivestem + this%matrix_phtransfer_receiver_patch(this%ilivestem_to_ideadstem_ph) = ideadstem + + this%ilivestemst_to_ilivestemxf_ph = 6 + this%matrix_phtransfer_doner_patch(this%ilivestemst_to_ilivestemxf_ph) = ilivestem_st + this%matrix_phtransfer_receiver_patch(this%ilivestemst_to_ilivestemxf_ph) = ilivestem_xf + + this%ilivestemxf_to_ilivestem_ph = 7 + this%matrix_phtransfer_doner_patch(this%ilivestemxf_to_ilivestem_ph) = ilivestem_xf + this%matrix_phtransfer_receiver_patch(this%ilivestemxf_to_ilivestem_ph) = ilivestem + + this%ideadstemst_to_ideadstemxf_ph = 8 + this%matrix_phtransfer_doner_patch(this%ideadstemst_to_ideadstemxf_ph) = ideadstem_st + this%matrix_phtransfer_receiver_patch(this%ideadstemst_to_ideadstemxf_ph) = ideadstem_xf + + this%ideadstemxf_to_ideadstem_ph = 9 + this%matrix_phtransfer_doner_patch(this%ideadstemxf_to_ideadstem_ph) = ideadstem_xf + this%matrix_phtransfer_receiver_patch(this%ideadstemxf_to_ideadstem_ph) = ideadstem + + this%ilivecroot_to_ideadcroot_ph = 10 + this%matrix_phtransfer_doner_patch(this%ilivecroot_to_ideadcroot_ph) = ilivecroot + this%matrix_phtransfer_receiver_patch(this%ilivecroot_to_ideadcroot_ph) = ideadcroot + + this%ilivecrootst_to_ilivecrootxf_ph = 11 + this%matrix_phtransfer_doner_patch(this%ilivecrootst_to_ilivecrootxf_ph) = ilivecroot_st + this%matrix_phtransfer_receiver_patch(this%ilivecrootst_to_ilivecrootxf_ph) = ilivecroot_xf + + this%ilivecrootxf_to_ilivecroot_ph = 12 + this%matrix_phtransfer_doner_patch(this%ilivecrootxf_to_ilivecroot_ph) = ilivecroot_xf + this%matrix_phtransfer_receiver_patch(this%ilivecrootxf_to_ilivecroot_ph) = ilivecroot + + this%ideadcrootst_to_ideadcrootxf_ph = 13 + this%matrix_phtransfer_doner_patch(this%ideadcrootst_to_ideadcrootxf_ph) = ideadcroot_st + this%matrix_phtransfer_receiver_patch(this%ideadcrootst_to_ideadcrootxf_ph) = ideadcroot_xf + + this%ideadcrootxf_to_ideadcroot_ph = 14 + this%matrix_phtransfer_doner_patch(this%ideadcrootxf_to_ideadcroot_ph) = ideadcroot_xf + this%matrix_phtransfer_receiver_patch(this%ideadcrootxf_to_ideadcroot_ph) = ideadcroot + + this%ileaf_to_iout_ph = 15 + this%matrix_phtransfer_doner_patch(this%ileaf_to_iout_ph) = ileaf + this%matrix_phtransfer_receiver_patch(this%ileaf_to_iout_ph) = ioutc + + this%ifroot_to_iout_ph = 16 + this%matrix_phtransfer_doner_patch(this%ifroot_to_iout_ph) = ifroot + this%matrix_phtransfer_receiver_patch(this%ifroot_to_iout_ph) = ioutc + + this%ilivestem_to_iout_ph = 17 + this%matrix_phtransfer_doner_patch(this%ilivestem_to_iout_ph) = ilivestem + this%matrix_phtransfer_receiver_patch(this%ilivestem_to_iout_ph) = ioutc + + if(use_crop)then + this%igrain_to_iout_ph = 18 + this%matrix_phtransfer_doner_patch(this%igrain_to_iout_ph) = igrain + this%matrix_phtransfer_receiver_patch(this%igrain_to_iout_ph) = ioutc + end if + + allocate(this%matrix_gmtransfer_doner_patch(1:18)) + allocate(this%matrix_gmtransfer_receiver_patch(1:18)) + + this%ileaf_to_iout_gm = 1 + this%matrix_gmtransfer_doner_patch(this%ileaf_to_iout_gm) = ileaf + this%matrix_gmtransfer_receiver_patch(this%ileaf_to_iout_gm) = ioutc + + this%ileafst_to_iout_gm = 2 + this%matrix_gmtransfer_doner_patch(this%ileafst_to_iout_gm) = ileaf_st + this%matrix_gmtransfer_receiver_patch(this%ileafst_to_iout_gm) = ioutc + + this%ileafxf_to_iout_gm = 3 + this%matrix_gmtransfer_doner_patch(this%ileafxf_to_iout_gm) = ileaf_xf + this%matrix_gmtransfer_receiver_patch(this%ileafxf_to_iout_gm) = ioutc + + this%ifroot_to_iout_gm = 4 + this%matrix_gmtransfer_doner_patch(this%ifroot_to_iout_gm) = ifroot + this%matrix_gmtransfer_receiver_patch(this%ifroot_to_iout_gm) = ioutc + + this%ifrootst_to_iout_gm = 5 + this%matrix_gmtransfer_doner_patch(this%ifrootst_to_iout_gm) = ifroot_st + this%matrix_gmtransfer_receiver_patch(this%ifrootst_to_iout_gm) = ioutc + + this%ifrootxf_to_iout_gm = 6 + this%matrix_gmtransfer_doner_patch(this%ifrootxf_to_iout_gm) = ifroot_xf + this%matrix_gmtransfer_receiver_patch(this%ifrootxf_to_iout_gm) = ioutc + + this%ilivestem_to_iout_gm = 7 + this%matrix_gmtransfer_doner_patch(this%ilivestem_to_iout_gm) = ilivestem + this%matrix_gmtransfer_receiver_patch(this%ilivestem_to_iout_gm) = ioutc + + this%ilivestemst_to_iout_gm = 8 + this%matrix_gmtransfer_doner_patch(this%ilivestemst_to_iout_gm) = ilivestem_st + this%matrix_gmtransfer_receiver_patch(this%ilivestemst_to_iout_gm) = ioutc + + this%ilivestemxf_to_iout_gm = 9 + this%matrix_gmtransfer_doner_patch(this%ilivestemxf_to_iout_gm) = ilivestem_xf + this%matrix_gmtransfer_receiver_patch(this%ilivestemxf_to_iout_gm) = ioutc + + this%ideadstem_to_iout_gm = 10 + this%matrix_gmtransfer_doner_patch(this%ideadstem_to_iout_gm) = ideadstem + this%matrix_gmtransfer_receiver_patch(this%ideadstem_to_iout_gm) = ioutc + + this%ideadstemst_to_iout_gm = 11 + this%matrix_gmtransfer_doner_patch(this%ideadstemst_to_iout_gm) = ideadstem_st + this%matrix_gmtransfer_receiver_patch(this%ideadstemst_to_iout_gm) = ioutc + + this%ideadstemxf_to_iout_gm = 12 + this%matrix_gmtransfer_doner_patch(this%ideadstemxf_to_iout_gm) = ideadstem_xf + this%matrix_gmtransfer_receiver_patch(this%ideadstemxf_to_iout_gm) = ioutc + + this%ilivecroot_to_iout_gm = 13 + this%matrix_gmtransfer_doner_patch(this%ilivecroot_to_iout_gm) = ilivecroot + this%matrix_gmtransfer_receiver_patch(this%ilivecroot_to_iout_gm) = ioutc + + this%ilivecrootst_to_iout_gm = 14 + this%matrix_gmtransfer_doner_patch(this%ilivecrootst_to_iout_gm) = ilivecroot_st + this%matrix_gmtransfer_receiver_patch(this%ilivecrootst_to_iout_gm) = ioutc + + this%ilivecrootxf_to_iout_gm = 15 + this%matrix_gmtransfer_doner_patch(this%ilivecrootxf_to_iout_gm) = ilivecroot_xf + this%matrix_gmtransfer_receiver_patch(this%ilivecrootxf_to_iout_gm) = ioutc + + this%ideadcroot_to_iout_gm = 16 + this%matrix_gmtransfer_doner_patch(this%ideadcroot_to_iout_gm) = ideadcroot + this%matrix_gmtransfer_receiver_patch(this%ideadcroot_to_iout_gm) = ioutc + + this%ideadcrootst_to_iout_gm = 17 + this%matrix_gmtransfer_doner_patch(this%ideadcrootst_to_iout_gm) = ideadcroot_st + this%matrix_gmtransfer_receiver_patch(this%ideadcrootst_to_iout_gm) = ioutc + + this%ideadcrootxf_to_iout_gm = 18 + this%matrix_gmtransfer_doner_patch(this%ideadcrootxf_to_iout_gm) = ideadcroot_xf + this%matrix_gmtransfer_receiver_patch(this%ideadcrootxf_to_iout_gm) = ioutc + + allocate(this%matrix_fitransfer_doner_patch(1:20)) + allocate(this%matrix_fitransfer_receiver_patch(1:20)) + + this%ilivestem_to_ideadstem_fi = 1 + this%matrix_fitransfer_doner_patch(this%ilivestem_to_ideadstem_fi) = ilivestem + this%matrix_fitransfer_receiver_patch(this%ilivestem_to_ideadstem_fi) = ideadstem + + this%ilivecroot_to_ideadcroot_fi = 2 + this%matrix_fitransfer_doner_patch(this%ilivecroot_to_ideadcroot_fi) = ilivecroot + this%matrix_fitransfer_receiver_patch(this%ilivecroot_to_ideadcroot_fi) = ideadcroot + + this%ileaf_to_iout_fi = 3 + this%matrix_fitransfer_doner_patch(this%ileaf_to_iout_fi) = ileaf + this%matrix_fitransfer_receiver_patch(this%ileaf_to_iout_fi) = ioutc + + this%ileafst_to_iout_fi = 4 + this%matrix_fitransfer_doner_patch(this%ileafst_to_iout_fi) = ileaf_st + this%matrix_fitransfer_receiver_patch(this%ileafst_to_iout_fi) = ioutc + + this%ileafxf_to_iout_fi = 5 + this%matrix_fitransfer_doner_patch(this%ileafxf_to_iout_fi) = ileaf_xf + this%matrix_fitransfer_receiver_patch(this%ileafxf_to_iout_fi) = ioutc + + this%ifroot_to_iout_fi = 6 + this%matrix_fitransfer_doner_patch(this%ifroot_to_iout_fi) = ifroot + this%matrix_fitransfer_receiver_patch(this%ifroot_to_iout_fi) = ioutc + + this%ifrootst_to_iout_fi = 7 + this%matrix_fitransfer_doner_patch(this%ifrootst_to_iout_fi) = ifroot_st + this%matrix_fitransfer_receiver_patch(this%ifrootst_to_iout_fi) = ioutc + + this%ifrootxf_to_iout_fi = 8 + this%matrix_fitransfer_doner_patch(this%ifrootxf_to_iout_fi) = ifroot_xf + this%matrix_fitransfer_receiver_patch(this%ifrootxf_to_iout_fi) = ioutc + + this%ilivestem_to_iout_fi = 9 + this%matrix_fitransfer_doner_patch(this%ilivestem_to_iout_fi) = ilivestem + this%matrix_fitransfer_receiver_patch(this%ilivestem_to_iout_fi) = ioutc + + this%ilivestemst_to_iout_fi = 10 + this%matrix_fitransfer_doner_patch(this%ilivestemst_to_iout_fi) = ilivestem_st + this%matrix_fitransfer_receiver_patch(this%ilivestemst_to_iout_fi) = ioutc + + this%ilivestemxf_to_iout_fi = 11 + this%matrix_fitransfer_doner_patch(this%ilivestemxf_to_iout_fi) = ilivestem_xf + this%matrix_fitransfer_receiver_patch(this%ilivestemxf_to_iout_fi) = ioutc + + this%ideadstem_to_iout_fi = 12 + this%matrix_fitransfer_doner_patch(this%ideadstem_to_iout_fi) = ideadstem + this%matrix_fitransfer_receiver_patch(this%ideadstem_to_iout_fi) = ioutc + + this%ideadstemst_to_iout_fi = 13 + this%matrix_fitransfer_doner_patch(this%ideadstemst_to_iout_fi) = ideadstem_st + this%matrix_fitransfer_receiver_patch(this%ideadstemst_to_iout_fi) = ioutc + + this%ideadstemxf_to_iout_fi = 14 + this%matrix_fitransfer_doner_patch(this%ideadstemxf_to_iout_fi) = ideadstem_xf + this%matrix_fitransfer_receiver_patch(this%ideadstemxf_to_iout_fi) = ioutc + + this%ilivecroot_to_iout_fi = 15 + this%matrix_fitransfer_doner_patch(this%ilivecroot_to_iout_fi) = ilivecroot + this%matrix_fitransfer_receiver_patch(this%ilivecroot_to_iout_fi) = ioutc + + this%ilivecrootst_to_iout_fi = 16 + this%matrix_fitransfer_doner_patch(this%ilivecrootst_to_iout_fi) = ilivecroot_st + this%matrix_fitransfer_receiver_patch(this%ilivecrootst_to_iout_fi) = ioutc + + this%ilivecrootxf_to_iout_fi = 17 + this%matrix_fitransfer_doner_patch(this%ilivecrootxf_to_iout_fi) = ilivecroot_xf + this%matrix_fitransfer_receiver_patch(this%ilivecrootxf_to_iout_fi) = ioutc + + this%ideadcroot_to_iout_fi = 18 + this%matrix_fitransfer_doner_patch(this%ideadcroot_to_iout_fi) = ideadcroot + this%matrix_fitransfer_receiver_patch(this%ideadcroot_to_iout_fi) = ioutc + + + this%ideadcrootst_to_iout_fi = 19 + this%matrix_fitransfer_doner_patch(this%ideadcrootst_to_iout_fi) = ideadcroot_st + this%matrix_fitransfer_receiver_patch(this%ideadcrootst_to_iout_fi) = ioutc + + this%ideadcrootxf_to_iout_fi = 20 + this%matrix_fitransfer_doner_patch(this%ideadcrootxf_to_iout_fi) = ideadcroot_xf + this%matrix_fitransfer_receiver_patch(this%ideadcrootxf_to_iout_fi) = ioutc + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + + allocate(this%m_leafc_to_litter_patch (begp:endp)) ; this%m_leafc_to_litter_patch (:) = nan + allocate(this%m_frootc_to_litter_patch (begp:endp)) ; this%m_frootc_to_litter_patch (:) = nan + allocate(this%m_leafc_storage_to_litter_patch (begp:endp)) ; this%m_leafc_storage_to_litter_patch (:) = nan + allocate(this%m_frootc_storage_to_litter_patch (begp:endp)) ; this%m_frootc_storage_to_litter_patch (:) = nan + allocate(this%m_livestemc_storage_to_litter_patch (begp:endp)) ; this%m_livestemc_storage_to_litter_patch (:) = nan + allocate(this%m_deadstemc_storage_to_litter_patch (begp:endp)) ; this%m_deadstemc_storage_to_litter_patch (:) = nan + allocate(this%m_livecrootc_storage_to_litter_patch (begp:endp)) ; this%m_livecrootc_storage_to_litter_patch (:) = nan + allocate(this%m_deadcrootc_storage_to_litter_patch (begp:endp)) ; this%m_deadcrootc_storage_to_litter_patch (:) = nan + allocate(this%m_leafc_xfer_to_litter_patch (begp:endp)) ; this%m_leafc_xfer_to_litter_patch (:) = nan + allocate(this%m_frootc_xfer_to_litter_patch (begp:endp)) ; this%m_frootc_xfer_to_litter_patch (:) = nan + allocate(this%m_livestemc_xfer_to_litter_patch (begp:endp)) ; this%m_livestemc_xfer_to_litter_patch (:) = nan + allocate(this%m_deadstemc_xfer_to_litter_patch (begp:endp)) ; this%m_deadstemc_xfer_to_litter_patch (:) = nan + allocate(this%m_livecrootc_xfer_to_litter_patch (begp:endp)) ; this%m_livecrootc_xfer_to_litter_patch (:) = nan + allocate(this%m_deadcrootc_xfer_to_litter_patch (begp:endp)) ; this%m_deadcrootc_xfer_to_litter_patch (:) = nan + allocate(this%m_livestemc_to_litter_patch (begp:endp)) ; this%m_livestemc_to_litter_patch (:) = nan + allocate(this%m_deadstemc_to_litter_patch (begp:endp)) ; this%m_deadstemc_to_litter_patch (:) = nan + allocate(this%m_livecrootc_to_litter_patch (begp:endp)) ; this%m_livecrootc_to_litter_patch (:) = nan + allocate(this%m_deadcrootc_to_litter_patch (begp:endp)) ; this%m_deadcrootc_to_litter_patch (:) = nan + allocate(this%m_gresp_storage_to_litter_patch (begp:endp)) ; this%m_gresp_storage_to_litter_patch (:) = nan + allocate(this%m_gresp_xfer_to_litter_patch (begp:endp)) ; this%m_gresp_xfer_to_litter_patch (:) = nan + allocate(this%hrv_leafc_to_litter_patch (begp:endp)) ; this%hrv_leafc_to_litter_patch (:) = nan + allocate(this%hrv_leafc_storage_to_litter_patch (begp:endp)) ; this%hrv_leafc_storage_to_litter_patch (:) = nan + allocate(this%hrv_leafc_xfer_to_litter_patch (begp:endp)) ; this%hrv_leafc_xfer_to_litter_patch (:) = nan + allocate(this%hrv_frootc_to_litter_patch (begp:endp)) ; this%hrv_frootc_to_litter_patch (:) = nan + allocate(this%hrv_frootc_storage_to_litter_patch (begp:endp)) ; this%hrv_frootc_storage_to_litter_patch (:) = nan + allocate(this%hrv_frootc_xfer_to_litter_patch (begp:endp)) ; this%hrv_frootc_xfer_to_litter_patch (:) = nan + allocate(this%hrv_livestemc_to_litter_patch (begp:endp)) ; this%hrv_livestemc_to_litter_patch (:) = nan + allocate(this%hrv_livestemc_storage_to_litter_patch (begp:endp)) ; this%hrv_livestemc_storage_to_litter_patch (:) = nan + allocate(this%hrv_livestemc_xfer_to_litter_patch (begp:endp)) ; this%hrv_livestemc_xfer_to_litter_patch (:) = nan + allocate(this%hrv_deadstemc_storage_to_litter_patch (begp:endp)) ; this%hrv_deadstemc_storage_to_litter_patch (:) = nan + allocate(this%hrv_deadstemc_xfer_to_litter_patch (begp:endp)) ; this%hrv_deadstemc_xfer_to_litter_patch (:) = nan + allocate(this%hrv_livecrootc_to_litter_patch (begp:endp)) ; this%hrv_livecrootc_to_litter_patch (:) = nan + allocate(this%hrv_livecrootc_storage_to_litter_patch (begp:endp)) ; this%hrv_livecrootc_storage_to_litter_patch (:) = nan + allocate(this%hrv_livecrootc_xfer_to_litter_patch (begp:endp)) ; this%hrv_livecrootc_xfer_to_litter_patch (:) = nan + allocate(this%hrv_deadcrootc_to_litter_patch (begp:endp)) ; this%hrv_deadcrootc_to_litter_patch (:) = nan + allocate(this%hrv_deadcrootc_storage_to_litter_patch (begp:endp)) ; this%hrv_deadcrootc_storage_to_litter_patch (:) = nan + allocate(this%hrv_deadcrootc_xfer_to_litter_patch (begp:endp)) ; this%hrv_deadcrootc_xfer_to_litter_patch (:) = nan + allocate(this%hrv_gresp_storage_to_litter_patch (begp:endp)) ; this%hrv_gresp_storage_to_litter_patch (:) = nan + allocate(this%hrv_gresp_xfer_to_litter_patch (begp:endp)) ; this%hrv_gresp_xfer_to_litter_patch (:) = nan + allocate(this%hrv_xsmrpool_to_atm_patch (begp:endp)) ; this%hrv_xsmrpool_to_atm_patch (:) = 0.0_r8 + allocate(this%m_leafc_to_fire_patch (begp:endp)) ; this%m_leafc_to_fire_patch (:) = nan + allocate(this%m_leafc_storage_to_fire_patch (begp:endp)) ; this%m_leafc_storage_to_fire_patch (:) = nan + allocate(this%m_leafc_xfer_to_fire_patch (begp:endp)) ; this%m_leafc_xfer_to_fire_patch (:) = nan + allocate(this%m_livestemc_to_fire_patch (begp:endp)) ; this%m_livestemc_to_fire_patch (:) = nan + allocate(this%m_livestemc_storage_to_fire_patch (begp:endp)) ; this%m_livestemc_storage_to_fire_patch (:) = nan + allocate(this%m_livestemc_xfer_to_fire_patch (begp:endp)) ; this%m_livestemc_xfer_to_fire_patch (:) = nan + allocate(this%m_deadstemc_to_fire_patch (begp:endp)) ; this%m_deadstemc_to_fire_patch (:) = nan + allocate(this%m_deadstemc_storage_to_fire_patch (begp:endp)) ; this%m_deadstemc_storage_to_fire_patch (:) = nan + allocate(this%m_deadstemc_xfer_to_fire_patch (begp:endp)) ; this%m_deadstemc_xfer_to_fire_patch (:) = nan + allocate(this%m_frootc_to_fire_patch (begp:endp)) ; this%m_frootc_to_fire_patch (:) = nan + allocate(this%m_frootc_storage_to_fire_patch (begp:endp)) ; this%m_frootc_storage_to_fire_patch (:) = nan + allocate(this%m_frootc_xfer_to_fire_patch (begp:endp)) ; this%m_frootc_xfer_to_fire_patch (:) = nan + allocate(this%m_livecrootc_to_fire_patch (begp:endp)) ; this%m_livecrootc_to_fire_patch (:) = nan + allocate(this%m_livecrootc_storage_to_fire_patch (begp:endp)) ; this%m_livecrootc_storage_to_fire_patch (:) = nan + allocate(this%m_livecrootc_xfer_to_fire_patch (begp:endp)) ; this%m_livecrootc_xfer_to_fire_patch (:) = nan + allocate(this%m_deadcrootc_to_fire_patch (begp:endp)) ; this%m_deadcrootc_to_fire_patch (:) = nan + allocate(this%m_deadcrootc_storage_to_fire_patch (begp:endp)) ; this%m_deadcrootc_storage_to_fire_patch (:) = nan + allocate(this%m_deadcrootc_xfer_to_fire_patch (begp:endp)) ; this%m_deadcrootc_xfer_to_fire_patch (:) = nan + allocate(this%m_gresp_storage_to_fire_patch (begp:endp)) ; this%m_gresp_storage_to_fire_patch (:) = nan + allocate(this%m_gresp_xfer_to_fire_patch (begp:endp)) ; this%m_gresp_xfer_to_fire_patch (:) = nan + allocate(this%m_leafc_to_litter_fire_patch (begp:endp)) ; this%m_leafc_to_litter_fire_patch (:) = nan + allocate(this%m_leafc_storage_to_litter_fire_patch (begp:endp)) ; this%m_leafc_storage_to_litter_fire_patch (:) = nan + allocate(this%m_leafc_xfer_to_litter_fire_patch (begp:endp)) ; this%m_leafc_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_livestemc_to_litter_fire_patch (begp:endp)) ; this%m_livestemc_to_litter_fire_patch (:) = nan + allocate(this%m_livestemc_storage_to_litter_fire_patch (begp:endp)) ; this%m_livestemc_storage_to_litter_fire_patch (:) = nan + allocate(this%m_livestemc_xfer_to_litter_fire_patch (begp:endp)) ; this%m_livestemc_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_livestemc_to_deadstemc_fire_patch (begp:endp)) ; this%m_livestemc_to_deadstemc_fire_patch (:) = nan + allocate(this%m_deadstemc_to_litter_fire_patch (begp:endp)) ; this%m_deadstemc_to_litter_fire_patch (:) = nan + allocate(this%m_deadstemc_storage_to_litter_fire_patch (begp:endp)) ; this%m_deadstemc_storage_to_litter_fire_patch (:) = nan + allocate(this%m_deadstemc_xfer_to_litter_fire_patch (begp:endp)) ; this%m_deadstemc_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_frootc_to_litter_fire_patch (begp:endp)) ; this%m_frootc_to_litter_fire_patch (:) = nan + allocate(this%m_frootc_storage_to_litter_fire_patch (begp:endp)) ; this%m_frootc_storage_to_litter_fire_patch (:) = nan + allocate(this%m_frootc_xfer_to_litter_fire_patch (begp:endp)) ; this%m_frootc_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_livecrootc_to_litter_fire_patch (begp:endp)) ; this%m_livecrootc_to_litter_fire_patch (:) = nan + allocate(this%m_livecrootc_storage_to_litter_fire_patch (begp:endp)) ; this%m_livecrootc_storage_to_litter_fire_patch (:) = nan + allocate(this%m_livecrootc_xfer_to_litter_fire_patch (begp:endp)) ; this%m_livecrootc_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_livecrootc_to_deadcrootc_fire_patch (begp:endp)) ; this%m_livecrootc_to_deadcrootc_fire_patch (:) = nan + allocate(this%m_deadcrootc_to_litter_fire_patch (begp:endp)) ; this%m_deadcrootc_to_litter_fire_patch (:) = nan + allocate(this%m_deadcrootc_storage_to_litter_fire_patch (begp:endp)) ; this%m_deadcrootc_storage_to_litter_fire_patch (:) = nan + allocate(this%m_deadcrootc_xfer_to_litter_fire_patch (begp:endp)) ; this%m_deadcrootc_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_gresp_storage_to_litter_fire_patch (begp:endp)) ; this%m_gresp_storage_to_litter_fire_patch (:) = nan + allocate(this%m_gresp_xfer_to_litter_fire_patch (begp:endp)) ; this%m_gresp_xfer_to_litter_fire_patch (:) = nan + allocate(this%leafc_xfer_to_leafc_patch (begp:endp)) ; this%leafc_xfer_to_leafc_patch (:) = nan + allocate(this%frootc_xfer_to_frootc_patch (begp:endp)) ; this%frootc_xfer_to_frootc_patch (:) = nan + allocate(this%livestemc_xfer_to_livestemc_patch (begp:endp)) ; this%livestemc_xfer_to_livestemc_patch (:) = nan + allocate(this%deadstemc_xfer_to_deadstemc_patch (begp:endp)) ; this%deadstemc_xfer_to_deadstemc_patch (:) = nan + allocate(this%livecrootc_xfer_to_livecrootc_patch (begp:endp)) ; this%livecrootc_xfer_to_livecrootc_patch (:) = nan + allocate(this%deadcrootc_xfer_to_deadcrootc_patch (begp:endp)) ; this%deadcrootc_xfer_to_deadcrootc_patch (:) = nan + allocate(this%leafc_to_litter_patch (begp:endp)) ; this%leafc_to_litter_patch (:) = nan + allocate(this%leafc_to_litter_fun_patch (begp:endp)) ; this%leafc_to_litter_fun_patch (:) = nan + allocate(this%frootc_to_litter_patch (begp:endp)) ; this%frootc_to_litter_patch (:) = nan + allocate(this%cpool_to_resp_patch (begp:endp)) ; this%cpool_to_resp_patch (:) = nan + allocate(this%cpool_to_leafc_resp_patch (begp:endp)) ; this%cpool_to_leafc_resp_patch (:) = nan + allocate(this%cpool_to_leafc_storage_resp_patch (begp:endp)) ; this%cpool_to_leafc_storage_resp_patch (:) = nan + allocate(this%cpool_to_frootc_resp_patch (begp:endp)) ; this%cpool_to_frootc_resp_patch (:) = nan + allocate(this%cpool_to_frootc_storage_resp_patch (begp:endp)) ; this%cpool_to_frootc_storage_resp_patch (:) = nan + allocate(this%cpool_to_livecrootc_resp_patch (begp:endp)) ; this%cpool_to_livecrootc_resp_patch (:) = nan + allocate(this%cpool_to_livecrootc_storage_resp_patch (begp:endp)) ; this%cpool_to_livecrootc_storage_resp_patch (:) = nan + allocate(this%cpool_to_livestemc_resp_patch (begp:endp)) ; this%cpool_to_livestemc_resp_patch (:) = nan + allocate(this%cpool_to_livestemc_storage_resp_patch (begp:endp)) ; this%cpool_to_livestemc_storage_resp_patch (:) = nan + allocate(this%leaf_mr_patch (begp:endp)) ; this%leaf_mr_patch (:) = nan + allocate(this%froot_mr_patch (begp:endp)) ; this%froot_mr_patch (:) = nan + allocate(this%livestem_mr_patch (begp:endp)) ; this%livestem_mr_patch (:) = nan + allocate(this%livecroot_mr_patch (begp:endp)) ; this%livecroot_mr_patch (:) = nan + allocate(this%grain_mr_patch (begp:endp)) ; this%grain_mr_patch (:) = nan + allocate(this%leaf_curmr_patch (begp:endp)) ; this%leaf_curmr_patch (:) = nan + allocate(this%froot_curmr_patch (begp:endp)) ; this%froot_curmr_patch (:) = nan + allocate(this%livestem_curmr_patch (begp:endp)) ; this%livestem_curmr_patch (:) = nan + allocate(this%livecroot_curmr_patch (begp:endp)) ; this%livecroot_curmr_patch (:) = nan + allocate(this%grain_curmr_patch (begp:endp)) ; this%grain_curmr_patch (:) = nan + allocate(this%leaf_xsmr_patch (begp:endp)) ; this%leaf_xsmr_patch (:) = nan + allocate(this%froot_xsmr_patch (begp:endp)) ; this%froot_xsmr_patch (:) = nan + allocate(this%livestem_xsmr_patch (begp:endp)) ; this%livestem_xsmr_patch (:) = nan + allocate(this%livecroot_xsmr_patch (begp:endp)) ; this%livecroot_xsmr_patch (:) = nan + allocate(this%grain_xsmr_patch (begp:endp)) ; this%grain_xsmr_patch (:) = nan + allocate(this%psnsun_to_cpool_patch (begp:endp)) ; this%psnsun_to_cpool_patch (:) = nan + allocate(this%psnshade_to_cpool_patch (begp:endp)) ; this%psnshade_to_cpool_patch (:) = nan + allocate(this%cpool_to_xsmrpool_patch (begp:endp)) ; this%cpool_to_xsmrpool_patch (:) = nan + allocate(this%cpool_to_leafc_patch (begp:endp)) ; this%cpool_to_leafc_patch (:) = nan + allocate(this%cpool_to_leafc_storage_patch (begp:endp)) ; this%cpool_to_leafc_storage_patch (:) = nan + allocate(this%cpool_to_frootc_patch (begp:endp)) ; this%cpool_to_frootc_patch (:) = nan + allocate(this%cpool_to_frootc_storage_patch (begp:endp)) ; this%cpool_to_frootc_storage_patch (:) = nan + allocate(this%cpool_to_livestemc_patch (begp:endp)) ; this%cpool_to_livestemc_patch (:) = nan + allocate(this%cpool_to_livestemc_storage_patch (begp:endp)) ; this%cpool_to_livestemc_storage_patch (:) = nan + allocate(this%cpool_to_deadstemc_patch (begp:endp)) ; this%cpool_to_deadstemc_patch (:) = nan + allocate(this%cpool_to_deadstemc_storage_patch (begp:endp)) ; this%cpool_to_deadstemc_storage_patch (:) = nan + allocate(this%cpool_to_livecrootc_patch (begp:endp)) ; this%cpool_to_livecrootc_patch (:) = nan + allocate(this%cpool_to_livecrootc_storage_patch (begp:endp)) ; this%cpool_to_livecrootc_storage_patch (:) = nan + allocate(this%cpool_to_deadcrootc_patch (begp:endp)) ; this%cpool_to_deadcrootc_patch (:) = nan + allocate(this%cpool_to_deadcrootc_storage_patch (begp:endp)) ; this%cpool_to_deadcrootc_storage_patch (:) = nan + allocate(this%cpool_to_gresp_storage_patch (begp:endp)) ; this%cpool_to_gresp_storage_patch (:) = nan + allocate(this%cpool_leaf_gr_patch (begp:endp)) ; this%cpool_leaf_gr_patch (:) = nan + allocate(this%cpool_leaf_storage_gr_patch (begp:endp)) ; this%cpool_leaf_storage_gr_patch (:) = nan + allocate(this%transfer_leaf_gr_patch (begp:endp)) ; this%transfer_leaf_gr_patch (:) = nan + allocate(this%cpool_froot_gr_patch (begp:endp)) ; this%cpool_froot_gr_patch (:) = nan + allocate(this%cpool_froot_storage_gr_patch (begp:endp)) ; this%cpool_froot_storage_gr_patch (:) = nan + allocate(this%transfer_froot_gr_patch (begp:endp)) ; this%transfer_froot_gr_patch (:) = nan + allocate(this%cpool_livestem_gr_patch (begp:endp)) ; this%cpool_livestem_gr_patch (:) = nan + allocate(this%cpool_livestem_storage_gr_patch (begp:endp)) ; this%cpool_livestem_storage_gr_patch (:) = nan + allocate(this%transfer_livestem_gr_patch (begp:endp)) ; this%transfer_livestem_gr_patch (:) = nan + allocate(this%cpool_deadstem_gr_patch (begp:endp)) ; this%cpool_deadstem_gr_patch (:) = nan + allocate(this%cpool_deadstem_storage_gr_patch (begp:endp)) ; this%cpool_deadstem_storage_gr_patch (:) = nan + allocate(this%transfer_deadstem_gr_patch (begp:endp)) ; this%transfer_deadstem_gr_patch (:) = nan + allocate(this%cpool_livecroot_gr_patch (begp:endp)) ; this%cpool_livecroot_gr_patch (:) = nan + allocate(this%cpool_livecroot_storage_gr_patch (begp:endp)) ; this%cpool_livecroot_storage_gr_patch (:) = nan + allocate(this%transfer_livecroot_gr_patch (begp:endp)) ; this%transfer_livecroot_gr_patch (:) = nan + allocate(this%cpool_deadcroot_gr_patch (begp:endp)) ; this%cpool_deadcroot_gr_patch (:) = nan + allocate(this%cpool_deadcroot_storage_gr_patch (begp:endp)) ; this%cpool_deadcroot_storage_gr_patch (:) = nan + allocate(this%transfer_deadcroot_gr_patch (begp:endp)) ; this%transfer_deadcroot_gr_patch (:) = nan + allocate(this%leafc_storage_to_xfer_patch (begp:endp)) ; this%leafc_storage_to_xfer_patch (:) = nan + allocate(this%frootc_storage_to_xfer_patch (begp:endp)) ; this%frootc_storage_to_xfer_patch (:) = nan + allocate(this%livestemc_storage_to_xfer_patch (begp:endp)) ; this%livestemc_storage_to_xfer_patch (:) = nan + allocate(this%deadstemc_storage_to_xfer_patch (begp:endp)) ; this%deadstemc_storage_to_xfer_patch (:) = nan + allocate(this%livecrootc_storage_to_xfer_patch (begp:endp)) ; this%livecrootc_storage_to_xfer_patch (:) = nan + allocate(this%deadcrootc_storage_to_xfer_patch (begp:endp)) ; this%deadcrootc_storage_to_xfer_patch (:) = nan + allocate(this%gresp_storage_to_xfer_patch (begp:endp)) ; this%gresp_storage_to_xfer_patch (:) = nan + allocate(this%livestemc_to_deadstemc_patch (begp:endp)) ; this%livestemc_to_deadstemc_patch (:) = nan + allocate(this%livecrootc_to_deadcrootc_patch (begp:endp)) ; this%livecrootc_to_deadcrootc_patch (:) = nan + allocate(this%current_gr_patch (begp:endp)) ; this%current_gr_patch (:) = nan + allocate(this%transfer_gr_patch (begp:endp)) ; this%transfer_gr_patch (:) = nan + allocate(this%storage_gr_patch (begp:endp)) ; this%storage_gr_patch (:) = nan + allocate(this%plant_calloc_patch (begp:endp)) ; this%plant_calloc_patch (:) = nan + allocate(this%excess_cflux_patch (begp:endp)) ; this%excess_cflux_patch (:) = nan + allocate(this%prev_leafc_to_litter_patch (begp:endp)) ; this%prev_leafc_to_litter_patch (:) = nan + allocate(this%prev_frootc_to_litter_patch (begp:endp)) ; this%prev_frootc_to_litter_patch (:) = nan + allocate(this%gpp_before_downreg_patch (begp:endp)) ; this%gpp_before_downreg_patch (:) = nan + allocate(this%availc_patch (begp:endp)) ; this%availc_patch (:) = nan + allocate(this%xsmrpool_recover_patch (begp:endp)) ; this%xsmrpool_recover_patch (:) = nan + allocate(this%xsmrpool_c13ratio_patch (begp:endp)) ; this%xsmrpool_c13ratio_patch (:) = nan + + allocate(this%cpool_to_grainc_patch (begp:endp)) ; this%cpool_to_grainc_patch (:) = nan + allocate(this%cpool_to_grainc_storage_patch (begp:endp)) ; this%cpool_to_grainc_storage_patch (:) = nan + allocate(this%livestemc_to_litter_patch (begp:endp)) ; this%livestemc_to_litter_patch (:) = nan + allocate(this%grainc_to_food_patch (begp:endp)) ; this%grainc_to_food_patch (:) = nan + allocate(this%leafc_to_biofuelc_patch (begp:endp)) ; this%leafc_to_biofuelc_patch (:) = nan + allocate(this%livestemc_to_biofuelc_patch (begp:endp)) ; this%livestemc_to_biofuelc_patch (:) = nan + allocate(this%grainc_to_seed_patch (begp:endp)) ; this%grainc_to_seed_patch (:) = nan + allocate(this%grainc_xfer_to_grainc_patch (begp:endp)) ; this%grainc_xfer_to_grainc_patch (:) = nan + allocate(this%cpool_grain_gr_patch (begp:endp)) ; this%cpool_grain_gr_patch (:) = nan + allocate(this%cpool_grain_storage_gr_patch (begp:endp)) ; this%cpool_grain_storage_gr_patch (:) = nan + allocate(this%transfer_grain_gr_patch (begp:endp)) ; this%transfer_grain_gr_patch (:) = nan + allocate(this%xsmrpool_to_atm_patch (begp:endp)) ; this%xsmrpool_to_atm_patch (:) = 0.0_r8 + allocate(this%xsmrpool_to_atm_col (begc:endc)) ; this%xsmrpool_to_atm_col (:) = 0.0_r8 + allocate(this%xsmrpool_to_atm_grc (begg:endg)) ; this%xsmrpool_to_atm_grc (:) = 0.0_r8 + allocate(this%grainc_storage_to_xfer_patch (begp:endp)) ; this%grainc_storage_to_xfer_patch (:) = nan + allocate(this%frootc_alloc_patch (begp:endp)) ; this%frootc_alloc_patch (:) = nan + allocate(this%frootc_loss_patch (begp:endp)) ; this%frootc_loss_patch (:) = nan + allocate(this%leafc_alloc_patch (begp:endp)) ; this%leafc_alloc_patch (:) = nan + allocate(this%leafc_loss_patch (begp:endp)) ; this%leafc_loss_patch (:) = nan + allocate(this%woodc_alloc_patch (begp:endp)) ; this%woodc_alloc_patch (:) = nan + allocate(this%woodc_loss_patch (begp:endp)) ; this%woodc_loss_patch (:) = nan + + allocate(this%phenology_c_to_litr_met_c_col (begc:endc,1:nlevdecomp_full)); + this%phenology_c_to_litr_met_c_col (:,:)=nan + + allocate(this%phenology_c_to_litr_cel_c_col (begc:endc,1:nlevdecomp_full)); this%phenology_c_to_litr_cel_c_col (:,:)=nan + allocate(this%phenology_c_to_litr_lig_c_col (begc:endc,1:nlevdecomp_full)); this%phenology_c_to_litr_lig_c_col (:,:)=nan + + allocate(this%gap_mortality_c_to_litr_met_c_col (begc:endc,1:nlevdecomp_full)); this%gap_mortality_c_to_litr_met_c_col(:,:)=nan + allocate(this%gap_mortality_c_to_litr_cel_c_col (begc:endc,1:nlevdecomp_full)); this%gap_mortality_c_to_litr_cel_c_col(:,:)=nan + allocate(this%gap_mortality_c_to_litr_lig_c_col (begc:endc,1:nlevdecomp_full)); this%gap_mortality_c_to_litr_lig_c_col(:,:)=nan + + allocate(this%gap_mortality_c_to_cwdc_col (begc:endc,1:nlevdecomp_full)); this%gap_mortality_c_to_cwdc_col (:,:)=nan + allocate(this%fire_mortality_c_to_cwdc_col (begc:endc,1:nlevdecomp_full)); this%fire_mortality_c_to_cwdc_col (:,:)=nan + allocate(this%m_c_to_litr_met_fire_col (begc:endc,1:nlevdecomp_full)); this%m_c_to_litr_met_fire_col (:,:)=nan + allocate(this%m_c_to_litr_cel_fire_col (begc:endc,1:nlevdecomp_full)); this%m_c_to_litr_cel_fire_col (:,:)=nan + allocate(this%m_c_to_litr_lig_fire_col (begc:endc,1:nlevdecomp_full)); this%m_c_to_litr_lig_fire_col (:,:)=nan + allocate(this%harvest_c_to_litr_met_c_col (begc:endc,1:nlevdecomp_full)); this%harvest_c_to_litr_met_c_col (:,:)=nan + allocate(this%harvest_c_to_litr_cel_c_col (begc:endc,1:nlevdecomp_full)); this%harvest_c_to_litr_cel_c_col (:,:)=nan + allocate(this%harvest_c_to_litr_lig_c_col (begc:endc,1:nlevdecomp_full)); this%harvest_c_to_litr_lig_c_col (:,:)=nan + allocate(this%harvest_c_to_cwdc_col (begc:endc,1:nlevdecomp_full)); this%harvest_c_to_cwdc_col (:,:)=nan + + allocate(this%dwt_slash_cflux_patch (begp:endp)) ; this%dwt_slash_cflux_patch (:) =nan + allocate(this%dwt_slash_cflux_grc (begg:endg)) ; this%dwt_slash_cflux_grc (:) =nan + allocate(this%dwt_frootc_to_litr_met_c_col (begc:endc,1:nlevdecomp_full)); this%dwt_frootc_to_litr_met_c_col (:,:)=nan + allocate(this%dwt_frootc_to_litr_cel_c_col (begc:endc,1:nlevdecomp_full)); this%dwt_frootc_to_litr_cel_c_col (:,:)=nan + allocate(this%dwt_frootc_to_litr_lig_c_col (begc:endc,1:nlevdecomp_full)); this%dwt_frootc_to_litr_lig_c_col (:,:)=nan + allocate(this%dwt_livecrootc_to_cwdc_col (begc:endc,1:nlevdecomp_full)); this%dwt_livecrootc_to_cwdc_col (:,:)=nan + allocate(this%dwt_deadcrootc_to_cwdc_col (begc:endc,1:nlevdecomp_full)); this%dwt_deadcrootc_to_cwdc_col (:,:)=nan + + allocate(this%dwt_seedc_to_leaf_patch (begp:endp)) ; this%dwt_seedc_to_leaf_patch (:) =nan + allocate(this%dwt_seedc_to_leaf_grc (begg:endg)) ; this%dwt_seedc_to_leaf_grc (:) =nan + allocate(this%dwt_seedc_to_deadstem_patch (begp:endp)) ; this%dwt_seedc_to_deadstem_patch(:) =nan + allocate(this%dwt_seedc_to_deadstem_grc (begg:endg)) ; this%dwt_seedc_to_deadstem_grc (:) =nan + allocate(this%dwt_conv_cflux_patch (begp:endp)) ; this%dwt_conv_cflux_patch (:) =nan + allocate(this%dwt_conv_cflux_grc (begg:endg)) ; this%dwt_conv_cflux_grc (:) =nan + allocate(this%dwt_conv_cflux_dribbled_grc (begg:endg)) ; this%dwt_conv_cflux_dribbled_grc(:) =nan + allocate(this%dwt_wood_productc_gain_patch (begp:endp)) ; this%dwt_wood_productc_gain_patch(:) =nan + allocate(this%dwt_crop_productc_gain_patch (begp:endp)) ; this%dwt_crop_productc_gain_patch(:) =nan + + allocate(this%crop_seedc_to_leaf_patch (begp:endp)) ; this%crop_seedc_to_leaf_patch (:) =nan + + allocate(this%cwdc_hr_col (begc:endc)) ; this%cwdc_hr_col (:) =nan + allocate(this%cwdc_loss_col (begc:endc)) ; this%cwdc_loss_col (:) =nan + allocate(this%litterc_loss_col (begc:endc)) ; this%litterc_loss_col (:) =nan + + allocate(this%grainc_to_cropprodc_patch(begp:endp)) + this%grainc_to_cropprodc_patch(:) = spval + + allocate(this%grainc_to_cropprodc_col(begc:endc)) + this%grainc_to_cropprodc_col(:) = nan + + allocate(this%m_decomp_cpools_to_fire_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%m_decomp_cpools_to_fire_vr_col(:,:,:)= nan + + allocate(this%m_decomp_cpools_to_fire_col(begc:endc,1:ndecomp_pools)) + this%m_decomp_cpools_to_fire_col(:,:)= nan + + allocate(this%m_decomp_cpools_to_fire_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%m_decomp_cpools_to_fire_vr_col(:,:,:)= nan + + allocate(this%m_decomp_cpools_to_fire_col(begc:endc,1:ndecomp_pools)) + this%m_decomp_cpools_to_fire_col(:,:)= nan + + allocate(this%rr_patch (begp:endp)) ; this%rr_patch (:) = spval + allocate(this%mr_patch (begp:endp)) ; this%mr_patch (:) = nan + allocate(this%gr_patch (begp:endp)) ; this%gr_patch (:) = nan + allocate(this%ar_patch (begp:endp)) ; this%ar_patch (:) = spval + allocate(this%npp_patch (begp:endp)) ; this%npp_patch (:) = spval + allocate(this%agnpp_patch (begp:endp)) ; this%agnpp_patch (:) = nan + allocate(this%bgnpp_patch (begp:endp)) ; this%bgnpp_patch (:) = nan + allocate(this%litfall_patch (begp:endp)) ; this%litfall_patch (:) = nan + allocate(this%wood_harvestc_patch (begp:endp)) ; this%wood_harvestc_patch (:) = nan + allocate(this%slash_harvestc_patch (begp:endp)) ; this%slash_harvestc_patch (:) = nan + allocate(this%cinputs_patch (begp:endp)) ; this%cinputs_patch (:) = nan + allocate(this%coutputs_patch (begp:endp)) ; this%coutputs_patch (:) = nan + allocate(this%gpp_patch (begp:endp)) ; this%gpp_patch (:) = spval + allocate(this%fire_closs_patch (begp:endp)) ; this%fire_closs_patch (:) = spval + allocate(this%sr_col (begc:endc)) ; this%sr_col (:) = nan + allocate(this%er_col (begc:endc)) ; this%er_col (:) = nan + allocate(this%litfire_col (begc:endc)) ; this%litfire_col (:) = nan + allocate(this%somfire_col (begc:endc)) ; this%somfire_col (:) = nan + allocate(this%totfire_col (begc:endc)) ; this%totfire_col (:) = nan + allocate(this%rr_col (begc:endc)) ; this%rr_col (:) = nan + allocate(this%ar_col (begc:endc)) ; this%ar_col (:) = nan + allocate(this%gpp_col (begc:endc)) ; this%gpp_col (:) = nan + allocate(this%npp_col (begc:endc)) ; this%npp_col (:) = nan + allocate(this%fire_closs_p2c_col (begc:endc)) ; this%fire_closs_p2c_col (:) = nan + allocate(this%fire_closs_col (begc:endc)) ; this%fire_closs_col (:) = spval + allocate(this%wood_harvestc_col (begc:endc)) ; this%wood_harvestc_col (:) = nan + allocate(this%hrv_xsmrpool_to_atm_col (begc:endc)) ; this%hrv_xsmrpool_to_atm_col (:) = 0.0_r8 + allocate(this%tempsum_npp_patch (begp:endp)) ; this%tempsum_npp_patch (:) = nan + allocate(this%annsum_npp_patch (begp:endp)) ; this%annsum_npp_patch (:) = spval + allocate(this%tempsum_litfall_patch (begp:endp)) ; this%tempsum_litfall_patch (:) = nan + allocate(this%annsum_litfall_patch (begp:endp)) ; this%annsum_litfall_patch (:) = nan + allocate(this%annsum_npp_col (begc:endc)) ; this%annsum_npp_col (:) = nan + allocate(this%lag_npp_col (begc:endc)) ; this%lag_npp_col (:) = spval + + + allocate(this%nep_col (begc:endc)) ; this%nep_col (:) = spval + allocate(this%nbp_grc (begg:endg)) ; this%nbp_grc (:) = nan + allocate(this%nee_grc (begg:endg)) ; this%nee_grc (:) = nan + allocate(this%landuseflux_grc (begg:endg)) ; this%landuseflux_grc (:) = nan + allocate(this%npp_Nactive_patch (begp:endp)) ; this%npp_Nactive_patch (:) = nan + allocate(this%npp_burnedoff_patch (begp:endp)) ; this%npp_burnedoff_patch (:) = nan + allocate(this%npp_Nnonmyc_patch (begp:endp)) ; this%npp_Nnonmyc_patch (:) = nan + allocate(this%npp_Nam_patch (begp:endp)) ; this%npp_Nam_patch (:) = nan + allocate(this%npp_Necm_patch (begp:endp)) ; this%npp_Necm_patch (:) = nan + allocate(this%npp_Nactive_no3_patch (begp:endp)) ; this%npp_Nactive_no3_patch (:) = nan + allocate(this%npp_Nactive_nh4_patch (begp:endp)) ; this%npp_Nactive_nh4_patch (:) = nan + allocate(this%npp_Nnonmyc_no3_patch (begp:endp)) ; this%npp_Nnonmyc_no3_patch (:) = nan + allocate(this%npp_Nnonmyc_nh4_patch (begp:endp)) ; this%npp_Nnonmyc_nh4_patch (:) = nan + allocate(this%npp_Nam_no3_patch (begp:endp)) ; this%npp_Nam_no3_patch (:) = nan + allocate(this%npp_Nam_nh4_patch (begp:endp)) ; this%npp_Nam_nh4_patch (:) = nan + allocate(this%npp_Necm_no3_patch (begp:endp)) ; this%npp_Necm_no3_patch (:) = nan + allocate(this%npp_Necm_nh4_patch (begp:endp)) ; this%npp_Necm_nh4_patch (:) = nan + allocate(this%npp_Nfix_patch (begp:endp)) ; this%npp_Nfix_patch (:) = nan + allocate(this%npp_Nretrans_patch (begp:endp)) ; this%npp_Nretrans_patch (:) = nan + allocate(this%npp_Nuptake_patch (begp:endp)) ; this%npp_Nuptake_patch (:) = nan + allocate(this%npp_growth_patch (begp:endp)) ; this%npp_growth_patch (:) = nan + allocate(this%leafc_change_patch (begp:endp)) ; this%leafc_change_patch (:) = nan + allocate(this%soilc_change_patch (begp:endp)) ; this%soilc_change_patch (:) = nan + + + ! initialize variables from restart file or set to cold start value + + this%dwt_conv_cflux_dribbled_grc(begg:endg) = 0._r8 + this%dwt_conv_cflux_grc(begg:endg) = 0._r8 + + + n = 0 + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + this%annsum_npp_col (n) = cncol(nc,nz, 33) + + + do nl = 1, nlevdecomp_full + this%dwt_frootc_to_litr_met_c_col(n,nl) = 0._r8 + this%dwt_frootc_to_litr_cel_c_col(n,nl) = 0._r8 + this%dwt_frootc_to_litr_lig_c_col(n,nl) = 0._r8 + this%dwt_livecrootc_to_cwdc_col(n,nl) = 0._r8 + this%dwt_deadcrootc_to_cwdc_col(n,nl) = 0._r8 + end do + + + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + + this%gpp_patch(p) = 0._r8 + this%excess_cflux_patch(p) = 0._r8 + this%leafc_to_litter_fun_patch(p) = 0._r8 + this%plant_calloc_patch(p) = 0._r8 + + ! "old" variables: CNCLM45 and before + this%annsum_npp_patch (np) = cnpft(nc,nz,nv, 26) + this%prev_frootc_to_litter_patch (np) = cnpft(nc,nz,nv, 41) + this%prev_leafc_to_litter_patch (np) = cnpft(nc,nz,nv, 42) + this%tempsum_npp_patch (np) = cnpft(nc,nz,nv, 45) + this%xsmrpool_recover_patch (np) = cnpft(nc,nz,nv, 47) + + + ! "new" variables: introduced in CNCLM50 + if (cold_start.eqv..false.) then + this%annsum_litfall_patch(np) = cnpft(nc,nz,nv, 82) + this%tempsum_litfall_patch(np) = cnpft(nc,nz,nv, 83) + elseif (cold_start) then + this%annsum_litfall_patch(np) = 0._r8 + this%tempsum_litfall_patch(np) = 0._r8 + else + _ASSERT(.FALSE.,'missing CNCLM50_cold_start setting') + end if + + end if + end do !nv + + this%excess_cflux_patch(np) = 0._r8 + this%leafc_to_litter_fun_patch(np) = 0._r8 + this%plant_calloc_patch(np) = 0._r8 + this%dwt_wood_productc_gain_patch(np) = 0._r8 ! following CNCLM45 setting + this%dwt_crop_productc_gain_patch(np) = 0._r8 ! following CNCLM45 setting + + + end do ! p + end do ! nz + end do ! nc + + ! Construct restart field names consistently to what is done in SpeciesNonIsotope & + ! SpeciesIsotope, to aid future migration to that infrastructure + if (carbon_type == 'c12') then + carbon_type_suffix = 'c' + else if (carbon_type == 'c13') then + carbon_type_suffix = 'c_13' + else if (carbon_type == 'c14') then + carbon_type_suffix = 'c_14' + else + write(iulog,*) 'CNVegCarbonFluxType InitAllocate: Unknown carbon_type: ', trim(carbon_type) + call endrun(msg='CNVegCarbonFluxType InitAllocate: Unknown carbon_type: ' // & + errMsg(sourcefile, __LINE__)) + end if + + if (use_cndv) then + allows_non_annual_delta = .true. + else + allows_non_annual_delta = .false. + end if + this%dwt_conv_cflux_dribbler = annual_flux_dribbler_gridcell( & + bounds = bounds, & + name = 'dwt_conv_flux_' // carbon_type_suffix, & + units = 'gC/m^2', & + allows_non_annual_delta = allows_non_annual_delta) + this%hrv_xsmrpool_to_atm_dribbler = annual_flux_dribbler_gridcell( & + bounds = bounds, & + name = 'hrv_xsmrpool_to_atm_' // carbon_type_suffix, & + units = 'gC/m^2', & + allows_non_annual_delta = .false.) + + end subroutine Init + +!----------------------------------------- + + subroutine SetValues ( this, nvegcpool, & + num_patch, filter_patch, value_patch, & + num_column, filter_column, value_column) + ! + ! !DESCRIPTION: + ! Set carbon state fluxes + ! + ! !ARGUMENTS: + class (cnveg_carbonflux_type) :: this + integer , intent(in) :: num_patch,nvegcpool + integer , intent(in) :: filter_patch(:) + real(r8), intent(in) :: value_patch + integer , intent(in) :: num_column + integer , intent(in) :: filter_column(:) + real(r8), intent(in) :: value_column + ! + ! !LOCAL VARIABLES: + integer :: fi,i ! loop index + integer :: j,k,l ! indices + !------------------------------------------------------------------------ + + + do fi = 1,num_patch + i = filter_patch(fi) + + this%m_leafc_to_litter_patch(i) = value_patch + this%m_frootc_to_litter_patch(i) = value_patch + this%m_leafc_storage_to_litter_patch(i) = value_patch + this%m_frootc_storage_to_litter_patch(i) = value_patch + this%m_livestemc_storage_to_litter_patch(i) = value_patch + this%m_deadstemc_storage_to_litter_patch(i) = value_patch + this%m_livecrootc_storage_to_litter_patch(i) = value_patch + this%m_deadcrootc_storage_to_litter_patch(i) = value_patch + this%m_leafc_xfer_to_litter_patch(i) = value_patch + this%m_frootc_xfer_to_litter_patch(i) = value_patch + this%m_livestemc_xfer_to_litter_patch(i) = value_patch + this%m_deadstemc_xfer_to_litter_patch(i) = value_patch + this%m_livecrootc_xfer_to_litter_patch(i) = value_patch + this%m_deadcrootc_xfer_to_litter_patch(i) = value_patch + this%m_livestemc_to_litter_patch(i) = value_patch + this%m_deadstemc_to_litter_patch(i) = value_patch + this%m_livecrootc_to_litter_patch(i) = value_patch + this%m_deadcrootc_to_litter_patch(i) = value_patch + this%m_gresp_storage_to_litter_patch(i) = value_patch + this%m_gresp_xfer_to_litter_patch(i) = value_patch + this%hrv_leafc_to_litter_patch(i) = value_patch + this%hrv_leafc_storage_to_litter_patch(i) = value_patch + this%hrv_leafc_xfer_to_litter_patch(i) = value_patch + this%hrv_frootc_to_litter_patch(i) = value_patch + this%hrv_frootc_storage_to_litter_patch(i) = value_patch + this%hrv_frootc_xfer_to_litter_patch(i) = value_patch + this%hrv_livestemc_to_litter_patch(i) = value_patch + this%hrv_livestemc_storage_to_litter_patch(i) = value_patch + this%hrv_livestemc_xfer_to_litter_patch(i) = value_patch + this%hrv_deadstemc_storage_to_litter_patch(i) = value_patch + this%hrv_deadstemc_xfer_to_litter_patch(i) = value_patch + this%hrv_livecrootc_to_litter_patch(i) = value_patch + this%hrv_livecrootc_storage_to_litter_patch(i) = value_patch + this%hrv_livecrootc_xfer_to_litter_patch(i) = value_patch + this%hrv_deadcrootc_to_litter_patch(i) = value_patch + this%hrv_deadcrootc_storage_to_litter_patch(i) = value_patch + this%hrv_deadcrootc_xfer_to_litter_patch(i) = value_patch + this%hrv_gresp_storage_to_litter_patch(i) = value_patch + this%hrv_gresp_xfer_to_litter_patch(i) = value_patch + this%hrv_xsmrpool_to_atm_patch(i) = value_patch + + + this%m_leafc_to_fire_patch(i) = value_patch + this%m_leafc_storage_to_fire_patch(i) = value_patch + this%m_leafc_xfer_to_fire_patch(i) = value_patch + this%m_livestemc_to_fire_patch(i) = value_patch + this%m_livestemc_storage_to_fire_patch(i) = value_patch + this%m_livestemc_xfer_to_fire_patch(i) = value_patch + this%m_deadstemc_to_fire_patch(i) = value_patch + this%m_deadstemc_storage_to_fire_patch(i) = value_patch + this%m_deadstemc_xfer_to_fire_patch(i) = value_patch + this%m_frootc_to_fire_patch(i) = value_patch + this%m_frootc_storage_to_fire_patch(i) = value_patch + this%m_frootc_xfer_to_fire_patch(i) = value_patch + this%m_livecrootc_to_fire_patch(i) = value_patch + this%m_livecrootc_storage_to_fire_patch(i) = value_patch + this%m_livecrootc_xfer_to_fire_patch(i) = value_patch + this%m_deadcrootc_to_fire_patch(i) = value_patch + this%m_deadcrootc_storage_to_fire_patch(i) = value_patch + this%m_deadcrootc_xfer_to_fire_patch(i) = value_patch + this%m_gresp_storage_to_fire_patch(i) = value_patch + this%m_gresp_xfer_to_fire_patch(i) = value_patch + + this%m_leafc_to_litter_fire_patch(i) = value_patch + this%m_leafc_storage_to_litter_fire_patch(i) = value_patch + this%m_leafc_xfer_to_litter_fire_patch(i) = value_patch + this%m_livestemc_to_litter_fire_patch(i) = value_patch + this%m_livestemc_storage_to_litter_fire_patch(i) = value_patch + this%m_livestemc_xfer_to_litter_fire_patch(i) = value_patch + this%m_livestemc_to_deadstemc_fire_patch(i) = value_patch + this%m_deadstemc_to_litter_fire_patch(i) = value_patch + this%m_deadstemc_storage_to_litter_fire_patch(i) = value_patch + this%m_deadstemc_xfer_to_litter_fire_patch(i) = value_patch + this%m_frootc_to_litter_fire_patch(i) = value_patch + this%m_frootc_storage_to_litter_fire_patch(i) = value_patch + this%m_frootc_xfer_to_litter_fire_patch(i) = value_patch + this%m_livecrootc_to_litter_fire_patch(i) = value_patch + this%m_livecrootc_storage_to_litter_fire_patch(i) = value_patch + this%m_livecrootc_xfer_to_litter_fire_patch(i) = value_patch + this%m_livecrootc_to_deadcrootc_fire_patch(i) = value_patch + this%m_deadcrootc_to_litter_fire_patch(i) = value_patch + this%m_deadcrootc_storage_to_litter_fire_patch(i) = value_patch + this%m_deadcrootc_xfer_to_litter_fire_patch(i) = value_patch + this%m_gresp_storage_to_litter_fire_patch(i) = value_patch + this%m_gresp_xfer_to_litter_fire_patch(i) = value_patch + + this%leafc_xfer_to_leafc_patch(i) = value_patch + this%frootc_xfer_to_frootc_patch(i) = value_patch + this%livestemc_xfer_to_livestemc_patch(i) = value_patch + this%deadstemc_xfer_to_deadstemc_patch(i) = value_patch + this%livecrootc_xfer_to_livecrootc_patch(i) = value_patch + this%deadcrootc_xfer_to_deadcrootc_patch(i) = value_patch + this%leafc_to_litter_patch(i) = value_patch + this%frootc_to_litter_patch(i) = value_patch + this%cpool_to_resp_patch(i) = value_patch + this%cpool_to_leafc_resp_patch(i) = value_patch + this%cpool_to_leafc_storage_resp_patch(i) = value_patch + this%cpool_to_frootc_resp_patch(i) = value_patch + this%cpool_to_frootc_storage_resp_patch(i) = value_patch + this%cpool_to_livecrootc_resp_patch(i) = value_patch + this%cpool_to_livecrootc_storage_resp_patch(i) = value_patch + this%cpool_to_livestemc_resp_patch(i) = value_patch + this%cpool_to_livestemc_storage_resp_patch(i) = value_patch + this%leaf_mr_patch(i) = value_patch + this%froot_mr_patch(i) = value_patch + this%livestem_mr_patch(i) = value_patch + this%livecroot_mr_patch(i) = value_patch + this%grain_mr_patch(i) = value_patch + this%leaf_curmr_patch(i) = value_patch + this%froot_curmr_patch(i) = value_patch + this%livestem_curmr_patch(i) = value_patch + this%livecroot_curmr_patch(i) = value_patch + this%grain_curmr_patch(i) = value_patch + this%leaf_xsmr_patch(i) = value_patch + this%froot_xsmr_patch(i) = value_patch + this%livestem_xsmr_patch(i) = value_patch + this%livecroot_xsmr_patch(i) = value_patch + this%grain_xsmr_patch(i) = value_patch + this%psnsun_to_cpool_patch(i) = value_patch + this%psnshade_to_cpool_patch(i) = value_patch + this%cpool_to_xsmrpool_patch(i) = value_patch + this%cpool_to_leafc_patch(i) = value_patch + this%cpool_to_leafc_storage_patch(i) = value_patch + this%cpool_to_frootc_patch(i) = value_patch + this%cpool_to_frootc_storage_patch(i) = value_patch + this%cpool_to_livestemc_patch(i) = value_patch + this%cpool_to_livestemc_storage_patch(i) = value_patch + this%cpool_to_deadstemc_patch(i) = value_patch + this%cpool_to_deadstemc_storage_patch(i) = value_patch + this%cpool_to_livecrootc_patch(i) = value_patch + this%cpool_to_livecrootc_storage_patch(i) = value_patch + this%cpool_to_deadcrootc_patch(i) = value_patch + this%cpool_to_deadcrootc_storage_patch(i) = value_patch + this%cpool_to_gresp_storage_patch(i) = value_patch + this%cpool_leaf_gr_patch(i) = value_patch + this%cpool_leaf_storage_gr_patch(i) = value_patch + this%transfer_leaf_gr_patch(i) = value_patch + this%cpool_froot_gr_patch(i) = value_patch + this%cpool_froot_storage_gr_patch(i) = value_patch + this%transfer_froot_gr_patch(i) = value_patch + this%cpool_livestem_gr_patch(i) = value_patch + this%cpool_livestem_storage_gr_patch(i) = value_patch + this%transfer_livestem_gr_patch(i) = value_patch + this%cpool_deadstem_gr_patch(i) = value_patch + this%cpool_deadstem_storage_gr_patch(i) = value_patch + this%transfer_deadstem_gr_patch(i) = value_patch + this%cpool_livecroot_gr_patch(i) = value_patch + this%cpool_livecroot_storage_gr_patch(i) = value_patch + this%transfer_livecroot_gr_patch(i) = value_patch + this%cpool_deadcroot_gr_patch(i) = value_patch + this%cpool_deadcroot_storage_gr_patch(i) = value_patch + this%transfer_deadcroot_gr_patch(i) = value_patch + this%leafc_storage_to_xfer_patch(i) = value_patch + this%frootc_storage_to_xfer_patch(i) = value_patch + this%livestemc_storage_to_xfer_patch(i) = value_patch + this%deadstemc_storage_to_xfer_patch(i) = value_patch + this%livecrootc_storage_to_xfer_patch(i) = value_patch + this%deadcrootc_storage_to_xfer_patch(i) = value_patch + this%gresp_storage_to_xfer_patch(i) = value_patch + this%livestemc_to_deadstemc_patch(i) = value_patch + this%livecrootc_to_deadcrootc_patch(i) = value_patch + + this%current_gr_patch(i) = value_patch + this%transfer_gr_patch(i) = value_patch + this%storage_gr_patch(i) = value_patch + this%frootc_alloc_patch(i) = value_patch + this%frootc_loss_patch(i) = value_patch + this%leafc_alloc_patch(i) = value_patch + this%leafc_loss_patch(i) = value_patch + this%woodc_alloc_patch(i) = value_patch + this%woodc_loss_patch(i) = value_patch + + this%crop_seedc_to_leaf_patch(i) = value_patch + this%grainc_to_cropprodc_patch(i) = value_patch +! Matrix + if(use_matrixcn)then + this%matrix_Cinput_patch(i) = value_patch + this%matrix_C13input_patch(i) = value_patch + this%matrix_C14input_patch(i) = value_patch + end if + end do + if(use_matrixcn)then + do j = 1, nvegcpool + do fi = 1,num_patch + i = filter_patch(fi) + this%matrix_alloc_patch(i,j) = value_patch + this%matrix_phturnover_patch (i,j) = value_patch + this%matrix_gmturnover_patch (i,j) = value_patch + this%matrix_fiturnover_patch (i,j) = value_patch + end do + end do + + do j = 1, ncphtrans + do fi = 1,num_patch + i = filter_patch(fi) + this%matrix_phtransfer_patch (i,j) = value_patch + end do + end do + + do j = 1, ncgmtrans + do fi = 1,num_patch + i = filter_patch(fi) + this%matrix_gmtransfer_patch (i,j) = value_patch + end do + end do + + do j = 1, ncfitrans + do fi = 1,num_patch + i = filter_patch(fi) + this%matrix_fitransfer_patch (i,j) = value_patch + end do + end do + end if + + + if ( use_crop )then + do fi = 1,num_patch + i = filter_patch(fi) + this%xsmrpool_to_atm_patch(i) = value_patch + this%livestemc_to_litter_patch(i) = value_patch + this%grainc_to_food_patch(i) = value_patch + + this%leafc_to_biofuelc_patch(i) = value_patch + this%livestemc_to_biofuelc_patch(i) = value_patch + + this%grainc_to_seed_patch(i) = value_patch + this%grainc_xfer_to_grainc_patch(i) = value_patch + this%cpool_to_grainc_patch(i) = value_patch + this%cpool_to_grainc_storage_patch(i) = value_patch + this%cpool_grain_gr_patch(i) = value_patch + this%cpool_grain_storage_gr_patch(i) = value_patch + this%transfer_grain_gr_patch(i) = value_patch + this%grainc_storage_to_xfer_patch(i) = value_patch + end do + end if + + + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + + this%phenology_c_to_litr_met_c_col(i,j) = value_column + this%phenology_c_to_litr_cel_c_col(i,j) = value_column + this%phenology_c_to_litr_lig_c_col(i,j) = value_column + + this%gap_mortality_c_to_litr_met_c_col(i,j) = value_column + this%gap_mortality_c_to_litr_cel_c_col(i,j) = value_column + this%gap_mortality_c_to_litr_lig_c_col(i,j) = value_column + this%gap_mortality_c_to_cwdc_col(i,j) = value_column + + this%fire_mortality_c_to_cwdc_col(i,j) = value_column + this%m_c_to_litr_met_fire_col(i,j) = value_column + this%m_c_to_litr_cel_fire_col(i,j) = value_column + this%m_c_to_litr_lig_fire_col(i,j) = value_column + + this%harvest_c_to_litr_met_c_col(i,j) = value_column + this%harvest_c_to_litr_cel_c_col(i,j) = value_column + this%harvest_c_to_litr_lig_c_col(i,j) = value_column + this%harvest_c_to_cwdc_col(i,j) = value_column + + end do + end do + + + do k = 1, ndecomp_pools + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%m_decomp_cpools_to_fire_vr_col(i,j,k) = value_column + end do + end do + end do + + do k = 1, ndecomp_pools + do fi = 1,num_column + i = filter_column(fi) + this%m_decomp_cpools_to_fire_col(i,k) = value_column + end do + end do + + do fi = 1,num_column + i = filter_column(fi) + + this%grainc_to_cropprodc_col(i) = value_column + this%cwdc_hr_col(i) = value_column + this%cwdc_loss_col(i) = value_column + this%litterc_loss_col(i) = value_column + + end do + + + do fi = 1,num_patch + i = filter_patch(fi) + + this%gpp_patch(i) = value_patch + this%mr_patch(i) = value_patch + this%gr_patch(i) = value_patch + this%ar_patch(i) = value_patch + this%rr_patch(i) = value_patch + this%npp_patch(i) = value_patch + this%agnpp_patch(i) = value_patch + this%bgnpp_patch(i) = value_patch + this%litfall_patch(i) = value_patch + this%wood_harvestc_patch(i) = value_patch + this%slash_harvestc_patch(i) = value_patch + this%cinputs_patch(i) = value_patch + this%coutputs_patch(i) = value_patch + this%fire_closs_patch(i) = value_patch + this%npp_Nactive_patch(i) = value_patch + this%npp_burnedoff_patch(i) = value_patch + this%npp_Nnonmyc_patch(i) = value_patch + this%npp_Nam_patch(i) = value_patch + this%npp_Necm_patch(i) = value_patch + this%npp_Nactive_no3_patch(i) = value_patch + this%npp_Nactive_nh4_patch(i) = value_patch + this%npp_Nnonmyc_no3_patch(i) = value_patch + this%npp_Nnonmyc_nh4_patch(i) = value_patch + this%npp_Nam_no3_patch(i) = value_patch + this%npp_Nam_nh4_patch(i) = value_patch + this%npp_Necm_no3_patch(i) = value_patch + this%npp_Necm_nh4_patch(i) = value_patch + this%npp_Nfix_patch(i) = value_patch + this%npp_Nretrans_patch(i) = value_patch + this%npp_Nuptake_patch(i) = value_patch + this%npp_growth_patch(i) = value_patch + this%leafc_change_patch(i) = value_patch + this%soilc_change_patch(i) = value_patch + end do + + do fi = 1,num_column + i = filter_column(fi) + + this%sr_col(i) = value_column + this%er_col(i) = value_column + this%litfire_col(i) = value_column + this%somfire_col(i) = value_column + this%totfire_col(i) = value_column + + ! Zero p2c column fluxes + this%rr_col(i) = value_column + this%ar_col(i) = value_column + this%gpp_col(i) = value_column + this%npp_col(i) = value_column + this%fire_closs_col(i) = value_column + this%wood_harvestc_col(i) = value_column + this%hrv_xsmrpool_to_atm_col(i) = value_column + this%nep_col(i) = value_column + if ( use_crop )then + this%xsmrpool_to_atm_col(i) = value_column + end if + + end do + + end subroutine SetValues + + !----------------------------------------------------------------------- + subroutine Summary_carbonflux(this, & + bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + isotope, soilbiogeochem_hr_col, soilbiogeochem_lithr_col, & + soilbiogeochem_decomp_cascade_ctransfer_col, & + product_closs_grc) + ! + ! !DESCRIPTION: + ! Perform patch and column-level carbon summary calculations + ! + ! !USES: + use clm_time_manager , only: get_step_size_real + use clm_varcon , only: secspday + use clm_varctl , only: nfix_timeconst, carbon_resp_opt + use subgridAveMod , only: p2c, c2g + use SoilBiogeochemDecompCascadeConType , only: decomp_cascade_con + use CNSharedParamsMod , only: use_fun + ! + ! !ARGUMENTS: + class(cnveg_carbonflux_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + character(len=*) , intent(in) :: isotope + real(r8) , intent(in) :: soilbiogeochem_hr_col(bounds%begc:) + real(r8) , intent(in) :: soilbiogeochem_lithr_col(bounds%begc:) + real(r8) , intent(in) :: soilbiogeochem_decomp_cascade_ctransfer_col(bounds%begc:,1:) + real(r8) , intent(in) :: product_closs_grc(bounds%begg:) + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,k,l,g ! indices + integer :: fp,fc ! lake filter indices + real(r8) :: nfixlags, dtime ! temp variables for making lagged npp + real(r8) :: maxdepth ! depth to integrate soil variables + real(r8) :: nep_grc(bounds%begg:bounds%endg) ! nep_col averaged to gridcell + real(r8) :: fire_closs_grc(bounds%begg:bounds%endg) ! fire_closs_col averaged to gridcell + real(r8) :: hrv_xsmrpool_to_atm_grc(bounds%begg:bounds%endg) ! hrv_xsmrpool_to_atm_col averaged to gridcell (gC/m2/s) + real(r8) :: hrv_xsmrpool_to_atm_delta_grc(bounds%begg:bounds%endg) ! hrv_xsmrpool_to_atm_col averaged to gridcell, expressed as a delta (not a flux) (gC/m2) + real(r8) :: hrv_xsmrpool_to_atm_dribbled_grc(bounds%begg:bounds%endg) ! hrv_xsmrpool_to_atm, dribbled over the year (gC/m2/s) + real(r8) :: dwt_conv_cflux_delta_grc(bounds%begg:bounds%endg) ! dwt_conv_cflux_grc expressed as a total delta (not a flux) (gC/m2) + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(product_closs_grc) == (/bounds%endg/)), sourcefile, __LINE__) + + ! calculate patch-level summary carbon fluxes and states + + dtime = get_step_size_real() + + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! maintenance respiration (MR) + if ( trim(isotope) == 'c13' .or. trim(isotope) == 'c14') then + this%leaf_mr_patch(p) = this%leaf_curmr_patch(p) + this%leaf_xsmr_patch(p) + this%froot_mr_patch(p) = this%froot_curmr_patch(p) + this%froot_xsmr_patch(p) + this%livestem_mr_patch(p) = this%livestem_curmr_patch(p) + this%livestem_xsmr_patch(p) + this%livecroot_mr_patch(p) = this%livecroot_curmr_patch(p) + this%livecroot_xsmr_patch(p) + endif + + this%mr_patch(p) = & + this%leaf_mr_patch(p) + & + this%froot_mr_patch(p) + & + this%livestem_mr_patch(p) + & + this%livecroot_mr_patch(p) + + if (carbon_resp_opt == 1) then + this%mr_patch(p) = & + this%cpool_to_resp_patch(p) + & + this%leaf_mr_patch(p) + & + this%froot_mr_patch(p) + & + this%livestem_mr_patch(p) + & + this%livecroot_mr_patch(p) + end if + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%mr_patch(p) = & + this%mr_patch(p) + & + this%grain_mr_patch(p) + end if + + ! growth respiration (GR) + + ! current GR is respired this time step for new growth displayed in this timestep + this%current_gr_patch(p) = & + this%cpool_leaf_gr_patch(p) + & + this%cpool_froot_gr_patch(p) + & + this%cpool_livestem_gr_patch(p) + & + this%cpool_deadstem_gr_patch(p) + & + this%cpool_livecroot_gr_patch(p) + & + this%cpool_deadcroot_gr_patch(p) + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%current_gr_patch(p) = this%current_gr_patch(p) + & + this%cpool_grain_gr_patch(p) + end if + + + ! transfer GR is respired this time step for transfer growth displayed in this timestep + this%transfer_gr_patch(p) = & + this%transfer_leaf_gr_patch(p) + & + this%transfer_froot_gr_patch(p) + & + this%transfer_livestem_gr_patch(p) + & + this%transfer_deadstem_gr_patch(p) + & + this%transfer_livecroot_gr_patch(p) + & + this%transfer_deadcroot_gr_patch(p) + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%transfer_gr_patch(p) = this%transfer_gr_patch(p) + & + this%transfer_grain_gr_patch(p) + end if + + ! storage GR is respired this time step for growth sent to storage for later display + this%storage_gr_patch(p) = & + this%cpool_leaf_storage_gr_patch(p) + & + this%cpool_froot_storage_gr_patch(p) + & + this%cpool_livestem_storage_gr_patch(p) + & + this%cpool_deadstem_storage_gr_patch(p) + & + this%cpool_livecroot_storage_gr_patch(p) + & + this%cpool_deadcroot_storage_gr_patch(p) + + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%storage_gr_patch(p) = this%storage_gr_patch(p) + & + this%cpool_grain_storage_gr_patch(p) + end if + + ! GR is the sum of current + transfer + storage GR + this%gr_patch(p) = & + this%current_gr_patch(p) + & + this%transfer_gr_patch(p) + & + this%storage_gr_patch(p) + + + ! autotrophic respiration (AR) adn + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%ar_patch(p) = & + this%mr_patch(p) + & + this%gr_patch(p) + if ( .not. this%dribble_crophrv_xsmrpool_2atm ) this%ar_patch(p) = this%ar_patch(p) + & + this%xsmrpool_to_atm_patch(p) ! xsmr... is -ve (slevis) + else + this%ar_patch(p) = & + this%mr_patch(p) + & + this%gr_patch(p) + end if + + if (use_fun) then + this%ar_patch(p) = this%ar_patch(p) + this%soilc_change_patch(p) + end if + + ! gross primary production (GPP) + this%gpp_patch(p) = & + this%psnsun_to_cpool_patch(p) + & + this%psnshade_to_cpool_patch(p) + + ! net primary production (NPP) + this%npp_patch(p) = & + this%gpp_patch(p) - & + this%ar_patch(p) + + + ! root respiration (RR) + this%rr_patch(p) = & + this%froot_mr_patch(p) + & + this%livecroot_mr_patch(p) + & + this%cpool_froot_gr_patch(p) + & + this%cpool_livecroot_gr_patch(p) + & + this%cpool_deadcroot_gr_patch(p) + & + this%transfer_froot_gr_patch(p) + & + this%transfer_livecroot_gr_patch(p) + & + this%transfer_deadcroot_gr_patch(p) + & + this%cpool_froot_storage_gr_patch(p) + & + this%cpool_livecroot_storage_gr_patch(p) + & + this%cpool_deadcroot_storage_gr_patch(p) + + ! update the annual NPP accumulator, for use in allocation code + if (trim(isotope) == 'bulk') then + this%tempsum_npp_patch(p) = & + this%tempsum_npp_patch(p) + & + this%npp_patch(p) + end if + + ! aboveground NPP: leaf, live stem, dead stem (AGNPP) + ! This is supposed to correspond as closely as possible to + ! field measurements of AGNPP, so it ignores the storage pools + ! and only treats the fluxes into displayed pools. + + this%agnpp_patch(p) = & + this%cpool_to_leafc_patch(p) + & + this%leafc_xfer_to_leafc_patch(p) + & + this%cpool_to_livestemc_patch(p) + & + this%livestemc_xfer_to_livestemc_patch(p) + & + this%cpool_to_deadstemc_patch(p) + & + this%deadstemc_xfer_to_deadstemc_patch(p) + + + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%agnpp_patch(p) = & + this%agnpp_patch(p) + & + this%cpool_to_grainc_patch(p) + & + this%grainc_xfer_to_grainc_patch(p) + end if + + ! belowground NPP: fine root, live coarse root, dead coarse root (BGNPP) + ! This is supposed to correspond as closely as possible to + ! field measurements of BGNPP, so it ignores the storage pools + ! and only treats the fluxes into displayed pools. + + this%bgnpp_patch(p) = & + this%cpool_to_frootc_patch(p) + & + this%frootc_xfer_to_frootc_patch(p) + & + this%cpool_to_livecrootc_patch(p) + & + this%livecrootc_xfer_to_livecrootc_patch(p) + & + this%cpool_to_deadcrootc_patch(p) + & + this%deadcrootc_xfer_to_deadcrootc_patch(p) + + ! litterfall (LITFALL) + + this%litfall_patch(p) = & + this%leafc_to_litter_patch(p) + & + this%frootc_to_litter_patch(p) + & + this%m_leafc_to_litter_patch(p) + & + this%m_leafc_storage_to_litter_patch(p) + & + this%m_leafc_xfer_to_litter_patch(p) + & + this%m_frootc_to_litter_patch(p) + & + this%m_frootc_storage_to_litter_patch(p) + & + this%m_frootc_xfer_to_litter_patch(p) + & + this%m_livestemc_to_litter_patch(p) + & + this%m_livestemc_storage_to_litter_patch(p) + & + this%m_livestemc_xfer_to_litter_patch(p) + & + this%m_deadstemc_to_litter_patch(p) + & + this%m_deadstemc_storage_to_litter_patch(p) + & + this%m_deadstemc_xfer_to_litter_patch(p) + & + this%m_livecrootc_to_litter_patch(p) + & + this%m_livecrootc_storage_to_litter_patch(p) + & + this%m_livecrootc_xfer_to_litter_patch(p) + & + this%m_deadcrootc_to_litter_patch(p) + & + this%m_deadcrootc_storage_to_litter_patch(p) + & + this%m_deadcrootc_xfer_to_litter_patch(p) + & + this%m_gresp_storage_to_litter_patch(p) + & + this%m_gresp_xfer_to_litter_patch(p) + & + + this%m_leafc_to_litter_fire_patch(p) + & + this%m_leafc_storage_to_litter_fire_patch(p) + & + this%m_leafc_xfer_to_litter_fire_patch(p) + & + this%m_livestemc_to_litter_fire_patch(p) + & + this%m_livestemc_storage_to_litter_fire_patch(p) + & + this%m_livestemc_xfer_to_litter_fire_patch(p) + & + this%m_deadstemc_to_litter_fire_patch(p) + & + this%m_deadstemc_storage_to_litter_fire_patch(p) + & + this%m_deadstemc_xfer_to_litter_fire_patch(p) + & + this%m_frootc_to_litter_fire_patch(p) + & + this%m_frootc_storage_to_litter_fire_patch(p) + & + this%m_frootc_xfer_to_litter_fire_patch(p) + & + this%m_livecrootc_to_litter_fire_patch(p) + & + this%m_livecrootc_storage_to_litter_fire_patch(p) + & + this%m_livecrootc_xfer_to_litter_fire_patch(p) + & + this%m_deadcrootc_to_litter_fire_patch(p) + & + this%m_deadcrootc_storage_to_litter_fire_patch(p) + & + this%m_deadcrootc_xfer_to_litter_fire_patch(p) + & + this%m_gresp_storage_to_litter_fire_patch(p) + & + this%m_gresp_xfer_to_litter_fire_patch(p) + & + + this%hrv_leafc_to_litter_patch(p) + & + this%hrv_leafc_storage_to_litter_patch(p) + & + this%hrv_leafc_xfer_to_litter_patch(p) + & + this%hrv_frootc_to_litter_patch(p) + & + this%hrv_frootc_storage_to_litter_patch(p) + & + this%hrv_frootc_xfer_to_litter_patch(p) + & + this%hrv_livestemc_to_litter_patch(p) + & + this%hrv_livestemc_storage_to_litter_patch(p) + & + this%hrv_livestemc_xfer_to_litter_patch(p) + & + this%hrv_deadstemc_storage_to_litter_patch(p) + & + this%hrv_deadstemc_xfer_to_litter_patch(p) + & + this%hrv_livecrootc_to_litter_patch(p) + & + this%hrv_livecrootc_storage_to_litter_patch(p) + & + this%hrv_livecrootc_xfer_to_litter_patch(p) + & + this%hrv_deadcrootc_to_litter_patch(p) + & + this%hrv_deadcrootc_storage_to_litter_patch(p) + & + this%hrv_deadcrootc_xfer_to_litter_patch(p) + & + this%hrv_gresp_storage_to_litter_patch(p) + & + this%hrv_gresp_xfer_to_litter_patch(p) + + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%litfall_patch(p) = & + this%litfall_patch(p) + & + this%livestemc_to_litter_patch(p) + + if (.not. use_grainproduct) then + this%litfall_patch(p) = & + this%litfall_patch(p) + & + this%grainc_to_food_patch(p) + end if + end if + + ! update the annual litfall accumulator, for use in mortality code + + if (use_cndv) then + this%tempsum_litfall_patch(p) = & + this%tempsum_litfall_patch(p) + & + this%leafc_to_litter_patch(p) + & + this%frootc_to_litter_patch(p) + end if + + ! patch-level carbon losses to fire changed by F. Li and S. Levis + + this%fire_closs_patch(p) = & + this%m_leafc_to_fire_patch(p) + & + this%m_leafc_storage_to_fire_patch(p) + & + this%m_leafc_xfer_to_fire_patch(p) + & + this%m_frootc_to_fire_patch(p) + & + this%m_frootc_storage_to_fire_patch(p) + & + this%m_frootc_xfer_to_fire_patch(p) + & + this%m_livestemc_to_fire_patch(p) + & + this%m_livestemc_storage_to_fire_patch(p) + & + this%m_livestemc_xfer_to_fire_patch(p) + & + this%m_deadstemc_to_fire_patch(p) + & + this%m_deadstemc_storage_to_fire_patch(p) + & + this%m_deadstemc_xfer_to_fire_patch(p) + & + this%m_livecrootc_to_fire_patch(p) + & + this%m_livecrootc_storage_to_fire_patch(p) + & + this%m_livecrootc_xfer_to_fire_patch(p) + & + this%m_deadcrootc_to_fire_patch(p) + & + this%m_deadcrootc_storage_to_fire_patch(p) + & + this%m_deadcrootc_xfer_to_fire_patch(p) + & + this%m_gresp_storage_to_fire_patch(p) + & + this%m_gresp_xfer_to_fire_patch(p) + + ! new summary variables for CLAMP + + ! (FROOTC_ALLOC) - fine root C allocation + this%frootc_alloc_patch(p) = & + this%frootc_xfer_to_frootc_patch(p) + & + this%cpool_to_frootc_patch(p) + + ! (FROOTC_LOSS) - fine root C loss changed by F. Li and S. Levis + this%frootc_loss_patch(p) = & + this%m_frootc_to_litter_patch(p) + & + this%m_frootc_to_fire_patch(p) + & + this%m_frootc_to_litter_fire_patch(p) + & + this%hrv_frootc_to_litter_patch(p) + & + this%frootc_to_litter_patch(p) + + ! (LEAFC_ALLOC) - leaf C allocation + this%leafc_alloc_patch(p) = & + this%leafc_xfer_to_leafc_patch(p) + & + this%cpool_to_leafc_patch(p) + + ! (LEAFC_LOSS) - leaf C loss changed by F. Li and S. Levis + this%leafc_loss_patch(p) = & + this%m_leafc_to_litter_patch(p) + & + this%m_leafc_to_fire_patch(p) + & + this%m_leafc_to_litter_fire_patch(p) + & + this%hrv_leafc_to_litter_patch(p) + & + this%leafc_to_litter_patch(p) + + ! (WOODC_ALLOC) - wood C allocation + this%woodc_alloc_patch(p) = & + this%livestemc_xfer_to_livestemc_patch(p) + & + this%deadstemc_xfer_to_deadstemc_patch(p) + & + this%livecrootc_xfer_to_livecrootc_patch(p) + & + this%deadcrootc_xfer_to_deadcrootc_patch(p) + & + this%cpool_to_livestemc_patch(p) + & + this%cpool_to_deadstemc_patch(p) + & + this%cpool_to_livecrootc_patch(p) + & + this%cpool_to_deadcrootc_patch(p) + + + + ! (WOODC_LOSS) - wood C loss + this%woodc_loss_patch(p) = & + this%m_livestemc_to_litter_patch(p) + & + this%m_deadstemc_to_litter_patch(p) + & + this%m_livecrootc_to_litter_patch(p) + & + this%m_deadcrootc_to_litter_patch(p) + & + this%m_livestemc_to_fire_patch(p) + & + this%m_deadstemc_to_fire_patch(p) + & + this%m_livecrootc_to_fire_patch(p) + & + this%m_deadcrootc_to_fire_patch(p) + & + this%hrv_livestemc_to_litter_patch(p) + & + this%hrv_livestemc_storage_to_litter_patch(p) + & + this%hrv_livestemc_xfer_to_litter_patch(p) + & + this%wood_harvestc_patch(p) + & + this%hrv_deadstemc_storage_to_litter_patch(p) + & + this%hrv_deadstemc_xfer_to_litter_patch(p) + & + this%hrv_livecrootc_to_litter_patch(p) + & + this%hrv_livecrootc_storage_to_litter_patch(p) + & + this%hrv_livecrootc_xfer_to_litter_patch(p) + & + this%hrv_deadcrootc_to_litter_patch(p) + & + this%hrv_deadcrootc_storage_to_litter_patch(p) + & + this%hrv_deadcrootc_xfer_to_litter_patch(p) + + + ! (Slash Harvest Flux) - Additional Wood Harvest Veg C Losses + this%slash_harvestc_patch(p) = & + this%hrv_leafc_to_litter_patch(p) + & + this%hrv_leafc_storage_to_litter_patch(p) + & + this%hrv_leafc_xfer_to_litter_patch(p) + & + this%hrv_frootc_to_litter_patch(p) + & + this%hrv_frootc_storage_to_litter_patch(p) + & + this%hrv_frootc_xfer_to_litter_patch(p) + & + this%hrv_livestemc_to_litter_patch(p) + & + this%hrv_livestemc_storage_to_litter_patch(p) + & + this%hrv_livestemc_xfer_to_litter_patch(p) + & + this%hrv_deadstemc_storage_to_litter_patch(p) + & + this%hrv_deadstemc_xfer_to_litter_patch(p) + & + this%hrv_livecrootc_to_litter_patch(p) + & + this%hrv_livecrootc_storage_to_litter_patch(p) + & + this%hrv_livecrootc_xfer_to_litter_patch(p) + & + this%hrv_deadcrootc_to_litter_patch(p) + & + this%hrv_deadcrootc_storage_to_litter_patch(p) + & + this%hrv_deadcrootc_xfer_to_litter_patch(p) + & + this%hrv_xsmrpool_to_atm_patch(p) + & + this%hrv_gresp_storage_to_litter_patch(p) + & + this%hrv_gresp_xfer_to_litter_patch(p) + + end do ! end of patches loop + + + !------------------------------------------------ + ! column variables + !------------------------------------------------ + + ! use p2c routine to get selected column-average patch-level fluxes and states + + call p2c(bounds, num_soilc, filter_soilc, & + this%hrv_xsmrpool_to_atm_patch(bounds%begp:bounds%endp), & + this%hrv_xsmrpool_to_atm_col(bounds%begc:bounds%endc)) + + if (use_crop .and. this%dribble_crophrv_xsmrpool_2atm) then + call p2c(bounds, num_soilc, filter_soilc, & + this%xsmrpool_to_atm_patch(bounds%begp:bounds%endp), & + this%xsmrpool_to_atm_col(bounds%begc:bounds%endc)) + + call c2g( bounds = bounds, & + carr = this%xsmrpool_to_atm_col(bounds%begc:bounds%endc), & + garr = this%xsmrpool_to_atm_grc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + end if + + call p2c(bounds, num_soilc, filter_soilc, & + this%fire_closs_patch(bounds%begp:bounds%endp), & + this%fire_closs_p2c_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + this%npp_patch(bounds%begp:bounds%endp), & + this%npp_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + this%rr_patch(bounds%begp:bounds%endp), & + this%rr_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + this%ar_patch(bounds%begp:bounds%endp), & + this%ar_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + this%gpp_patch(bounds%begp:bounds%endp), & + this%gpp_col(bounds%begc:bounds%endc)) + + + ! this code is to calculate an exponentially-relaxed npp value for use in NDynamics code + + if ( trim(isotope) == 'bulk') then + if (nfix_timeconst > 0._r8 .and. nfix_timeconst < 500._r8 ) then + nfixlags = nfix_timeconst * secspday + do fc = 1,num_soilc + c = filter_soilc(fc) + if ( this%lag_npp_col(c) /= spval ) then + this%lag_npp_col(c) = & + this%lag_npp_col(c) * exp(-dtime/nfixlags) + & + this%npp_col(c) * (1._r8 - exp(-dtime/nfixlags)) + else + ! first timestep + this%lag_npp_col(c) = this%npp_col(c) + endif + end do + endif + endif + + + ! vertically integrate column-level carbon fire losses +! if(.not. use_soil_matrixcn)then + do l = 1, ndecomp_pools + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%m_decomp_cpools_to_fire_col(c,l) = & + this%m_decomp_cpools_to_fire_col(c,l) + & + this%m_decomp_cpools_to_fire_vr_col(c,j,l)*dzsoi_decomp(j) + end do + end do + end do +! end if !not use_soil_matrixcn + + + do fc = 1,num_soilc + c = filter_soilc(fc) + + g = col%gridcell(c) + + ! litter fire losses (LITFIRE) + this%litfire_col(c) = 0._r8 + + ! soil organic matter fire losses (SOMFIRE) + this%somfire_col(c) = 0._r8 + + ! total ecosystem fire losses (TOTFIRE) + this%totfire_col(c) = & + this%litfire_col(c) + & + this%somfire_col(c) + + ! carbon losses to fire, including patch losses + this%fire_closs_col(c) = this%fire_closs_p2c_col(c) + do l = 1, ndecomp_pools + this%fire_closs_col(c) = & + this%fire_closs_col(c) + & + this%m_decomp_cpools_to_fire_col(c,l) + end do + + ! total soil respiration, heterotrophic + root respiration (SR) + this%sr_col(c) = & + this%rr_col(c) + & + soilbiogeochem_hr_col(c) + + ! total ecosystem respiration, autotrophic + heterotrophic (ER) + this%er_col(c) = & + this%ar_col(c) + & + soilbiogeochem_hr_col(c) + + ! coarse woody debris heterotrophic respiration + this%cwdc_hr_col(c) = 0._r8 + ! net ecosystem production, excludes fire flux, landcover change, + ! and loss from wood products, positive for sink (NEP) + this%nep_col(c) = & + this%gpp_col(c) - & + this%er_col(c) + + end do + + call c2g( bounds = bounds, & + carr = this%nep_col(bounds%begc:bounds%endc), & + garr = nep_grc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + call c2g( bounds = bounds, & + carr = this%fire_closs_col(bounds%begc:bounds%endc), & + garr = fire_closs_grc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + call c2g( bounds = bounds, & + carr = this%hrv_xsmrpool_to_atm_col(bounds%begc:bounds%endc), & + garr = hrv_xsmrpool_to_atm_grc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + hrv_xsmrpool_to_atm_delta_grc(bounds%begg:bounds%endg) = & + hrv_xsmrpool_to_atm_grc(bounds%begg:bounds%endg) * dtime + call this%hrv_xsmrpool_to_atm_dribbler%set_curr_delta(bounds, & + hrv_xsmrpool_to_atm_delta_grc(bounds%begg:bounds%endg)) + call this%hrv_xsmrpool_to_atm_dribbler%get_curr_flux(bounds, & + hrv_xsmrpool_to_atm_dribbled_grc(bounds%begg:bounds%endg)) + + + dwt_conv_cflux_delta_grc(bounds%begg:bounds%endg) = & + this%dwt_conv_cflux_grc(bounds%begg:bounds%endg) * dtime + call this%dwt_conv_cflux_dribbler%set_curr_delta(bounds, & + dwt_conv_cflux_delta_grc(bounds%begg:bounds%endg)) + call this%dwt_conv_cflux_dribbler%get_curr_flux(bounds, & + this%dwt_conv_cflux_dribbled_grc(bounds%begg:bounds%endg)) + + do g = bounds%begg, bounds%endg + ! net ecosystem exchange of carbon, includes fire flux and hrv_xsmrpool flux, + ! positive for source (NEE) + this%nee_grc(g) = & + -nep_grc(g) + & + fire_closs_grc(g) + & + hrv_xsmrpool_to_atm_dribbled_grc(g) + + this%landuseflux_grc(g) = & + this%dwt_conv_cflux_dribbled_grc(g) + & + product_closs_grc(g) + + ! net biome production of carbon, positive for sink + this%nbp_grc(g) = & + -this%nee_grc(g) - & + this%landuseflux_grc(g) + if ( this%dribble_crophrv_xsmrpool_2atm ) this%nbp_grc(g) = this%nbp_grc(g) - this%xsmrpool_to_atm_grc(g) + end do + + ! coarse woody debris C loss + do fc = 1,num_soilc + c = filter_soilc(fc) + this%cwdc_loss_col(c) = 0._r8 + end do + associate(is_cwd => decomp_cascade_con%is_cwd) ! TRUE => pool is a cwd pool + do l = 1, ndecomp_pools + if ( is_cwd(l) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + this%cwdc_loss_col(c) = & + this%cwdc_loss_col(c) + & + this%m_decomp_cpools_to_fire_col(c,l) + end do + end if + end do + do k = 1, ndecomp_cascade_transitions + if ( is_cwd(decomp_cascade_con%cascade_donor_pool(k)) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + this%cwdc_loss_col(c) = & + this%cwdc_loss_col(c) + & + soilbiogeochem_decomp_cascade_ctransfer_col(c,k) + end do + end if + end do + end associate + + + + ! litter C loss + do fc = 1,num_soilc + c = filter_soilc(fc) + this%litterc_loss_col(c) = soilbiogeochem_lithr_col(c) + end do + associate(is_litter => decomp_cascade_con%is_litter) ! TRUE => pool is a litter pool + do l = 1, ndecomp_pools + if ( is_litter(l) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + this%litterc_loss_col(c) = & + this%litterc_loss_col(c) + & + this%m_decomp_cpools_to_fire_col(c,l) + end do + end if + end do + do k = 1, ndecomp_cascade_transitions + if ( is_litter(decomp_cascade_con%cascade_donor_pool(k)) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + this%litterc_loss_col(c) = & + this%litterc_loss_col(c) + & + soilbiogeochem_decomp_cascade_ctransfer_col(c,k) + end do + end if + end do + end associate + + end subroutine Summary_carbonflux +!----------------------------------- + subroutine ZeroDwt( this, bounds ) + ! + ! !DESCRIPTION + ! Initialize flux variables needed for dynamic land use. + ! + ! !ARGUMENTS: + class(cnveg_carbonflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: c, g, j ! indices + !----------------------------------------------------------------------- + + ! set conversion and product pool fluxes to 0 at the beginning of every timestep + + do g = bounds%begg, bounds%endg + this%dwt_seedc_to_leaf_grc(g) = 0._r8 + this%dwt_seedc_to_deadstem_grc(g) = 0._r8 + this%dwt_conv_cflux_grc(g) = 0._r8 + this%dwt_slash_cflux_grc(g) = 0._r8 + end do + + do j = 1, nlevdecomp_full + do c = bounds%begc,bounds%endc + this%dwt_frootc_to_litr_met_c_col(c,j) = 0._r8 + this%dwt_frootc_to_litr_cel_c_col(c,j) = 0._r8 + this%dwt_frootc_to_litr_lig_c_col(c,j) = 0._r8 + this%dwt_livecrootc_to_cwdc_col(c,j) = 0._r8 + this%dwt_deadcrootc_to_cwdc_col(c,j) = 0._r8 + end do + end do + + end subroutine ZeroDwt + + !----------------------------------------------------------------------- +end module CNVegCarbonFluxType + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegCarbonStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegCarbonStateType.F90 new file mode 100755 index 000000000..329b6f21f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegCarbonStateType.F90 @@ -0,0 +1,758 @@ +module CNVegCarbonStateType + +#include "shr_assert.h" + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varctl , only : iulog, use_cndv, use_crop, use_matrixcn + use clm_varpar , only : numpft, num_zon, num_veg, & + var_col, var_pft, CN_zone_weight + use clm_varcon , only : spval + use nanMod , only : nan + use decompMod , only : bounds_type + use pftconMod , only : noveg, npcropmin, pftcon + use PatchType , only : patch + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: cnveg_carbonstate_type + + integer :: species ! c12, c13, c14 + + real(r8), pointer :: grainc_patch (:) ! (gC/m2) grain C (crop model) + real(r8), pointer :: grainc_storage_patch (:) ! (gC/m2) grain C storage (crop model) + real(r8), pointer :: grainc_xfer_patch (:) ! (gC/m2) grain C transfer (crop model) + real(r8), pointer :: matrix_cap_grainc_patch (:) ! (gC/m2) Capacity of grain C + real(r8), pointer :: matrix_cap_grainc_storage_patch (:) ! (gC/m2) Capacity of grain storage C + real(r8), pointer :: matrix_cap_grainc_xfer_patch (:) ! (gC/m2) Capacity of grain transfer C + real(r8), pointer :: leafc_patch (:) ! (gC/m2) leaf C + real(r8), pointer :: leafc_storage_patch (:) ! (gC/m2) leaf C storage + real(r8), pointer :: leafc_xfer_patch (:) ! (gC/m2) leaf C transfer + real(r8), pointer :: matrix_cap_leafc_patch (:) ! (gC/m2) Capacity of leaf C + real(r8), pointer :: matrix_cap_leafc_storage_patch (:) ! (gC/m2) Capacity of leaf C storage + real(r8), pointer :: matrix_cap_leafc_xfer_patch (:) ! (gC/m2) Capacity of leaf C transfer + real(r8), pointer :: leafc_storage_xfer_acc_patch (:) ! (gC/m2) Accmulated leaf C transfer + real(r8), pointer :: storage_cdemand_patch (:) ! (gC/m2) C use from the C storage pool + real(r8), pointer :: frootc_patch (:) ! (gC/m2) fine root C + real(r8), pointer :: frootc_storage_patch (:) ! (gC/m2) fine root C storage + real(r8), pointer :: frootc_xfer_patch (:) ! (gC/m2) fine root C transfer + real(r8), pointer :: matrix_cap_frootc_patch (:) ! (gC/m2) Capacity of fine root C + real(r8), pointer :: matrix_cap_frootc_storage_patch (:) ! (gC/m2) Capacity of fine root C storage + real(r8), pointer :: matrix_cap_frootc_xfer_patch (:) ! (gC/m2) Capacity of fine root C transfer + real(r8), pointer :: livestemc_patch (:) ! (gC/m2) live stem C + real(r8), pointer :: livestemc_storage_patch (:) ! (gC/m2) live stem C storage + real(r8), pointer :: livestemc_xfer_patch (:) ! (gC/m2) live stem C transfer + real(r8), pointer :: matrix_cap_livestemc_patch (:) ! (gC/m2) Capacity of live stem C + real(r8), pointer :: matrix_cap_livestemc_storage_patch (:) ! (gC/m2) Capacity of live stem C storage + real(r8), pointer :: matrix_cap_livestemc_xfer_patch (:) ! (gC/m2) Capacity of live stem C transfer + real(r8), pointer :: deadstemc_patch (:) ! (gC/m2) dead stem C + real(r8), pointer :: deadstemc_storage_patch (:) ! (gC/m2) dead stem C storage + real(r8), pointer :: deadstemc_xfer_patch (:) ! (gC/m2) dead stem C transfer + real(r8), pointer :: matrix_cap_deadstemc_patch (:) ! (gC/m2) Capacity of dead stem C + real(r8), pointer :: matrix_cap_deadstemc_storage_patch (:) ! (gC/m2) Capacity of dead stem C storage + real(r8), pointer :: matrix_cap_deadstemc_xfer_patch (:) ! (gC/m2) Capacity of dead stem C transfer + real(r8), pointer :: livecrootc_patch (:) ! (gC/m2) live coarse root C + real(r8), pointer :: livecrootc_storage_patch (:) ! (gC/m2) live coarse root C storage + real(r8), pointer :: livecrootc_xfer_patch (:) ! (gC/m2) live coarse root C transfer + real(r8), pointer :: matrix_cap_livecrootc_patch (:) ! (gC/m2) Capacity of live coarse root C + real(r8), pointer :: matrix_cap_livecrootc_storage_patch (:) ! (gC/m2) Capacity of live coarse root C storage + real(r8), pointer :: matrix_cap_livecrootc_xfer_patch (:) ! (gC/m2) Capacity of live coarse root C transfer + real(r8), pointer :: deadcrootc_patch (:) ! (gC/m2) dead coarse root C + real(r8), pointer :: deadcrootc_storage_patch (:) ! (gC/m2) dead coarse root C storage + real(r8), pointer :: deadcrootc_xfer_patch (:) ! (gC/m2) dead coarse root C transfer + real(r8), pointer :: matrix_cap_deadcrootc_patch (:) ! (gC/m2) Capacity of dead coarse root C + real(r8), pointer :: matrix_cap_deadcrootc_storage_patch (:) ! (gC/m2) Capacity of dead coarse root C storage + real(r8), pointer :: matrix_cap_deadcrootc_xfer_patch (:) ! (gC/m2) Capacity of dead coarse root C transfer + real(r8), pointer :: gresp_storage_patch (:) ! (gC/m2) growth respiration storage + real(r8), pointer :: gresp_xfer_patch (:) ! (gC/m2) growth respiration transfer + real(r8), pointer :: cpool_patch (:) ! (gC/m2) temporary photosynthate C pool + real(r8), pointer :: xsmrpool_patch (:) ! (gC/m2) abstract C pool to meet excess MR demand + real(r8), pointer :: xsmrpool_loss_patch (:) ! (gC/m2) abstract C pool to meet excess MR demand loss + real(r8), pointer :: ctrunc_patch (:) ! (gC/m2) patch-level sink for C truncation + real(r8), pointer :: woodc_patch (:) ! (gC/m2) wood C + real(r8), pointer :: leafcmax_patch (:) ! (gC/m2) ann max leaf C + real(r8), pointer :: totc_patch (:) ! (gC/m2) total patch-level carbon, including cpool + real(r8), pointer :: rootc_col (:) ! (gC/m2) root carbon at column level (fire) + real(r8), pointer :: leafc_col (:) ! (gC/m2) column-level leafc (fire) + real(r8), pointer :: deadstemc_col (:) ! (gC/m2) column-level deadstemc (fire) + real(r8), pointer :: fuelc_col (:) ! fuel load outside cropland + real(r8), pointer :: fuelc_crop_col (:) ! fuel load for cropland + real(r8), pointer :: cropseedc_deficit_patch (:) ! (gC/m2) pool for seeding new crop growth; this is a NEGATIVE term, indicating the amount of seed usage that needs to be repaid +! initial pool size of year for matrix + real(r8), pointer :: leafc0_patch (:) ! (gC/m2) Initial value of leaf C for SASU + real(r8), pointer :: leafc0_storage_patch (:) ! (gC/m2) Initial value of leaf C storage for SASU + real(r8), pointer :: leafc0_xfer_patch (:) ! (gC/m2) Initial value of leaf C transfer for SASU + real(r8), pointer :: frootc0_patch (:) ! (gC/m2) Initial value of fine root C for SASU + real(r8), pointer :: frootc0_storage_patch (:) ! (gC/m2) Initial value of fine root C storage for SASU + real(r8), pointer :: frootc0_xfer_patch (:) ! (gC/m2) Initial value of fine root C transfer for SASU + real(r8), pointer :: livestemc0_patch (:) ! (gC/m2) Initial value of live stem C for SASU + real(r8), pointer :: livestemc0_storage_patch (:) ! (gC/m2) Initial value of live stem C storage for SASU + real(r8), pointer :: livestemc0_xfer_patch (:) ! (gC/m2) Initial value of live stem C transfer for SASU + real(r8), pointer :: deadstemc0_patch (:) ! (gC/m2) Initial value of dead stem C for SASU + real(r8), pointer :: deadstemc0_storage_patch (:) ! (gC/m2) Initial value of dead stem C storage for SASU + real(r8), pointer :: deadstemc0_xfer_patch (:) ! (gC/m2) Initial value of dead stem C transfer for SASU + real(r8), pointer :: livecrootc0_patch (:) ! (gC/m2) Initial value of live coarse root C for SASU + real(r8), pointer :: livecrootc0_storage_patch (:) ! (gC/m2) Initial value of live coarse root C storage for SASU + real(r8), pointer :: livecrootc0_xfer_patch (:) ! (gC/m2) Initial value of live coarse root C transfer for SASU + real(r8), pointer :: deadcrootc0_patch (:) ! (gC/m2) Initial value of dead coarse root C for SASU + real(r8), pointer :: deadcrootc0_storage_patch (:) ! (gC/m2) Initial value of dead coarse root C storage for SASU + real(r8), pointer :: deadcrootc0_xfer_patch (:) ! (gC/m2) Initial value of dead coarse root C transfer for SASU + real(r8), pointer :: grainc0_patch (:) ! (gC/m2) Initial value of fine grain C for SASU + real(r8), pointer :: grainc0_storage_patch (:) ! (gC/m2) Initial value of fine grain C storage for SASU + real(r8), pointer :: grainc0_xfer_patch (:) ! (gC/m2) Initial value of fine grain C transfer for SASU + + ! pools for dynamic landcover + real(r8), pointer :: seedc_grc (:) ! (gC/m2) gridcell-level pool for seeding new PFTs via dynamic landcover + + ! summary (diagnostic) state variables, not involved in mass balance + real(r8), pointer :: dispvegc_patch (:) ! (gC/m2) displayed veg carbon, excluding storage and cpool + real(r8), pointer :: storvegc_patch (:) ! (gC/m2) stored vegetation carbon, excluding cpool + real(r8), pointer :: totvegc_patch (:) ! (gC/m2) total vegetation carbon, excluding cpool + real(r8), pointer :: totvegc_col (:) ! (gC/m2) total vegetation carbon, excluding cpool averaged to column (p2c) + + ! Total C pools + real(r8), pointer :: totc_p2c_col (:) ! (gC/m2) totc_patch averaged to col + real(r8), pointer :: totc_col (:) ! (gC/m2) total column carbon, incl veg and cpool + real(r8), pointer :: totecosysc_col (:) ! (gC/m2) total ecosystem carbon, incl veg but excl cpool + real(r8), pointer :: totc_grc (:) ! (gC/m2) total gridcell carbon + +! Accumulation variables are accumulated for a whole year. They are used for matrix spinup and calculation of diagnostic variables + real(r8), pointer :: matrix_calloc_leaf_acc_patch (:) ! (gC/m2/year) Input C allocated to leaf during this year + real(r8), pointer :: matrix_calloc_leafst_acc_patch (:) ! (gC/m2/year) Input C allocated to leaf storage during this year + real(r8), pointer :: matrix_calloc_froot_acc_patch (:) ! (gC/m2/year) Input C allocated to fine root during this year + real(r8), pointer :: matrix_calloc_frootst_acc_patch (:) ! (gC/m2/year) Input C allocated to fine root storage during this year + real(r8), pointer :: matrix_calloc_livestem_acc_patch (:) ! (gC/m2/year) Input C allocated to live stem during this year + real(r8), pointer :: matrix_calloc_livestemst_acc_patch (:) ! (gC/m2/year) Input C allocated to live stem storage during this year + real(r8), pointer :: matrix_calloc_deadstem_acc_patch (:) ! (gC/m2/year) Input C allocated to dead stem during this year + real(r8), pointer :: matrix_calloc_deadstemst_acc_patch (:) ! (gC/m2/year) Input C allocated to dead stem storage during this year + real(r8), pointer :: matrix_calloc_livecroot_acc_patch (:) ! (gC/m2/year) Input C allocated to live coarse root during this year + real(r8), pointer :: matrix_calloc_livecrootst_acc_patch (:) ! (gC/m2/year) Input C allocated to live coarse root storage during this year + real(r8), pointer :: matrix_calloc_deadcroot_acc_patch (:) ! (gC/m2/year) Input C allocated to dead coarse root during this year + real(r8), pointer :: matrix_calloc_deadcrootst_acc_patch (:) ! (gC/m2/year) Input C allocated to dead coarse root storage during this year + real(r8), pointer :: matrix_calloc_grain_acc_patch (:) ! (gC/m2/year) Input C allocated to grain during this year + real(r8), pointer :: matrix_calloc_grainst_acc_patch (:) ! (gC/m2/year) Input C allocated to grain storage during this year + + real(r8), pointer :: matrix_ctransfer_leafst_to_leafxf_acc_patch (:) ! (gC/m2/year) C transfer from leaf storage to leaf transfer pool during this year + real(r8), pointer :: matrix_ctransfer_leafxf_to_leaf_acc_patch (:) ! (gC/m2/year) C transfer from leaf transfer to leaf pool during this year + real(r8), pointer :: matrix_ctransfer_frootst_to_frootxf_acc_patch (:) ! (gC/m2/year) C transfer from fine root storage to fine root transfer pool during this year + real(r8), pointer :: matrix_ctransfer_frootxf_to_froot_acc_patch (:) ! (gC/m2/year) C transfer from fine root transfer to fine root pool during this year + real(r8), pointer :: matrix_ctransfer_livestemst_to_livestemxf_acc_patch (:) ! (gC/m2/year) C transfer from live stem storage to live stem transfer pool during this year + real(r8), pointer :: matrix_ctransfer_livestemxf_to_livestem_acc_patch (:) ! (gC/m2/year) C transfer from live stem transfer to live stem pool during this year + real(r8), pointer :: matrix_ctransfer_deadstemst_to_deadstemxf_acc_patch (:) ! (gC/m2/year) C transfer from dead stem storage to dead stem transfer pool during this year + real(r8), pointer :: matrix_ctransfer_deadstemxf_to_deadstem_acc_patch (:) ! (gC/m2/year) C transfer from dead stem transfer to dead stem pool during this year + real(r8), pointer :: matrix_ctransfer_livecrootst_to_livecrootxf_acc_patch (:) ! (gC/m2/year) C transfer from live coarse root storage to live coarse root transfer pool during this year + real(r8), pointer :: matrix_ctransfer_livecrootxf_to_livecroot_acc_patch (:) ! (gC/m2/year) C transfer from live coarse root transfer to live coarse root pool during this year + real(r8), pointer :: matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_patch (:) ! (gC/m2/year) C transfer from dead coarse root storage to dead coarse root transfer pool during this year + real(r8), pointer :: matrix_ctransfer_deadcrootxf_to_deadcroot_acc_patch (:) ! (gC/m2/year) C transfer from dead coarse root transfer to dead coarse root pool during this year + real(r8), pointer :: matrix_ctransfer_grainst_to_grainxf_acc_patch (:) ! (gC/m2/year) C transfer from grain storage to grain transfer pool during this year + real(r8), pointer :: matrix_ctransfer_grainxf_to_grain_acc_patch (:) ! (gC/m2/year) C transfer from grain transfer to grain pool during this year + real(r8), pointer :: matrix_ctransfer_livestem_to_deadstem_acc_patch (:) ! (gC/m2/year) C transfer from live stem to dead stem pool during this year + real(r8), pointer :: matrix_ctransfer_livecroot_to_deadcroot_acc_patch (:) ! (gC/m2/year) C transfer from live coarse root to dead coarse root pool during this year + + real(r8), pointer :: matrix_cturnover_leaf_acc_patch (:) ! (gC/m2/year) C turnover from leaf + real(r8), pointer :: matrix_cturnover_leafst_acc_patch (:) ! (gC/m2/year) C turnover from leaf storage + real(r8), pointer :: matrix_cturnover_leafxf_acc_patch (:) ! (gC/m2/year) C turnover from leaf transfer + real(r8), pointer :: matrix_cturnover_froot_acc_patch (:) ! (gC/m2/year) C turnover from fine root + real(r8), pointer :: matrix_cturnover_frootst_acc_patch (:) ! (gC/m2/year) C turnover from fine root storage + real(r8), pointer :: matrix_cturnover_frootxf_acc_patch (:) ! (gC/m2/year) C turnover from fine root transfer + real(r8), pointer :: matrix_cturnover_livestem_acc_patch (:) ! (gC/m2/year) C turnover from live stem + real(r8), pointer :: matrix_cturnover_livestemst_acc_patch (:) ! (gC/m2/year) C turnover from live stem storage + real(r8), pointer :: matrix_cturnover_livestemxf_acc_patch (:) ! (gC/m2/year) C turnover from live stem transfer + real(r8), pointer :: matrix_cturnover_deadstem_acc_patch (:) ! (gC/m2/year) C turnover from dead stem + real(r8), pointer :: matrix_cturnover_deadstemst_acc_patch (:) ! (gC/m2/year) C turnover from dead stem storage + real(r8), pointer :: matrix_cturnover_deadstemxf_acc_patch (:) ! (gC/m2/year) C turnover from dead stem transfer + real(r8), pointer :: matrix_cturnover_livecroot_acc_patch (:) ! (gC/m2/year) C turnover from live coarse root + real(r8), pointer :: matrix_cturnover_livecrootst_acc_patch (:) ! (gC/m2/year) C turnover from live coarse root storage + real(r8), pointer :: matrix_cturnover_livecrootxf_acc_patch (:) ! (gC/m2/year) C turnover from live coarse root transfer + real(r8), pointer :: matrix_cturnover_deadcroot_acc_patch (:) ! (gC/m2/year) C turnover from dead coarse root + real(r8), pointer :: matrix_cturnover_deadcrootst_acc_patch (:) ! (gC/m2/year) C turnover from dead coarse root storage + real(r8), pointer :: matrix_cturnover_deadcrootxf_acc_patch (:) ! (gC/m2/year) C turnover from dead coarse root transfer + real(r8), pointer :: matrix_cturnover_grain_acc_patch (:) ! (gC/m2/year) C turnover from grain + real(r8), pointer :: matrix_cturnover_grainst_acc_patch (:) ! (gC/m2/year) C turnover from grain storage + real(r8), pointer :: matrix_cturnover_grainxf_acc_patch (:) ! (gC/m2/year) C turnover from grain transfer + + real(r8), pointer :: grainc_SASUsave_patch (:) ! (gC/m2) grain C (crop model) + real(r8), pointer :: grainc_storage_SASUsave_patch (:) ! (gC/m2) grain C storage (crop model) + real(r8), pointer :: leafc_SASUsave_patch (:) ! (gC/m2) leaf C + real(r8), pointer :: leafc_storage_SASUsave_patch (:) ! (gC/m2) leaf C storage + real(r8), pointer :: leafc_xfer_SASUsave_patch (:) ! (gC/m2) leaf C transfer + real(r8), pointer :: frootc_SASUsave_patch (:) ! (gC/m2) fine root C + real(r8), pointer :: frootc_storage_SASUsave_patch (:) ! (gC/m2) fine root C storage + real(r8), pointer :: frootc_xfer_SASUsave_patch (:) ! (gC/m2) fine root C transfer + real(r8), pointer :: livestemc_SASUsave_patch (:) ! (gC/m2) live stem C + real(r8), pointer :: livestemc_storage_SASUsave_patch (:) ! (gC/m2) live stem C storage + real(r8), pointer :: livestemc_xfer_SASUsave_patch (:) ! (gC/m2) live stem C transfer + real(r8), pointer :: deadstemc_SASUsave_patch (:) ! (gC/m2) dead stem C + real(r8), pointer :: deadstemc_storage_SASUsave_patch (:) ! (gC/m2) dead stem C storage + real(r8), pointer :: deadstemc_xfer_SASUsave_patch (:) ! (gC/m2) dead stem C transfer + real(r8), pointer :: livecrootc_SASUsave_patch (:) ! (gC/m2) live coarse root C + real(r8), pointer :: livecrootc_storage_SASUsave_patch (:) ! (gC/m2) live coarse root C storage + real(r8), pointer :: livecrootc_xfer_SASUsave_patch (:) ! (gC/m2) live coarse root C transfer + real(r8), pointer :: deadcrootc_SASUsave_patch (:) ! (gC/m2) dead coarse root C + real(r8), pointer :: deadcrootc_storage_SASUsave_patch (:) ! (gC/m2) dead coarse root C storage + real(r8), pointer :: deadcrootc_xfer_SASUsave_patch (:) ! (gC/m2) dead coarse root C transfer + logical, private :: dribble_crophrv_xsmrpool_2atm + + contains + + procedure , public :: Summary => Summary_carbonstate + procedure , public :: ZeroDWT + procedure , public :: Init + procedure , private :: InitReadNML ! Read in namelist + + end type cnveg_carbonstate_type + +type(cnveg_carbonstate_type), public, target, save :: cnveg_carbonstate_inst + + real(r8), public :: spinup_factor_deadwood = 1.0_r8 ! Spinup factor used for this simulation + real(r8), public :: spinup_factor_AD = 10.0_r8 ! Spinup factor used when in Accelerated Decomposition mode + + ! !PRIVATE DATA: + + type, private :: cnvegcarbonstate_const_type + ! !PRIVATE MEMBER DATA: + real(r8) :: initial_vegC = 20._r8 ! Initial vegetation carbon for leafc/frootc and storage + end type + type(cnvegcarbonstate_const_type), private :: cnvegcstate_const ! Constants used here + + character(len=*), parameter :: sourcefile = & + __FILE__ + +contains + +!---------------------------------------------- + subroutine Init(this, bounds, NLFilename, nch, ityp, fveg, cncol, cnpft) + +! !DESCRIPTION: +! Initialize CTSM carbon states +! jk Apr 2021: type is allocated and initialized to NaN; +! if data arrays from restart file are passed (cncol and cnpft), the type is then initialized with these values +! +! !ARGUMENTS: + implicit none + + ! INPUT + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: NLFilename ! Namelist filename + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: ityp ! PFT index + real, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: fveg ! PFT fraction + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + real, dimension(nch,NUM_ZON,NUM_VEG,VAR_PFT), intent(in) :: cnpft ! gkw: PFT CN restart + class(cnveg_carbonstate_type) :: this + + ! LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + integer :: np, nc, nz, p, nv, n + !-------------------------------------------------------- + + begp = bounds%begp ; endp = bounds%endp + begg = bounds%begg ; endg = bounds%endg + begc = bounds%begc ; endc = bounds%endc + + allocate(this%leafc_patch (begp:endp)) ; this%leafc_patch (:) = spval + allocate(this%leafc_storage_patch (begp:endp)) ; this%leafc_storage_patch (:) = nan + allocate(this%leafc_xfer_patch (begp:endp)) ; this%leafc_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_leafc_patch (begp:endp)) ; this%matrix_cap_leafc_patch (:) = nan + allocate(this%matrix_cap_leafc_storage_patch (begp:endp)) ; this%matrix_cap_leafc_storage_patch (:) = nan + allocate(this%matrix_cap_leafc_xfer_patch (begp:endp)) ; this%matrix_cap_leafc_xfer_patch (:) = nan + end if + allocate(this%leafc_storage_xfer_acc_patch (begp:endp)) ; this%leafc_storage_xfer_acc_patch (:) = nan + allocate(this%storage_cdemand_patch (begp:endp)) ; this%storage_cdemand_patch (:) = nan + allocate(this%frootc_patch (begp:endp)) ; this%frootc_patch (:) = nan + allocate(this%frootc_storage_patch (begp:endp)) ; this%frootc_storage_patch (:) = nan + allocate(this%frootc_xfer_patch (begp:endp)) ; this%frootc_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_frootc_patch (begp:endp)) ; this%matrix_cap_frootc_patch (:) = nan + allocate(this%matrix_cap_frootc_storage_patch (begp:endp)) ; this%matrix_cap_frootc_storage_patch (:) = nan + allocate(this%matrix_cap_frootc_xfer_patch (begp:endp)) ; this%matrix_cap_frootc_xfer_patch (:) = nan + end if + allocate(this%livestemc_patch (begp:endp)) ; this%livestemc_patch (:) = nan + allocate(this%livestemc_storage_patch (begp:endp)) ; this%livestemc_storage_patch (:) = nan + allocate(this%livestemc_xfer_patch (begp:endp)) ; this%livestemc_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_livestemc_patch (begp:endp)) ; this%matrix_cap_livestemc_patch (:) = nan + allocate(this%matrix_cap_livestemc_storage_patch (begp:endp)) ; this%matrix_cap_livestemc_storage_patch (:) = nan + allocate(this%matrix_cap_livestemc_xfer_patch (begp:endp)) ; this%matrix_cap_livestemc_xfer_patch (:) = nan + end if + allocate(this%deadstemc_patch (begp:endp)) ; this%deadstemc_patch (:) = spval + allocate(this%deadstemc_storage_patch (begp:endp)) ; this%deadstemc_storage_patch (:) = nan + allocate(this%deadstemc_xfer_patch (begp:endp)) ; this%deadstemc_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_deadstemc_patch (begp:endp)) ; this%matrix_cap_deadstemc_patch (:) = nan + allocate(this%matrix_cap_deadstemc_storage_patch (begp:endp)) ; this%matrix_cap_deadstemc_storage_patch (:) = nan + allocate(this%matrix_cap_deadstemc_xfer_patch (begp:endp)) ; this%matrix_cap_deadstemc_xfer_patch (:) = nan + end if + allocate(this%livecrootc_patch (begp:endp)) ; this%livecrootc_patch (:) = nan + allocate(this%livecrootc_storage_patch (begp:endp)) ; this%livecrootc_storage_patch (:) = nan + allocate(this%livecrootc_xfer_patch (begp:endp)) ; this%livecrootc_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_livecrootc_patch (begp:endp)) ; this%matrix_cap_livecrootc_patch (:) = nan + allocate(this%matrix_cap_livecrootc_storage_patch (begp:endp)) ; this%matrix_cap_livecrootc_storage_patch(:) = nan + allocate(this%matrix_cap_livecrootc_xfer_patch (begp:endp)) ; this%matrix_cap_livecrootc_xfer_patch (:) = nan + end if + allocate(this%deadcrootc_patch (begp:endp)) ; this%deadcrootc_patch (:) = nan + allocate(this%deadcrootc_storage_patch (begp:endp)) ; this%deadcrootc_storage_patch (:) = nan + allocate(this%deadcrootc_xfer_patch (begp:endp)) ; this%deadcrootc_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_deadcrootc_patch (begp:endp)) ; this%matrix_cap_deadcrootc_patch (:) = nan + allocate(this%matrix_cap_deadcrootc_storage_patch (begp:endp)) ; this%matrix_cap_deadcrootc_storage_patch(:) = nan + allocate(this%matrix_cap_deadcrootc_xfer_patch (begp:endp)) ; this%matrix_cap_deadcrootc_xfer_patch (:) = nan + end if + allocate(this%gresp_storage_patch (begp:endp)) ; this%gresp_storage_patch (:) = nan + allocate(this%gresp_xfer_patch (begp:endp)) ; this%gresp_xfer_patch (:) = nan + allocate(this%cpool_patch (begp:endp)) ; this%cpool_patch (:) = nan + allocate(this%xsmrpool_patch (begp:endp)) ; this%xsmrpool_patch (:) = nan + allocate(this%xsmrpool_loss_patch (begp:endp)) ; this%xsmrpool_loss_patch (:) = nan + allocate(this%ctrunc_patch (begp:endp)) ; this%ctrunc_patch (:) = nan + allocate(this%dispvegc_patch (begp:endp)) ; this%dispvegc_patch (:) = nan + allocate(this%storvegc_patch (begp:endp)) ; this%storvegc_patch (:) = nan + allocate(this%leafcmax_patch (begp:endp)) ; this%leafcmax_patch (:) = nan + allocate(this%totc_patch (begp:endp)) ; this%totc_patch (:) = spval + allocate(this%grainc_patch (begp:endp)) ; this%grainc_patch (:) = nan + allocate(this%grainc_storage_patch (begp:endp)) ; this%grainc_storage_patch (:) = nan + allocate(this%grainc_xfer_patch (begp:endp)) ; this%grainc_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_grainc_patch (begp:endp)) ; this%matrix_cap_grainc_patch (:) = nan + allocate(this%matrix_cap_grainc_storage_patch (begp:endp)) ; this%matrix_cap_grainc_storage_patch (:) = nan + allocate(this%matrix_cap_grainc_xfer_patch (begp:endp)) ; this%matrix_cap_grainc_xfer_patch (:) = nan + end if + allocate(this%woodc_patch (begp:endp)) ; this%woodc_patch (:) = nan +!initial pool size of year for matrix + if(use_matrixcn)then + allocate(this%leafc0_patch (begp:endp)) ; this%leafc0_patch (:) = nan + allocate(this%leafc0_storage_patch (begp:endp)) ; this%leafc0_storage_patch (:) = nan + allocate(this%leafc0_xfer_patch (begp:endp)) ; this%leafc0_xfer_patch (:) = nan + allocate(this%frootc0_patch (begp:endp)) ; this%frootc0_patch (:) = nan + allocate(this%frootc0_storage_patch (begp:endp)) ; this%frootc0_storage_patch (:) = nan + allocate(this%frootc0_xfer_patch (begp:endp)) ; this%frootc0_xfer_patch (:) = nan + allocate(this%livestemc0_patch (begp:endp)) ; this%livestemc0_patch (:) = nan + allocate(this%livestemc0_storage_patch (begp:endp)) ; this%livestemc0_storage_patch (:) = nan + allocate(this%livestemc0_xfer_patch (begp:endp)) ; this%livestemc0_xfer_patch (:) = nan + allocate(this%deadstemc0_patch (begp:endp)) ; this%deadstemc0_patch (:) = nan + allocate(this%deadstemc0_storage_patch (begp:endp)) ; this%deadstemc0_storage_patch (:) = nan + allocate(this%deadstemc0_xfer_patch (begp:endp)) ; this%deadstemc0_xfer_patch (:) = nan + allocate(this%livecrootc0_patch (begp:endp)) ; this%livecrootc0_patch (:) = nan + allocate(this%livecrootc0_storage_patch (begp:endp)) ; this%livecrootc0_storage_patch (:) = nan + allocate(this%livecrootc0_xfer_patch (begp:endp)) ; this%livecrootc0_xfer_patch (:) = nan + allocate(this%deadcrootc0_patch (begp:endp)) ; this%deadcrootc0_patch (:) = nan + allocate(this%deadcrootc0_storage_patch (begp:endp)) ; this%deadcrootc0_storage_patch (:) = nan + allocate(this%deadcrootc0_xfer_patch (begp:endp)) ; this%deadcrootc0_xfer_patch (:) = nan + allocate(this%grainc0_patch (begp:endp)) ; this%grainc0_patch (:) = nan + allocate(this%grainc0_storage_patch (begp:endp)) ; this%grainc0_storage_patch (:) = nan + allocate(this%grainc0_xfer_patch (begp:endp)) ; this%grainc0_xfer_patch (:) = nan + + allocate(this%leafc_SASUsave_patch (begp:endp)) ; this%leafc_SASUsave_patch (:) = nan + allocate(this%leafc_storage_SASUsave_patch (begp:endp)) ; this%leafc_storage_SASUsave_patch (:) = nan + allocate(this%leafc_xfer_SASUsave_patch (begp:endp)) ; this%leafc_xfer_SASUsave_patch (:) = nan + allocate(this%frootc_SASUsave_patch (begp:endp)) ; this%frootc_SASUsave_patch (:) = nan + allocate(this%frootc_storage_SASUsave_patch (begp:endp)) ; this%frootc_storage_SASUsave_patch (:) = nan + allocate(this%frootc_xfer_SASUsave_patch (begp:endp)) ; this%frootc_xfer_SASUsave_patch (:) = nan + allocate(this%livestemc_SASUsave_patch (begp:endp)) ; this%livestemc_SASUsave_patch (:) = nan + allocate(this%livestemc_storage_SASUsave_patch (begp:endp)) ; this%livestemc_storage_SASUsave_patch (:) = nan + allocate(this%livestemc_xfer_SASUsave_patch (begp:endp)) ; this%livestemc_xfer_SASUsave_patch (:) = nan + allocate(this%deadstemc_SASUsave_patch (begp:endp)) ; this%deadstemc_SASUsave_patch (:) = nan + allocate(this%deadstemc_storage_SASUsave_patch (begp:endp)) ; this%deadstemc_storage_SASUsave_patch (:) = nan + allocate(this%deadstemc_xfer_SASUsave_patch (begp:endp)) ; this%deadstemc_xfer_SASUsave_patch (:) = nan + allocate(this%livecrootc_SASUsave_patch (begp:endp)) ; this%livecrootc_SASUsave_patch (:) = nan + allocate(this%livecrootc_storage_SASUsave_patch (begp:endp)) ; this%livecrootc_storage_SASUsave_patch (:) = nan + allocate(this%livecrootc_xfer_SASUsave_patch (begp:endp)) ; this%livecrootc_xfer_SASUsave_patch (:) = nan + allocate(this%deadcrootc_SASUsave_patch (begp:endp)) ; this%deadcrootc_SASUsave_patch (:) = nan + allocate(this%deadcrootc_storage_SASUsave_patch (begp:endp)) ; this%deadcrootc_storage_SASUsave_patch (:) = nan + allocate(this%deadcrootc_xfer_SASUsave_patch (begp:endp)) ; this%deadcrootc_xfer_SASUsave_patch (:) = nan + allocate(this%grainc_SASUsave_patch (begp:endp)) ; this%grainc_SASUsave_patch (:) = nan + allocate(this%grainc_storage_SASUsave_patch (begp:endp)) ; this%grainc_storage_SASUsave_patch (:) = nan + + allocate(this%matrix_calloc_leaf_acc_patch (begp:endp)); this%matrix_calloc_leaf_acc_patch (:) = nan + allocate(this%matrix_calloc_leafst_acc_patch (begp:endp)); this%matrix_calloc_leafst_acc_patch (:) = nan + allocate(this%matrix_calloc_froot_acc_patch (begp:endp)); this%matrix_calloc_froot_acc_patch (:) = nan + allocate(this%matrix_calloc_frootst_acc_patch (begp:endp)); this%matrix_calloc_frootst_acc_patch (:) = nan + allocate(this%matrix_calloc_livestem_acc_patch (begp:endp)); this%matrix_calloc_livestem_acc_patch (:) = nan + allocate(this%matrix_calloc_livestemst_acc_patch (begp:endp)); this%matrix_calloc_livestemst_acc_patch (:) = nan + allocate(this%matrix_calloc_deadstem_acc_patch (begp:endp)); this%matrix_calloc_deadstem_acc_patch (:) = nan + allocate(this%matrix_calloc_deadstemst_acc_patch (begp:endp)); this%matrix_calloc_deadstemst_acc_patch (:) = nan + allocate(this%matrix_calloc_livecroot_acc_patch (begp:endp)); this%matrix_calloc_livecroot_acc_patch (:) = nan + allocate(this%matrix_calloc_livecrootst_acc_patch (begp:endp)); this%matrix_calloc_livecrootst_acc_patch (:) = nan + allocate(this%matrix_calloc_deadcroot_acc_patch (begp:endp)); this%matrix_calloc_deadcroot_acc_patch (:) = nan + allocate(this%matrix_calloc_deadcrootst_acc_patch (begp:endp)); this%matrix_calloc_deadcrootst_acc_patch (:) = nan + allocate(this%matrix_calloc_grain_acc_patch (begp:endp)); this%matrix_calloc_grain_acc_patch (:) = nan + allocate(this%matrix_calloc_grainst_acc_patch (begp:endp)); this%matrix_calloc_grainst_acc_patch (:) = nan + + allocate(this%matrix_ctransfer_leafst_to_leafxf_acc_patch (begp:endp)) + this%matrix_ctransfer_leafst_to_leafxf_acc_patch (:) = nan + allocate(this%matrix_ctransfer_leafxf_to_leaf_acc_patch (begp:endp)) + this%matrix_ctransfer_leafxf_to_leaf_acc_patch (:) = nan + allocate(this%matrix_ctransfer_frootst_to_frootxf_acc_patch (begp:endp)) + this%matrix_ctransfer_frootst_to_frootxf_acc_patch (:) = nan + allocate(this%matrix_ctransfer_frootxf_to_froot_acc_patch (begp:endp)) + this%matrix_ctransfer_frootxf_to_froot_acc_patch (:) = nan + allocate(this%matrix_ctransfer_livestemst_to_livestemxf_acc_patch (begp:endp)) + this%matrix_ctransfer_livestemst_to_livestemxf_acc_patch (:) = nan + allocate(this%matrix_ctransfer_livestemxf_to_livestem_acc_patch (begp:endp)) + this%matrix_ctransfer_livestemxf_to_livestem_acc_patch (:) = nan + allocate(this%matrix_ctransfer_deadstemst_to_deadstemxf_acc_patch (begp:endp)) + this%matrix_ctransfer_deadstemst_to_deadstemxf_acc_patch (:) = nan + allocate(this%matrix_ctransfer_deadstemxf_to_deadstem_acc_patch (begp:endp)) + this%matrix_ctransfer_deadstemxf_to_deadstem_acc_patch (:) = nan + allocate(this%matrix_ctransfer_livecrootst_to_livecrootxf_acc_patch (begp:endp)) + this%matrix_ctransfer_livecrootst_to_livecrootxf_acc_patch (:) = nan + allocate(this%matrix_ctransfer_livecrootxf_to_livecroot_acc_patch (begp:endp)) + this%matrix_ctransfer_livecrootxf_to_livecroot_acc_patch (:) = nan + allocate(this%matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_patch (begp:endp)) + this%matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_patch (:) = nan + allocate(this%matrix_ctransfer_deadcrootxf_to_deadcroot_acc_patch (begp:endp)) + this%matrix_ctransfer_deadcrootxf_to_deadcroot_acc_patch (:) = nan + allocate(this%matrix_ctransfer_grainst_to_grainxf_acc_patch (begp:endp)) + this%matrix_ctransfer_grainst_to_grainxf_acc_patch (:) = nan + allocate(this%matrix_ctransfer_grainxf_to_grain_acc_patch (begp:endp)) + this%matrix_ctransfer_grainxf_to_grain_acc_patch (:) = nan + allocate(this%matrix_ctransfer_livestem_to_deadstem_acc_patch (begp:endp)) + this%matrix_ctransfer_livestem_to_deadstem_acc_patch (:) = nan + allocate(this%matrix_ctransfer_livecroot_to_deadcroot_acc_patch (begp:endp)) + this%matrix_ctransfer_livecroot_to_deadcroot_acc_patch (:) = nan + + allocate(this%matrix_cturnover_leaf_acc_patch (begp:endp)) ; this%matrix_cturnover_leaf_acc_patch (:) = nan + allocate(this%matrix_cturnover_leafst_acc_patch (begp:endp)) ; this%matrix_cturnover_leafst_acc_patch (:) = nan + allocate(this%matrix_cturnover_leafxf_acc_patch (begp:endp)) ; this%matrix_cturnover_leafxf_acc_patch (:) = nan + allocate(this%matrix_cturnover_froot_acc_patch (begp:endp)) ; this%matrix_cturnover_froot_acc_patch (:) = nan + allocate(this%matrix_cturnover_frootst_acc_patch (begp:endp)) ; this%matrix_cturnover_frootst_acc_patch (:) = nan + allocate(this%matrix_cturnover_frootxf_acc_patch (begp:endp)) ; this%matrix_cturnover_frootxf_acc_patch (:) = nan + allocate(this%matrix_cturnover_livestem_acc_patch (begp:endp)) ; this%matrix_cturnover_livestem_acc_patch (:) = nan + allocate(this%matrix_cturnover_livestemst_acc_patch (begp:endp)) ; this%matrix_cturnover_livestemst_acc_patch (:) = nan + allocate(this%matrix_cturnover_livestemxf_acc_patch (begp:endp)) ; this%matrix_cturnover_livestemxf_acc_patch (:) = nan + allocate(this%matrix_cturnover_deadstem_acc_patch (begp:endp)) ; this%matrix_cturnover_deadstem_acc_patch (:) = nan + allocate(this%matrix_cturnover_deadstemst_acc_patch (begp:endp)) ; this%matrix_cturnover_deadstemst_acc_patch (:) = nan + allocate(this%matrix_cturnover_deadstemxf_acc_patch (begp:endp)) ; this%matrix_cturnover_deadstemxf_acc_patch (:) = nan + allocate(this%matrix_cturnover_livecroot_acc_patch (begp:endp)) ; this%matrix_cturnover_livecroot_acc_patch (:) = nan + allocate(this%matrix_cturnover_livecrootst_acc_patch (begp:endp)) ; this%matrix_cturnover_livecrootst_acc_patch (:) = nan + allocate(this%matrix_cturnover_livecrootxf_acc_patch (begp:endp)) ; this%matrix_cturnover_livecrootxf_acc_patch (:) = nan + allocate(this%matrix_cturnover_deadcroot_acc_patch (begp:endp)) ; this%matrix_cturnover_deadcroot_acc_patch (:) = nan + allocate(this%matrix_cturnover_deadcrootst_acc_patch (begp:endp)) ; this%matrix_cturnover_deadcrootst_acc_patch (:) = nan + allocate(this%matrix_cturnover_deadcrootxf_acc_patch (begp:endp)) ; this%matrix_cturnover_deadcrootxf_acc_patch (:) = nan + allocate(this%matrix_cturnover_grain_acc_patch (begp:endp)) ; this%matrix_cturnover_grain_acc_patch (:) = nan + allocate(this%matrix_cturnover_grainst_acc_patch (begp:endp)) ; this%matrix_cturnover_grainst_acc_patch (:) = nan + allocate(this%matrix_cturnover_grainxf_acc_patch (begp:endp)) ; this%matrix_cturnover_grainxf_acc_patch (:) = nan + end if + + allocate(this%cropseedc_deficit_patch (begp:endp)) ; this%cropseedc_deficit_patch (:) = nan + allocate(this%seedc_grc (begg:endg)) ; this%seedc_grc (:) = nan + allocate(this%rootc_col (begc:endc)) ; this%rootc_col (:) = nan + allocate(this%leafc_col (begc:endc)) ; this%leafc_col (:) = nan + allocate(this%deadstemc_col (begc:endc)) ; this%deadstemc_col (:) = nan + allocate(this%fuelc_col (begc:endc)) ; this%fuelc_col (:) = nan + allocate(this%fuelc_crop_col (begc:endc)) ; this%fuelc_crop_col (:) = nan + + allocate(this%totvegc_patch (begp:endp)) ; this%totvegc_patch (:) = spval + allocate(this%totvegc_col (begc:endc)) ; this%totvegc_col (:) = nan + + allocate(this%totc_p2c_col (begc:endc)) ; this%totc_p2c_col (:) = nan + allocate(this%totc_col (begc:endc)) ; this%totc_col (:) = spval + allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan + allocate(this%totc_grc (begg:endg)) ; this%totc_grc (:) = nan + + ! initialize variables from restart file or set to cold start value + n = 0 + np = 0 + do nc = 1,nch ! catchment tile loop + + this%seedc_grc(nc) = 0. + + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + this%totvegc_col(n) = cncol(nc,nz, 6) + this%seedc_grc (nc) = this%seedc_grc(nc) + cncol(nc,nz,9)*CN_zone_weight(nz) + this%totc_col (n) = cncol(nc,nz,14) + + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + + ! "old" variables: CNCLM45 and before + this%cpool_patch (np) = cnpft(nc,nz,nv, 1) + this%deadcrootc_patch (np) = cnpft(nc,nz,nv, 2) + this%deadcrootc_storage_patch(np) = cnpft(nc,nz,nv, 3) + this%deadcrootc_xfer_patch (np) = cnpft(nc,nz,nv, 4) + this%deadstemc_patch (np) = cnpft(nc,nz,nv, 5) + this%deadstemc_storage_patch (np) = cnpft(nc,nz,nv, 6) + this%deadstemc_xfer_patch (np) = cnpft(nc,nz,nv, 7) + this%frootc_patch (np) = cnpft(nc,nz,nv, 8) + this%frootc_storage_patch (np) = cnpft(nc,nz,nv, 9) + this%frootc_xfer_patch (np) = cnpft(nc,nz,nv, 10) + this%gresp_storage_patch (np) = cnpft(nc,nz,nv, 11) + this%gresp_xfer_patch (np) = cnpft(nc,nz,nv, 12) + this%leafc_patch (np) = cnpft(nc,nz,nv, 13) + this%leafc_storage_patch (np) = cnpft(nc,nz,nv, 14) + this%leafc_xfer_patch (np) = cnpft(nc,nz,nv, 15) + this%livecrootc_patch (np) = cnpft(nc,nz,nv, 16) + this%livecrootc_storage_patch(np) = cnpft(nc,nz,nv, 17) + this%livecrootc_xfer_patch (np) = cnpft(nc,nz,nv, 18) + this%livestemc_patch (np) = cnpft(nc,nz,nv, 19) + this%livestemc_storage_patch (np) = cnpft(nc,nz,nv, 20) + this%livestemc_xfer_patch (np) = cnpft(nc,nz,nv, 21) + this%ctrunc_patch (np) = cnpft(nc,nz,nv, 22) + this%xsmrpool_patch (np) = cnpft(nc,nz,nv, 23) + + this%totvegc_patch (np) = & + this%leafc_patch(np) + & + this%leafc_storage_patch(np) + & + this%leafc_xfer_patch(np) + & + this%frootc_patch(np) + & + this%frootc_storage_patch(np) + & + this%frootc_xfer_patch(np) + & + this%livestemc_patch(np) + & + this%livestemc_storage_patch(np) + & + this%livestemc_xfer_patch(np) + & + this%deadstemc_patch(np) + & + this%deadstemc_storage_patch(np) + & + this%deadstemc_xfer_patch(np) + & + this%livecrootc_patch(np) + & + this%livecrootc_storage_patch(np) + & + this%livecrootc_xfer_patch(np) + & + this%deadcrootc_patch(np) + & + this%deadcrootc_storage_patch(np) + & + this%deadcrootc_xfer_patch(np) + & + this%gresp_storage_patch(np) + & + this%gresp_xfer_patch(np) + & + this%cpool_patch(np) + + end if + end do !nv + end do ! p + end do ! nz + end do ! nc + + call this%InitReadNML ( NLFilename ) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitReadNML(this, NLFilename) + ! + ! !DESCRIPTION: + ! Read the namelist for CNVegCarbonState + ! + !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + ! + ! !ARGUMENTS: + class(cnveg_carbonstate_type) :: this + character(len=*) , intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'InitReadNML' + character(len=*), parameter :: nmlname = 'cnvegcarbonstate' ! MUST match what is in namelist below + !----------------------------------------------------------------------- + real(r8) :: initial_vegC + namelist /cnvegcarbonstate/ initial_vegC + + initial_vegC = cnvegcstate_const%initial_vegC + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=cnvegcarbonstate, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (initial_vegC , mpicom) + + cnvegcstate_const%initial_vegC = initial_vegC + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=cnvegcarbonstate) ! Name here MUST be the same as in nmlname above! + write(iulog,*) ' ' + end if + + !----------------------------------------------------------------------- + end subroutine InitReadNML + + !----------------------------------------------------------------------- + subroutine Summary_carbonstate(this, bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + soilbiogeochem_cwdc_col, soilbiogeochem_totlitc_col, soilbiogeochem_totsomc_col, & + soilbiogeochem_ctrunc_col) + ! + ! !USES: + use subgridAveMod, only : p2c + use clm_time_manager , only : get_nstep + + ! + ! !DESCRIPTION: + ! Perform patch and column-level carbon summary calculations + ! + ! !ARGUMENTS: + class(cnveg_carbonstate_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all active columns + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + real(r8) , intent(in) :: soilbiogeochem_cwdc_col(bounds%begc:) + real(r8) , intent(in) :: soilbiogeochem_totlitc_col(bounds%begc:) + real(r8) , intent(in) :: soilbiogeochem_totsomc_col(bounds%begc:) + real(r8) , intent(in) :: soilbiogeochem_ctrunc_col(bounds%begc:) + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,k,l ! indices + integer :: fp,fc ! lake filter indices + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(soilbiogeochem_cwdc_col) == (/bounds%endc/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(soilbiogeochem_totlitc_col) == (/bounds%endc/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(soilbiogeochem_totsomc_col) == (/bounds%endc/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(soilbiogeochem_ctrunc_col) == (/bounds%endc/)), sourcefile, __LINE__) + + ! calculate patch -level summary of carbon state + + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! displayed vegetation carbon, excluding storage and cpool (DISPVEGC) + this%dispvegc_patch(p) = & + this%leafc_patch(p) + & + this%frootc_patch(p) + & + this%livestemc_patch(p) + & + this%deadstemc_patch(p) + & + this%livecrootc_patch(p) + & + this%deadcrootc_patch(p) + + ! stored vegetation carbon, excluding cpool (STORVEGC) + this%storvegc_patch(p) = & + this%cpool_patch(p) + & + this%leafc_storage_patch(p) + & + this%frootc_storage_patch(p) + & + this%livestemc_storage_patch(p) + & + this%deadstemc_storage_patch(p) + & + this%livecrootc_storage_patch(p) + & + this%deadcrootc_storage_patch(p) + & + this%leafc_xfer_patch(p) + & + this%frootc_xfer_patch(p) + & + this%livestemc_xfer_patch(p) + & + this%deadstemc_xfer_patch(p) + & + this%livecrootc_xfer_patch(p) + & + this%deadcrootc_xfer_patch(p) + & + this%gresp_storage_patch(p) + & + this%gresp_xfer_patch(p) + + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%storvegc_patch(p) = & + this%storvegc_patch(p) + & + this%grainc_storage_patch(p) + & + this%grainc_xfer_patch(p) + + this%dispvegc_patch(p) = & + this%dispvegc_patch(p) + & + this%grainc_patch(p) + end if + + ! total vegetation carbon, excluding cpool (TOTVEGC) + this%totvegc_patch(p) = & + this%dispvegc_patch(p) + & + this%storvegc_patch(p) + + ! total patch-level carbon, including xsmrpool, ctrunc + this%totc_patch(p) = & + this%totvegc_patch(p) + & + this%xsmrpool_patch(p) + & + this%ctrunc_patch(p) + + if (use_crop) then + this%totc_patch(p) = this%totc_patch(p) + this%cropseedc_deficit_patch(p) + & + this%xsmrpool_loss_patch(p) + end if + + ! (WOODC) - wood C + this%woodc_patch(p) = & + this%deadstemc_patch(p) + & + this%livestemc_patch(p) + & + this%deadcrootc_patch(p) + & + this%livecrootc_patch(p) + + end do + + ! -------------------------------------------- + ! column level summary + ! -------------------------------------------- + + call p2c(bounds, num_soilc, filter_soilc, & + this%totvegc_patch(bounds%begp:bounds%endp), & + this%totvegc_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + this%totc_patch(bounds%begp:bounds%endp), & + this%totc_p2c_col(bounds%begc:bounds%endc)) + + do fc = 1,num_allc + c = filter_allc(fc) + + ! total ecosystem carbon, including veg but excluding cpool (TOTECOSYSC) + this%totecosysc_col(c) = & + soilbiogeochem_cwdc_col(c) + & + soilbiogeochem_totlitc_col(c) + & + soilbiogeochem_totsomc_col(c) + & + this%totvegc_col(c) + + ! total column carbon, including veg and cpool (TOTCOLC) + this%totc_col(c) = this%totc_p2c_col(c) + & + soilbiogeochem_cwdc_col(c) + & + soilbiogeochem_totlitc_col(c) + & + soilbiogeochem_totsomc_col(c) + & + soilbiogeochem_ctrunc_col(c) + + end do + + end subroutine Summary_carbonstate + + !----------------------------------------------------------------------- + subroutine ZeroDwt( this, bounds ) + ! + ! !DESCRIPTION + ! Initialize variables needed for dynamic land use. + ! + ! !ARGUMENTS: + class(cnveg_carbonstate_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p ! indices + !----------------------------------------------------------------------- + + do p = bounds%begp,bounds%endp + this%dispvegc_patch(p) = 0._r8 + this%storvegc_patch(p) = 0._r8 + this%totc_patch(p) = 0._r8 + end do + + end subroutine ZeroDwt + +end module CNVegCarbonStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegNitrogenFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegNitrogenFluxType.F90 new file mode 100755 index 000000000..b7d31f842 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegNitrogenFluxType.F90 @@ -0,0 +1,1432 @@ +module CNVegNitrogenFluxType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use decompMod , only : bounds_type + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools + use clm_varpar , only : nlevdecomp_full, nlevgrnd,nlevdecomp + use clm_varpar , only : nlevdecomp_full, nlevdecomp,nvegnpool,& + nnphtrans,nngmtrans,nnfitrans,nnphouttrans,& + nngmouttrans,nnfiouttrans + use clm_varpar , only : ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,& + igrain,igrain_st,igrain_xf,iretransn,ioutn + use clm_varpar , only : numpft, num_zon, num_veg, & + var_col, var_pft, CN_zone_weight + use clm_varcon , only : spval, ispval, dzsoi_decomp + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_crop, use_matrixcn + use PatchType , only : patch + use CNSharedParamsMod , only : use_fun + use LandunitType , only : lun + use landunit_varcon , only : istsoil, istcrop + + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: cnveg_nitrogenflux_type + + ! gap mortality fluxes + real(r8), pointer :: m_leafn_to_litter_patch (:) ! patch leaf N mortality (gN/m2/s) + real(r8), pointer :: m_frootn_to_litter_patch (:) ! patch fine root N mortality (gN/m2/s) + real(r8), pointer :: m_leafn_storage_to_litter_patch (:) ! patch leaf N storage mortality (gN/m2/s) + real(r8), pointer :: m_frootn_storage_to_litter_patch (:) ! patch fine root N storage mortality (gN/m2/s) + real(r8), pointer :: m_livestemn_storage_to_litter_patch (:) ! patch live stem N storage mortality (gN/m2/s) + real(r8), pointer :: m_deadstemn_storage_to_litter_patch (:) ! patch dead stem N storage mortality (gN/m2/s) + real(r8), pointer :: m_livecrootn_storage_to_litter_patch (:) ! patch live coarse root N storage mortality (gN/m2/s) + real(r8), pointer :: m_deadcrootn_storage_to_litter_patch (:) ! patch dead coarse root N storage mortality (gN/m2/s) + real(r8), pointer :: m_leafn_xfer_to_litter_patch (:) ! patch leaf N transfer mortality (gN/m2/s) + real(r8), pointer :: m_frootn_xfer_to_litter_patch (:) ! patch fine root N transfer mortality (gN/m2/s) + real(r8), pointer :: m_livestemn_xfer_to_litter_patch (:) ! patch live stem N transfer mortality (gN/m2/s) + real(r8), pointer :: m_deadstemn_xfer_to_litter_patch (:) ! patch dead stem N transfer mortality (gN/m2/s) + real(r8), pointer :: m_livecrootn_xfer_to_litter_patch (:) ! patch live coarse root N transfer mortality (gN/m2/s) + real(r8), pointer :: m_deadcrootn_xfer_to_litter_patch (:) ! patch dead coarse root N transfer mortality (gN/m2/s) + real(r8), pointer :: m_livestemn_to_litter_patch (:) ! patch live stem N mortality (gN/m2/s) + real(r8), pointer :: m_deadstemn_to_litter_patch (:) ! patch dead stem N mortality (gN/m2/s) + real(r8), pointer :: m_livecrootn_to_litter_patch (:) ! patch live coarse root N mortality (gN/m2/s) + real(r8), pointer :: m_deadcrootn_to_litter_patch (:) ! patch dead coarse root N mortality (gN/m2/s) + real(r8), pointer :: m_retransn_to_litter_patch (:) ! patch retranslocated N pool mortality (gN/m2/s) + + ! harvest fluxes + real(r8), pointer :: hrv_leafn_to_litter_patch (:) ! patch leaf N harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_frootn_to_litter_patch (:) ! patch fine root N harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_leafn_storage_to_litter_patch (:) ! patch leaf N storage harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_frootn_storage_to_litter_patch (:) ! patch fine root N storage harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_livestemn_storage_to_litter_patch (:) ! patch live stem N storage harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_deadstemn_storage_to_litter_patch (:) ! patch dead stem N storage harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_livecrootn_storage_to_litter_patch (:) ! patch live coarse root N storage harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_deadcrootn_storage_to_litter_patch (:) ! patch dead coarse root N storage harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_leafn_xfer_to_litter_patch (:) ! patch leaf N transfer harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_frootn_xfer_to_litter_patch (:) ! patch fine root N transfer harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_livestemn_xfer_to_litter_patch (:) ! patch live stem N transfer harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_deadstemn_xfer_to_litter_patch (:) ! patch dead stem N transfer harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_livecrootn_xfer_to_litter_patch (:) ! patch live coarse root N transfer harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_deadcrootn_xfer_to_litter_patch (:) ! patch dead coarse root N transfer harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_livestemn_to_litter_patch (:) ! patch live stem N harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_livecrootn_to_litter_patch (:) ! patch live coarse root N harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_deadcrootn_to_litter_patch (:) ! patch dead coarse root N harvest mortality (gN/m2/s) + real(r8), pointer :: hrv_retransn_to_litter_patch (:) ! patch retranslocated N pool harvest mortality (gN/m2/s) + real(r8), pointer :: grainn_to_cropprodn_patch (:) ! patch grain N to crop product pool (gN/m2/s) + real(r8), pointer :: grainn_to_cropprodn_col (:) ! col grain N to crop product pool (gN/m2/s) + real(r8), pointer :: m_n_to_litr_met_fire_col (:,:) ! col N from leaf, froot, xfer and storage N to litter labile N by fire (gN/m3/s) + real(r8), pointer :: m_n_to_litr_cel_fire_col (:,:) ! col N from leaf, froot, xfer and storage N to litter cellulose N by fire (gN/m3/s) + real(r8), pointer :: m_n_to_litr_lig_fire_col (:,:) ! col N from leaf, froot, xfer and storage N to litter lignin N by fire (gN/m3/s) + real(r8), pointer :: harvest_n_to_litr_met_n_col (:,:) ! col N fluxes associated with harvest to litter metabolic pool (gN/m3/s) + real(r8), pointer :: harvest_n_to_litr_cel_n_col (:,:) ! col N fluxes associated with harvest to litter cellulose pool (gN/m3/s) + real(r8), pointer :: harvest_n_to_litr_lig_n_col (:,:) ! col N fluxes associated with harvest to litter lignin pool (gN/m3/s) + real(r8), pointer :: harvest_n_to_cwdn_col (:,:) ! col N fluxes associated with harvest to CWD pool (gN/m3/s) + + ! fire N fluxes + real(r8), pointer :: m_decomp_npools_to_fire_vr_col (:,:,:) ! col vertically-resolved decomposing N fire loss (gN/m3/s) + real(r8), pointer :: m_decomp_npools_to_fire_col (:,:) ! col vertically-integrated (diagnostic) decomposing N fire loss (gN/m2/s) + real(r8), pointer :: m_leafn_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from leafn + real(r8), pointer :: m_leafn_storage_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from leafn_storage + real(r8), pointer :: m_leafn_xfer_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from leafn_xfer + real(r8), pointer :: m_livestemn_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from livestemn + real(r8), pointer :: m_livestemn_storage_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from livestemn_storage + real(r8), pointer :: m_livestemn_xfer_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from livestemn_xfer + real(r8), pointer :: m_deadstemn_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from deadstemn + real(r8), pointer :: m_deadstemn_storage_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from deadstemn_storage + real(r8), pointer :: m_deadstemn_xfer_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from deadstemn_xfer + real(r8), pointer :: m_frootn_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from frootn + real(r8), pointer :: m_frootn_storage_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from frootn_storage + real(r8), pointer :: m_frootn_xfer_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from frootn_xfer + real(r8), pointer :: m_livecrootn_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from m_livecrootn_to_fire + real(r8), pointer :: m_livecrootn_storage_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from livecrootn_storage + real(r8), pointer :: m_livecrootn_xfer_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from livecrootn_xfer + real(r8), pointer :: m_deadcrootn_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from deadcrootn + real(r8), pointer :: m_deadcrootn_storage_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from deadcrootn_storage + real(r8), pointer :: m_deadcrootn_xfer_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from deadcrootn_xfer + real(r8), pointer :: m_retransn_to_fire_patch (:) ! patch (gN/m2/s) fire N emissions from retransn + real(r8), pointer :: m_leafn_to_litter_fire_patch (:) ! patch (gN/m2/s) from leafn to litter N due to fire + real(r8), pointer :: m_leafn_storage_to_litter_fire_patch (:) ! patch (gN/m2/s) from leafn_storage to litter N due to fire + real(r8), pointer :: m_leafn_xfer_to_litter_fire_patch (:) ! patch (gN/m2/s) from leafn_xfer to litter N due to fire + real(r8), pointer :: m_livestemn_to_litter_fire_patch (:) ! patch (gN/m2/s) from livestemn to litter N due to fire + real(r8), pointer :: m_livestemn_storage_to_litter_fire_patch (:) ! patch (gN/m2/s) from livestemn_storage to litter N due to fire + real(r8), pointer :: m_livestemn_xfer_to_litter_fire_patch (:) ! patch (gN/m2/s) from livestemn_xfer to litter N due to fire + real(r8), pointer :: m_livestemn_to_deadstemn_fire_patch (:) ! patch (gN/m2/s) from livestemn to deadstemn N due to fire + real(r8), pointer :: m_deadstemn_to_litter_fire_patch (:) ! patch (gN/m2/s) from deadstemn to litter N due to fire + real(r8), pointer :: m_deadstemn_storage_to_litter_fire_patch (:) ! patch (gN/m2/s) from deadstemn_storage to litter N due to fire + real(r8), pointer :: m_deadstemn_xfer_to_litter_fire_patch (:) ! patch (gN/m2/s) from deadstemn_xfer to litter N due to fire + real(r8), pointer :: m_frootn_to_litter_fire_patch (:) ! patch (gN/m2/s) from frootn to litter N due to fire + real(r8), pointer :: m_frootn_storage_to_litter_fire_patch (:) ! patch (gN/m2/s) from frootn_storage to litter N due to fire + real(r8), pointer :: m_frootn_xfer_to_litter_fire_patch (:) ! patch (gN/m2/s) from frootn_xfer to litter N due to fire + real(r8), pointer :: m_livecrootn_to_litter_fire_patch (:) ! patch (gN/m2/s) from livecrootn to litter N due to fire + real(r8), pointer :: m_livecrootn_storage_to_litter_fire_patch (:) ! patch (gN/m2/s) from livecrootn_storage to litter N due to fire + real(r8), pointer :: m_livecrootn_xfer_to_litter_fire_patch (:) ! patch (gN/m2/s) from livecrootn_xfer to litter N due to fire + real(r8), pointer :: m_livecrootn_to_deadcrootn_fire_patch (:) ! patch (gN/m2/s) from livecrootn_xfer to deadcrootn due to fire + real(r8), pointer :: m_deadcrootn_to_litter_fire_patch (:) ! patch (gN/m2/s) from deadcrootn to deadcrootn due to fire + real(r8), pointer :: m_deadcrootn_storage_to_litter_fire_patch (:) ! patch (gN/m2/s) from deadcrootn_storage to deadcrootn due to fire + real(r8), pointer :: m_deadcrootn_xfer_to_litter_fire_patch (:) ! patch (gN/m2/s) from deadcrootn_xfer to deadcrootn due to fire + real(r8), pointer :: m_retransn_to_litter_fire_patch (:) ! patch (gN/m2/s) from retransn to deadcrootn due to fire + real(r8), pointer :: fire_nloss_patch (:) ! patch total patch-level fire N loss (gN/m2/s) + real(r8), pointer :: fire_nloss_col (:) ! col total column-level fire N loss (gN/m2/s) + real(r8), pointer :: fire_nloss_p2c_col (:) ! col patch2col column-level fire N loss (gN/m2/s) (p2c) + real(r8), pointer :: fire_mortality_n_to_cwdn_col (:,:) ! col N fluxes associated with fire mortality to CWD pool (gN/m3/s) + + ! phenology fluxes from transfer pool + real(r8), pointer :: grainn_xfer_to_grainn_patch (:) ! patch grain N growth from storage for prognostic crop model (gN/m2/s) + real(r8), pointer :: leafn_xfer_to_leafn_patch (:) ! patch leaf N growth from storage (gN/m2/s) + real(r8), pointer :: frootn_xfer_to_frootn_patch (:) ! patch fine root N growth from storage (gN/m2/s) + real(r8), pointer :: livestemn_xfer_to_livestemn_patch (:) ! patch live stem N growth from storage (gN/m2/s) + real(r8), pointer :: deadstemn_xfer_to_deadstemn_patch (:) ! patch dead stem N growth from storage (gN/m2/s) + real(r8), pointer :: livecrootn_xfer_to_livecrootn_patch (:) ! patch live coarse root N growth from storage (gN/m2/s) + real(r8), pointer :: deadcrootn_xfer_to_deadcrootn_patch (:) ! patch dead coarse root N growth from storage (gN/m2/s) + + ! litterfall fluxes + real(r8), pointer :: livestemn_to_litter_patch (:) ! patch livestem N to litter (gN/m2/s) + real(r8), pointer :: grainn_to_food_patch (:) ! patch grain N to food for prognostic crop (gN/m2/s) + real(r8), pointer :: leafn_to_biofueln_patch (:) ! patch leaf N to biofuel N (gN/m2/s) + real(r8), pointer :: livestemn_to_biofueln_patch (:) ! patch livestem N to biofuel N (gN/m2/s) + real(r8), pointer :: grainn_to_seed_patch (:) ! patch grain N to seed for prognostic crop (gN/m2/s) + real(r8), pointer :: leafn_to_litter_patch (:) ! patch leaf N litterfall (gN/m2/s) + real(r8), pointer :: leafn_to_retransn_patch (:) ! patch leaf N to retranslocated N pool (gN/m2/s) + real(r8), pointer :: frootn_to_retransn_patch (:) ! patch fine root N to retranslocated N pool (gN/m2/s) + real(r8), pointer :: frootn_to_litter_patch (:) ! patch fine root N litterfall (gN/m2/s) + + ! allocation fluxes + real(r8), pointer :: retransn_to_npool_patch (:) ! patch deployment of retranslocated N (gN/m2/s) + real(r8), pointer :: free_retransn_to_npool_patch (:) ! patch deployment of free retranslocated N (gN/m2/s) + real(r8), pointer :: sminn_to_npool_patch (:) ! patch deployment of soil mineral N uptake (gN/m2/s) + real(r8), pointer :: npool_to_grainn_patch (:) ! patch allocation to grain N for prognostic crop (gN/m2/s) + real(r8), pointer :: npool_to_grainn_storage_patch (:) ! patch allocation to grain N storage for prognostic crop (gN/m2/s) + real(r8), pointer :: npool_to_leafn_patch (:) ! patch allocation to leaf N (gN/m2/s) + real(r8), pointer :: npool_to_leafn_storage_patch (:) ! patch allocation to leaf N storage (gN/m2/s) + real(r8), pointer :: npool_to_frootn_patch (:) ! patch allocation to fine root N (gN/m2/s) + real(r8), pointer :: npool_to_frootn_storage_patch (:) ! patch allocation to fine root N storage (gN/m2/s) + real(r8), pointer :: npool_to_livestemn_patch (:) ! patch allocation to live stem N (gN/m2/s) + real(r8), pointer :: npool_to_livestemn_storage_patch (:) ! patch allocation to live stem N storage (gN/m2/s) + real(r8), pointer :: npool_to_deadstemn_patch (:) ! patch allocation to dead stem N (gN/m2/s) + real(r8), pointer :: npool_to_deadstemn_storage_patch (:) ! patch allocation to dead stem N storage (gN/m2/s) + real(r8), pointer :: npool_to_livecrootn_patch (:) ! patch allocation to live coarse root N (gN/m2/s) + real(r8), pointer :: npool_to_livecrootn_storage_patch (:) ! patch allocation to live coarse root N storage (gN/m2/s) + real(r8), pointer :: npool_to_deadcrootn_patch (:) ! patch allocation to dead coarse root N (gN/m2/s) + real(r8), pointer :: npool_to_deadcrootn_storage_patch (:) ! patch allocation to dead coarse root N storage (gN/m2/s) + + ! annual turnover of storage to transfer pools + real(r8), pointer :: grainn_storage_to_xfer_patch (:) ! patch grain N shift storage to transfer for prognostic crop (gN/m2/s) + real(r8), pointer :: leafn_storage_to_xfer_patch (:) ! patch leaf N shift storage to transfer (gN/m2/s) + real(r8), pointer :: frootn_storage_to_xfer_patch (:) ! patch fine root N shift storage to transfer (gN/m2/s) + real(r8), pointer :: livestemn_storage_to_xfer_patch (:) ! patch live stem N shift storage to transfer (gN/m2/s) + real(r8), pointer :: deadstemn_storage_to_xfer_patch (:) ! patch dead stem N shift storage to transfer (gN/m2/s) + real(r8), pointer :: livecrootn_storage_to_xfer_patch (:) ! patch live coarse root N shift storage to transfer (gN/m2/s) + real(r8), pointer :: deadcrootn_storage_to_xfer_patch (:) ! patch dead coarse root N shift storage to transfer (gN/m2/s) + real(r8), pointer :: fert_patch (:) ! patch applied fertilizer (gN/m2/s) + real(r8), pointer :: fert_counter_patch (:) ! patch >0 fertilize; <=0 not + real(r8), pointer :: soyfixn_patch (:) ! patch soybean fixed N (gN/m2/s) + + ! turnover of livewood to deadwood, with retranslocation + real(r8), pointer :: livestemn_to_deadstemn_patch (:) ! patch live stem N turnover (gN/m2/s) + real(r8), pointer :: livestemn_to_retransn_patch (:) ! patch live stem N to retranslocated N pool (gN/m2/s) + real(r8), pointer :: livecrootn_to_deadcrootn_patch (:) ! patch live coarse root N turnover (gN/m2/s) + real(r8), pointer :: livecrootn_to_retransn_patch (:) ! patch live coarse root N to retranslocated N pool (gN/m2/s) + + ! summary (diagnostic) flux variables, not involved in mass balance + real(r8), pointer :: ndeploy_patch (:) ! patch total N deployed to growth and storage (gN/m2/s) + real(r8), pointer :: wood_harvestn_patch (:) ! patch total N losses to wood product pools (gN/m2/s) + real(r8), pointer :: wood_harvestn_col (:) ! col total N losses to wood product pools (gN/m2/s) (p2c) + ! phenology: litterfall and crop fluxes + real(r8), pointer :: phenology_n_to_litr_met_n_col (:,:) ! col N fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gN/m3/s) + real(r8), pointer :: phenology_n_to_litr_cel_n_col (:,:) ! col N fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gN/m3/s) + real(r8), pointer :: phenology_n_to_litr_lig_n_col (:,:) ! col N fluxes associated with phenology (litterfall and crop) to litter lignin pool (gN/m3/s) + + ! gap mortality fluxes + real(r8), pointer :: gap_mortality_n_to_litr_met_n_col (:,:) ! col N fluxes associated with gap mortality to litter metabolic pool (gN/m3/s) + real(r8), pointer :: gap_mortality_n_to_litr_cel_n_col (:,:) ! col N fluxes associated with gap mortality to litter cellulose pool (gN/m3/s) + real(r8), pointer :: gap_mortality_n_to_litr_lig_n_col (:,:) ! col N fluxes associated with gap mortality to litter lignin pool (gN/m3/s) + real(r8), pointer :: gap_mortality_n_to_cwdn_col (:,:) ! col N fluxes associated with gap mortality to CWD pool (gN/m3/s) + + ! dynamic landcover fluxes + real(r8), pointer :: dwt_seedn_to_leaf_patch (:) ! (gN/m2/s) seed source to patch-level; although this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_seedn_to_leaf_grc (:) ! (gN/m2/s) dwt_seedn_to_leaf_patch summed to the gridcell-level + real(r8), pointer :: dwt_seedn_to_deadstem_patch (:) ! (gN/m2/s) seed source to patch-level; although this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_seedn_to_deadstem_grc (:) ! (gN/m2/s) dwt_seedn_to_deadstem_patch summed to the gridcell-level + real(r8), pointer :: dwt_conv_nflux_patch (:) ! (gN/m2/s) conversion N flux (immediate loss to atm); although this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_conv_nflux_grc (:) ! (gN/m2/s) dwt_conv_nflux_patch summed to the gridcell-level + real(r8), pointer :: dwt_wood_productn_gain_patch (:) ! patch (gN/m2/s) addition to wood product pools from landcover change; even though this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_crop_productn_gain_patch (:) ! patch (gN/m2/s) addition to crop product pool from landcover change; even though this is a patch-level flux, it is expressed per unit GRIDCELL area + real(r8), pointer :: dwt_frootn_to_litr_met_n_col (:,:) ! col (gN/m3/s) fine root to litter due to landcover change + real(r8), pointer :: dwt_frootn_to_litr_cel_n_col (:,:) ! col (gN/m3/s) fine root to litter due to landcover change + real(r8), pointer :: dwt_frootn_to_litr_lig_n_col (:,:) ! col (gN/m3/s) fine root to litter due to landcover change + real(r8), pointer :: dwt_livecrootn_to_cwdn_col (:,:) ! col (gN/m3/s) live coarse root to CWD due to landcover change + real(r8), pointer :: dwt_deadcrootn_to_cwdn_col (:,:) ! col (gN/m3/s) dead coarse root to CWD due to landcover change + + ! crop fluxes + real(r8), pointer :: crop_seedn_to_leaf_patch (:) ! patch (gN/m2/s) seed source to leaf, for crops + + ! Misc + real(r8), pointer :: plant_ndemand_patch (:) ! N flux required to support initial GPP (gN/m2/s) + real(r8), pointer :: avail_retransn_patch (:) ! N flux available from retranslocation pool (gN/m2/s) + real(r8), pointer :: plant_nalloc_patch (:) ! total allocated N flux (gN/m2/s) + real(r8), pointer :: plant_ndemand_retrans_patch (:) ! The N demand pool generated for FUN2.0; mainly used for deciduous trees (gN/m2/s) + real(r8), pointer :: plant_ndemand_season_patch (:) ! The N demand pool for seasonal deciduous (gN/m2/s) + real(r8), pointer :: plant_ndemand_stress_patch (:) ! The N demand pool for stress deciduous (gN/m2/s) + real(r8), pointer :: Nactive_patch (:) ! N acquired by mycorrhizal uptake (gN/m2/s) + real(r8), pointer :: Nnonmyc_patch (:) ! N acquired by non-myc uptake (gN/m2/s) + real(r8), pointer :: Nam_patch (:) ! N acquired by AM plant (gN/m2/s) + real(r8), pointer :: Necm_patch (:) ! N acquired by ECM plant (gN/m2/s) + real(r8), pointer :: Nactive_no3_patch (:) ! N acquired by mycorrhizal uptake (gN/m2/s) + real(r8), pointer :: Nactive_nh4_patch (:) ! N acquired by mycorrhizal uptake (gN/m2/s) + real(r8), pointer :: Nnonmyc_no3_patch (:) ! N acquired by non-myc (gN/m2/s) + real(r8), pointer :: Nnonmyc_nh4_patch (:) ! N acquired by non-myc (gN/m2/s) + real(r8), pointer :: Nam_no3_patch (:) ! N acquired by AM plant (gN/m2/s) + real(r8), pointer :: Nam_nh4_patch (:) ! N acquired by AM plant (gN/m2/s) + real(r8), pointer :: Necm_no3_patch (:) ! N acquired by ECM plant (gN/m2/s) + real(r8), pointer :: Necm_nh4_patch (:) ! N acquired by ECM plant (gN/m2/s) + real(r8), pointer :: Nfix_patch (:) ! N acquired by Symbiotic BNF (gN/m2/s) + real(r8), pointer :: Npassive_patch (:) ! N acquired by passive uptake (gN/m2/s) + real(r8), pointer :: Nretrans_patch (:) ! N acquired by retranslocation (gN/m2/s) + real(r8), pointer :: Nretrans_org_patch (:) ! N acquired by retranslocation (gN/m2/s) + real(r8), pointer :: Nretrans_season_patch (:) ! N acquired by retranslocation (gN/m2/s) + real(r8), pointer :: Nretrans_stress_patch (:) ! N acquired by retranslocation (gN/m2/s) + real(r8), pointer :: Nuptake_patch (:) ! Total N uptake of FUN (gN/m2/s) + real(r8), pointer :: sminn_to_plant_fun_patch (:) ! Total soil N uptake of FUN (gN/m2/s) + real(r8), pointer :: sminn_to_plant_fun_vr_patch (:,:) ! Total layer soil N uptake of FUN (gN/m2/s) + real(r8), pointer :: sminn_to_plant_fun_no3_vr_patch (:,:) ! Total layer no3 uptake of FUN (gN/m2/s) + real(r8), pointer :: sminn_to_plant_fun_nh4_vr_patch (:,:) ! Total layer nh4 uptake of FUN (gN/m2/s) + real(r8), pointer :: cost_nfix_patch (:) ! Average cost of fixation (gN/m2/s) + real(r8), pointer :: cost_nactive_patch (:) ! Average cost of active uptake (gN/m2/s) + real(r8), pointer :: cost_nretrans_patch (:) ! Average cost of retranslocation (gN/m2/s) + real(r8), pointer :: nuptake_npp_fraction_patch (:) ! frac of npp spent on N acquisition (gN/m2/s) + ! Matrix + real(r8), pointer :: matrix_nalloc_patch (:,:) ! B-matrix for nitrogen allocation + real(r8), pointer :: matrix_Ninput_patch (:) ! I-matrix for nitrogen input + + real(r8), pointer :: matrix_nphtransfer_patch (:,:) ! A-matrix_phenologh for nitrogen + real(r8), pointer :: matrix_nphturnover_patch (:,:) ! K-matrix_phenologh for nitrogen + integer, pointer :: matrix_nphtransfer_doner_patch (:) ! A-matrix_phenology non-zero indices (column indices) for nitrogen + integer, pointer :: matrix_nphtransfer_receiver_patch (:) ! A-matrix_phenology non-zero indices (row indices) for nitrogen + + real(r8), pointer :: matrix_ngmtransfer_patch (:,:) ! A-matrix_gap mortality for nitrogen + real(r8), pointer :: matrix_ngmturnover_patch (:,:) ! K-matrix_gap mortality for nitrogen + integer, pointer :: matrix_ngmtransfer_doner_patch (:) ! A-matrix_gap mortality non-zero indices (column indices) for nitrogen + integer, pointer :: matrix_ngmtransfer_receiver_patch (:) ! A-matrix_gap mortality non-zero indices (row indices) for nitrogen + + real(r8), pointer :: matrix_nfitransfer_patch (:,:) ! A-matrix_fire for nitrogen + real(r8), pointer :: matrix_nfiturnover_patch (:,:) ! K-matrix_fire for nitrogen + integer, pointer :: matrix_nfitransfer_doner_patch (:) ! A-matrix_fire non-zero indices (column indices) for nitrogen + integer, pointer :: matrix_nfitransfer_receiver_patch (:) ! A-matrix_fire non-zero indices (row indices) for nitrogen + + integer ileafst_to_ileafxf_ph ! Index of phenology related N transfer from leaf storage pool to leaf transfer pool + integer ileafxf_to_ileaf_ph ! Index of phenology related N transfer from leaf transfer pool to leaf pool + integer ifrootst_to_ifrootxf_ph ! Index of phenology related N transfer from fine root storage pool to fine root transfer pool + integer ifrootxf_to_ifroot_ph ! Index of phenology related N transfer from fine root transfer pool to fine root pool + integer ilivestemst_to_ilivestemxf_ph ! Index of phenology related N transfer from live stem storage pool to live stem transfer pool + integer ilivestemxf_to_ilivestem_ph ! Index of phenology related N transfer from live stem transfer pool to live stem pool + integer ideadstemst_to_ideadstemxf_ph ! Index of phenology related N transfer from dead stem storage pool to dead stem transfer pool + integer ideadstemxf_to_ideadstem_ph ! Index of phenology related N transfer from dead stem transfer pool to dead stem pool + integer ilivecrootst_to_ilivecrootxf_ph ! Index of phenology related N transfer from live coarse root storage pool to live coarse root transfer pool + integer ilivecrootxf_to_ilivecroot_ph ! Index of phenology related N transfer from live coarse root transfer pool to live coarse root pool + integer ideadcrootst_to_ideadcrootxf_ph ! Index of phenology related N transfer from dead coarse root storage pool to dead coarse root transfer pool + integer ideadcrootxf_to_ideadcroot_ph ! Index of phenology related N transfer from dead coarse root transfer pool to dead coarse root pool + integer ilivestem_to_ideadstem_ph ! Index of phenology related N transfer from live stem pool to dead stem pool + integer ilivecroot_to_ideadcroot_ph ! Index of phenology related N transfer from live coarse root pool to dead coarse root pool + integer iretransn_to_ileaf_ph ! Index of phenology related N transfer from retranslocation pool to leaf pool + integer iretransn_to_ileafst_ph ! Index of phenology related N transfer from retranslocation pool to leaf storage pool + integer iretransn_to_ifroot_ph ! Index of phenology related N transfer from retranslocation pool to fine root pool + integer iretransn_to_ifrootst_ph ! Index of phenology related N transfer from retranslocation pool to fine root storage pool + integer iretransn_to_ilivestem_ph ! Index of phenology related N transfer from retranslocation pool to live stem pool + integer iretransn_to_ilivestemst_ph ! Index of phenology related N transfer from retranslocation pool to live stem storage pool + integer iretransn_to_ideadstem_ph ! Index of phenology related N transfer from retranslocation pool to dead stem pool + integer iretransn_to_ideadstemst_ph ! Index of phenology related N transfer from retranslocation pool to dead stem storage pool + integer iretransn_to_ilivecroot_ph ! Index of phenology related N transfer from retranslocation pool to live coarse root pool + integer iretransn_to_ilivecrootst_ph ! Index of phenology related N transfer from retranslocation pool to live coarse root storage pool + integer iretransn_to_ideadcroot_ph ! Index of phenology related N transfer from retranslocation pool to dead coarse root pool + integer iretransn_to_ideadcrootst_ph ! Index of phenology related N transfer from retranslocation pool to dead coarse root storage pool + integer iretransn_to_igrain_ph ! Index of phenology related N transfer from retranslocation pool to grain pool + integer iretransn_to_igrainst_ph ! Index of phenology related N transfer from retranslocation pool to grain storage pool + integer ileaf_to_iout_ph ! Index of phenology related N transfer from leaf pool to outside of vegetation pools + integer ifroot_to_iout_ph ! Index of phenology related N transfer from fine root pool to outside of vegetation pools + integer ilivestem_to_iout_ph ! Index of phenology related N transfer from live stem pool to outside of vegetation pools + integer ileaf_to_iretransn_ph ! Index of phenology related N transfer from leaf pool to retranslocation pools + integer ifroot_to_iretransn_ph ! Index of phenology related N transfer from fine root pool to retranslocation pools + integer ilivestem_to_iretransn_ph ! Index of phenology related N transfer from live stem pool to retranslocation pools + integer ilivecroot_to_iretransn_ph ! Index of phenology related N transfer from live coarse root pool to retranslocation pools + integer igrain_to_iout_ph ! Index of phenology related N transfer from grain pool to outside of vegetation pools + integer iretransn_to_iout_ph ! Index of phenology related N transfer from retranslocation pool to outside of vegetation pools + integer ileaf_to_iout_gm ! Index of gap mortality related N transfer from leaf pool to outside of vegetation pools + integer ileafst_to_iout_gm ! Index of gap mortality related N transfer from leaf storage pool to outside of vegetation pools + integer ileafxf_to_iout_gm ! Index of gap mortality related N transfer from leaf transfer pool to outside of vegetation pools + integer ifroot_to_iout_gm ! Index of gap mortality related N transfer from fine root pool to outside of vegetation pools + integer ifrootst_to_iout_gm ! Index of gap mortality related N transfer from fine root storage pool to outside of vegetation pools + integer ifrootxf_to_iout_gm ! Index of gap mortality related N transfer from fine root transfer pool to outside of vegetation pools + integer ilivestem_to_iout_gm ! Index of gap mortality related N transfer from live stem pool to outside of vegetation pools + integer ilivestemst_to_iout_gm ! Index of gap mortality related N transfer from live stem storage pool to outside of vegetation pools + integer ilivestemxf_to_iout_gm ! Index of gap mortality related N transfer from live stem transfer pool to outside of vegetation pools + integer ideadstem_to_iout_gm ! Index of gap mortality related N transfer from dead stem pool to outside of vegetation pools + integer ideadstemst_to_iout_gm ! Index of gap mortality related N transfer from dead stem storage pool to outside of vegetation pools + integer ideadstemxf_to_iout_gm ! Index of gap mortality related N transfer from dead stem transfer pool to outside of vegetation pools + integer ilivecroot_to_iout_gm ! Index of gap mortality related N transfer from live coarse root pool to outside of vegetation pools + integer ilivecrootst_to_iout_gm ! Index of gap mortality related N transfer from live coarse root storage pool to outside of vegetation pools + integer ilivecrootxf_to_iout_gm ! Index of gap mortality related N transfer from live coarse root transfer pool to outside of vegetation pools + integer ideadcroot_to_iout_gm ! Index of gap mortality related N transfer from dead coarse root pool to outside of vegetation pools + integer ideadcrootst_to_iout_gm ! Index of gap mortality related N transfer from dead coarse root storage pool to outside of vegetation pools + integer ideadcrootxf_to_iout_gm ! Index of gap mortality related N transfer from dead coarse root transfer pool to outside of vegetation pools + integer iretransn_to_iout_gm ! Index of gap mortality related N transfer from retranslocation to outside of vegetation pools + integer ileaf_to_iout_fi ! Index of fire related N transfer from leaf pool to outside of vegetation pools + integer ileafst_to_iout_fi ! Index of fire related N transfer from leaf storage pool to outside of vegetation pools + integer ileafxf_to_iout_fi ! Index of fire related N transfer from leaf transfer pool to outside of vegetation pools + integer ifroot_to_iout_fi ! Index of fire related N transfer from fine root pool to outside of vegetation pools + integer ifrootst_to_iout_fi ! Index of fire related N transfer from fine root storage pool to outside of vegetation pools + integer ifrootxf_to_iout_fi ! Index of fire related N transfer from fine root transfer pool to outside of vegetation pools + integer ilivestem_to_iout_fi ! Index of fire related N transfer from live stem pool to outside of vegetation pools + integer ilivestemst_to_iout_fi ! Index of fire related N transfer from live stem storage pool to outside of vegetation pools + integer ilivestemxf_to_iout_fi ! Index of fire related N transfer from live stem transfer pool to outside of vegetation pools + integer ideadstem_to_iout_fi ! Index of fire related N transfer from dead stem pool to outside of vegetation pools + integer ideadstemst_to_iout_fi ! Index of fire related N transfer from dead stem storage pool to outside of vegetation pools + integer ideadstemxf_to_iout_fi ! Index of fire related N transfer from dead stem transfer pool to outside of vegetation pools + integer ilivecroot_to_iout_fi ! Index of fire related N transfer from live coarse root pool to outside of vegetation pools + integer ilivecrootst_to_iout_fi ! Index of fire related N transfer from live coarse root storage pool to outside of vegetation pools + integer ilivecrootxf_to_iout_fi ! Index of fire related N transfer from live coarse root transfer pool to outside of vegetation pools + integer ideadcroot_to_iout_fi ! Index of fire related N transfer from dead coarse root pool to outside of vegetation pools + integer ideadcrootst_to_iout_fi ! Index of fire related N transfer from dead coarse root storage pool to outside of vegetation pools + integer ideadcrootxf_to_iout_fi ! Index of fire related N transfer from dead coarse root transfer pool to outside of vegetation pools + integer iretransn_to_iout_fi ! Index of fire related N transfer from retranslocation transfer pool to outside of vegetation pools + integer ilivestem_to_ideadstem_fi ! Index of fire related N transfer from live stem pool to dead stem pools + integer ilivecroot_to_ideadcroot_fi ! Index of fire related N transfer from live coarse root pool to dead coarse root pools + + integer,pointer :: list_phn_phgmn (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKphn to AKphn+AKgmn + integer,pointer :: list_gmn_phgmn (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKgmn to AKphn+AKgmn + integer,pointer :: list_phn_phgmfin (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKphn to AKphn+AKgmn+AKfin + integer,pointer :: list_gmn_phgmfin (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKgmn to AKphn+AKgmn+AKfin + integer,pointer :: list_fin_phgmfin (:) ! Index mapping for sparse matrix addition (save to reduce computational cost): from AKfin to AKphn+AKgmn+AKfin + integer,pointer :: list_aphn (:) ! Indices of non-diagnoal entries in full sparse matrix Aph for N cycle + integer,pointer :: list_agmn (:) ! Indices of non-diagnoal entries in full sparse matrix Agm for N cycle + integer,pointer :: list_afin (:) ! Indices of non-diagnoal entries in full sparse matrix Afi for N cycle + + contains + + procedure , public :: SetValues + procedure , public :: Summary => Summary_nitrogenflux + procedure , public :: ZeroDWT + procedure , public :: Init + + end type cnveg_nitrogenflux_type + +type(cnveg_nitrogenflux_type), public, target, save :: cnveg_nitrogenflux_inst + +contains + +!--------------------------------------- + subroutine Init(this, bounds, nch, ityp, fveg, cncol, cnpft) + +! !DESCRIPTION: +! Initialize CTSM nitrogen fluxes +! jk Apr 2021: type is allocated and initialized to NaN; +! if data arrays from restart file are passed (cncol and cnpft), the type is then initialized with these values +! +! !ARGUMENTS: + implicit none + + ! INPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: ityp ! PFT index + real, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: fveg ! PFT fraction + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + real, dimension(nch,NUM_ZON,NUM_VEG,VAR_PFT), intent(in) :: cnpft ! gkw: PFT CN restart + class(cnveg_nitrogenflux_type) :: this + + ! LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + integer :: np, nc, nz, p, nv, n, l, j + !-------------------------------- + + allocate(this%matrix_nphtransfer_doner_patch(1:37)) + allocate(this%matrix_nphtransfer_receiver_patch(1:37)) + + this%ileaf_to_iretransn_ph = 1 + this%matrix_nphtransfer_doner_patch(this%ileaf_to_iretransn_ph) = ileaf + this%matrix_nphtransfer_receiver_patch(this%ileaf_to_iretransn_ph) = iretransn + + this%ileafst_to_ileafxf_ph = 2 + this%matrix_nphtransfer_doner_patch(this%ileafst_to_ileafxf_ph) = ileaf_st + this%matrix_nphtransfer_receiver_patch(this%ileafst_to_ileafxf_ph) = ileaf_xf + + this%ileafxf_to_ileaf_ph = 3 + this%matrix_nphtransfer_doner_patch(this%ileafxf_to_ileaf_ph) = ileaf_xf + this%matrix_nphtransfer_receiver_patch(this%ileafxf_to_ileaf_ph) = ileaf + + this%ifroot_to_iretransn_ph = 4 + this%matrix_nphtransfer_doner_patch(this%ifroot_to_iretransn_ph) = ifroot + this%matrix_nphtransfer_receiver_patch(this%ifroot_to_iretransn_ph) = iretransn + + this%ifrootst_to_ifrootxf_ph = 5 + this%matrix_nphtransfer_doner_patch(this%ifrootst_to_ifrootxf_ph) = ifroot_st + this%matrix_nphtransfer_receiver_patch(this%ifrootst_to_ifrootxf_ph) = ifroot_xf + + this%ifrootxf_to_ifroot_ph = 6 + this%matrix_nphtransfer_doner_patch(this%ifrootxf_to_ifroot_ph) = ifroot_xf + this%matrix_nphtransfer_receiver_patch(this%ifrootxf_to_ifroot_ph) = ifroot + + this%ilivestem_to_ideadstem_ph = 7 + this%matrix_nphtransfer_doner_patch(this%ilivestem_to_ideadstem_ph) = ilivestem + this%matrix_nphtransfer_receiver_patch(this%ilivestem_to_ideadstem_ph) = ideadstem + + this%ilivestem_to_iretransn_ph = 8 + this%matrix_nphtransfer_doner_patch(this%ilivestem_to_iretransn_ph) = ilivestem + this%matrix_nphtransfer_receiver_patch(this%ilivestem_to_iretransn_ph) = iretransn + + this%ilivestemst_to_ilivestemxf_ph = 9 + this%matrix_nphtransfer_doner_patch(this%ilivestemst_to_ilivestemxf_ph) = ilivestem_st + this%matrix_nphtransfer_receiver_patch(this%ilivestemst_to_ilivestemxf_ph) = ilivestem_xf + + this%ilivestemxf_to_ilivestem_ph = 10 + this%matrix_nphtransfer_doner_patch(this%ilivestemxf_to_ilivestem_ph) = ilivestem_xf + this%matrix_nphtransfer_receiver_patch(this%ilivestemxf_to_ilivestem_ph) = ilivestem + + this%ideadstemst_to_ideadstemxf_ph = 11 + this%matrix_nphtransfer_doner_patch(this%ideadstemst_to_ideadstemxf_ph) = ideadstem_st + this%matrix_nphtransfer_receiver_patch(this%ideadstemst_to_ideadstemxf_ph) = ideadstem_xf + + this%ideadstemxf_to_ideadstem_ph = 12 + this%matrix_nphtransfer_doner_patch(this%ideadstemxf_to_ideadstem_ph) = ideadstem_xf + this%matrix_nphtransfer_receiver_patch(this%ideadstemxf_to_ideadstem_ph) = ideadstem + + this%ilivecroot_to_ideadcroot_ph = 13 + this%matrix_nphtransfer_doner_patch(this%ilivecroot_to_ideadcroot_ph) = ilivecroot + this%matrix_nphtransfer_receiver_patch(this%ilivecroot_to_ideadcroot_ph) = ideadcroot + + this%ilivecroot_to_iretransn_ph = 14 + this%matrix_nphtransfer_doner_patch(this%ilivecroot_to_iretransn_ph) = ilivecroot + this%matrix_nphtransfer_receiver_patch(this%ilivecroot_to_iretransn_ph) = iretransn + + this%ilivecrootst_to_ilivecrootxf_ph = 15 + this%matrix_nphtransfer_doner_patch(this%ilivecrootst_to_ilivecrootxf_ph) = ilivecroot_st + this%matrix_nphtransfer_receiver_patch(this%ilivecrootst_to_ilivecrootxf_ph) = ilivecroot_xf + + this%ilivecrootxf_to_ilivecroot_ph = 16 + this%matrix_nphtransfer_doner_patch(this%ilivecrootxf_to_ilivecroot_ph) = ilivecroot_xf + this%matrix_nphtransfer_receiver_patch(this%ilivecrootxf_to_ilivecroot_ph) = ilivecroot + + this%ideadcrootst_to_ideadcrootxf_ph = 17 + this%matrix_nphtransfer_doner_patch(this%ideadcrootst_to_ideadcrootxf_ph) = ideadcroot_st + this%matrix_nphtransfer_receiver_patch(this%ideadcrootst_to_ideadcrootxf_ph) = ideadcroot_xf + + this%ideadcrootxf_to_ideadcroot_ph = 18 + this%matrix_nphtransfer_doner_patch(this%ideadcrootxf_to_ideadcroot_ph) = ideadcroot_xf + this%matrix_nphtransfer_receiver_patch(this%ideadcrootxf_to_ideadcroot_ph) = ideadcroot + + this%iretransn_to_ileaf_ph = 19 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ileaf_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ileaf_ph) = ileaf + + this%iretransn_to_ileafst_ph = 20 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ileafst_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ileafst_ph) = ileaf_st + + this%iretransn_to_ifroot_ph = 21 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ifroot_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ifroot_ph) = ifroot + + this%iretransn_to_ifrootst_ph = 22 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ifrootst_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ifrootst_ph) = ifroot_st + this%iretransn_to_ilivestem_ph = 23 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ilivestem_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ilivestem_ph) = ilivestem + + this%iretransn_to_ilivestemst_ph = 24 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ilivestemst_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ilivestemst_ph) = ilivestem_st + + this%iretransn_to_ideadstem_ph = 25 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ideadstem_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ideadstem_ph) = ideadstem + + this%iretransn_to_ideadstemst_ph = 26 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ideadstemst_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ideadstemst_ph) = ideadstem_st + + this%iretransn_to_ilivecroot_ph = 27 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ilivecroot_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ilivecroot_ph) = ilivecroot + + this%iretransn_to_ilivecrootst_ph = 28 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ilivecrootst_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ilivecrootst_ph) = ilivecroot_st + + this%iretransn_to_ideadcroot_ph = 29 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ideadcroot_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ideadcroot_ph) = ideadcroot + + this%iretransn_to_ideadcrootst_ph = 30 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_ideadcrootst_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_ideadcrootst_ph) = ideadcroot_st + + if(.not. use_crop)then + this%ileaf_to_iout_ph = 31 + this%matrix_nphtransfer_doner_patch(this%ileaf_to_iout_ph) = ileaf + this%matrix_nphtransfer_receiver_patch(this%ileaf_to_iout_ph) = ioutn + + this%ifroot_to_iout_ph = 32 + this%matrix_nphtransfer_doner_patch(this%ifroot_to_iout_ph) = ifroot + this%matrix_nphtransfer_receiver_patch(this%ifroot_to_iout_ph) = ioutn + + this%ilivestem_to_iout_ph = 33 + this%matrix_nphtransfer_doner_patch(this%ilivestem_to_iout_ph) = ilivestem + this%matrix_nphtransfer_receiver_patch(this%ilivestem_to_iout_ph) = ioutn + + this%iretransn_to_iout_ph = 34 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_iout_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_iout_ph) = ioutn + else + this%iretransn_to_igrain_ph = 31 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_igrain_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_igrain_ph) = igrain + + this%iretransn_to_igrainst_ph = 32 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_igrainst_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_igrainst_ph) = igrain_st + + this%ileaf_to_iout_ph = 33 + this%matrix_nphtransfer_doner_patch(this%ileaf_to_iout_ph) = ileaf + this%matrix_nphtransfer_receiver_patch(this%ileaf_to_iout_ph) = ioutn + + this%ifroot_to_iout_ph = 34 + this%matrix_nphtransfer_doner_patch(this%ifroot_to_iout_ph) = ifroot + this%matrix_nphtransfer_receiver_patch(this%ifroot_to_iout_ph) = ioutn + + this%ilivestem_to_iout_ph = 35 + this%matrix_nphtransfer_doner_patch(this%ilivestem_to_iout_ph) = ilivestem + this%matrix_nphtransfer_receiver_patch(this%ilivestem_to_iout_ph) = ioutn + + this%igrain_to_iout_ph = 36 + this%matrix_nphtransfer_doner_patch(this%igrain_to_iout_ph) = igrain + this%matrix_nphtransfer_receiver_patch(this%igrain_to_iout_ph) = ioutn + + this%iretransn_to_iout_ph = 37 + this%matrix_nphtransfer_doner_patch(this%iretransn_to_iout_ph) = iretransn + this%matrix_nphtransfer_receiver_patch(this%iretransn_to_iout_ph) = ioutn + end if + + allocate(this%matrix_ngmtransfer_doner_patch(1:19)) + allocate(this%matrix_ngmtransfer_receiver_patch(1:19)) + + this%ileaf_to_iout_gm = 1 + this%matrix_ngmtransfer_doner_patch(this%ileaf_to_iout_gm) = ileaf + this%matrix_ngmtransfer_receiver_patch(this%ileaf_to_iout_gm) = ioutn + + this%ileafst_to_iout_gm = 2 + this%matrix_ngmtransfer_doner_patch(this%ileafst_to_iout_gm) = ileaf_st + this%matrix_ngmtransfer_receiver_patch(this%ileafst_to_iout_gm) = ioutn + + this%ileafxf_to_iout_gm = 3 + this%matrix_ngmtransfer_doner_patch(this%ileafxf_to_iout_gm) = ileaf_xf + this%matrix_ngmtransfer_receiver_patch(this%ileafxf_to_iout_gm) = ioutn + + this%ifroot_to_iout_gm = 4 + this%matrix_ngmtransfer_doner_patch(this%ifroot_to_iout_gm) = ifroot + this%matrix_ngmtransfer_receiver_patch(this%ifroot_to_iout_gm) = ioutn + + this%ifrootst_to_iout_gm = 5 + this%matrix_ngmtransfer_doner_patch(this%ifrootst_to_iout_gm) = ifroot_st + this%matrix_ngmtransfer_receiver_patch(this%ifrootst_to_iout_gm) = ioutn + + this%ifrootxf_to_iout_gm = 6 + this%matrix_ngmtransfer_doner_patch(this%ifrootxf_to_iout_gm) = ifroot_xf + this%matrix_ngmtransfer_receiver_patch(this%ifrootxf_to_iout_gm) = ioutn + + this%ilivestem_to_iout_gm = 7 + this%matrix_ngmtransfer_doner_patch(this%ilivestem_to_iout_gm) = ilivestem + this%matrix_ngmtransfer_receiver_patch(this%ilivestem_to_iout_gm) = ioutn + + this%ilivestemst_to_iout_gm = 8 + this%matrix_ngmtransfer_doner_patch(this%ilivestemst_to_iout_gm) = ilivestem_st + this%matrix_ngmtransfer_receiver_patch(this%ilivestemst_to_iout_gm) = ioutn + + this%ilivestemxf_to_iout_gm = 9 + this%matrix_ngmtransfer_doner_patch(this%ilivestemxf_to_iout_gm) = ilivestem_xf + this%matrix_ngmtransfer_receiver_patch(this%ilivestemxf_to_iout_gm) = ioutn + + this%ideadstem_to_iout_gm = 10 + this%matrix_ngmtransfer_doner_patch(this%ideadstem_to_iout_gm) = ideadstem + this%matrix_ngmtransfer_receiver_patch(this%ideadstem_to_iout_gm) = ioutn + + this%ideadstemst_to_iout_gm = 11 + this%matrix_ngmtransfer_doner_patch(this%ideadstemst_to_iout_gm) = ideadstem_st + this%matrix_ngmtransfer_receiver_patch(this%ideadstemst_to_iout_gm) = ioutn + + this%ideadstemxf_to_iout_gm = 12 + this%matrix_ngmtransfer_doner_patch(this%ideadstemxf_to_iout_gm) = ideadstem_xf + this%matrix_ngmtransfer_receiver_patch(this%ideadstemxf_to_iout_gm) = ioutn + + this%ilivecroot_to_iout_gm = 13 + this%matrix_ngmtransfer_doner_patch(this%ilivecroot_to_iout_gm) = ilivecroot + this%matrix_ngmtransfer_receiver_patch(this%ilivecroot_to_iout_gm) = ioutn + + this%ilivecrootst_to_iout_gm = 14 + this%matrix_ngmtransfer_doner_patch(this%ilivecrootst_to_iout_gm) = ilivecroot_st + this%matrix_ngmtransfer_receiver_patch(this%ilivecrootst_to_iout_gm) = ioutn + + + this%ilivecrootxf_to_iout_gm = 15 + this%matrix_ngmtransfer_doner_patch(this%ilivecrootxf_to_iout_gm) = ilivecroot_xf + this%matrix_ngmtransfer_receiver_patch(this%ilivecrootxf_to_iout_gm) = ioutn + + this%ideadcroot_to_iout_gm = 16 + this%matrix_ngmtransfer_doner_patch(this%ideadcroot_to_iout_gm) = ideadcroot + this%matrix_ngmtransfer_receiver_patch(this%ideadcroot_to_iout_gm) = ioutn + + this%ideadcrootst_to_iout_gm = 17 + this%matrix_ngmtransfer_doner_patch(this%ideadcrootst_to_iout_gm) = ideadcroot_st + this%matrix_ngmtransfer_receiver_patch(this%ideadcrootst_to_iout_gm) = ioutn + + this%ideadcrootxf_to_iout_gm = 18 + this%matrix_ngmtransfer_doner_patch(this%ideadcrootxf_to_iout_gm) = ideadcroot_xf + this%matrix_ngmtransfer_receiver_patch(this%ideadcrootxf_to_iout_gm) = ioutn + + this%iretransn_to_iout_gm = 19 + this%matrix_ngmtransfer_doner_patch(this%iretransn_to_iout_gm) = iretransn + this%matrix_ngmtransfer_receiver_patch(this%iretransn_to_iout_gm) = ioutn + + allocate(this%matrix_nfitransfer_doner_patch(1:21)) + allocate(this%matrix_nfitransfer_receiver_patch(1:21)) + + this%ilivestem_to_ideadstem_fi = 1 + this%matrix_nfitransfer_doner_patch(this%ilivestem_to_ideadstem_fi) = ilivestem + this%matrix_nfitransfer_receiver_patch(this%ilivestem_to_ideadstem_fi) = ideadstem + + this%ilivecroot_to_ideadcroot_fi = 2 + this%matrix_nfitransfer_doner_patch(this%ilivecroot_to_ideadcroot_fi) = ilivecroot + this%matrix_nfitransfer_receiver_patch(this%ilivecroot_to_ideadcroot_fi) = ideadcroot + + this%ileaf_to_iout_fi = 3 + this%matrix_nfitransfer_doner_patch(this%ileaf_to_iout_fi) = ileaf + this%matrix_nfitransfer_receiver_patch(this%ileaf_to_iout_fi) = ioutn + + this%ileafst_to_iout_fi = 4 + this%matrix_nfitransfer_doner_patch(this%ileafst_to_iout_fi) = ileaf_st + this%matrix_nfitransfer_receiver_patch(this%ileafst_to_iout_fi) = ioutn + + this%ileafxf_to_iout_fi = 5 + this%matrix_nfitransfer_doner_patch(this%ileafxf_to_iout_fi) = ileaf_xf + this%matrix_nfitransfer_receiver_patch(this%ileafxf_to_iout_fi) = ioutn + + this%ifroot_to_iout_fi = 6 + this%matrix_nfitransfer_doner_patch(this%ifroot_to_iout_fi) = ifroot + this%matrix_nfitransfer_receiver_patch(this%ifroot_to_iout_fi) = ioutn + + this%ifrootst_to_iout_fi = 7 + this%matrix_nfitransfer_doner_patch(this%ifrootst_to_iout_fi) = ifroot_st + this%matrix_nfitransfer_receiver_patch(this%ifrootst_to_iout_fi) = ioutn + + this%ifrootxf_to_iout_fi = 8 + this%matrix_nfitransfer_doner_patch(this%ifrootxf_to_iout_fi) = ifroot_xf + this%matrix_nfitransfer_receiver_patch(this%ifrootxf_to_iout_fi) = ioutn + + this%ilivestem_to_iout_fi = 9 + this%matrix_nfitransfer_doner_patch(this%ilivestem_to_iout_fi) = ilivestem + this%matrix_nfitransfer_receiver_patch(this%ilivestem_to_iout_fi) = ioutn + + this%ilivestemst_to_iout_fi = 10 + this%matrix_nfitransfer_doner_patch(this%ilivestemst_to_iout_fi) = ilivestem_st + this%matrix_nfitransfer_receiver_patch(this%ilivestemst_to_iout_fi) = ioutn + + this%ilivestemxf_to_iout_fi = 11 + this%matrix_nfitransfer_doner_patch(this%ilivestemxf_to_iout_fi) = ilivestem_xf + this%matrix_nfitransfer_receiver_patch(this%ilivestemxf_to_iout_fi) = ioutn + + this%ideadstem_to_iout_fi = 12 + this%matrix_nfitransfer_doner_patch(this%ideadstem_to_iout_fi) = ideadstem + this%matrix_nfitransfer_receiver_patch(this%ideadstem_to_iout_fi) = ioutn + + this%ideadstemst_to_iout_fi = 13 + this%matrix_nfitransfer_doner_patch(this%ideadstemst_to_iout_fi) = ideadstem_st + this%matrix_nfitransfer_receiver_patch(this%ideadstemst_to_iout_fi) = ioutn + + this%ideadstemxf_to_iout_fi = 14 + this%matrix_nfitransfer_doner_patch(this%ideadstemxf_to_iout_fi) = ideadstem_xf + this%matrix_nfitransfer_receiver_patch(this%ideadstemxf_to_iout_fi) = ioutn + + this%ilivecroot_to_iout_fi = 15 + this%matrix_nfitransfer_doner_patch(this%ilivecroot_to_iout_fi) = ilivecroot + this%matrix_nfitransfer_receiver_patch(this%ilivecroot_to_iout_fi) = ioutn + + this%ilivecrootst_to_iout_fi = 16 + this%matrix_nfitransfer_doner_patch(this%ilivecrootst_to_iout_fi) = ilivecroot_st + this%matrix_nfitransfer_receiver_patch(this%ilivecrootst_to_iout_fi) = ioutn + + this%ilivecrootxf_to_iout_fi = 17 + this%matrix_nfitransfer_doner_patch(this%ilivecrootxf_to_iout_fi) = ilivecroot_xf + this%matrix_nfitransfer_receiver_patch(this%ilivecrootxf_to_iout_fi) = ioutn + + + this%ideadcroot_to_iout_fi = 18 + this%matrix_nfitransfer_doner_patch(this%ideadcroot_to_iout_fi) = ideadcroot + this%matrix_nfitransfer_receiver_patch(this%ideadcroot_to_iout_fi) = ioutn + + this%ideadcrootst_to_iout_fi = 19 + this%matrix_nfitransfer_doner_patch(this%ideadcrootst_to_iout_fi) = ideadcroot_st + this%matrix_nfitransfer_receiver_patch(this%ideadcrootst_to_iout_fi) = ioutn + + this%ideadcrootxf_to_iout_fi = 20 + this%matrix_nfitransfer_doner_patch(this%ideadcrootxf_to_iout_fi) = ideadcroot_xf + this%matrix_nfitransfer_receiver_patch(this%ideadcrootxf_to_iout_fi) = ioutn + + this%iretransn_to_iout_fi = 21 + this%matrix_nfitransfer_doner_patch(this%iretransn_to_iout_fi) = iretransn + this%matrix_nfitransfer_receiver_patch(this%iretransn_to_iout_fi) = ioutn + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + + allocate(this%m_leafn_to_litter_patch (begp:endp)) ; this%m_leafn_to_litter_patch (:) = nan + allocate(this%m_frootn_to_litter_patch (begp:endp)) ; this%m_frootn_to_litter_patch (:) = nan + allocate(this%m_leafn_storage_to_litter_patch (begp:endp)) ; this%m_leafn_storage_to_litter_patch (:) = nan + allocate(this%m_frootn_storage_to_litter_patch (begp:endp)) ; this%m_frootn_storage_to_litter_patch (:) = nan + allocate(this%m_livestemn_storage_to_litter_patch (begp:endp)) ; this%m_livestemn_storage_to_litter_patch (:) = nan + allocate(this%m_deadstemn_storage_to_litter_patch (begp:endp)) ; this%m_deadstemn_storage_to_litter_patch (:) = nan + allocate(this%m_livecrootn_storage_to_litter_patch (begp:endp)) ; this%m_livecrootn_storage_to_litter_patch (:) = nan + allocate(this%m_deadcrootn_storage_to_litter_patch (begp:endp)) ; this%m_deadcrootn_storage_to_litter_patch (:) = nan + allocate(this%m_leafn_xfer_to_litter_patch (begp:endp)) ; this%m_leafn_xfer_to_litter_patch (:) = nan + allocate(this%m_frootn_xfer_to_litter_patch (begp:endp)) ; this%m_frootn_xfer_to_litter_patch (:) = nan + allocate(this%m_livestemn_xfer_to_litter_patch (begp:endp)) ; this%m_livestemn_xfer_to_litter_patch (:) = nan + allocate(this%m_deadstemn_xfer_to_litter_patch (begp:endp)) ; this%m_deadstemn_xfer_to_litter_patch (:) = nan + allocate(this%m_livecrootn_xfer_to_litter_patch (begp:endp)) ; this%m_livecrootn_xfer_to_litter_patch (:) = nan + allocate(this%m_deadcrootn_xfer_to_litter_patch (begp:endp)) ; this%m_deadcrootn_xfer_to_litter_patch (:) = nan + allocate(this%m_livestemn_to_litter_patch (begp:endp)) ; this%m_livestemn_to_litter_patch (:) = nan + allocate(this%m_deadstemn_to_litter_patch (begp:endp)) ; this%m_deadstemn_to_litter_patch (:) = nan + allocate(this%m_livecrootn_to_litter_patch (begp:endp)) ; this%m_livecrootn_to_litter_patch (:) = nan + allocate(this%m_deadcrootn_to_litter_patch (begp:endp)) ; this%m_deadcrootn_to_litter_patch (:) = nan + allocate(this%m_retransn_to_litter_patch (begp:endp)) ; this%m_retransn_to_litter_patch (:) = nan + allocate(this%hrv_leafn_to_litter_patch (begp:endp)) ; this%hrv_leafn_to_litter_patch (:) = nan + allocate(this%hrv_frootn_to_litter_patch (begp:endp)) ; this%hrv_frootn_to_litter_patch (:) = nan + allocate(this%hrv_leafn_storage_to_litter_patch (begp:endp)) ; this%hrv_leafn_storage_to_litter_patch (:) = nan + allocate(this%hrv_frootn_storage_to_litter_patch (begp:endp)) ; this%hrv_frootn_storage_to_litter_patch (:) = nan + allocate(this%hrv_livestemn_storage_to_litter_patch (begp:endp)) ; this%hrv_livestemn_storage_to_litter_patch (:) = nan + allocate(this%hrv_deadstemn_storage_to_litter_patch (begp:endp)) ; this%hrv_deadstemn_storage_to_litter_patch (:) = nan + allocate(this%hrv_livecrootn_storage_to_litter_patch (begp:endp)) ; this%hrv_livecrootn_storage_to_litter_patch (:) = nan + allocate(this%hrv_deadcrootn_storage_to_litter_patch (begp:endp)) ; this%hrv_deadcrootn_storage_to_litter_patch (:) = nan + allocate(this%hrv_leafn_xfer_to_litter_patch (begp:endp)) ; this%hrv_leafn_xfer_to_litter_patch (:) = nan + allocate(this%hrv_frootn_xfer_to_litter_patch (begp:endp)) ; this%hrv_frootn_xfer_to_litter_patch (:) = nan + allocate(this%hrv_livestemn_xfer_to_litter_patch (begp:endp)) ; this%hrv_livestemn_xfer_to_litter_patch (:) = nan + allocate(this%hrv_deadstemn_xfer_to_litter_patch (begp:endp)) ; this%hrv_deadstemn_xfer_to_litter_patch (:) = nan + allocate(this%hrv_livecrootn_xfer_to_litter_patch (begp:endp)) ; this%hrv_livecrootn_xfer_to_litter_patch (:) = nan + allocate(this%hrv_deadcrootn_xfer_to_litter_patch (begp:endp)) ; this%hrv_deadcrootn_xfer_to_litter_patch (:) = nan + allocate(this%hrv_livestemn_to_litter_patch (begp:endp)) ; this%hrv_livestemn_to_litter_patch (:) = nan + allocate(this%hrv_livecrootn_to_litter_patch (begp:endp)) ; this%hrv_livecrootn_to_litter_patch (:) = nan + allocate(this%hrv_deadcrootn_to_litter_patch (begp:endp)) ; this%hrv_deadcrootn_to_litter_patch (:) = nan + allocate(this%hrv_retransn_to_litter_patch (begp:endp)) ; this%hrv_retransn_to_litter_patch (:) = nan + + allocate(this%m_leafn_to_fire_patch (begp:endp)) ; this%m_leafn_to_fire_patch (:) = nan + allocate(this%m_leafn_storage_to_fire_patch (begp:endp)) ; this%m_leafn_storage_to_fire_patch (:) = nan + allocate(this%m_leafn_xfer_to_fire_patch (begp:endp)) ; this%m_leafn_xfer_to_fire_patch (:) = nan + allocate(this%m_livestemn_to_fire_patch (begp:endp)) ; this%m_livestemn_to_fire_patch (:) = nan + allocate(this%m_livestemn_storage_to_fire_patch (begp:endp)) ; this%m_livestemn_storage_to_fire_patch (:) = nan + allocate(this%m_livestemn_xfer_to_fire_patch (begp:endp)) ; this%m_livestemn_xfer_to_fire_patch (:) = nan + allocate(this%m_deadstemn_to_fire_patch (begp:endp)) ; this%m_deadstemn_to_fire_patch (:) = nan + allocate(this%m_deadstemn_storage_to_fire_patch (begp:endp)) ; this%m_deadstemn_storage_to_fire_patch (:) = nan + allocate(this%m_deadstemn_xfer_to_fire_patch (begp:endp)) ; this%m_deadstemn_xfer_to_fire_patch (:) = nan + allocate(this%m_frootn_to_fire_patch (begp:endp)) ; this%m_frootn_to_fire_patch (:) = nan + allocate(this%m_frootn_storage_to_fire_patch (begp:endp)) ; this%m_frootn_storage_to_fire_patch (:) = nan + allocate(this%m_frootn_xfer_to_fire_patch (begp:endp)) ; this%m_frootn_xfer_to_fire_patch (:) = nan + allocate(this%m_livecrootn_to_fire_patch (begp:endp)) ; + allocate(this%m_livecrootn_storage_to_fire_patch (begp:endp)) ; this%m_livecrootn_storage_to_fire_patch (:) = nan + allocate(this%m_livecrootn_xfer_to_fire_patch (begp:endp)) ; this%m_livecrootn_xfer_to_fire_patch (:) = nan + allocate(this%m_deadcrootn_to_fire_patch (begp:endp)) ; this%m_deadcrootn_to_fire_patch (:) = nan + allocate(this%m_deadcrootn_storage_to_fire_patch (begp:endp)) ; this%m_deadcrootn_storage_to_fire_patch (:) = nan + allocate(this%m_deadcrootn_xfer_to_fire_patch (begp:endp)) ; this%m_deadcrootn_xfer_to_fire_patch (:) = nan + allocate(this%m_retransn_to_fire_patch (begp:endp)) ; this%m_retransn_to_fire_patch (:) = nan + + allocate(this%m_leafn_to_litter_fire_patch (begp:endp)) ; this%m_leafn_to_litter_fire_patch (:) = nan + allocate(this%m_leafn_storage_to_litter_fire_patch (begp:endp)) ; this%m_leafn_storage_to_litter_fire_patch (:) = nan + allocate(this%m_leafn_xfer_to_litter_fire_patch (begp:endp)) ; this%m_leafn_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_livestemn_to_litter_fire_patch (begp:endp)) ; this%m_livestemn_to_litter_fire_patch (:) = nan + allocate(this%m_livestemn_storage_to_litter_fire_patch (begp:endp)) ; this%m_livestemn_storage_to_litter_fire_patch (:) = nan + allocate(this%m_livestemn_xfer_to_litter_fire_patch (begp:endp)) ; this%m_livestemn_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_livestemn_to_deadstemn_fire_patch (begp:endp)) ; this%m_livestemn_to_deadstemn_fire_patch (:) = nan + allocate(this%m_deadstemn_to_litter_fire_patch (begp:endp)) ; this%m_deadstemn_to_litter_fire_patch (:) = nan + allocate(this%m_deadstemn_storage_to_litter_fire_patch (begp:endp)) ; this%m_deadstemn_storage_to_litter_fire_patch (:) = nan + allocate(this%m_deadstemn_xfer_to_litter_fire_patch (begp:endp)) ; this%m_deadstemn_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_frootn_to_litter_fire_patch (begp:endp)) ; this%m_frootn_to_litter_fire_patch (:) = nan + allocate(this%m_frootn_storage_to_litter_fire_patch (begp:endp)) ; this%m_frootn_storage_to_litter_fire_patch (:) = nan + allocate(this%m_frootn_xfer_to_litter_fire_patch (begp:endp)) ; this%m_frootn_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_livecrootn_to_litter_fire_patch (begp:endp)) ; this%m_livecrootn_to_litter_fire_patch (:) = nan + allocate(this%m_livecrootn_storage_to_litter_fire_patch (begp:endp)) ; this%m_livecrootn_storage_to_litter_fire_patch (:) = nan + allocate(this%m_livecrootn_xfer_to_litter_fire_patch (begp:endp)) ; this%m_livecrootn_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_livecrootn_to_deadcrootn_fire_patch (begp:endp)) ; this%m_livecrootn_to_deadcrootn_fire_patch (:) = nan + allocate(this%m_deadcrootn_to_litter_fire_patch (begp:endp)) ; this%m_deadcrootn_to_litter_fire_patch (:) = nan + allocate(this%m_deadcrootn_storage_to_litter_fire_patch (begp:endp)) ; this%m_deadcrootn_storage_to_litter_fire_patch (:) = nan + allocate(this%m_deadcrootn_xfer_to_litter_fire_patch (begp:endp)) ; this%m_deadcrootn_xfer_to_litter_fire_patch (:) = nan + allocate(this%m_retransn_to_litter_fire_patch (begp:endp)) ; this%m_retransn_to_litter_fire_patch (:) = nan + + + allocate(this%leafn_xfer_to_leafn_patch (begp:endp)) ; this%leafn_xfer_to_leafn_patch (:) = nan + allocate(this%frootn_xfer_to_frootn_patch (begp:endp)) ; this%frootn_xfer_to_frootn_patch (:) = nan + allocate(this%livestemn_xfer_to_livestemn_patch (begp:endp)) ; this%livestemn_xfer_to_livestemn_patch (:) = nan + allocate(this%deadstemn_xfer_to_deadstemn_patch (begp:endp)) ; this%deadstemn_xfer_to_deadstemn_patch (:) = nan + allocate(this%livecrootn_xfer_to_livecrootn_patch (begp:endp)) ; this%livecrootn_xfer_to_livecrootn_patch (:) = nan + allocate(this%deadcrootn_xfer_to_deadcrootn_patch (begp:endp)) ; this%deadcrootn_xfer_to_deadcrootn_patch (:) = nan + allocate(this%leafn_to_litter_patch (begp:endp)) ; this%leafn_to_litter_patch (:) = nan + allocate(this%leafn_to_retransn_patch (begp:endp)) ; this%leafn_to_retransn_patch (:) = nan + allocate(this%frootn_to_retransn_patch (begp:endp)) ; this%frootn_to_retransn_patch (:) = nan + allocate(this%frootn_to_litter_patch (begp:endp)) ; this%frootn_to_litter_patch (:) = nan + allocate(this%retransn_to_npool_patch (begp:endp)) ; this%retransn_to_npool_patch (:) = nan + allocate(this%free_retransn_to_npool_patch (begp:endp)) ; this%free_retransn_to_npool_patch (:) = nan + allocate(this%sminn_to_npool_patch (begp:endp)) ; this%sminn_to_npool_patch (:) = nan + + allocate(this%npool_to_leafn_patch (begp:endp)) ; this%npool_to_leafn_patch (:) = nan + allocate(this%npool_to_leafn_storage_patch (begp:endp)) ; this%npool_to_leafn_storage_patch (:) = nan + allocate(this%npool_to_frootn_patch (begp:endp)) ; this%npool_to_frootn_patch (:) = nan + allocate(this%npool_to_frootn_storage_patch (begp:endp)) ; this%npool_to_frootn_storage_patch (:) = nan + allocate(this%npool_to_livestemn_patch (begp:endp)) ; this%npool_to_livestemn_patch (:) = nan + allocate(this%npool_to_livestemn_storage_patch (begp:endp)) ; this%npool_to_livestemn_storage_patch (:) = nan + allocate(this%npool_to_deadstemn_patch (begp:endp)) ; this%npool_to_deadstemn_patch (:) = nan + allocate(this%npool_to_deadstemn_storage_patch (begp:endp)) ; this%npool_to_deadstemn_storage_patch (:) = nan + allocate(this%npool_to_livecrootn_patch (begp:endp)) ; this%npool_to_livecrootn_patch (:) = nan + allocate(this%npool_to_livecrootn_storage_patch (begp:endp)) ; this%npool_to_livecrootn_storage_patch (:) = nan + allocate(this%npool_to_deadcrootn_patch (begp:endp)) ; this%npool_to_deadcrootn_patch (:) = nan + allocate(this%npool_to_deadcrootn_storage_patch (begp:endp)) ; this%npool_to_deadcrootn_storage_patch (:) = nan + allocate(this%leafn_storage_to_xfer_patch (begp:endp)) ; this%leafn_storage_to_xfer_patch (:) = nan + allocate(this%frootn_storage_to_xfer_patch (begp:endp)) ; this%frootn_storage_to_xfer_patch (:) = nan + allocate(this%livestemn_storage_to_xfer_patch (begp:endp)) ; this%livestemn_storage_to_xfer_patch (:) = nan + allocate(this%deadstemn_storage_to_xfer_patch (begp:endp)) ; this%deadstemn_storage_to_xfer_patch (:) = nan + allocate(this%livecrootn_storage_to_xfer_patch (begp:endp)) ; this%livecrootn_storage_to_xfer_patch (:) = nan + allocate(this%deadcrootn_storage_to_xfer_patch (begp:endp)) ; this%deadcrootn_storage_to_xfer_patch (:) = nan + allocate(this%livestemn_to_deadstemn_patch (begp:endp)) ; this%livestemn_to_deadstemn_patch (:) = nan + allocate(this%livestemn_to_retransn_patch (begp:endp)) ; this%livestemn_to_retransn_patch (:) = nan + allocate(this%livecrootn_to_deadcrootn_patch (begp:endp)) ; this%livecrootn_to_deadcrootn_patch (:) = nan + allocate(this%livecrootn_to_retransn_patch (begp:endp)) ; this%livecrootn_to_retransn_patch (:) = nan + allocate(this%ndeploy_patch (begp:endp)) ; this%ndeploy_patch (:) = nan + allocate(this%wood_harvestn_patch (begp:endp)) ; this%wood_harvestn_patch (:) = nan + allocate(this%fire_nloss_patch (begp:endp)) ; this%fire_nloss_patch (:) = spval + allocate(this%npool_to_grainn_patch (begp:endp)) ; this%npool_to_grainn_patch (:) = nan + allocate(this%npool_to_grainn_storage_patch (begp:endp)) ; this%npool_to_grainn_storage_patch (:) = nan + allocate(this%livestemn_to_litter_patch (begp:endp)) ; this%livestemn_to_litter_patch (:) = nan + allocate(this%grainn_to_food_patch (begp:endp)) ; this%grainn_to_food_patch (:) = nan + allocate(this%leafn_to_biofueln_patch (begp:endp)) ; this%leafn_to_biofueln_patch (:) = nan + allocate(this%livestemn_to_biofueln_patch (begp:endp)) ; this%livestemn_to_biofueln_patch (:) = nan + allocate(this%grainn_to_seed_patch (begp:endp)) ; this%grainn_to_seed_patch (:) = nan + allocate(this%grainn_xfer_to_grainn_patch (begp:endp)) ; this%grainn_xfer_to_grainn_patch (:) = nan + allocate(this%grainn_storage_to_xfer_patch (begp:endp)) ; this%grainn_storage_to_xfer_patch (:) = nan + allocate(this%fert_patch (begp:endp)) ; this%fert_patch (:) = nan + allocate(this%fert_counter_patch (begp:endp)) ; this%fert_counter_patch (:) = nan + allocate(this%soyfixn_patch (begp:endp)) ; this%soyfixn_patch (:) = nan + + allocate(this%grainn_to_cropprodn_patch (begp:endp)) ; this%grainn_to_cropprodn_patch (:) = spval + allocate(this%grainn_to_cropprodn_col (begc:endc)) ; this%grainn_to_cropprodn_col (:) = nan + + allocate(this%fire_nloss_col (begc:endc)) ; this%fire_nloss_col (:) = nan + allocate(this%fire_nloss_p2c_col (begc:endc)) ; this%fire_nloss_p2c_col (:) = nan + + allocate(this%m_n_to_litr_met_fire_col (begc:endc,1:nlevdecomp_full)) ; this%m_n_to_litr_met_fire_col (:,:) = nan + allocate(this%m_n_to_litr_cel_fire_col (begc:endc,1:nlevdecomp_full)) ; this%m_n_to_litr_cel_fire_col (:,:) = nan + allocate(this%m_n_to_litr_lig_fire_col (begc:endc,1:nlevdecomp_full)) ; this%m_n_to_litr_lig_fire_col (:,:) = nan + + allocate(this%dwt_seedn_to_leaf_patch (begp:endp)) ; this%dwt_seedn_to_leaf_patch (:) = nan + allocate(this%dwt_seedn_to_leaf_grc (begg:endg)) ; this%dwt_seedn_to_leaf_grc (:) = nan + allocate(this%dwt_seedn_to_deadstem_patch (begp:endp)) ; this%dwt_seedn_to_deadstem_patch (:) = nan + allocate(this%dwt_seedn_to_deadstem_grc (begg:endg)) ; this%dwt_seedn_to_deadstem_grc (:) = nan + allocate(this%dwt_conv_nflux_patch (begp:endp)) ; this%dwt_conv_nflux_patch (:) = nan + allocate(this%dwt_conv_nflux_grc (begg:endg)) ; this%dwt_conv_nflux_grc (:) = nan + allocate(this%dwt_wood_productn_gain_patch (begp:endp)) ; this%dwt_wood_productn_gain_patch (:) = nan + allocate(this%dwt_crop_productn_gain_patch (begp:endp)) ; this%dwt_crop_productn_gain_patch (:) = nan + allocate(this%wood_harvestn_col (begc:endc)) ; this%wood_harvestn_col (:) = nan + + allocate(this%dwt_frootn_to_litr_met_n_col (begc:endc,1:nlevdecomp_full)) ; this%dwt_frootn_to_litr_met_n_col (:,:) = nan + allocate(this%dwt_frootn_to_litr_cel_n_col (begc:endc,1:nlevdecomp_full)) ; this%dwt_frootn_to_litr_cel_n_col (:,:) = nan + allocate(this%dwt_frootn_to_litr_lig_n_col (begc:endc,1:nlevdecomp_full)) ; this%dwt_frootn_to_litr_lig_n_col (:,:) = nan + allocate(this%dwt_livecrootn_to_cwdn_col (begc:endc,1:nlevdecomp_full)) ; this%dwt_livecrootn_to_cwdn_col (:,:) = nan + allocate(this%dwt_deadcrootn_to_cwdn_col (begc:endc,1:nlevdecomp_full)) ; this%dwt_deadcrootn_to_cwdn_col (:,:) = nan + + allocate(this%crop_seedn_to_leaf_patch (begp:endp)) ; this%crop_seedn_to_leaf_patch (:) = nan + + allocate(this%m_decomp_npools_to_fire_vr_col (begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + allocate(this%m_decomp_npools_to_fire_col (begc:endc,1:ndecomp_pools )) + + this%m_decomp_npools_to_fire_vr_col (:,:,:) = nan + this%m_decomp_npools_to_fire_col (:,:) = nan + + allocate(this%phenology_n_to_litr_met_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%phenology_n_to_litr_cel_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%phenology_n_to_litr_lig_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%gap_mortality_n_to_litr_met_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%gap_mortality_n_to_litr_cel_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%gap_mortality_n_to_litr_lig_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%gap_mortality_n_to_cwdn_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%fire_mortality_n_to_cwdn_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%harvest_n_to_litr_met_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%harvest_n_to_litr_cel_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%harvest_n_to_litr_lig_n_col (begc:endc, 1:nlevdecomp_full)) + allocate(this%harvest_n_to_cwdn_col (begc:endc, 1:nlevdecomp_full)) + + this%phenology_n_to_litr_met_n_col (:,:) = nan + this%phenology_n_to_litr_cel_n_col (:,:) = nan + this%phenology_n_to_litr_lig_n_col (:,:) = nan + this%gap_mortality_n_to_litr_met_n_col (:,:) = nan + this%gap_mortality_n_to_litr_cel_n_col (:,:) = nan + this%gap_mortality_n_to_litr_lig_n_col (:,:) = nan + this%gap_mortality_n_to_cwdn_col (:,:) = nan + this%fire_mortality_n_to_cwdn_col (:,:) = nan + this%harvest_n_to_litr_met_n_col (:,:) = nan + this%harvest_n_to_litr_cel_n_col (:,:) = nan + this%harvest_n_to_litr_lig_n_col (:,:) = nan + this%harvest_n_to_cwdn_col (:,:) = nan + + allocate(this%plant_ndemand_patch (begp:endp)) ; this%plant_ndemand_patch (:) = spval + allocate(this%avail_retransn_patch (begp:endp)) ; this%avail_retransn_patch (:) = nan + allocate(this%plant_nalloc_patch (begp:endp)) ; this%plant_nalloc_patch (:) = nan + + allocate(this%plant_ndemand_retrans_patch (begp:endp)) ; this%plant_ndemand_retrans_patch (:) = nan + allocate(this%plant_ndemand_season_patch (begp:endp)) ; this%plant_ndemand_season_patch (:) = nan + allocate(this%plant_ndemand_stress_patch (begp:endp)) ; this%plant_ndemand_stress_patch (:) = nan + allocate(this%Nactive_patch (begp:endp)) ; this%Nactive_patch (:) = nan + allocate(this%Nnonmyc_patch (begp:endp)) ; this%Nnonmyc_patch (:) = nan + allocate(this%Nam_patch (begp:endp)) ; this%Nam_patch (:) = nan + allocate(this%Necm_patch (begp:endp)) ; this%Necm_patch (:) = nan + allocate(this%Nactive_no3_patch (begp:endp)) ; this%Nactive_no3_patch (:) = nan + allocate(this%Nactive_nh4_patch (begp:endp)) ; this%Nactive_nh4_patch (:) = nan + allocate(this%Nnonmyc_no3_patch (begp:endp)) ; this%Nnonmyc_no3_patch (:) = nan + allocate(this%Nnonmyc_nh4_patch (begp:endp)) ; this%Nnonmyc_nh4_patch (:) = nan + allocate(this%Nam_no3_patch (begp:endp)) ; this%Nam_no3_patch (:) = nan + allocate(this%Nam_nh4_patch (begp:endp)) ; this%Nam_nh4_patch (:) = nan + allocate(this%Necm_no3_patch (begp:endp)) ; this%Necm_no3_patch (:) = nan + allocate(this%Necm_nh4_patch (begp:endp)) ; this%Necm_nh4_patch (:) = nan + allocate(this%Npassive_patch (begp:endp)) ; this%Npassive_patch (:) = nan + allocate(this%Nfix_patch (begp:endp)) ; this%Nfix_patch (:) = nan + allocate(this%Nretrans_patch (begp:endp)) ; this%Nretrans_patch (:) = nan + allocate(this%Nretrans_org_patch (begp:endp)) ; this%Nretrans_org_patch (:) = nan + allocate(this%Nretrans_season_patch (begp:endp)) ; this%Nretrans_season_patch (:) = nan + allocate(this%Nretrans_stress_patch (begp:endp)) ; this%Nretrans_stress_patch (:) = nan + allocate(this%Nuptake_patch (begp:endp)) ; this%Nuptake_patch (:) = nan + allocate(this%sminn_to_plant_fun_patch (begp:endp)) ; this%sminn_to_plant_fun_patch (:) = nan + allocate(this%sminn_to_plant_fun_vr_patch (begp:endp,1:nlevdecomp_full)) + this%sminn_to_plant_fun_vr_patch (:,:) = nan + allocate(this%sminn_to_plant_fun_no3_vr_patch (begp:endp,1:nlevdecomp_full)) + this%sminn_to_plant_fun_no3_vr_patch (:,:) = nan + allocate(this%sminn_to_plant_fun_nh4_vr_patch (begp:endp,1:nlevdecomp_full)) + this%sminn_to_plant_fun_nh4_vr_patch (:,:) = nan + allocate(this%cost_nfix_patch (begp:endp)) ; this%cost_nfix_patch (:) = nan + allocate(this%cost_nactive_patch (begp:endp)) ; this%cost_nactive_patch (:) = nan + allocate(this%cost_nretrans_patch (begp:endp)) ; this%cost_nretrans_patch (:) = nan + allocate(this%nuptake_npp_fraction_patch (begp:endp)) ; this%nuptake_npp_fraction_patch (:) = nan + + ! initialize variables from restart file or set to cold start value + n = 0 + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + + + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + + this%plant_ndemand_patch (np) = cnpft(nc,nz,nv, 75) + + end if + end do !nv + this%dwt_wood_productn_gain_patch(np) = 0. ! following CNCLM45 setting + this%dwt_crop_productn_gain_patch(np) = 0. ! following CNCLM45 setting + end do ! p + end do ! nz + end do ! nc + + do p = begp,endp + l = patch%landunit(p) + + if ( use_crop )then + this%fert_counter_patch(p) = spval + this%fert_patch(p) = 0._r8 + this%soyfixn_patch(p) = 0._r8 + end if + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%fert_counter_patch(p) = 0._r8 + end if + if ( use_fun ) then !previously set to spval for special land units + if (lun%ifspecial(l)) then + this%plant_ndemand_patch(p) = 0._r8 + this%avail_retransn_patch(p) = 0._r8 + this%plant_nalloc_patch(p) = 0._r8 + this%Npassive_patch(p) = 0._r8 + this%Nactive_patch(p) = 0._r8 + this%Nnonmyc_patch(p) = 0._r8 + this%Nam_patch(p) = 0._r8 + this%Necm_patch(p) = 0._r8 + if (use_nitrif_denitrif) then + this%Nactive_no3_patch(p) = 0._r8 + this%Nactive_nh4_patch(p) = 0._r8 + this%Nnonmyc_no3_patch(p) = 0._r8 + this%Nnonmyc_nh4_patch(p) = 0._r8 + this%Nam_no3_patch(p) = 0._r8 + this%Nam_nh4_patch(p) = 0._r8 + this%Necm_no3_patch(p) = 0._r8 + this%Necm_nh4_patch(p) = 0._r8 + end if + this%Nfix_patch(p) = 0._r8 + this%Nretrans_patch(p) = 0._r8 + this%Nretrans_org_patch(p) = 0._r8 + this%Nretrans_season_patch(p) = 0._r8 + this%Nretrans_stress_patch(p) = 0._r8 + this%Nuptake_patch(p) = 0._r8 + this%sminn_to_plant_fun_patch(p) = 0._r8 + this%cost_nfix_patch = 0._r8 + this%cost_nactive_patch = 0._r8 + this%cost_nretrans_patch = 0._r8 + this%nuptake_npp_fraction_patch = 0._r8 + + do j = 1, nlevdecomp + this%sminn_to_plant_fun_vr_patch(p,j) = 0._r8 + this%sminn_to_plant_fun_no3_vr_patch(p,j) = 0._r8 + this%sminn_to_plant_fun_nh4_vr_patch(p,j) = 0._r8 + end do + end if + end if + end do + + + end subroutine Init + +!------------------------------------------ + subroutine SetValues ( this,nvegnpool, & + num_patch, filter_patch, value_patch, & + num_column, filter_column, value_column) + ! + ! !DESCRIPTION: + ! Set nitrogen flux variables + ! + ! !ARGUMENTS: + ! !ARGUMENTS: + class (cnveg_nitrogenflux_type) :: this + integer , intent(in) :: num_patch,nvegnpool + integer , intent(in) :: filter_patch(:) + real(r8), intent(in) :: value_patch + integer , intent(in) :: num_column + integer , intent(in) :: filter_column(:) + real(r8), intent(in) :: value_column + ! + ! !LOCAL VARIABLES: + integer :: fi,i,j,k,l ! loop index + !------------------------------------------------------------------------ + + do fi = 1,num_patch + i=filter_patch(fi) + + this%m_leafn_to_litter_patch(i) = value_patch + this%m_frootn_to_litter_patch(i) = value_patch + this%m_leafn_storage_to_litter_patch(i) = value_patch + this%m_frootn_storage_to_litter_patch(i) = value_patch + this%m_livestemn_storage_to_litter_patch(i) = value_patch + this%m_deadstemn_storage_to_litter_patch(i) = value_patch + this%m_livecrootn_storage_to_litter_patch(i) = value_patch + this%m_deadcrootn_storage_to_litter_patch(i) = value_patch + this%m_leafn_xfer_to_litter_patch(i) = value_patch + this%m_frootn_xfer_to_litter_patch(i) = value_patch + this%m_livestemn_xfer_to_litter_patch(i) = value_patch + this%m_deadstemn_xfer_to_litter_patch(i) = value_patch + this%m_livecrootn_xfer_to_litter_patch(i) = value_patch + this%m_deadcrootn_xfer_to_litter_patch(i) = value_patch + this%m_livestemn_to_litter_patch(i) = value_patch + this%m_deadstemn_to_litter_patch(i) = value_patch + this%m_livecrootn_to_litter_patch(i) = value_patch + this%m_deadcrootn_to_litter_patch(i) = value_patch + this%m_retransn_to_litter_patch(i) = value_patch + this%hrv_leafn_to_litter_patch(i) = value_patch + this%hrv_frootn_to_litter_patch(i) = value_patch + this%hrv_leafn_storage_to_litter_patch(i) = value_patch + this%hrv_frootn_storage_to_litter_patch(i) = value_patch + this%hrv_livestemn_storage_to_litter_patch(i) = value_patch + this%hrv_deadstemn_storage_to_litter_patch(i) = value_patch + this%hrv_livecrootn_storage_to_litter_patch(i) = value_patch + this%hrv_deadcrootn_storage_to_litter_patch(i) = value_patch + this%hrv_leafn_xfer_to_litter_patch(i) = value_patch + this%hrv_frootn_xfer_to_litter_patch(i) = value_patch + this%hrv_livestemn_xfer_to_litter_patch(i) = value_patch + this%hrv_deadstemn_xfer_to_litter_patch(i) = value_patch + this%hrv_livecrootn_xfer_to_litter_patch(i) = value_patch + this%hrv_deadcrootn_xfer_to_litter_patch(i) = value_patch + this%hrv_livestemn_to_litter_patch(i) = value_patch + this%hrv_livecrootn_to_litter_patch(i) = value_patch + this%hrv_deadcrootn_to_litter_patch(i) = value_patch + this%hrv_retransn_to_litter_patch(i) = value_patch + + this%m_leafn_to_fire_patch(i) = value_patch + this%m_leafn_storage_to_fire_patch(i) = value_patch + this%m_leafn_xfer_to_fire_patch(i) = value_patch + this%m_livestemn_to_fire_patch(i) = value_patch + this%m_livestemn_storage_to_fire_patch(i) = value_patch + this%m_livestemn_xfer_to_fire_patch(i) = value_patch + this%m_deadstemn_to_fire_patch(i) = value_patch + this%m_deadstemn_storage_to_fire_patch(i) = value_patch + this%m_deadstemn_xfer_to_fire_patch(i) = value_patch + this%m_frootn_to_fire_patch(i) = value_patch + this%m_frootn_storage_to_fire_patch(i) = value_patch + this%m_frootn_xfer_to_fire_patch(i) = value_patch + this%m_livecrootn_to_fire_patch(i) = value_patch + this%m_livecrootn_storage_to_fire_patch(i) = value_patch + this%m_livecrootn_xfer_to_fire_patch(i) = value_patch + this%m_deadcrootn_to_fire_patch(i) = value_patch + this%m_deadcrootn_storage_to_fire_patch(i) = value_patch + this%m_deadcrootn_xfer_to_fire_patch(i) = value_patch + this%m_retransn_to_fire_patch(i) = value_patch + + + this%m_leafn_to_litter_fire_patch(i) = value_patch + this%m_leafn_storage_to_litter_fire_patch(i) = value_patch + this%m_leafn_xfer_to_litter_fire_patch(i) = value_patch + this%m_livestemn_to_litter_fire_patch(i) = value_patch + this%m_livestemn_storage_to_litter_fire_patch(i) = value_patch + this%m_livestemn_xfer_to_litter_fire_patch(i) = value_patch + this%m_livestemn_to_deadstemn_fire_patch(i) = value_patch + this%m_deadstemn_to_litter_fire_patch(i) = value_patch + this%m_deadstemn_storage_to_litter_fire_patch(i) = value_patch + this%m_deadstemn_xfer_to_litter_fire_patch(i) = value_patch + this%m_frootn_to_litter_fire_patch(i) = value_patch + this%m_frootn_storage_to_litter_fire_patch(i) = value_patch + this%m_frootn_xfer_to_litter_fire_patch(i) = value_patch + this%m_livecrootn_to_litter_fire_patch(i) = value_patch + this%m_livecrootn_storage_to_litter_fire_patch(i) = value_patch + this%m_livecrootn_xfer_to_litter_fire_patch(i) = value_patch + this%m_livecrootn_to_deadcrootn_fire_patch(i) = value_patch + this%m_deadcrootn_to_litter_fire_patch(i) = value_patch + this%m_deadcrootn_storage_to_litter_fire_patch(i) = value_patch + this%m_deadcrootn_xfer_to_litter_fire_patch(i) = value_patch + this%m_retransn_to_litter_fire_patch(i) = value_patch + + + this%leafn_xfer_to_leafn_patch(i) = value_patch + this%frootn_xfer_to_frootn_patch(i) = value_patch + this%livestemn_xfer_to_livestemn_patch(i) = value_patch + this%deadstemn_xfer_to_deadstemn_patch(i) = value_patch + this%livecrootn_xfer_to_livecrootn_patch(i) = value_patch + this%deadcrootn_xfer_to_deadcrootn_patch(i) = value_patch + this%leafn_to_litter_patch(i) = value_patch + this%leafn_to_retransn_patch(i) = value_patch + this%frootn_to_litter_patch(i) = value_patch + this%retransn_to_npool_patch(i) = value_patch + this%free_retransn_to_npool_patch(i) = value_patch + this%sminn_to_npool_patch(i) = value_patch + this%npool_to_leafn_patch(i) = value_patch + this%npool_to_leafn_storage_patch(i) = value_patch + this%npool_to_frootn_patch(i) = value_patch + this%npool_to_frootn_storage_patch(i) = value_patch + this%npool_to_livestemn_patch(i) = value_patch + this%npool_to_livestemn_storage_patch(i) = value_patch + this%npool_to_deadstemn_patch(i) = value_patch + this%npool_to_deadstemn_storage_patch(i) = value_patch + this%npool_to_livecrootn_patch(i) = value_patch + this%npool_to_livecrootn_storage_patch(i) = value_patch + this%npool_to_deadcrootn_patch(i) = value_patch + this%npool_to_deadcrootn_storage_patch(i) = value_patch + this%leafn_storage_to_xfer_patch(i) = value_patch + this%frootn_storage_to_xfer_patch(i) = value_patch + this%livestemn_storage_to_xfer_patch(i) = value_patch + this%deadstemn_storage_to_xfer_patch(i) = value_patch + this%livecrootn_storage_to_xfer_patch(i) = value_patch + this%deadcrootn_storage_to_xfer_patch(i) = value_patch + this%livestemn_to_deadstemn_patch(i) = value_patch + this%livestemn_to_retransn_patch(i) = value_patch + this%livecrootn_to_deadcrootn_patch(i) = value_patch + this%livecrootn_to_retransn_patch(i) = value_patch + this%ndeploy_patch(i) = value_patch + this%wood_harvestn_patch(i) = value_patch + this%fire_nloss_patch(i) = value_patch + + this%crop_seedn_to_leaf_patch(i) = value_patch + this%grainn_to_cropprodn_patch(i) = value_patch + end do + + if ( use_crop )then + do fi = 1,num_patch + i = filter_patch(fi) + this%livestemn_to_litter_patch(i) = value_patch + this%grainn_to_food_patch(i) = value_patch + this%leafn_to_biofueln_patch(i) = value_patch + this%livestemn_to_biofueln_patch(i) = value_patch + this%grainn_to_seed_patch(i) = value_patch + this%grainn_xfer_to_grainn_patch(i) = value_patch + this%npool_to_grainn_patch(i) = value_patch + this%npool_to_grainn_storage_patch(i) = value_patch + this%grainn_storage_to_xfer_patch(i) = value_patch + this%soyfixn_patch(i) = value_patch + this%frootn_to_retransn_patch(i) = value_patch + end do + end if + + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + + ! phenology: litterfall and crop fluxes associated wit + this%phenology_n_to_litr_met_n_col(i,j) = value_column + this%phenology_n_to_litr_cel_n_col(i,j) = value_column + this%phenology_n_to_litr_lig_n_col(i,j) = value_column + + ! gap mortality + this%gap_mortality_n_to_litr_met_n_col(i,j) = value_column + this%gap_mortality_n_to_litr_cel_n_col(i,j) = value_column + this%gap_mortality_n_to_litr_lig_n_col(i,j) = value_column + this%gap_mortality_n_to_cwdn_col(i,j) = value_column + + ! fire + this%fire_mortality_n_to_cwdn_col(i,j) = value_column + this%m_n_to_litr_met_fire_col(i,j) = value_column + this%m_n_to_litr_cel_fire_col(i,j) = value_column + this%m_n_to_litr_lig_fire_col(i,j) = value_column + + ! harvest + this%harvest_n_to_litr_met_n_col(i,j) = value_column + this%harvest_n_to_litr_cel_n_col(i,j) = value_column + this%harvest_n_to_litr_lig_n_col(i,j) = value_column + this%harvest_n_to_cwdn_col(i,j) = value_column + end do + end do + + do fi = 1,num_column + i = filter_column(fi) + + this%grainn_to_cropprodn_col(i) = value_column + this%fire_nloss_col(i) = value_column + + ! Zero p2c column fluxes + this%fire_nloss_col(i) = value_column + this%wood_harvestn_col(i) = value_column + end do + + do k = 1, ndecomp_pools + do fi = 1,num_column + i = filter_column(fi) + this%m_decomp_npools_to_fire_col(i,k) = value_column + end do + end do +! Matrix + if(use_matrixcn)then + do j = 1, nvegnpool + do fi = 1,num_patch + i = filter_patch(fi) + this%matrix_nalloc_patch(i,j) = value_patch + this%matrix_nphturnover_patch (i,j) = value_patch + this%matrix_ngmturnover_patch (i,j) = value_patch + this%matrix_nfiturnover_patch (i,j) = value_patch + end do + end do + + do j = 1, nnphtrans + do fi = 1,num_patch + i = filter_patch(fi) + this%matrix_nphtransfer_patch (i,j) = value_patch + end do + end do + + do j = 1, nngmtrans + do fi = 1,num_patch + i = filter_patch(fi) + this%matrix_ngmtransfer_patch (i,j) = value_patch + end do + end do + + do j = 1, nnfitrans + do fi = 1,num_patch + i = filter_patch(fi) + this%matrix_nfitransfer_patch (i,j) = value_patch + end do + end do + + end if + do k = 1, ndecomp_pools + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%m_decomp_npools_to_fire_vr_col(i,j,k) = value_column + end do + end do + end do + + end subroutine SetValues + + !----------------------------------------------------------------------- + subroutine Summary_nitrogenflux(this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp) + ! + ! !USES: + use clm_varpar , only: nlevdecomp,ndecomp_cascade_transitions,ndecomp_pools + use clm_varctl , only: use_nitrif_denitrif + use subgridAveMod , only: p2c + ! + ! !ARGUMENTS: + class (cnveg_nitrogenflux_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,k,l ! indices + integer :: fp,fc ! lake filter indices + real(r8) :: maxdepth ! depth to integrate soil variables + !----------------------------------------------------------------------- + + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! total N deployment (from sminn and retranslocated N pool) (NDEPLOY) + this%ndeploy_patch(p) = & + this%sminn_to_npool_patch(p) + & + this%retransn_to_npool_patch(p) + & + this%free_retransn_to_npool_patch(p) + + + ! total patch-level fire N losses + this%fire_nloss_patch(p) = & + this%m_leafn_to_fire_patch(p) + & + this%m_leafn_storage_to_fire_patch(p) + & + this%m_leafn_xfer_to_fire_patch(p) + & + this%m_frootn_to_fire_patch(p) + & + this%m_frootn_storage_to_fire_patch(p) + & + this%m_frootn_xfer_to_fire_patch(p) + & + this%m_livestemn_to_fire_patch(p) + & + this%m_livestemn_storage_to_fire_patch(p) + & + this%m_livestemn_xfer_to_fire_patch(p) + & + this%m_deadstemn_to_fire_patch(p) + & + this%m_deadstemn_storage_to_fire_patch(p) + & + this%m_deadstemn_xfer_to_fire_patch(p) + & + this%m_livecrootn_to_fire_patch(p) + & + this%m_livecrootn_storage_to_fire_patch(p) + & + this%m_livecrootn_xfer_to_fire_patch(p) + & + this%m_deadcrootn_to_fire_patch(p) + & + this%m_deadcrootn_storage_to_fire_patch(p) + & + this%m_deadcrootn_xfer_to_fire_patch(p) + & + this%m_retransn_to_fire_patch(p) + + end do + + call p2c(bounds, num_soilc, filter_soilc, & + this%fire_nloss_patch(bounds%begp:bounds%endp), & + this%fire_nloss_p2c_col(bounds%begc:bounds%endc)) + + + ! vertically integrate column-level fire N losses + do k = 1, ndecomp_pools + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%m_decomp_npools_to_fire_col(c,k) = & + this%m_decomp_npools_to_fire_col(c,k) + & + this%m_decomp_npools_to_fire_vr_col(c,j,k) * dzsoi_decomp(j) + end do + end do + end do + + ! total column-level fire N losses + do fc = 1,num_soilc + c = filter_soilc(fc) + this%fire_nloss_col(c) = this%fire_nloss_p2c_col(c) + end do + do k = 1, ndecomp_pools + do fc = 1,num_soilc + c = filter_soilc(fc) + this%fire_nloss_col(c) = & + this%fire_nloss_col(c) + & + this%m_decomp_npools_to_fire_col(c,k) + end do + end do + + end subroutine Summary_nitrogenflux + + !----------------------------------------------------------------------- + subroutine ZeroDwt( this, bounds ) + ! + ! !DESCRIPTION + ! Initialize flux variables needed for dynamic land use. + ! + ! !ARGUMENTS: + class(cnveg_nitrogenflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: c, g, j ! indices + !----------------------------------------------------------------------- + + do g = bounds%begg, bounds%endg + this%dwt_seedn_to_leaf_grc(g) = 0._r8 + this%dwt_seedn_to_deadstem_grc(g) = 0._r8 + this%dwt_conv_nflux_grc(g) = 0._r8 + end do + + do j = 1, nlevdecomp_full + do c = bounds%begc,bounds%endc + this%dwt_frootn_to_litr_met_n_col(c,j) = 0._r8 + this%dwt_frootn_to_litr_cel_n_col(c,j) = 0._r8 + this%dwt_frootn_to_litr_lig_n_col(c,j) = 0._r8 + this%dwt_livecrootn_to_cwdn_col(c,j) = 0._r8 + this%dwt_deadcrootn_to_cwdn_col(c,j) = 0._r8 + end do + end do + + end subroutine ZeroDwt + +end module CNVegNitrogenFluxType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegNitrogenStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegNitrogenStateType.F90 new file mode 100755 index 000000000..c22587391 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegNitrogenStateType.F90 @@ -0,0 +1,630 @@ +module CNVegNitrogenStateType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use MAPL_ExceptionHandling + use clm_varctl , only : use_matrixcn, use_crop + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_century_decomp + use clm_varpar , only : NUM_ZON, NUM_VEG, VAR_COL, VAR_PFT, & + numpft, CN_zone_weight + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevcan + use clm_varpar , only : nlevdecomp_full, nlevdecomp + use clm_varcon , only : spval, ispval, dzsoi_decomp, zisoi + use nanMod , only : nan + use decompMod , only : bounds_type + use pftconMod , only : npcropmin + use PatchType , only : patch + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + type, public :: cnveg_nitrogenstate_type + + real(r8), pointer :: grainn_patch (:) ! (gN/m2) grain N (crop) + real(r8), pointer :: grainn_storage_patch (:) ! (gN/m2) grain N storage (crop) + real(r8), pointer :: grainn_xfer_patch (:) ! (gN/m2) grain N transfer (crop) + real(r8), pointer :: matrix_cap_grainn_patch (:) ! (gN/m2) Capacity of grain N + real(r8), pointer :: matrix_cap_grainn_storage_patch (:) ! (gN/m2) Capacity of grain N storage + real(r8), pointer :: matrix_cap_grainn_xfer_patch (:) ! (gN/m2) Capacity of grain N transfer + real(r8), pointer :: leafn_patch (:) ! (gN/m2) leaf N + real(r8), pointer :: leafn_storage_patch (:) ! (gN/m2) leaf N storage + real(r8), pointer :: leafn_xfer_patch (:) ! (gN/m2) leaf N transfer + real(r8), pointer :: matrix_cap_leafn_patch (:) ! (gN/m2) Capacity of leaf N + real(r8), pointer :: matrix_cap_leafn_storage_patch (:) ! (gN/m2) Capacity of leaf N storage + real(r8), pointer :: matrix_cap_leafn_xfer_patch (:) ! (gN/m2) Capacity of leaf N transfer + real(r8), pointer :: leafn_storage_xfer_acc_patch (:) ! (gN/m2) Accmulated leaf N transfer + real(r8), pointer :: storage_ndemand_patch (:) ! (gN/m2) N demand during the offset period + real(r8), pointer :: frootn_patch (:) ! (gN/m2) fine root N + real(r8), pointer :: frootn_storage_patch (:) ! (gN/m2) fine root N storage + real(r8), pointer :: frootn_xfer_patch (:) ! (gN/m2) fine root N transfer + real(r8), pointer :: matrix_cap_frootn_patch (:) ! (gN/m2) Capacity of fine root N + real(r8), pointer :: matrix_cap_frootn_storage_patch (:) ! (gN/m2) Capacity of fine root N storage + real(r8), pointer :: matrix_cap_frootn_xfer_patch (:) ! (gN/m2) Capacity of fine root N transfer + real(r8), pointer :: livestemn_patch (:) ! (gN/m2) live stem N + real(r8), pointer :: livestemn_storage_patch (:) ! (gN/m2) live stem N storage + real(r8), pointer :: livestemn_xfer_patch (:) ! (gN/m2) live stem N transfer + real(r8), pointer :: deadstemn_patch (:) ! (gN/m2) dead stem N + real(r8), pointer :: deadstemn_storage_patch (:) ! (gN/m2) dead stem N storage + real(r8), pointer :: deadstemn_xfer_patch (:) ! (gN/m2) dead stem N transfer + real(r8), pointer :: livecrootn_patch (:) ! (gN/m2) live coarse root N + real(r8), pointer :: livecrootn_storage_patch (:) ! (gN/m2) live coarse root N storage + real(r8), pointer :: livecrootn_xfer_patch (:) ! (gN/m2) live coarse root N transfer + real(r8), pointer :: deadcrootn_patch (:) ! (gN/m2) dead coarse root N + real(r8), pointer :: deadcrootn_storage_patch (:) ! (gN/m2) dead coarse root N storage + real(r8), pointer :: deadcrootn_xfer_patch (:) ! (gN/m2) dead coarse root N transfer + real(r8), pointer :: matrix_cap_livestemn_patch (:) ! (gN/m2) Capacity of live stem N + real(r8), pointer :: matrix_cap_livestemn_storage_patch (:) ! (gN/m2) Capacity of live stem N storage + real(r8), pointer :: matrix_cap_livestemn_xfer_patch (:) ! (gN/m2) Capacity of live stem N transfer + real(r8), pointer :: matrix_cap_deadstemn_patch (:) ! (gN/m2) Capacity of dead stem N + real(r8), pointer :: matrix_cap_deadstemn_storage_patch (:) ! (gN/m2) Capacity of dead stem N storage + real(r8), pointer :: matrix_cap_deadstemn_xfer_patch (:) ! (gN/m2) Capacity of dead stem N transfer + real(r8), pointer :: matrix_cap_livecrootn_patch (:) ! (gN/m2) Capacity of live coarse root N + real(r8), pointer :: matrix_cap_livecrootn_storage_patch (:) ! (gN/m2) Capacity of live coarse root N storage + real(r8), pointer :: matrix_cap_livecrootn_xfer_patch (:) ! (gN/m2) Capacity of live coarse root N transfer + real(r8), pointer :: matrix_cap_deadcrootn_patch (:) ! (gN/m2) Capacity of dead coarse root N + real(r8), pointer :: matrix_cap_deadcrootn_storage_patch (:) ! (gN/m2) Capacity of dead coarse root N storage + real(r8), pointer :: matrix_cap_deadcrootn_xfer_patch (:) ! (gN/m2) Capacity of dead coarse root N transfer + real(r8), pointer :: retransn_patch (:) ! (gN/m2) plant pool of retranslocated N + real(r8), pointer :: npool_patch (:) ! (gN/m2) temporary plant N pool + real(r8), pointer :: ntrunc_patch (:) ! (gN/m2) patch-level sink for N truncation + real(r8), pointer :: cropseedn_deficit_patch (:) ! (gN/m2) pool for seeding new crop growth; this is a NEGATIVE term, indicating the amount of seed usage that needs to be repaid + real(r8), pointer :: seedn_grc (:) ! (gN/m2) gridcell-level pool for seeding new pFTs via dynamic landcover +! Pool for initial step of year for matrix + real(r8), pointer :: leafn0_patch (:) ! (gN/m2) Initial value of leaf N for SASU + real(r8), pointer :: leafn0_storage_patch (:) ! (gN/m2) Initial value of leaf N storage for SASU + real(r8), pointer :: leafn0_xfer_patch (:) ! (gN/m2) Initial value of leaf N transfer for SASU + real(r8), pointer :: frootn0_patch (:) ! (gN/m2) Initial value of fine root N for SASU + real(r8), pointer :: frootn0_storage_patch (:) ! (gN/m2) Initial value of fine root N storage for SASU + real(r8), pointer :: frootn0_xfer_patch (:) ! (gN/m2) Initial value of fine root N transfer for SASU + real(r8), pointer :: livestemn0_patch (:) ! (gN/m2) Initial value of live stem N for SASU + real(r8), pointer :: livestemn0_storage_patch (:) ! (gN/m2) Initial value of live stem N storage for SASU + real(r8), pointer :: livestemn0_xfer_patch (:) ! (gN/m2) Initial value of live stem N transfer for SASU + real(r8), pointer :: deadstemn0_patch (:) ! (gN/m2) Initial value of dead stem N for SASU + real(r8), pointer :: deadstemn0_storage_patch (:) ! (gN/m2) Initial value of dead stem N storage for SASU + real(r8), pointer :: deadstemn0_xfer_patch (:) ! (gN/m2) Initial value of dead stem N transfer for SASU + real(r8), pointer :: livecrootn0_patch (:) ! (gN/m2) Initial value of live coarse root N for SASU + real(r8), pointer :: livecrootn0_storage_patch (:) ! (gN/m2) Initial value of live coarse root N storage for SASU + real(r8), pointer :: livecrootn0_xfer_patch (:) ! (gN/m2) Initial value of live coarse root N transfer for SASU + real(r8), pointer :: deadcrootn0_patch (:) ! (gN/m2) Initial value of dead coarse root N for SASU + real(r8), pointer :: deadcrootn0_storage_patch (:) ! (gN/m2) Initial value of dead coarse root N storage for SASU + real(r8), pointer :: deadcrootn0_xfer_patch (:) ! (gN/m2) Initial value of dead coarse root N transfer for SASU + real(r8), pointer :: retransn0_patch (:) ! (gN/m2) Initial value of dead coarse root N transfer for SASU + real(r8), pointer :: grainn0_patch (:) ! (gN/m2) Initial value of grain N for SASU + real(r8), pointer :: grainn0_storage_patch (:) ! (gN/m2) Initial value of grain N storage for SASU + real(r8), pointer :: grainn0_xfer_patch (:) ! (gN/m2) Initial value of grain N transfer for SASU + + ! summary (diagnostic) state variables, not involved in mass balance + real(r8), pointer :: dispvegn_patch (:) ! (gN/m2) displayed veg nitrogen, excluding storage + real(r8), pointer :: storvegn_patch (:) ! (gN/m2) stored vegetation nitrogen + real(r8), pointer :: totvegn_patch (:) ! (gN/m2) total vegetation nitrogen + real(r8), pointer :: totvegn_col (:) ! (gN/m2) total vegetation nitrogen (p2c) + real(r8), pointer :: totn_patch (:) ! (gN/m2) total patch-level nitrogen + real(r8), pointer :: totn_p2c_col (:) ! (gN/m2) totn_patch averaged to col + real(r8), pointer :: totn_col (:) ! (gN/m2) total column nitrogen, incl veg + real(r8), pointer :: totecosysn_col (:) ! (gN/m2) total ecosystem nitrogen, incl veg + real(r8), pointer :: totn_grc (:) ! (gN/m2) total gridcell nitrogen +! acc spinup + real(r8), pointer :: matrix_nalloc_leaf_acc_patch (:) ! (gN/m2/year) Input N allocated to leaf during this year + real(r8), pointer :: matrix_nalloc_leafst_acc_patch (:) ! (gN/m2/year) Input N allocated to leaf storage during this year + real(r8), pointer :: matrix_nalloc_froot_acc_patch (:) ! (gN/m2/year) Input N allocated to fine root during this year + real(r8), pointer :: matrix_nalloc_frootst_acc_patch (:) ! (gN/m2/year) Input N allocated to fine root storage during this year + real(r8), pointer :: matrix_nalloc_livestem_acc_patch (:) ! (gN/m2/year) Input N allocated to live stem during this year + real(r8), pointer :: matrix_nalloc_livestemst_acc_patch (:) ! (gN/m2/year) Input N allocated to live stem storage during this year + real(r8), pointer :: matrix_nalloc_deadstem_acc_patch (:) ! (gN/m2/year) Input N allocated to dead stem during this year + real(r8), pointer :: matrix_nalloc_deadstemst_acc_patch (:) ! (gN/m2/year) Input N allocated to dead stem storage during this year + real(r8), pointer :: matrix_nalloc_livecroot_acc_patch (:) ! (gN/m2/year) Input N allocated to live coarse root during this year + real(r8), pointer :: matrix_nalloc_livecrootst_acc_patch (:) ! (gN/m2/year) Input N allocated to live coarse root storage during this year + real(r8), pointer :: matrix_nalloc_deadcroot_acc_patch (:) ! (gN/m2/year) Input N allocated to dead coarse root during this year + real(r8), pointer :: matrix_nalloc_deadcrootst_acc_patch (:) ! (gN/m2/year) Input N allocated to dead coarse root storage during this year + real(r8), pointer :: matrix_nalloc_grain_acc_patch (:) ! (gN/m2/year) Input N allocated to grain during this year + real(r8), pointer :: matrix_nalloc_grainst_acc_patch (:) ! (gN/m2/year) Input N allocated to grain storage during this year + + real(r8), pointer :: matrix_ntransfer_leafst_to_leafxf_acc_patch (:) ! (gN/m2/year) N transfer from leaf storage to leaf transfer pool during this year + real(r8), pointer :: matrix_ntransfer_leafxf_to_leaf_acc_patch (:) ! (gN/m2/year) N transfer from leaf transfer to leaf pool during this year + real(r8), pointer :: matrix_ntransfer_frootst_to_frootxf_acc_patch (:) ! (gN/m2/year) N transfer from fine root storage to fine root transfer pool during this year + real(r8), pointer :: matrix_ntransfer_frootxf_to_froot_acc_patch (:) ! (gN/m2/year) N transfer from fine root transfer to fine root pool during this year + real(r8), pointer :: matrix_ntransfer_livestemst_to_livestemxf_acc_patch (:) ! (gN/m2/year) N transfer from live stem storage to live stem transfer pool during this year + real(r8), pointer :: matrix_ntransfer_livestemxf_to_livestem_acc_patch (:) ! (gN/m2/year) N transfer from live stem transfer to live stem pool during this year + real(r8), pointer :: matrix_ntransfer_deadstemst_to_deadstemxf_acc_patch (:) ! (gN/m2/year) N transfer from dead stem storage to dead stem transfer pool during this year + real(r8), pointer :: matrix_ntransfer_deadstemxf_to_deadstem_acc_patch (:) ! (gN/m2/year) N transfer from dead stem transfer to dead stem pool during this year + real(r8), pointer :: matrix_ntransfer_livecrootst_to_livecrootxf_acc_patch (:) ! (gN/m2/year) N transfer from live coarse root storage to live coarse root transfer pool during this year + real(r8), pointer :: matrix_ntransfer_livecrootxf_to_livecroot_acc_patch (:) ! (gN/m2/year) N transfer from live coarse root transfer to live coarse root pool during this year + real(r8), pointer :: matrix_ntransfer_deadcrootst_to_deadcrootxf_acc_patch (:) ! (gN/m2/year) N transfer from dead coarse root storage to dead coarse root transfer pool during this year + real(r8), pointer :: matrix_ntransfer_deadcrootxf_to_deadcroot_acc_patch (:) ! (gN/m2/year) N transfer from dead coarse root transfer to dead coarse root pool during this year + real(r8), pointer :: matrix_ntransfer_grainst_to_grainxf_acc_patch (:) ! (gN/m2/year) N transfer from grain storage to grain transfer pool during this year + real(r8), pointer :: matrix_ntransfer_grainxf_to_grain_acc_patch (:) ! (gN/m2/year) N transfer from grain transfer to grain pool during this year + real(r8), pointer :: matrix_ntransfer_livestem_to_deadstem_acc_patch (:) ! (gN/m2/year) N transfer from live stem to dead stem pool during this year + real(r8), pointer :: matrix_ntransfer_livecroot_to_deadcroot_acc_patch (:) ! (gN/m2/year) N transfer from live coarse root to dead coarse root pool during this year + + real(r8), pointer :: matrix_ntransfer_retransn_to_leaf_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to leaf pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_leafst_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to leaf storage pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_froot_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to fine root pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_frootst_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to fine root storage pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_livestem_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to live stem pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_livestemst_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to live stem storage pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_deadstem_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to dead stem pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_deadstemst_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to dead stem storage pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_livecroot_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to live coarse root pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_livecrootst_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to live coarse root storage pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_deadcroot_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to dead coarse root pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_deadcrootst_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to dead coarse root storage pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_grain_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to grain pool during this year + real(r8), pointer :: matrix_ntransfer_retransn_to_grainst_acc_patch (:) ! (gN/m2/year) N transfer from retranslocation to grain storage pool during this year + + real(r8), pointer :: matrix_ntransfer_leaf_to_retransn_acc_patch (:) ! (gN/m2/year) N transfer from leaf to retranslocation pool during this year + real(r8), pointer :: matrix_ntransfer_froot_to_retransn_acc_patch (:) ! (gN/m2/year) N transfer from fine root to retranslocation pool during this year + real(r8), pointer :: matrix_ntransfer_livestem_to_retransn_acc_patch (:) ! (gN/m2/year) N transfer from live stem to retranslocation pool during this year + real(r8), pointer :: matrix_ntransfer_livecroot_to_retransn_acc_patch (:) ! (gN/m2/year) N transfer from live coarse root to retranslocation pool during this year + + real(r8), pointer :: matrix_nturnover_leaf_acc_patch (:) ! (gN/m2/year) N turnover from leaf + real(r8), pointer :: matrix_nturnover_leafst_acc_patch (:) ! (gN/m2/year) N turnover from leaf storage + real(r8), pointer :: matrix_nturnover_leafxf_acc_patch (:) ! (gN/m2/year) N turnover from leaf transfer + real(r8), pointer :: matrix_nturnover_froot_acc_patch (:) ! (gN/m2/year) N turnover from root + real(r8), pointer :: matrix_nturnover_frootst_acc_patch (:) ! (gN/m2/year) N turnover from root storage + real(r8), pointer :: matrix_nturnover_frootxf_acc_patch (:) ! (gN/m2/year) N turnover from root transfer + real(r8), pointer :: matrix_nturnover_livestem_acc_patch (:) ! (gN/m2/year) N turnover from live stem + real(r8), pointer :: matrix_nturnover_livestemst_acc_patch (:) ! (gN/m2/year) N turnover from live stem storage + real(r8), pointer :: matrix_nturnover_livestemxf_acc_patch (:) ! (gN/m2/year) N turnover from live stem transfer + real(r8), pointer :: matrix_nturnover_deadstem_acc_patch (:) ! (gN/m2/year) N turnover from dead stem + real(r8), pointer :: matrix_nturnover_deadstemst_acc_patch (:) ! (gN/m2/year) N turnover from dead stem storage + real(r8), pointer :: matrix_nturnover_deadstemxf_acc_patch (:) ! (gN/m2/year) N turnover from dead stem transfer + real(r8), pointer :: matrix_nturnover_livecroot_acc_patch (:) ! (gN/m2/year) N turnover from live coarse root + real(r8), pointer :: matrix_nturnover_livecrootst_acc_patch (:) ! (gN/m2/year) N turnover from live coarse root storage + real(r8), pointer :: matrix_nturnover_livecrootxf_acc_patch (:) ! (gN/m2/year) N turnover from live coarse root transfer + real(r8), pointer :: matrix_nturnover_deadcroot_acc_patch (:) ! (gN/m2/year) N turnover from dead coarse root + real(r8), pointer :: matrix_nturnover_deadcrootst_acc_patch (:) ! (gN/m2/year) N turnover from dead coarse root storage + real(r8), pointer :: matrix_nturnover_deadcrootxf_acc_patch (:) ! (gN/m2/year) N turnover from dead coarse root transfer + real(r8), pointer :: matrix_nturnover_grain_acc_patch (:) ! (gN/m2/year) N turnover from grain + real(r8), pointer :: matrix_nturnover_grainst_acc_patch (:) ! (gN/m2/year) N turnover from grain storage + real(r8), pointer :: matrix_nturnover_grainxf_acc_patch (:) ! (gN/m2/year) N turnover from grain transfer + real(r8), pointer :: matrix_nturnover_retransn_acc_patch (:) ! (gN/m2/year) N turnover from retranslocation transfer + + real(r8), pointer :: grainn_SASUsave_patch (:) ! (gC/m2) grain C (crop model) + real(r8), pointer :: grainn_storage_SASUsave_patch (:) ! (gC/m2) grain C storage (crop model) + real(r8), pointer :: leafn_SASUsave_patch (:) ! (gC/m2) leaf C + real(r8), pointer :: leafn_storage_SASUsave_patch (:) ! (gC/m2) leaf C storage + real(r8), pointer :: leafn_xfer_SASUsave_patch (:) ! (gC/m2) leaf C transfer + real(r8), pointer :: frootn_SASUsave_patch (:) ! (gC/m2) fine root C + real(r8), pointer :: frootn_storage_SASUsave_patch (:) ! (gC/m2) fine root C storage + real(r8), pointer :: frootn_xfer_SASUsave_patch (:) ! (gC/m2) fine root C transfer + real(r8), pointer :: livestemn_SASUsave_patch (:) ! (gC/m2) live stem C + real(r8), pointer :: livestemn_storage_SASUsave_patch (:) ! (gC/m2) live stem C storage + real(r8), pointer :: livestemn_xfer_SASUsave_patch (:) ! (gC/m2) live stem C transfer + real(r8), pointer :: deadstemn_SASUsave_patch (:) ! (gC/m2) dead stem C + real(r8), pointer :: deadstemn_storage_SASUsave_patch (:) ! (gC/m2) dead stem C storage + real(r8), pointer :: deadstemn_xfer_SASUsave_patch (:) ! (gC/m2) dead stem C transfer + real(r8), pointer :: livecrootn_SASUsave_patch (:) ! (gC/m2) live coarse root C + real(r8), pointer :: livecrootn_storage_SASUsave_patch (:) ! (gC/m2) live coarse root C storage + real(r8), pointer :: livecrootn_xfer_SASUsave_patch (:) ! (gC/m2) live coarse root C transfer + real(r8), pointer :: deadcrootn_SASUsave_patch (:) ! (gC/m2) dead coarse root C + real(r8), pointer :: deadcrootn_storage_SASUsave_patch (:) ! (gC/m2) dead coarse root C storage + real(r8), pointer :: deadcrootn_xfer_SASUsave_patch (:) ! (gC/m2) dead coarse root C transfer:wq + + contains + + procedure , public :: Summary => Summary_nitrogenstate + procedure , public :: ZeroDWT + procedure , public :: Init + +end type cnveg_nitrogenstate_type +type(cnveg_nitrogenstate_type), public, target, save :: cnveg_nitrogenstate_inst + +contains + +!------------------------------------------------------------- + subroutine Init(this, bounds, nch, ityp, fveg, cncol, cnpft) + +! !DESCRIPTION: +! Initialize CTSM nitrogen states +! jk Apr 2021: type is allocated and initialized to NaN; +! if data arrays from restart file are passed (cncol and cnpft), the type is then initialized with these values +! +! !ARGUMENTS: + implicit none + + ! INPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: ityp ! PFT index + real, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: fveg ! PFT fraction + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + real, dimension(nch,NUM_ZON,NUM_VEG,VAR_PFT), intent(in) :: cnpft ! gkw: PFT CN restart + class(cnveg_nitrogenstate_type) :: this + + + ! LOCAL: + + integer :: begp, endp, begg, endg, begc, endc + integer :: np, nc, nz, p, nv, n + !--------------------------------------------------------------------- + + begp = bounds%begp ; endp = bounds%endp + begg = bounds%begg ; endg = bounds%endg + begc = bounds%begc ; endc = bounds%endc + + allocate(this%grainn_patch (begp:endp)) ; this%grainn_patch (:) = nan + allocate(this%grainn_storage_patch (begp:endp)) ; this%grainn_storage_patch (:) = nan + allocate(this%grainn_xfer_patch (begp:endp)) ; this%grainn_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_grainn_patch (begp:endp)) ; this%matrix_cap_grainn_patch (:) = nan + allocate(this%matrix_cap_grainn_storage_patch (begp:endp)) ; this%matrix_cap_grainn_storage_patch (:) = nan + allocate(this%matrix_cap_grainn_xfer_patch (begp:endp)) ; this%matrix_cap_grainn_xfer_patch (:) = nan + end if + allocate(this%leafn_patch (begp:endp)) ; this%leafn_patch (:) = nan + allocate(this%leafn_storage_patch (begp:endp)) ; this%leafn_storage_patch (:) = nan + allocate(this%leafn_xfer_patch (begp:endp)) ; this%leafn_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_leafn_patch (begp:endp)) ; this%matrix_cap_leafn_patch (:) = nan + allocate(this%matrix_cap_leafn_storage_patch (begp:endp)) ; this%matrix_cap_leafn_storage_patch (:) = nan + allocate(this%matrix_cap_leafn_xfer_patch (begp:endp)) ; this%matrix_cap_leafn_xfer_patch (:) = nan + end if + allocate(this%leafn_storage_xfer_acc_patch (begp:endp)) ; this%leafn_storage_xfer_acc_patch (:) = nan + allocate(this%storage_ndemand_patch (begp:endp)) ; this%storage_ndemand_patch (:) = nan + allocate(this%frootn_patch (begp:endp)) ; this%frootn_patch (:) = nan + allocate(this%frootn_storage_patch (begp:endp)) ; this%frootn_storage_patch (:) = nan + allocate(this%frootn_xfer_patch (begp:endp)) ; this%frootn_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_frootn_patch (begp:endp)) ; this%matrix_cap_frootn_patch (:) = nan + allocate(this%matrix_cap_frootn_storage_patch (begp:endp)) ; this%matrix_cap_frootn_storage_patch (:) = nan + allocate(this%matrix_cap_frootn_xfer_patch (begp:endp)) ; this%matrix_cap_frootn_xfer_patch (:) = nan + end if + allocate(this%livestemn_patch (begp:endp)) ; this%livestemn_patch (:) = nan + allocate(this%livestemn_storage_patch (begp:endp)) ; this%livestemn_storage_patch (:) = nan + allocate(this%livestemn_xfer_patch (begp:endp)) ; this%livestemn_xfer_patch (:) = nan + allocate(this%deadstemn_patch (begp:endp)) ; this%deadstemn_patch (:) = nan + allocate(this%deadstemn_storage_patch (begp:endp)) ; this%deadstemn_storage_patch (:) = nan + allocate(this%deadstemn_xfer_patch (begp:endp)) ; this%deadstemn_xfer_patch (:) = nan + allocate(this%livecrootn_patch (begp:endp)) ; this%livecrootn_patch (:) = nan + allocate(this%livecrootn_storage_patch (begp:endp)) ; this%livecrootn_storage_patch (:) = nan + allocate(this%livecrootn_xfer_patch (begp:endp)) ; this%livecrootn_xfer_patch (:) = nan + allocate(this%deadcrootn_patch (begp:endp)) ; this%deadcrootn_patch (:) = nan + allocate(this%deadcrootn_storage_patch (begp:endp)) ; this%deadcrootn_storage_patch (:) = nan + allocate(this%deadcrootn_xfer_patch (begp:endp)) ; this%deadcrootn_xfer_patch (:) = nan + if(use_matrixcn)then + allocate(this%matrix_cap_livestemn_patch (begp:endp)) ; this%matrix_cap_livestemn_patch (:) = nan + allocate(this%matrix_cap_livestemn_storage_patch (begp:endp)) ; this%matrix_cap_livestemn_storage_patch (:) = nan + allocate(this%matrix_cap_livestemn_xfer_patch (begp:endp)) ; this%matrix_cap_livestemn_xfer_patch (:) = nan + allocate(this%matrix_cap_deadstemn_patch (begp:endp)) ; this%matrix_cap_deadstemn_patch (:) = nan + allocate(this%matrix_cap_deadstemn_storage_patch (begp:endp)) ; this%matrix_cap_deadstemn_storage_patch (:) = nan + allocate(this%matrix_cap_deadstemn_xfer_patch (begp:endp)) ; this%matrix_cap_deadstemn_xfer_patch (:) = nan + allocate(this%matrix_cap_livecrootn_patch (begp:endp)) ; this%matrix_cap_livecrootn_patch (:) = nan + allocate(this%matrix_cap_livecrootn_storage_patch (begp:endp)) ; this%matrix_cap_livecrootn_storage_patch (:) = nan + allocate(this%matrix_cap_livecrootn_xfer_patch (begp:endp)) ; this%matrix_cap_livecrootn_xfer_patch (:) = nan + allocate(this%matrix_cap_deadcrootn_patch (begp:endp)) ; this%matrix_cap_deadcrootn_patch (:) = nan + allocate(this%matrix_cap_deadcrootn_storage_patch (begp:endp)) ; this%matrix_cap_deadcrootn_storage_patch (:) = nan + allocate(this%matrix_cap_deadcrootn_xfer_patch (begp:endp)) ; this%matrix_cap_deadcrootn_xfer_patch (:) = nan + end if + allocate(this%retransn_patch (begp:endp)) ; this%retransn_patch (:) = nan + allocate(this%npool_patch (begp:endp)) ; this%npool_patch (:) = nan + allocate(this%ntrunc_patch (begp:endp)) ; this%ntrunc_patch (:) = nan + allocate(this%dispvegn_patch (begp:endp)) ; this%dispvegn_patch (:) = nan + allocate(this%storvegn_patch (begp:endp)) ; this%storvegn_patch (:) = nan + allocate(this%totvegn_patch (begp:endp)) ; this%totvegn_patch (:) = spval + allocate(this%totn_patch (begp:endp)) ; this%totn_patch (:) = spval + + allocate(this%cropseedn_deficit_patch (begp:endp)) ; this%cropseedn_deficit_patch (:) = nan + allocate(this%seedn_grc (begg:endg)) ; this%seedn_grc (:) = nan + allocate(this%totvegn_col (begc:endc)) ; this%totvegn_col (:) = nan + allocate(this%totn_p2c_col (begc:endc)) ; this%totn_p2c_col (:) = nan + allocate(this%totn_col (begc:endc)) ; this%totn_col (:) = spval + allocate(this%totecosysn_col (begc:endc)) ; this%totecosysn_col (:) = nan + allocate(this%totn_grc (begg:endg)) ; this%totn_grc (:) = nan + + if(use_matrixcn)then + allocate(this%leafn0_patch (begp:endp)) ; this%leafn0_patch (:) = nan + allocate(this%leafn0_storage_patch (begp:endp)) ; this%leafn0_storage_patch (:) = nan + allocate(this%leafn0_xfer_patch (begp:endp)) ; this%leafn0_xfer_patch (:) = nan + allocate(this%frootn0_patch (begp:endp)) ; this%frootn0_patch (:) = nan + allocate(this%frootn0_storage_patch (begp:endp)) ; this%frootn0_storage_patch (:) = nan + allocate(this%frootn0_xfer_patch (begp:endp)) ; this%frootn0_xfer_patch (:) = nan + allocate(this%livestemn0_patch (begp:endp)) ; this%livestemn0_patch (:) = nan + allocate(this%livestemn0_storage_patch (begp:endp)) ; this%livestemn0_storage_patch (:) = nan + allocate(this%livestemn0_xfer_patch (begp:endp)) ; this%livestemn0_xfer_patch (:) = nan + allocate(this%deadstemn0_patch (begp:endp)) ; this%deadstemn0_patch (:) = nan + allocate(this%deadstemn0_storage_patch (begp:endp)) ; this%deadstemn0_storage_patch (:) = nan + allocate(this%deadstemn0_xfer_patch (begp:endp)) ; this%deadstemn0_xfer_patch (:) = nan + allocate(this%livecrootn0_patch (begp:endp)) ; this%livecrootn0_patch (:) = nan + allocate(this%livecrootn0_storage_patch (begp:endp)) ; this%livecrootn0_storage_patch (:) = nan + allocate(this%livecrootn0_xfer_patch (begp:endp)) ; this%livecrootn0_xfer_patch (:) = nan + allocate(this%deadcrootn0_patch (begp:endp)) ; this%deadcrootn0_patch (:) = nan + allocate(this%deadcrootn0_storage_patch (begp:endp)) ; this%deadcrootn0_storage_patch (:) = nan + allocate(this%deadcrootn0_xfer_patch (begp:endp)) ; this%deadcrootn0_xfer_patch (:) = nan + allocate(this%grainn0_patch (begp:endp)) ; this%grainn0_patch (:) = nan + allocate(this%grainn0_storage_patch (begp:endp)) ; this%grainn0_storage_patch (:) = nan + allocate(this%grainn0_xfer_patch (begp:endp)) ; this%grainn0_xfer_patch (:) = nan + allocate(this%retransn0_patch (begp:endp)) ; this%retransn0_patch (:) = nan + + allocate(this%leafn_SASUsave_patch (begp:endp)) ; this%leafn_SASUsave_patch (:) = nan + allocate(this%leafn_storage_SASUsave_patch (begp:endp)) ; this%leafn_storage_SASUsave_patch (:) = nan + allocate(this%leafn_xfer_SASUsave_patch (begp:endp)) ; this%leafn_xfer_SASUsave_patch (:) = nan + allocate(this%frootn_SASUsave_patch (begp:endp)) ; this%frootn_SASUsave_patch (:) = nan + allocate(this%frootn_storage_SASUsave_patch (begp:endp)) ; this%frootn_storage_SASUsave_patch (:) = nan + allocate(this%frootn_xfer_SASUsave_patch (begp:endp)) ; this%frootn_xfer_SASUsave_patch (:) = nan + allocate(this%livestemn_SASUsave_patch (begp:endp)) ; this%livestemn_SASUsave_patch (:) = nan + allocate(this%livestemn_storage_SASUsave_patch (begp:endp)) ; this%livestemn_storage_SASUsave_patch (:) = nan + allocate(this%livestemn_xfer_SASUsave_patch (begp:endp)) ; this%livestemn_xfer_SASUsave_patch (:) = nan + allocate(this%deadstemn_SASUsave_patch (begp:endp)) ; this%deadstemn_SASUsave_patch (:) = nan + allocate(this%deadstemn_storage_SASUsave_patch (begp:endp)) ; this%deadstemn_storage_SASUsave_patch (:) = nan + allocate(this%deadstemn_xfer_SASUsave_patch (begp:endp)) ; this%deadstemn_xfer_SASUsave_patch (:) = nan + allocate(this%livecrootn_SASUsave_patch (begp:endp)) ; this%livecrootn_SASUsave_patch (:) = nan + allocate(this%livecrootn_storage_SASUsave_patch (begp:endp)) ; this%livecrootn_storage_SASUsave_patch (:) = nan + allocate(this%livecrootn_xfer_SASUsave_patch (begp:endp)) ; this%livecrootn_xfer_SASUsave_patch (:) = nan + allocate(this%deadcrootn_SASUsave_patch (begp:endp)) ; this%deadcrootn_SASUsave_patch (:) = nan + allocate(this%deadcrootn_storage_SASUsave_patch (begp:endp)) ; this%deadcrootn_storage_SASUsave_patch (:) = nan + allocate(this%deadcrootn_xfer_SASUsave_patch (begp:endp)) ; this%deadcrootn_xfer_SASUsave_patch (:) = nan + allocate(this%grainn_SASUsave_patch (begp:endp)) ; this%grainn_SASUsave_patch (:) = nan + allocate(this%grainn_storage_SASUsave_patch (begp:endp)) ; this%grainn_storage_SASUsave_patch (:) = nan + + allocate(this%matrix_nalloc_leaf_acc_patch (begp:endp)) ; this%matrix_nalloc_leaf_acc_patch (:) = nan + allocate(this%matrix_nalloc_leafst_acc_patch (begp:endp)) ; this%matrix_nalloc_leafst_acc_patch (:) = nan + allocate(this%matrix_nalloc_froot_acc_patch (begp:endp)) ; this%matrix_nalloc_froot_acc_patch (:) = nan + allocate(this%matrix_nalloc_frootst_acc_patch (begp:endp)) ; this%matrix_nalloc_frootst_acc_patch (:) = nan + allocate(this%matrix_nalloc_livestem_acc_patch (begp:endp)) ; this%matrix_nalloc_livestem_acc_patch (:) = nan + allocate(this%matrix_nalloc_livestemst_acc_patch (begp:endp)) ; this%matrix_nalloc_livestemst_acc_patch (:) = nan + allocate(this%matrix_nalloc_deadstem_acc_patch (begp:endp)) ; this%matrix_nalloc_deadstem_acc_patch (:) = nan + allocate(this%matrix_nalloc_deadstemst_acc_patch (begp:endp)) ; this%matrix_nalloc_deadstemst_acc_patch (:) = nan + allocate(this%matrix_nalloc_livecroot_acc_patch (begp:endp)) ; this%matrix_nalloc_livecroot_acc_patch (:) = nan + allocate(this%matrix_nalloc_livecrootst_acc_patch (begp:endp)) ; this%matrix_nalloc_livecrootst_acc_patch (:) = nan + allocate(this%matrix_nalloc_deadcroot_acc_patch (begp:endp)) ; this%matrix_nalloc_deadcroot_acc_patch (:) = nan + allocate(this%matrix_nalloc_deadcrootst_acc_patch (begp:endp)) ; this%matrix_nalloc_deadcrootst_acc_patch (:) = nan + allocate(this%matrix_nalloc_grain_acc_patch (begp:endp)) ; this%matrix_nalloc_grain_acc_patch (:) = nan + allocate(this%matrix_nalloc_grainst_acc_patch (begp:endp)) ; this%matrix_nalloc_grainst_acc_patch (:) = nan + + allocate(this%matrix_ntransfer_leafst_to_leafxf_acc_patch (begp:endp)) ; this%matrix_ntransfer_leafst_to_leafxf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_leafxf_to_leaf_acc_patch (begp:endp)) ; this%matrix_ntransfer_leafxf_to_leaf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_frootst_to_frootxf_acc_patch (begp:endp)) ; this%matrix_ntransfer_frootst_to_frootxf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_frootxf_to_froot_acc_patch (begp:endp)) ; this%matrix_ntransfer_frootxf_to_froot_acc_patch (:) = nan + allocate(this%matrix_ntransfer_livestemst_to_livestemxf_acc_patch (begp:endp)) ; this%matrix_ntransfer_livestemst_to_livestemxf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_livestemxf_to_livestem_acc_patch (begp:endp)) ; this%matrix_ntransfer_livestemxf_to_livestem_acc_patch (:) = nan + allocate(this%matrix_ntransfer_deadstemst_to_deadstemxf_acc_patch (begp:endp)) ; this%matrix_ntransfer_deadstemst_to_deadstemxf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_deadstemxf_to_deadstem_acc_patch (begp:endp)) ; this%matrix_ntransfer_deadstemxf_to_deadstem_acc_patch (:) = nan + allocate(this%matrix_ntransfer_livecrootst_to_livecrootxf_acc_patch (begp:endp)) ; this%matrix_ntransfer_livecrootst_to_livecrootxf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_livecrootxf_to_livecroot_acc_patch (begp:endp)) ; this%matrix_ntransfer_livecrootxf_to_livecroot_acc_patch (:) = nan + allocate(this%matrix_ntransfer_deadcrootst_to_deadcrootxf_acc_patch (begp:endp)) ; this%matrix_ntransfer_deadcrootst_to_deadcrootxf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_deadcrootxf_to_deadcroot_acc_patch (begp:endp)) ; this%matrix_ntransfer_deadcrootxf_to_deadcroot_acc_patch (:) = nan + allocate(this%matrix_ntransfer_grainst_to_grainxf_acc_patch (begp:endp)) ; this%matrix_ntransfer_grainst_to_grainxf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_grainxf_to_grain_acc_patch (begp:endp)) ; this%matrix_ntransfer_grainxf_to_grain_acc_patch (:) = nan + allocate(this%matrix_ntransfer_livestem_to_deadstem_acc_patch (begp:endp)) ; this%matrix_ntransfer_livestem_to_deadstem_acc_patch (:) = nan + allocate(this%matrix_ntransfer_livecroot_to_deadcroot_acc_patch (begp:endp)) ; this%matrix_ntransfer_livecroot_to_deadcroot_acc_patch (:) = nan + + allocate(this%matrix_ntransfer_retransn_to_leaf_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_leaf_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_leafst_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_leafst_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_froot_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_froot_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_frootst_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_frootst_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_livestem_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_livestem_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_livestemst_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_livestemst_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_deadstem_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_deadstem_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_deadstemst_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_deadstemst_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_livecroot_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_livecroot_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_livecrootst_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_livecrootst_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_deadcroot_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_deadcroot_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_deadcrootst_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_deadcrootst_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_grain_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_grain_acc_patch (:) = nan + allocate(this%matrix_ntransfer_retransn_to_grainst_acc_patch (begp:endp)) ; this%matrix_ntransfer_retransn_to_grainst_acc_patch (:) = nan + + allocate(this%matrix_ntransfer_leaf_to_retransn_acc_patch (begp:endp)) ; this%matrix_ntransfer_leaf_to_retransn_acc_patch (:) = nan + allocate(this%matrix_ntransfer_froot_to_retransn_acc_patch (begp:endp)) ; this%matrix_ntransfer_froot_to_retransn_acc_patch (:) = nan + allocate(this%matrix_ntransfer_livestem_to_retransn_acc_patch (begp:endp)) ; this%matrix_ntransfer_livestem_to_retransn_acc_patch (:) = nan + allocate(this%matrix_ntransfer_livecroot_to_retransn_acc_patch (begp:endp)) ; this%matrix_ntransfer_livecroot_to_retransn_acc_patch (:) = nan + + allocate(this%matrix_nturnover_leaf_acc_patch (begp:endp)) ; this%matrix_nturnover_leaf_acc_patch (:) = nan + allocate(this%matrix_nturnover_leafst_acc_patch (begp:endp)) ; this%matrix_nturnover_leafst_acc_patch (:) = nan + allocate(this%matrix_nturnover_leafxf_acc_patch (begp:endp)) ; this%matrix_nturnover_leafxf_acc_patch (:) = nan + allocate(this%matrix_nturnover_froot_acc_patch (begp:endp)) ; this%matrix_nturnover_froot_acc_patch (:) = nan + allocate(this%matrix_nturnover_frootst_acc_patch (begp:endp)) ; this%matrix_nturnover_frootst_acc_patch (:) = nan + allocate(this%matrix_nturnover_frootxf_acc_patch (begp:endp)) ; this%matrix_nturnover_frootxf_acc_patch (:) = nan + allocate(this%matrix_nturnover_livestem_acc_patch (begp:endp)) ; this%matrix_nturnover_livestem_acc_patch (:) = nan + allocate(this%matrix_nturnover_livestemst_acc_patch (begp:endp)) ; this%matrix_nturnover_livestemst_acc_patch (:) = nan + allocate(this%matrix_nturnover_livestemxf_acc_patch (begp:endp)) ; this%matrix_nturnover_livestemxf_acc_patch (:) = nan + allocate(this%matrix_nturnover_deadstem_acc_patch (begp:endp)) ; this%matrix_nturnover_deadstem_acc_patch (:) = nan + allocate(this%matrix_nturnover_deadstemst_acc_patch (begp:endp)) ; this%matrix_nturnover_deadstemst_acc_patch (:) = nan + allocate(this%matrix_nturnover_deadstemxf_acc_patch (begp:endp)) ; this%matrix_nturnover_deadstemxf_acc_patch (:) = nan + allocate(this%matrix_nturnover_livecroot_acc_patch (begp:endp)) ; this%matrix_nturnover_livecroot_acc_patch (:) = nan + allocate(this%matrix_nturnover_livecrootst_acc_patch (begp:endp)) ; this%matrix_nturnover_livecrootst_acc_patch (:) = nan + allocate(this%matrix_nturnover_livecrootxf_acc_patch (begp:endp)) ; this%matrix_nturnover_livecrootxf_acc_patch (:) = nan + allocate(this%matrix_nturnover_deadcroot_acc_patch (begp:endp)) ; this%matrix_nturnover_deadcroot_acc_patch (:) = nan + allocate(this%matrix_nturnover_deadcrootst_acc_patch (begp:endp)) ; this%matrix_nturnover_deadcrootst_acc_patch (:) = nan + allocate(this%matrix_nturnover_deadcrootxf_acc_patch (begp:endp)) ; this%matrix_nturnover_deadcrootxf_acc_patch (:) = nan + allocate(this%matrix_nturnover_grain_acc_patch (begp:endp)) ; this%matrix_nturnover_grain_acc_patch (:) = nan + allocate(this%matrix_nturnover_grainst_acc_patch (begp:endp)) ; this%matrix_nturnover_grainst_acc_patch (:) = nan + allocate(this%matrix_nturnover_grainxf_acc_patch (begp:endp)) ; this%matrix_nturnover_grainxf_acc_patch (:) = nan + allocate(this%matrix_nturnover_retransn_acc_patch (begp:endp)) ; this%matrix_nturnover_retransn_acc_patch (:) = nan + end if + + ! initialize arrays with values from restarts + + n = 0 + np = 0 + do nc = 1,nch ! catchment tile loop + + this%seedn_grc(nc) = 0 + + do nz = 1,NUM_ZON ! CN zone loop + n = n + 1 + + this%seedn_grc(nc) = this%seedn_grc(nc) + cncol(nc,nz,23)*CN_zone_weight(nz) + this%totn_col(n) = cncol(nc,nz,29) + + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,NUM_VEG ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + + this%deadcrootn_patch (np) = cnpft(nc,nz,nv, 48) + this%deadcrootn_storage_patch (np) = cnpft(nc,nz,nv, 49) + this%deadcrootn_xfer_patch (np) = cnpft(nc,nz,nv, 50) + this%deadstemn_patch (np) = cnpft(nc,nz,nv, 51) + this%deadstemn_storage_patch (np) = cnpft(nc,nz,nv, 52) + this%deadstemn_xfer_patch (np) = cnpft(nc,nz,nv, 53) + this%frootn_patch (np) = cnpft(nc,nz,nv, 54) + this%frootn_storage_patch (np) = cnpft(nc,nz,nv, 55) + this%frootn_xfer_patch (np) = cnpft(nc,nz,nv, 56) + this%leafn_patch (np) = cnpft(nc,nz,nv, 57) + this%leafn_storage_patch (np) = cnpft(nc,nz,nv, 58) + this%leafn_xfer_patch (np) = cnpft(nc,nz,nv, 59) + this%livecrootn_patch (np) = cnpft(nc,nz,nv, 60) + this%livecrootn_storage_patch (np) = cnpft(nc,nz,nv, 61) + this%livecrootn_xfer_patch (np) = cnpft(nc,nz,nv, 62) + this%livestemn_patch (np) = cnpft(nc,nz,nv, 63) + this%livestemn_storage_patch (np) = cnpft(nc,nz,nv, 64) + this%livestemn_xfer_patch (np) = cnpft(nc,nz,nv, 65) + this%npool_patch (np) = cnpft(nc,nz,nv, 66) + this%ntrunc_patch (np) = cnpft(nc,nz,nv, 67) + this%retransn_patch (np) = cnpft(nc,nz,nv, 68) + + end if + end do !nv + end do !p + end do !nz + end do ! nc + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine Summary_nitrogenstate(this, bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp,& + soilbiogeochem_nitrogenstate_inst) + ! + ! !USES: + use subgridAveMod, only : p2c + use SoilBiogeochemNitrogenStateType, only : soilbiogeochem_nitrogenstate_type + ! + ! !ARGUMENTS: + class(cnveg_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all active columns + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(soilbiogeochem_nitrogenstate_type) , intent(in) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,k,l ! indices + integer :: fp,fc ! lake filter indices + real(r8) :: maxdepth ! depth to integrate soil variables + !----------------------------------------------------------------------- + + ! -------------------------------------------- + ! patch level summary + ! -------------------------------------------- + + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! displayed vegetation nitrogen, excluding storage (DISPVEGN) + this%dispvegn_patch(p) = & + this%leafn_patch(p) + & + this%frootn_patch(p) + & + this%livestemn_patch(p) + & + this%deadstemn_patch(p) + & + this%livecrootn_patch(p) + & + this%deadcrootn_patch(p) + + ! stored vegetation nitrogen, including retranslocated N pool (STORVEGN) + this%storvegn_patch(p) = & + this%leafn_storage_patch(p) + & + this%frootn_storage_patch(p) + & + this%livestemn_storage_patch(p) + & + this%deadstemn_storage_patch(p) + & + this%livecrootn_storage_patch(p) + & + this%deadcrootn_storage_patch(p) + & + this%leafn_xfer_patch(p) + & + this%frootn_xfer_patch(p) + & + this%livestemn_xfer_patch(p) + & + this%deadstemn_xfer_patch(p) + & + this%livecrootn_xfer_patch(p) + & + this%deadcrootn_xfer_patch(p) + & + this%npool_patch(p) + & + this%retransn_patch(p) + + if ( use_crop .and. patch%itype(p) >= npcropmin )then + this%dispvegn_patch(p) = & + this%dispvegn_patch(p) + & + this%grainn_patch(p) + + this%storvegn_patch(p) = & + this%storvegn_patch(p) + & + this%grainn_storage_patch(p) + & + this%grainn_xfer_patch(p) + & + this%cropseedn_deficit_patch(p) + end if + + ! total vegetation nitrogen (TOTVEGN) + this%totvegn_patch(p) = & + this%dispvegn_patch(p) + & + this%storvegn_patch(p) + + ! total patch-level carbon (add ntrunc) + this%totn_patch(p) = & + this%totvegn_patch(p) + & + this%ntrunc_patch(p) + + end do + + ! -------------------------------------------- + ! column level summary + ! -------------------------------------------- + + call p2c(bounds, num_soilc, filter_soilc, & + this%totvegn_patch(bounds%begp:bounds%endp), & + this%totvegn_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + this%totn_patch(bounds%begp:bounds%endp), & + this%totn_p2c_col(bounds%begc:bounds%endc)) + + + do fc = 1,num_allc + c = filter_allc(fc) + + ! total ecosystem nitrogen, including veg (TOTECOSYSN) + this%totecosysn_col(c) = & + soilbiogeochem_nitrogenstate_inst%cwdn_col(c) + & + soilbiogeochem_nitrogenstate_inst%totlitn_col(c) + & + soilbiogeochem_nitrogenstate_inst%totsomn_col(c) + & + soilbiogeochem_nitrogenstate_inst%sminn_col(c) + & + this%totvegn_col(c) + + ! total column nitrogen, including patch (TOTCOLN) + + this%totn_col(c) = this%totn_p2c_col(c) + & + soilbiogeochem_nitrogenstate_inst%cwdn_col(c) + & + soilbiogeochem_nitrogenstate_inst%totlitn_col(c) + & + soilbiogeochem_nitrogenstate_inst%totsomn_col(c) + & + soilbiogeochem_nitrogenstate_inst%sminn_col(c) + & + soilbiogeochem_nitrogenstate_inst%ntrunc_col(c) + + end do + + end subroutine Summary_nitrogenstate + + !----------------------------------------------------------------------- + subroutine ZeroDwt( this, bounds ) + ! + ! !DESCRIPTION + ! Initialize variables needed for dynamic land use. + ! + ! !ARGUMENTS: + class(cnveg_nitrogenstate_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p ! indices + !----------------------------------------------------------------------- + + do p = bounds%begp,bounds%endp + this%dispvegn_patch(p) = 0._r8 + this%storvegn_patch(p) = 0._r8 + this%totvegn_patch(p) = 0._r8 + this%totn_patch(p) = 0._r8 + end do + + end subroutine ZeroDwt + +end module CNVegNitrogenStateType + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegStateType.F90 new file mode 100755 index 000000000..3d7135a4f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CNVegStateType.F90 @@ -0,0 +1,256 @@ +module CNVegStateType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use clm_varpar , only : nlevsno, nlevgrnd, nlevlak, nlevsoi, & + num_zon, num_veg, var_col, var_pft, numpft + use clm_varcon , only : spval, ispval + use decompMod , only : bounds_type + use AnnualFluxDribbler, only : annual_flux_dribbler_type, annual_flux_dribbler_patch + + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: cnveg_state_type + + integer , pointer :: burndate_patch (:) ! patch crop burn date + type(annual_flux_dribbler_type) :: dwt_dribbler_patch ! object to convert instantaneous dwt values into values that are smoothed / dribbled throughout the year + real(r8) , pointer :: dwt_smoothed_patch (:) ! change in patch weight (-1 to 1) on the gridcell in this time step; changes in first time step of year are smoothed (dribbled) over the whole year + + ! Prognostic crop model + ! + ! TODO(wjs, 2016-02-22) Most / all of these crop-specific state variables should be + ! moved to CropType + real(r8) , pointer :: hdidx_patch (:) ! patch cold hardening index? + real(r8) , pointer :: cumvd_patch (:) ! patch cumulative vernalization d?ependence? + real(r8) , pointer :: gddmaturity_patch (:) ! patch growing degree days (gdd) needed to harvest (ddays) + real(r8) , pointer :: huileaf_patch (:) ! patch heat unit index needed from planting to leaf emergence + real(r8) , pointer :: huigrain_patch (:) ! patch heat unit index needed to reach vegetative maturity + real(r8) , pointer :: aleafi_patch (:) ! patch saved leaf allocation coefficient from phase 2 + real(r8) , pointer :: astemi_patch (:) ! patch saved stem allocation coefficient from phase 2 + real(r8) , pointer :: aleaf_patch (:) ! patch leaf allocation coefficient + real(r8) , pointer :: astem_patch (:) ! patch stem allocation coefficient + real(r8) , pointer :: htmx_patch (:) ! patch max hgt attained by a crop during yr (m) + integer , pointer :: peaklai_patch (:) ! patch 1: max allowed lai; 0: not at max + + integer , pointer :: idop_patch (:) ! patch date of planting + + real(r8) , pointer :: gdp_lf_col (:) ! col global real gdp data (k US$/capita) + real(r8) , pointer :: peatf_lf_col (:) ! col global peatland fraction data (0-1) + integer , pointer :: abm_lf_col (:) ! col global peak month of crop fire emissions + + real(r8) , pointer :: lgdp_col (:) ! col gdp limitation factor for fire occurrence (0-1) + real(r8) , pointer :: lgdp1_col (:) ! col gdp limitation factor for fire spreading (0-1) + real(r8) , pointer :: lpop_col (:) ! col pop limitation factor for fire spreading (0-1) + + real(r8) , pointer :: tempavg_t2m_patch (:) ! patch temporary average 2m air temperature (K) + real(r8) , pointer :: annavg_t2m_patch (:) ! patch annual average 2m air temperature (K) + real(r8) , pointer :: annavg_t2m_col (:) ! col annual average of 2m air temperature, averaged from patch-level (K) + real(r8) , pointer :: annsum_counter_col (:) ! col seconds since last annual accumulator turnover + + ! Fire + real(r8) , pointer :: nfire_col (:) ! col fire counts (count/km2/sec), valid only in Reg. C + real(r8) , pointer :: fsr_col (:) ! col fire spread rate at column level (m/s) + real(r8) , pointer :: fd_col (:) ! col fire duration at column level (hr) + real(r8) , pointer :: lfc_col (:) ! col conversion area fraction of BET and BDT that haven't burned before (/timestep) + real(r8) , pointer :: lfc2_col (:) ! col conversion area fraction of BET and BDT that burned (/sec) + real(r8) , pointer :: dtrotr_col (:) ! col annual decreased fraction coverage of BET on the gridcell (0-1) + real(r8) , pointer :: trotr1_col (:) ! col patch weight of BET on the column (0-1) + real(r8) , pointer :: trotr2_col (:) ! col patch weight of BDT on the column (0-1) + real(r8) , pointer :: cropf_col (:) ! col crop fraction in veg column (0-1) + real(r8) , pointer :: baf_crop_col (:) ! col baf for cropland(/sec) + real(r8) , pointer :: baf_peatf_col (:) ! col baf for peatland (/sec) + real(r8) , pointer :: fbac_col (:) ! col total burned area out of conversion (/sec) + real(r8) , pointer :: fbac1_col (:) ! col burned area out of conversion region due to land use fire (/sec) + real(r8) , pointer :: wtlf_col (:) ! col fractional coverage of non-crop Patches (0-1) + real(r8) , pointer :: lfwt_col (:) ! col fractional coverage of non-crop and non-bare-soil Patches (0-1) + real(r8) , pointer :: farea_burned_col (:) ! col fractional area burned (/sec) + + real(r8), pointer :: dormant_flag_patch (:) ! patch dormancy flag + real(r8), pointer :: days_active_patch (:) ! patch number of days since last dormancy + real(r8), pointer :: onset_flag_patch (:) ! patch onset flag + real(r8), pointer :: onset_counter_patch (:) ! patch onset days counter + real(r8), pointer :: onset_gddflag_patch (:) ! patch onset flag for growing degree day sum + real(r8), pointer :: onset_fdd_patch (:) ! patch onset freezing degree days counter + real(r8), pointer :: onset_gdd_patch (:) ! patch onset growing degree days + real(r8), pointer :: onset_swi_patch (:) ! patch onset soil water index + real(r8), pointer :: offset_flag_patch (:) ! patch offset flag + real(r8), pointer :: offset_counter_patch (:) ! patch offset days counter + real(r8), pointer :: offset_fdd_patch (:) ! patch offset freezing degree days counter + real(r8), pointer :: offset_swi_patch (:) ! patch offset soil water index + real(r8), pointer :: grain_flag_patch (:) ! patch 1: grain fill stage; 0: not + real(r8), pointer :: lgsf_patch (:) ! patch long growing season factor [0-1] + real(r8), pointer :: bglfr_patch (:) ! patch background litterfall rate (1/s) + real(r8), pointer :: bgtr_patch (:) ! patch background transfer growth rate (1/s) + real(r8), pointer :: c_allometry_patch (:) ! patch C allocation index (DIM) + real(r8), pointer :: n_allometry_patch (:) ! patch N allocation index (DIM) + + real(r8), pointer :: tempsum_potential_gpp_patch (:) ! patch temporary annual sum of potential GPP + real(r8), pointer :: annsum_potential_gpp_patch (:) ! patch annual sum of potential GPP + real(r8), pointer :: tempmax_retransn_patch (:) ! patch temporary annual max of retranslocated N pool (gN/m2) + real(r8), pointer :: annmax_retransn_patch (:) ! patch annual max of retranslocated N pool (gN/m2) + real(r8), pointer :: downreg_patch (:) ! patch fractional reduction in GPP due to N limitation (DIM) + real(r8), pointer :: leafcn_offset_patch (:) ! patch leaf C:N used by FUN + real(r8), pointer :: plantCN_patch (:) ! patch plant C:N used by FUN + + contains + + procedure, public :: Init + + end type cnveg_state_type + + type(cnveg_state_type), public, target, save :: cnveg_state_inst + +contains + +!----------------------------------------------------- +!---------------------------------------------- + subroutine Init(this, bounds, nch, ityp, fveg, cncol, cnpft) + +! !DESCRIPTION: +! Initialize CTSM vegetation states +! jk Apr 2021: type is allocated and initialized to NaN; +! if data arrays from restart file are passed (cncol and cnpft), the type is then initialized with these values +! +! !ARGUMENTS: + implicit none + + ! INPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: ityp ! PFT index + real, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: fveg ! PFT fraction + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + real, dimension(nch,NUM_ZON,NUM_VEG,VAR_PFT), intent(in) :: cnpft ! gkw: PFT CN restart + class(cnveg_state_type) :: this + + ! LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: np, nc, nz, p, nv, n + !-------------------------------- + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + allocate(this%burndate_patch (begp:endp)) ; this%burndate_patch (:) = ispval + allocate(this%dwt_smoothed_patch (begp:endp)) ; this%dwt_smoothed_patch (:) = nan + + allocate(this%hdidx_patch (begp:endp)) ; this%hdidx_patch (:) = nan + allocate(this%cumvd_patch (begp:endp)) ; this%cumvd_patch (:) = nan + allocate(this%gddmaturity_patch (begp:endp)) ; this%gddmaturity_patch (:) = spval + allocate(this%huileaf_patch (begp:endp)) ; this%huileaf_patch (:) = nan + allocate(this%huigrain_patch (begp:endp)) ; this%huigrain_patch (:) = 0.0_r8 + allocate(this%aleafi_patch (begp:endp)) ; this%aleafi_patch (:) = nan + allocate(this%astemi_patch (begp:endp)) ; this%astemi_patch (:) = nan + allocate(this%aleaf_patch (begp:endp)) ; this%aleaf_patch (:) = nan + allocate(this%astem_patch (begp:endp)) ; this%astem_patch (:) = nan + allocate(this%htmx_patch (begp:endp)) ; this%htmx_patch (:) = 0.0_r8 + allocate(this%peaklai_patch (begp:endp)) ; this%peaklai_patch (:) = 0 + + allocate(this%idop_patch (begp:endp)) ; this%idop_patch (:) = huge(1) + + allocate(this%gdp_lf_col (begc:endc)) ; + allocate(this%peatf_lf_col (begc:endc)) ; + allocate(this%abm_lf_col (begc:endc)) ; + + allocate(this%lgdp_col (begc:endc)) ; + allocate(this%lgdp1_col (begc:endc)) ; + allocate(this%lpop_col (begc:endc)) ; + + allocate(this%tempavg_t2m_patch (begp:endp)) ; this%tempavg_t2m_patch (:) = nan + allocate(this%annsum_counter_col (begc:endc)) ; this%annsum_counter_col (:) = nan + allocate(this%annavg_t2m_col (begc:endc)) ; this%annavg_t2m_col (:) = nan + allocate(this%annavg_t2m_patch (begp:endp)) ; this%annavg_t2m_patch (:) = spval + + allocate(this%nfire_col (begc:endc)) ; this%nfire_col (:) = spval + allocate(this%fsr_col (begc:endc)) ; this%fsr_col (:) = nan + allocate(this%fd_col (begc:endc)) ; this%fd_col (:) = nan + allocate(this%lfc_col (begc:endc)) ; this%lfc_col (:) = spval + allocate(this%lfc2_col (begc:endc)) ; this%lfc2_col (:) = 0._r8 + allocate(this%dtrotr_col (begc:endc)) ; this%dtrotr_col (:) = 0._r8 + allocate(this%trotr1_col (begc:endc)) ; this%trotr1_col (:) = 0._r8 + allocate(this%trotr2_col (begc:endc)) ; this%trotr2_col (:) = 0._r8 + allocate(this%cropf_col (begc:endc)) ; this%cropf_col (:) = nan + allocate(this%baf_crop_col (begc:endc)) ; this%baf_crop_col (:) = nan + allocate(this%baf_peatf_col (begc:endc)) ; this%baf_peatf_col (:) = nan + allocate(this%fbac_col (begc:endc)) ; this%fbac_col (:) = nan + allocate(this%fbac1_col (begc:endc)) ; this%fbac1_col (:) = nan + allocate(this%wtlf_col (begc:endc)) ; this%wtlf_col (:) = nan + allocate(this%lfwt_col (begc:endc)) ; this%lfwt_col (:) = nan + allocate(this%farea_burned_col (begc:endc)) ; this%farea_burned_col (:) = nan + + allocate(this%dormant_flag_patch (begp:endp)) ; this%dormant_flag_patch (:) = nan + allocate(this%days_active_patch (begp:endp)) ; this%days_active_patch (:) = nan + allocate(this%onset_flag_patch (begp:endp)) ; this%onset_flag_patch (:) = nan + allocate(this%onset_counter_patch (begp:endp)) ; this%onset_counter_patch (:) = nan + allocate(this%onset_gddflag_patch (begp:endp)) ; this%onset_gddflag_patch (:) = nan + allocate(this%onset_fdd_patch (begp:endp)) ; this%onset_fdd_patch (:) = nan + allocate(this%onset_gdd_patch (begp:endp)) ; this%onset_gdd_patch (:) = nan + allocate(this%onset_swi_patch (begp:endp)) ; this%onset_swi_patch (:) = nan + allocate(this%offset_flag_patch (begp:endp)) ; this%offset_flag_patch (:) = nan + allocate(this%offset_counter_patch (begp:endp)) ; this%offset_counter_patch (:) = nan + allocate(this%offset_fdd_patch (begp:endp)) ; this%offset_fdd_patch (:) = nan + allocate(this%offset_swi_patch (begp:endp)) ; this%offset_swi_patch (:) = nan + allocate(this%grain_flag_patch (begp:endp)) ; this%grain_flag_patch (:) = nan + allocate(this%lgsf_patch (begp:endp)) ; this%lgsf_patch (:) = nan + allocate(this%bglfr_patch (begp:endp)) ; this%bglfr_patch (:) = nan + allocate(this%bgtr_patch (begp:endp)) ; this%bgtr_patch (:) = nan + allocate(this%c_allometry_patch (begp:endp)) ; this%c_allometry_patch (:) = nan + allocate(this%n_allometry_patch (begp:endp)) ; this%n_allometry_patch (:) = nan + allocate(this%tempsum_potential_gpp_patch (begp:endp)) ; this%tempsum_potential_gpp_patch (:) = nan + allocate(this%annsum_potential_gpp_patch (begp:endp)) ; this%annsum_potential_gpp_patch (:) = nan + allocate(this%tempmax_retransn_patch (begp:endp)) ; this%tempmax_retransn_patch (:) = nan + allocate(this%annmax_retransn_patch (begp:endp)) ; this%annmax_retransn_patch (:) = nan + allocate(this%downreg_patch (begp:endp)) ; this%downreg_patch (:) = nan + allocate(this%leafcn_offset_patch (begp:endp)) ; this%leafcn_offset_patch (:) = nan + allocate(this%plantCN_patch (begp:endp)) ; this%plantCN_patch (:) = nan + + ! initialize variables from restart file or set to cold start value + n = 0 + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + this%annsum_counter_col (n) = cncol(nc,nz, 31) + this%annavg_t2m_col (n) = cncol(nc,nz, 32) + this%farea_burned_col (n) = cncol(nc,nz, 34) + + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + + this%annavg_t2m_patch (np) = cnpft(nc,nz,nv, 24) + this%annmax_retransn_patch (np) = cnpft(nc,nz,nv, 25) + this%annsum_potential_gpp_patch (np) = cnpft(nc,nz,nv, 27) + this%days_active_patch (np) = cnpft(nc,nz,nv, 29) + this%dormant_flag_patch (np) = cnpft(nc,nz,nv, 30) + this%offset_counter_patch (np) = cnpft(nc,nz,nv, 31) + this%offset_fdd_patch (np) = cnpft(nc,nz,nv, 32) + this%offset_flag_patch (np) = cnpft(nc,nz,nv, 33) + this%offset_swi_patch (np) = cnpft(nc,nz,nv, 34) + this%onset_counter_patch (np) = cnpft(nc,nz,nv, 35) + this%onset_fdd_patch (np) = cnpft(nc,nz,nv, 36) + this%onset_flag_patch (np) = cnpft(nc,nz,nv, 37) + this%onset_gdd_patch (np) = cnpft(nc,nz,nv, 38) + this%onset_gddflag_patch (np) = cnpft(nc,nz,nv, 39) + this%onset_swi_patch (np) = cnpft(nc,nz,nv, 40) + this%tempavg_t2m_patch (np) = cnpft(nc,nz,nv, 43) + this%tempmax_retransn_patch (np) = cnpft(nc,nz,nv, 44) + this%tempsum_potential_gpp_patch (np) = cnpft(nc,nz,nv, 46) + + end if + end do !nv + end do ! p + end do ! nz + end do ! nc + + end subroutine Init + + +end module CNVegStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CanopyStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CanopyStateType.F90 new file mode 100755 index 000000000..1f54142cb --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CanopyStateType.F90 @@ -0,0 +1,251 @@ +#include "MAPL_Generic.h" + +module CanopyStateType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varpar , only : nlevcan, nvegwcs, numpft, num_zon, num_veg, & + var_col, var_pft + use clm_varcon , only : spval + use nanMod , only : nan + use decompMod , only : bounds_type + use MAPL_ExceptionHandling + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: canopystate_type + + integer , pointer :: frac_veg_nosno_patch (:) ! patch fraction of vegetation not covered by snow (0 OR 1) [-] + integer , pointer :: frac_veg_nosno_alb_patch (:) ! patch fraction of vegetation not covered by snow (0 OR 1) [-] + + real(r8) , pointer :: tlai_patch (:) ! patch canopy one-sided leaf area index, no burying by snow + real(r8) , pointer :: tsai_patch (:) ! patch canopy one-sided stem area index, no burying by snow + real(r8) , pointer :: elai_patch (:) ! patch canopy one-sided leaf area index with burying by snow + real(r8) , pointer :: esai_patch (:) ! patch canopy one-sided stem area index with burying by snow + real(r8) , pointer :: elai240_patch (:) ! patch canopy one-sided leaf area index with burying by snow average over 10days + real(r8) , pointer :: laisun_patch (:) ! patch patch sunlit projected leaf area index + real(r8) , pointer :: laisha_patch (:) ! patch patch shaded projected leaf area index + real(r8) , pointer :: laisun_z_patch (:,:) ! patch patch sunlit leaf area for canopy layer + real(r8) , pointer :: laisha_z_patch (:,:) ! patch patch shaded leaf area for canopy layer + real(r8) , pointer :: mlaidiff_patch (:) ! patch difference between lai month one and month two (for dry deposition of chemical tracers) + real(r8) , pointer :: annlai_patch (:,:) ! patch 12 months of monthly lai from input data set (for dry deposition of chemical tracers) + real(r8) , pointer :: stem_biomass_patch (:) ! Aboveground stem biomass (kg/m**2) + real(r8) , pointer :: leaf_biomass_patch (:) ! Aboveground leaf biomass (kg/m**2) + real(r8) , pointer :: htop_patch (:) ! patch canopy top (m) + real(r8) , pointer :: hbot_patch (:) ! patch canopy bottom (m) + real(r8) , pointer :: z0m_patch (:) ! patch momentum roughness length (m) + real(r8) , pointer :: displa_patch (:) ! patch displacement height (m) + real(r8) , pointer :: fsun_patch (:) ! patch sunlit fraction of canopy + real(r8) , pointer :: fsun24_patch (:) ! patch 24hr average of sunlit fraction of canopy + real(r8) , pointer :: fsun240_patch (:) ! patch 240hr average of sunlit fraction of canopy + + real(r8) , pointer :: dleaf_patch (:) ! patch characteristic leaf width (diameter) [m] + ! for non-ED/FATES this is the same as pftcon%dleaf() + real(r8) , pointer :: rscanopy_patch (:) ! patch canopy stomatal resistance (s/m) (ED specific) + + real(r8) , pointer :: vegwp_patch (:,:) ! patch vegetation water matric potential (mm) + real(r8) , pointer :: vegwp_ln_patch (:,:) ! patch vegetation water matric potential at local noon (mm) + real(r8) , pointer :: vegwp_pd_patch (:,:) ! patch predawn vegetation water matric potential (mm) + + real(r8) :: leaf_mr_vcm = spval ! Scalar constant of leaf respiration with Vcmax + + contains + + procedure, public :: Init + procedure, public :: ReadNML + + end type canopystate_type + type(canopystate_type), public, target, save :: canopystate_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + +contains + +!-------------------------------------------------------------- + subroutine Init(this, bounds, nch, ityp, fveg, cncol, cnpft, cn5_cold_start, rc) + + ! !DESCRIPTION: + ! Initialize CTSM canopy state type needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + ! INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + real, dimension(nch,num_zon,var_col), intent(in) :: cncol ! column-level restart variable array + real, dimension(nch,num_zon,num_veg,var_pft), intent(in) :: cnpft ! pft-level (patch-level) restart variable array + logical, optional, intent(in) :: cn5_cold_start + class(canopystate_type) :: this + integer, optional, intent(out) :: rc + + ! LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + integer :: np, nc, nz, p, nv, nw + logical :: cold_start = .false. + !--------------------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + begg = bounds%begg ; endg = bounds%endg + + ! check whether a cn5_cold_start option was set and change cold_start accordingly + if (present(cn5_cold_start) .and. (cn5_cold_start.eqv..true.)) then + cold_start = .true. + end if + + ! jkolassa: if cold_start is false, check that both CNCOL and CNPFT have the expected size for CNCLM50, else abort + if ((cold_start.eqv..false.) .and. ((size(cncol,3).ne.var_col) .or. & + (size(cnpft,4).ne.var_pft))) then + _ASSERT(.FALSE.,'option CNCLM50_cold_start = .FALSE. requires a CNCLM50 restart file') + end if + + allocate(this%frac_veg_nosno_patch (begp:endp)) ; this%frac_veg_nosno_patch (:) = huge(1) + allocate(this%frac_veg_nosno_alb_patch (begp:endp)) ; this%frac_veg_nosno_alb_patch (:) = 0 + allocate(this%tlai_patch (begp:endp)) ; this%tlai_patch (:) = 0. + allocate(this%tsai_patch (begp:endp)) ; this%tsai_patch (:) = 0. + allocate(this%elai_patch (begp:endp)) ; this%elai_patch (:) = 0. + allocate(this%elai240_patch (begp:endp)) ; this%elai240_patch (:) = 0. + allocate(this%esai_patch (begp:endp)) ; this%esai_patch (:) = 0. + allocate(this%laisun_patch (begp:endp)) ; this%laisun_patch (:) = 0. + allocate(this%laisha_patch (begp:endp)) ; this%laisha_patch (:) = 0. + allocate(this%laisun_z_patch (begp:endp,1:nlevcan)) ; this%laisun_z_patch (:,:) = 0. + allocate(this%laisha_z_patch (begp:endp,1:nlevcan)) ; this%laisha_z_patch (:,:) = 0. + allocate(this%mlaidiff_patch (begp:endp)) ; this%mlaidiff_patch (:) = 0. + allocate(this%annlai_patch (12,begp:endp)) ; this%annlai_patch (:,:) = 0. + allocate(this%stem_biomass_patch (begp:endp)) ; this%stem_biomass_patch (:) = 0. + allocate(this%leaf_biomass_patch (begp:endp)) ; this%leaf_biomass_patch (:) = 0. + allocate(this%htop_patch (begp:endp)) ; this%htop_patch (:) = 0. + allocate(this%hbot_patch (begp:endp)) ; this%hbot_patch (:) = 0. + allocate(this%z0m_patch (begp:endp)) ; this%z0m_patch (:) = nan + allocate(this%displa_patch (begp:endp)) ; this%displa_patch (:) = nan + allocate(this%fsun_patch (begp:endp)) ; this%fsun_patch (:) = spval + allocate(this%fsun24_patch (begp:endp)) ; this%fsun24_patch (:) = nan + allocate(this%fsun240_patch (begp:endp)) ; this%fsun240_patch (:) = nan + + allocate(this%dleaf_patch (begp:endp)) ; this%dleaf_patch (:) = nan + allocate(this%rscanopy_patch (begp:endp)) ; this%rscanopy_patch (:) = nan +! allocate(this%gccanopy_patch (begp:endp)) ; this%gccanopy_patch (:) = 0.0_r8 + allocate(this%vegwp_patch (begp:endp,1:nvegwcs)) ; this%vegwp_patch (:,:) = nan + allocate(this%vegwp_ln_patch (begp:endp,1:nvegwcs)) ; this%vegwp_ln_patch (:,:) = nan + allocate(this%vegwp_pd_patch (begp:endp,1:nvegwcs)) ; this%vegwp_pd_patch (:,:) = nan + + ! set parameters to default values or read from parameter file + +! this%leaf_mr_vcm = 0.032 !0.015 ! jkolassa Mar 2022: 0.015 is default value in CTSM5.1, but accoring to ChangeLog 0.032 should be used for Atkin leaf respiration method, which we are using + + + ! initialize variables from restart file or set to cold start value + + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + + ! "old" variables: CNCLM45 and before + this%elai_patch (np) = cnpft(nc,nz,nv, 69) + this%esai_patch (np) = cnpft(nc,nz,nv, 70) + this%hbot_patch (np) = cnpft(nc,nz,nv, 71) + this%htop_patch (np) = cnpft(nc,nz,nv, 72) + this%tlai_patch (np) = cnpft(nc,nz,nv, 73) + this%tsai_patch (np) = cnpft(nc,nz,nv, 74) + + ! "new" variables: introduced in CNCLM50 + if (cold_start.eqv..false.) then + do nw = 1,nvegwcs + this%vegwp_patch(np,nw) = cnpft(nc,nz,nv, 78+(nw-1)) + end do + elseif (cold_start) then + this%vegwp_patch(np,1:nvegwcs) = -2.5e4_r8 + else + _ASSERT(.FALSE.,'missing CNCLM50_cold_start setting') + end if + + ! jkolassa Mar 2022: these two quantites are computed in Photosynthesis, + ! so maybe the do not need to be initialized here + this%vegwp_ln_patch(np,1:nvegwcs) = -2.5e4_r8 + this%vegwp_pd_patch(np,1:nvegwcs) = -2.5e4_r8 + + ! jkolassa May 2022: we do not model vegetation on snow, so the variable below is 1 always + this%frac_veg_nosno_patch(np) = 1 + + end if ! ityp = p + + end do !nv + end do ! p + end do ! nz + end do ! nc + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine ReadNML( this, NLFilename ) + ! + ! Read in canopy parameter namelist + ! + ! USES: + use shr_mpi_mod , only : shr_mpi_bcast + use abortutils , only : endrun + use spmdMod , only : masterproc, mpicom + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + use shr_log_mod , only : errMsg => shr_log_errMsg + ! + ! ARGUMENTS: + implicit none + class(canopystate_type) :: this + character(len=*), intent(IN) :: NLFilename ! Namelist filename + ! LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + real(r8) :: leaf_mr_vcm ! Scalar of leaf respiration to vcmax + character(len=32) :: subname = 'CanopyStateType::ReadNML' ! subroutine name + !----------------------------------------------------------------------- + namelist / clm_canopy_inparm / leaf_mr_vcm + + ! ---------------------------------------------------------------------- + ! Read namelist from input namelist filename + ! ---------------------------------------------------------------------- + + if ( masterproc )then + + unitn = getavu() + write(iulog,*) 'Read in clm_canopy_inparm namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, 'clm_canopy_inparm', status=ierr) + if (ierr == 0) then + read(unitn, clm_canopy_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading clm_canopy_inparm namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR finding clm_canopy_inparm namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + + end if + + ! Broadcast namelist variables read in + call shr_mpi_bcast(leaf_mr_vcm, mpicom) + this%leaf_mr_vcm = leaf_mr_vcm + + end subroutine ReadNML + + +end module CanopyStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ColumnType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ColumnType.F90 new file mode 100755 index 000000000..b403f34b6 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ColumnType.F90 @@ -0,0 +1,176 @@ +module ColumnType + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Column data type allocation and initialization + ! -------------------------------------------------------- + ! column types can have values of + ! -------------------------------------------------------- + ! 1 => (istsoil) soil (vegetated or bare soil) + ! 2 => (istcrop) crop (only for crop configuration) + ! 3 => (UNUSED) (formerly non-multiple elevation class land ice; currently unused) + ! 4 => (istice_mec) land ice (multiple elevation classes) + ! 5 => (istdlak) deep lake + ! 6 => (istwet) wetland + ! 71 => (icol_roof) urban roof + ! 72 => (icol_sunwall) urban sunwall + ! 73 => (icol_shadewall) urban shadewall + ! 74 => (icol_road_imperv) urban impervious road + ! 75 => (icol_road_perv) urban pervious road + + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use decompMod , only : bounds_type + use clm_varcon , only : zsoi, dzsoi, zisoi, dzsoi_decomp, spval, ispval + use clm_varctl , only : use_fates + use clm_varpar , only : nlevsno, nlevgrnd, nlevlak, nlevmaxurbgrnd,nlevurb, & + CN_zone_weight, numpft, num_zon + + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: column_type + ! g/l/c/p hierarchy, local g/l/c/p cells only + integer , pointer :: landunit (:) ! index into landunit level quantities + real(r8), pointer :: wtlunit (:) ! weight (relative to landunit) + integer , pointer :: gridcell (:) ! index into gridcell level quantities + real(r8), pointer :: wtgcell (:) ! weight (relative to gridcell) + integer , pointer :: patchi (:) ! beginning patch index for each column + integer , pointer :: patchf (:) ! ending patch index for each column + integer , pointer :: npatches (:) ! number of patches for each column + + ! topological mapping functionality + integer , pointer :: itype (:) ! column type (after init, should only be modified via update_itype routine) + integer , pointer :: lun_itype (:) ! landunit type (col%lun_itype(ci) is the same as lun%itype(col%landunit(ci)), but is often a more convenient way to access this type + logical , pointer :: active (:) ! true=>do computations on this column + logical , pointer :: type_is_dynamic (:) ! true=>itype can change throughout the run + + ! topography + ! TODO(wjs, 2016-04-05) Probably move these things into topoMod + real(r8), pointer :: micro_sigma (:) ! microtopography pdf sigma (m) + real(r8), pointer :: topo_slope (:) ! gridcell topographic slope + real(r8), pointer :: topo_std (:) ! gridcell elevation standard deviation + + ! vertical levels + integer , pointer :: snl (:) ! number of snow layers + real(r8), pointer :: dz (:,:) ! layer thickness (m) (-nlevsno+1:nlevgrnd) + real(r8), pointer :: z (:,:) ! layer depth (m) (-nlevsno+1:nlevgrnd) + real(r8), pointer :: zi (:,:) ! interface level below a "z" level (m) (-nlevsno+0:nlevgrnd) + real(r8), pointer :: zii (:) ! convective boundary height [m] + real(r8), pointer :: dz_lake (:,:) ! lake layer thickness (m) (1:nlevlak) + real(r8), pointer :: z_lake (:,:) ! layer depth for lake (m) + real(r8), pointer :: lakedepth (:) ! variable lake depth (m) + integer , pointer :: nbedrock (:) ! variable depth to bedrock index + + ! other column characteristics + logical , pointer :: hydrologically_active(:) ! true if this column is a hydrologically active type + logical , pointer :: urbpoi (:) ! true=>urban point + + + ! levgrnd_class gives the class in which each layer falls. This is relevant for + ! columns where there are 2 or more fundamentally different layer types. For + ! example, this distinguishes between soil and bedrock layers. The particular value + ! assigned to each class is irrelevant; the important thing is that different + ! classes (e.g., soil vs. bedrock) have different values of levgrnd_class. + ! + ! levgrnd_class = ispval indicates that the given layer is completely unused for + ! this column (i.e., this column doesn't use the full nlevgrnd layers). + integer , pointer :: levgrnd_class (:,:) ! class in which each layer falls (1:nlevgrnd) + + contains + + procedure, public :: Init + + end type column_type + type(column_type), public, target :: col + + contains + +!----------------------------------------------------- + subroutine Init(this, bounds,nch) + + ! !ARGUMENTS: + implicit none + + ! INPUT: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + class(column_type) :: this + + ! LOCAL: + + integer :: begc, endc + integer :: nc, nz, n, c + !---------------------------- + + begc = bounds%begc ; endc = bounds%endc + + ! The following is set in initGridCellsMod + allocate(this%gridcell (begc:endc)) ; this%gridcell (:) = ispval + allocate(this%wtgcell (begc:endc)) ; this%wtgcell (:) = nan + allocate(this%landunit (begc:endc)) ; this%landunit (:) = ispval + allocate(this%wtlunit (begc:endc)) ; this%wtlunit (:) = nan + allocate(this%patchi (begc:endc)) ; this%patchi (:) = ispval + allocate(this%patchf (begc:endc)) ; this%patchf (:) = ispval + allocate(this%npatches (begc:endc)) ; this%npatches (:) = ispval + allocate(this%itype (begc:endc)) ; this%itype (:) = ispval + allocate(this%lun_itype (begc:endc)) ; this%lun_itype (:) = ispval + allocate(this%active (begc:endc)) ; this%active (:) = .false. + allocate(this%type_is_dynamic(begc:endc)) ; this%type_is_dynamic(:) = .false. + + ! The following is set in initVerticalMod + allocate(this%snl (begc:endc)) ; this%snl (:) = ispval !* cannot be averaged up + allocate(this%dz (begc:endc,-nlevsno+1:nlevmaxurbgrnd)) ; this%dz (:,:) = nan + allocate(this%z (begc:endc,-nlevsno+1:nlevmaxurbgrnd)) ; this%z (:,:) = nan + allocate(this%zi (begc:endc,-nlevsno+0:nlevmaxurbgrnd)) ; this%zi (:,:) = nan + allocate(this%zii (begc:endc)) ; this%zii (:) = nan + allocate(this%lakedepth (begc:endc)) ; this%lakedepth (:) = spval + allocate(this%dz_lake (begc:endc,nlevlak)) ; this%dz_lake (:,:) = nan + allocate(this%z_lake (begc:endc,nlevlak)) ; this%z_lake (:,:) = nan + + allocate(this%nbedrock (begc:endc)) ; this%nbedrock (:) = ispval + allocate(this%levgrnd_class(begc:endc,nlevmaxurbgrnd)) ; this%levgrnd_class(:,:) = ispval + allocate(this%micro_sigma (begc:endc)) ; this%micro_sigma (:) = nan + allocate(this%topo_slope (begc:endc)) ; this%topo_slope (:) = nan + allocate(this%topo_std (begc:endc)) ; this%topo_std (:) = nan + + allocate(this%hydrologically_active(begc:endc)) ; this%hydrologically_active(:) = .false. + allocate(this%urbpoi (begc:endc)) ; this%urbpoi (:) = .false. + + + this%nbedrock(:) = 1 !jkolassa: set this to 1, since we only have one soil layer + + do c = bounds%begc,bounds%endc + this%z(c,1:nlevgrnd) = zsoi(1:nlevgrnd) + this%zi(c,0:nlevgrnd) = zisoi(0:nlevgrnd) + this%dz(c,1:nlevgrnd) = dzsoi(1:nlevgrnd) + if (nlevgrnd < nlevurb) then + this%z(c,nlevgrnd+1:nlevurb) = spval + this%zi(c,nlevgrnd+1:nlevurb) = spval + this%dz(c,nlevgrnd+1:nlevurb) = spval + end if + end do + + + + n = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + this%active(n) = .true. + this%gridcell(n) = nc + this%wtgcell(n) = CN_zone_weight(nz) + this%landunit(n) = nc + this%wtlunit(n) = CN_zone_weight(nz) + this%patchi(n) = (numpft+1)*(n-1) + 1 + this%patchf(n) = (numpft+1)*n + end do ! nz + end do ! nc + + end subroutine Init +end module ColumnType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CropType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CropType.F90 new file mode 100755 index 000000000..6a223ae63 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_CropType.F90 @@ -0,0 +1,73 @@ +module CropType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varcon , only : spval + use nanMod , only : nan + use decompMod , only : bounds_type + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: crop_type + + ! Note that cropplant and harvdate could be 2D to facilitate rotation + integer , pointer :: nyrs_crop_active_patch (:) ! number of years this crop patch has been active (0 for non-crop patches) + logical , pointer :: croplive_patch (:) ! patch Flag, true if planted, not harvested + logical , pointer :: cropplant_patch (:) ! patch Flag, true if planted + integer , pointer :: harvdate_patch (:) ! patch harvest date + real(r8), pointer :: fertnitro_patch (:) ! patch fertilizer nitrogen + real(r8), pointer :: gddplant_patch (:) ! patch accum gdd past planting date for crop (ddays) + real(r8), pointer :: gddtsoi_patch (:) ! patch growing degree-days from planting (top two soil layers) (ddays) + real(r8), pointer :: vf_patch (:) ! patch vernalization factor for cereal + real(r8), pointer :: cphase_patch (:) ! phenology phase + real(r8), pointer :: latbaset_patch (:) ! Latitude vary baset for gddplant (degree C) + character(len=20) :: baset_mapping + real(r8) :: baset_latvary_intercept + real(r8) :: baset_latvary_slope + + contains + + procedure , public :: Init + + end type crop_type + type(crop_type), public, target, save :: crop_inst + +contains + +!------------------------------------------------------ + subroutine Init(this, bounds) + + ! !DESCRIPTION: + ! Initialize CTSM crop type needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(crop_type) :: this + + !LOCAL + integer :: begp, endp + + !--------------------------------- + + begp = bounds%begp ; endp = bounds%endp + + allocate(this%nyrs_crop_active_patch(begp:endp)) ; this%nyrs_crop_active_patch(:) = 0 + allocate(this%croplive_patch (begp:endp)) ; this%croplive_patch (:) = .false. + allocate(this%cropplant_patch(begp:endp)) ; this%cropplant_patch(:) = .false. + allocate(this%harvdate_patch (begp:endp)) ; this%harvdate_patch (:) = huge(1) + allocate(this%fertnitro_patch (begp:endp)) ; this%fertnitro_patch (:) = spval + allocate(this%gddplant_patch (begp:endp)) ; this%gddplant_patch (:) = spval + allocate(this%gddtsoi_patch (begp:endp)) ; this%gddtsoi_patch (:) = spval + allocate(this%vf_patch (begp:endp)) ; this%vf_patch (:) = 0.0_r8 + allocate(this%cphase_patch (begp:endp)) ; this%cphase_patch (:) = 0.0_r8 + allocate(this%latbaset_patch (begp:endp)) ; this%latbaset_patch (:) = spval + + end subroutine Init + +end module CropType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_DriverMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_DriverMod.F90 new file mode 100755 index 000000000..ba5340f53 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_DriverMod.F90 @@ -0,0 +1,772 @@ +module CNCLM_DriverMod + + use, intrinsic :: iso_fortran_env, only: INT64 + use nanMod , only : nan + use CNVegetationFacade + use clm_varpar , only : nlevsno, nlevmaxurbgrnd, num_veg, num_zon, CN_zone_weight,& + var_col, var_pft, nlevgrnd, numpft, ndecomp_pools + use clm_varcon , only : grav, denh2o + use clm_time_manager , only : is_first_step, get_nstep + use decompMod + use filterMod + use SoilBiogeochemCarbonFluxType + use SoilBiogeochemNitrogenFluxType + use SoilBiogeochemCarbonStateType + use SoilBiogeochemNitrogenStateType + use ActiveLayerMod + use GridcellType + use FireMethodType + use SaturatedExcessRunoffMod + use WaterDiagnosticBulkType + use atm2lndType + use Wateratm2lndBulkType + use CNVegStateType + use WaterStateBulkType + use SoilStateType + use TemperatureType + use WaterDiagnosticBulkType + use WaterStateBulkType + use WaterFluxBulkType + use FrictionVelocityMod + use ActiveLayerMod + use SoilBiogeochemStateType + use CanopyStateType + use CropType + use ch4Mod + use PhotosynthesisMod + use EnergyFluxType + use CNFireEmissionsMod + use CN_initMod + use CNVegCarbonFluxType + use CNVegCarbonStateType + use CNVegNitrogenFluxType + use CNVegNitrogenStateType + use CNProductsMod + use CNFireFactoryMod + use FireDataBaseType + use CNFireLi2014Mod + use CNFireLi2016Mod + use CNFireLi2021Mod + use CNFireBaseMod + use CN2CLMType + use WaterType + + implicit none + private + +! !PUBLIC MEMBER FUNCTIONS: + public :: CN_Driver + public :: CN_exit + public :: get_CN_LAI + +contains + +!--------------------------------- + subroutine CN_Driver(istep,nch,ityp,fveg,ndep,tp1,tairm,psis,bee,dayl,btran_fire,car1m,& + rzm,sfm,rhm,windm,rainfm,snowfm,prec10d,prec60d,et365d,gdp,& + abm,peatf,hdm,lnfm,poros,rh30,totwat,bflow,runsrf,sndzn,& + fsnow,tg10d,t2m5d,sndzn5d,water_inst,first, & + psnsunm, psnsham, lmrsunm, lmrsham, laisunm, laisham, wpwet, & + zlai,zsai,ztai,colc,nppg,gppg,srg,arg,hrg,neeg,burn,closs,nfire,& + som_closs,root,vegc,xsmr,ndeployg,denitg,sminn_leachedg,sminng,& + col_fire_nlossg,leafng,leafcg,gross_nming,net_nming,& + nfix_to_sminng,actual_immobg,fpgg,fpig,sminn_to_plantg,& + sminn_to_npoolg,ndep_to_sminng,totvegng,totlitng,totsomng,& + retransng,retransn_to_npoolg,fuelcg,totlitcg,cwdcg,rootcg) + + + !ARGUMENTS + implicit none + + !INPUT + integer(INT64), intent(in) :: istep ! number of CN time steps run + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + real, dimension(nch), intent(in) :: ndep ! nitrogen deposition [g m^-2 s^-1] + real, dimension(nch), intent(in) :: tp1 ! soil temperatures [K] + real, dimension(nch), intent(in) :: tairm ! surface air temperature [K] averaged over CN interval + real, dimension(nch), intent(in) :: bee ! Clapp-Hornberger 'b' [-] + real, dimension(nch), intent(in) :: psis ! saturated matric potential [m] + real, dimension(nch), intent(in) :: dayl ! daylength [seconds] + real, dimension(nch,num_zon), intent(in) :: btran_fire + real, dimension(nch), intent(in) :: car1m ! fraction of tile that is saturated area + real, dimension(nch,num_zon), intent(in) :: rzm ! weighted root-zone moisture content as frac of WHC + real, dimension(nch,num_zon), intent(in) :: sfm ! weighted surface moisture content as frac of WHC + real, dimension(nch), intent(in) :: rhm ! relative humidity (%) + real, dimension(nch), intent(in) :: windm ! wind speed (m/s) + real, dimension(nch), intent(in) :: rainfm ! rainfall (convective + largescale) (kg/m2/s) + real, dimension(nch), intent(in) :: snowfm ! snowfall (kg/m2/s) + real, dimension(nch), intent(in) :: prec10d ! 10-day running mean of total precipitation (mm H2O/s) + real, dimension(nch), intent(in) :: prec60d ! 60-day running mean of total precipitation (mm H2O/s) + real, dimension(nch), intent(in) :: et365d ! 365-day running mean of total ET (EVPSOI + EVPINT + EVPVEG) (W m-2) + real, dimension(nch), intent(in) :: gdp ! Real GDP (K 1995US$/capita) + real, dimension(nch), intent(in) :: abm ! Peak month for agricultural fire, unitless + real, dimension(nch), intent(in) :: peatf ! Fraction of peatland, unitless (0-1) + real, dimension(nch), intent(in) :: hdm ! Human population density in 2010 (individual/km2) + real, dimension(nch), intent(in) :: lnfm ! Lightning frequency [Flashes/km^2/day] + real, dimension(nch), intent(in) :: poros ! porosity + real, dimension(nch), intent(in) :: rh30 ! 30-day running mean of relative humidity + real, dimension(nch), intent(in) :: totwat ! soil liquid water content [kg m^-2] + real, dimension(nch), intent(in) :: bflow ! baseflow + real, dimension(nch), intent(in) :: runsrf ! surface runoff [kg m^-2 s^-1] + real, dimension(nch), intent(in) :: sndzn ! snow height of snow covered area (m) + real, dimension(nch), intent(in) :: fsnow ! snow cover fraction [0-1] + real, dimension(nch), intent(in) :: tg10d ! 10-day running mean of ground temperature [K] + real, dimension(nch), intent(in) :: t2m5d ! 5-day running mean of daily minimum 2m temperature [K] + real, dimension(nch), intent(in) :: sndzn5d ! 5-day running mean of total snow depth + type(water_type), intent(in) :: water_inst + logical, intent(in) :: first + real, dimension(nch,num_veg,num_zon), intent(in) :: psnsunm + real, dimension(nch,num_veg,num_zon), intent(in) :: psnsham + real, dimension(nch,num_veg,num_zon), intent(in) :: lmrsunm + real, dimension(nch,num_veg,num_zon), intent(in) :: lmrsham + real, dimension(nch,num_veg,num_zon), intent(in) :: laisunm + real, dimension(nch,num_veg,num_zon), intent(in) :: laisham + real, dimension(nch), intent(in) :: wpwet ! wetness at wilting point + + + ! OUTPUT + + real, dimension(nch,num_veg,num_zon), intent(out) :: zlai ! leaf-area index for tile (subject to burying by snow) + real, dimension(nch,num_veg,num_zon), intent(out) :: zsai ! stem-area index for tile + real, dimension(nch,num_veg,num_zon), intent(out) :: ztai ! leaf-area index for tile (not buried by snow) + + real, dimension(nch,num_zon), intent(out) :: colc ! column total carbon + real, dimension(nch), intent(out) :: nppg ! (gC/m2/s) net primary production [PFT] + real, dimension(nch), intent(out) :: gppg ! (gC/m2/s) gross primary production [PFT] + + real, dimension(nch), intent(out) :: srg ! (gC/m2/s) total soil respiration (HR + root resp) [column] + real, dimension(nch), intent(out) :: arg ! (gC/m2/s) autotrophic respiration [column] + real, dimension(nch), intent(out) :: hrg ! (gC/m2/s) heterotrophic respiration [column] + real, dimension(nch), intent(out) :: neeg ! (gC/m2/s) net ecosystem exchange of carbon, includes fire, landuse, harvest, and hrv_xsmrpool flux, positive for source [column] + + real, dimension(nch), intent(out) :: fuelcg ! fuel avalability for non-crop areas outside tropical closed broadleaf evergreen closed forests (gC/m2) + real, dimension(nch), intent(out) :: totlitcg ! (gC/m2) total litter carbon + real, dimension(nch), intent(out) :: cwdcg ! (gC/m2) coarse woody debris C + real, dimension(nch), intent(out) :: rootcg ! (gC/m2) total root carbon + + real, dimension(nch), intent(out) :: burn ! burn rate / fractional area burned (/sec) + real, dimension(nch), intent(out) :: closs ! (gC/m2/s) total fire C loss + real, dimension(nch), intent(out) :: nfire ! fire counts (count/km2/s) + real, dimension(nch), intent(out) :: som_closs ! (gC/m2/s) carbon emissions due to peat burning + + real, dimension(nch), intent(out) :: root ! fine root carbon [gC/m2] + real, dimension(nch), intent(out) :: vegc ! (gC/m2) total vegetation carbon, excluding cpool + real, dimension(nch), intent(out) :: xsmr ! (gC/m2) abstract C pool to meet excess maintenance respiration (MR) demand + + real, dimension(nch), intent(out) :: ndeployg ! total N deployed to growth and storage (gN/m2/s) + real, dimension(nch), intent(out) :: denitg ! total rate of denitrification (gN/m2/s) + real, dimension(nch), intent(out) :: sminn_leachedg ! soil mineral N pool loss to leaching (gN/m2/s) + real, dimension(nch), intent(out) :: sminng ! (gN/m2) soil mineral N + real, dimension(nch), intent(out) :: col_fire_nlossg ! (gN/m2/s) total column-level fire N loss + real, dimension(nch), intent(out) :: leafng ! (gN/m2) leaf N + real, dimension(nch), intent(out) :: leafcg ! (gC/m2) leaf C + real, dimension(nch), intent(out) :: gross_nming ! gross rate of N mineralization (gN/m2/s) + real, dimension(nch), intent(out) :: net_nming ! vert-int (diagnostic) net rate of N mineralization (gN/m2/s) + real, dimension(nch), intent(out) :: nfix_to_sminng ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) + real, dimension(nch), intent(out) :: actual_immobg ! vert-int (diagnostic) actual N immobilization (gN/m2/s) + real, dimension(nch), intent(out) :: fpgg ! fraction of potential gpp (no units) + real, dimension(nch), intent(out) :: fpig ! fraction of potential immobilization (no units) + real, dimension(nch), intent(out) :: sminn_to_plantg ! vert-int (diagnostic) plant uptake of soil mineral N (gN/m2/s) + real, dimension(nch), intent(out) :: sminn_to_npoolg ! deployment of soil mineral N uptake (gN/m2/s) + real, dimension(nch), intent(out) :: ndep_to_sminng ! atmospheric N deposition to soil mineral N (gN/m2/s) + real, dimension(nch), intent(out) :: totvegng ! (gN/m2) total vegetation nitrogen + real, dimension(nch), intent(out) :: totlitng ! (gN/m2) total litter nitrogen + real, dimension(nch), intent(out) :: totsomng ! (gN/m2) total soil organic matter nitrogen + real, dimension(nch), intent(out) :: retransng ! (gN/m2) plant pool of retranslocated N + real, dimension(nch), intent(out) :: retransn_to_npoolg ! deployment of retranslocated N (gN/m2/s) + + !LOCAL + + ! jkolassa: not sure the below type declarations are necessary or whether use statements + ! above are enough + +! type(bounds_type) :: bounds +! type(clumpfilter) :: filter +! type(soilbiogeochem_carbonflux_type) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonflux_type) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonflux_type) :: c14_soilbiogeochem_carbonflux_inst +! type(soilbiogeochem_nitrogenflux_type) :: soilbiogeochem_nitrogenflux_inst +! type(gridcell_type) :: grc +! type(cn_vegetation_type) :: bgc_vegetation_inst +! type(saturated_excess_runoff_type) :: saturated_excess_runoff_inst + type(wateratm2lndbulk_type) :: wateratm2lndbulk_inst +! type(soilstate_type) :: soilstate_inst +! type(atm2lnd_type) :: atm2lnd_inst +! type(temperature_type) :: temperature_inst + type(waterdiagnosticbulk_type) :: waterdiagnosticbulk_inst +! type(cnveg_state_type) :: cnveg_state_inst + type(waterstatebulk_type) :: waterstatebulk_inst +! type(waterfluxbulk_type) :: waterfluxbulk_inst +! type(frictionvel_type) :: frictionvel_inst +! type(active_layer_type) :: active_layer_inst +! type(soilbiogeochem_carbonstate_type) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) :: c14_soilbiogeochem_carbonstate_inst +! type(soilbiogeochem_nitrogenstate_type):: soilbiogeochem_nitrogenstate_inst +! type(soilbiogeochem_state_type) :: soilbiogeochem_state_inst +! type(crop_type) :: crop_inst +! type(ch4_type) :: ch4_inst +! type(photosyns_type) :: photosyns_inst +! type(energyflux_type) :: energyflux_inst + type(fireemis_type) :: fireemis_inst +! type(cnveg_carbonflux_type) :: cnveg_carbonflux_inst +! type(cnveg_carbonstate_type) :: cnveg_carbonstate_inst +! type(cnveg_nitrogenflux_type) :: cnveg_nitrogenflux_inst +! type(cnveg_nitrogenstate_type) :: cnveg_nitrogenstate_inst + !type(cnfire_li2014_type) :: cnfire_li2014_inst +! type(cnfire_li2016_type) :: cnfire_li2016_inst +! type(cnfire_li2021_type) :: cnfire_li2021_inst + + real :: pwtgcell + logical, save :: doalb = .true. ! assume surface albedo calculation time step; jkolassa: following setting from previous CNCLM versions + integer :: n, p, nc, nz, np, nv + integer(INT64) :: nstep_cn ! number of CN model steps run + + !------------------------------- + + ! update time step + nstep_cn = get_nstep(istep) + + ! update CLM types with current states + + n = 0 + p = 0 + do nc = 1,nch ! catchment tile loop + + grc%dayl(nc) = dayl(nc) + water_inst%wateratm2lndbulk_inst%forc_rh_grc(nc) = rhm(nc) + atm2lnd_inst%forc_wind_grc(nc) = windm(nc) + atm2lnd_inst%forc_ndep_grc(nc) = ndep(nc) + + cn2clm_inst%forc_hdm_cn2clm(nc) = hdm(nc) + cn2clm_inst%forc_lnfm_cn2clm(nc) = lnfm(nc) + ! cnfire_li2016_inst%forc_hdm(nc) = hdm(nc) + ! cnfire_li2016_inst%forc_lnfm(nc) = lnfm(nc) + ! cnfire_li2021_inst%forc_hdm(nc) = hdm(nc) + ! cnfire_li2021_inst%forc_lnfm(nc) = lnfm(nc) + + + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + temperature_inst%t_soisno_col(n,-nlevsno+1:nlevmaxurbgrnd) = tp1(nc) ! jkolassa: only one soil and no snow column at this point (may change in future) + temperature_inst%t_grnd_col(n) = temperature_inst%t_soisno_col(n,1) + temperature_inst%t_soi17cm_col(n) = temperature_inst%t_grnd_col(n) + soilstate_inst%soilpsi_col(n,1:nlevgrnd) = 1.e-6*psis(nc)*grav*denh2o*rzm(nc,nz)**(-bee(nc)) ! jkolassa: only one soil layer at this point + soilstate_inst%psiwilt_col(n,1:nlevgrnd) = 1.e-6*psis(nc)*grav*denh2o*wpwet(nc)**(-bee(nc)) ! jkolassa: soil water potential at wilting point (not a CLM variable, but added to use instead of constant threshold to determine water stress) + soilstate_inst%watsat_col(n,1:nlevmaxurbgrnd) = poros(nc) + soilstate_inst%bd_col(n,1:nlevmaxurbgrnd) = (1. - soilstate_inst%watsat_col(n,1:nlevmaxurbgrnd))*2700. + atm2lnd_inst%forc_t_downscaled_col(n) = tairm(nc) + water_inst%wateratm2lndbulk_inst%forc_rain_downscaled_col(n) = rainfm(nc) + water_inst%wateratm2lndbulk_inst%forc_snow_downscaled_col(n) = snowfm(nc) + water_inst%waterdiagnosticbulk_inst%wf_col(n) = sfm(nc,nz) + water_inst%waterdiagnosticbulk_inst%wf2_col(n) = rzm(nc,nz) + water_inst%waterdiagnosticbulk_inst%frac_sno_col(n) = fsnow(nc) + water_inst%waterdiagnosticbulk_inst%snow_depth_col(n) = sndzn(nc) + water_inst%waterdiagnosticbulk_inst%snow_5day_col(n) = sndzn5d(nc) + bgc_vegetation_inst%cnveg_state_inst%gdp_lf_col(n) = gdp(nc) + bgc_vegetation_inst%cnveg_state_inst%abm_lf_col(n) = abm(nc) + bgc_vegetation_inst%cnveg_state_inst%peatf_lf_col(n) = peatf(nc) + water_inst%waterstatebulk_inst%h2osoi_liq_col(n,-nlevsno+1:nlevgrnd) = totwat(nc) + water_inst%waterfluxbulk_inst%qflx_drain_col(n) = bflow(nc) + water_inst%waterfluxbulk_inst%qflx_surf_col(n) = runsrf(nc) + water_inst%waterfluxbulk_inst%AnnET(n) = et365d(nc)*(0.0864*0.408/3600) ! convert from W m-2 to mm/s + + ! compute column-level saturated area fraction (water table at surface) + if(nz==1) then + saturated_excess_runoff_inst%fsat_col(n) = min(max(0.,car1m(nc)/CN_zone_weight(nz)),1.) + elseif(nz==2) then + saturated_excess_runoff_inst%fsat_col(n) = min(max(0.,(car1m(nc)-CN_zone_weight(1))/CN_zone_weight(nz)),1.) + elseif(nz==3) then + saturated_excess_runoff_inst%fsat_col(n) = min(max(0.,(car1m(nc)-CN_zone_weight(1)-CN_zone_weight(2))/CN_zone_weight(nz)),1.) + endif + + do np = 0,numpft ! PFT index loop + p = p + 1 + temperature_inst%t_ref2m_patch(p) = tairm(nc) + temperature_inst%soila10_patch(p) = tg10d(nc) + temperature_inst%t_a5min_patch(p) = t2m5d(nc) + cn2clm_inst%btran2_patch_cn2clm(p) = btran_fire(nc,nz) + ! cnfire_li2016_inst%cnfire_base_type%btran2_patch(p) = btran_fire(nc,nz) + ! cnfire_li2021_inst%cnfire_base_type%btran2_patch(p) = btran_fire(nc,nz) + water_inst%wateratm2lndbulk_inst%prec60_patch(p) = prec60d(nc) + water_inst%wateratm2lndbulk_inst%prec10_patch(p) = prec10d(nc) + water_inst%wateratm2lndbulk_inst%rh30_patch(p) = rh30(nc) + frictionvel_inst%forc_hgt_u_patch(p) = 30. ! following CNCLM45 implementation, but this should be available from the GridComp + + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==np .and. fveg(nc,nv,nz)>1.e-4) then + photosyns_inst%psnsun_patch(p) = psnsunm(nc,nv,nz) + photosyns_inst%psnsha_patch(p) = psnsham(nc,nv,nz) + photosyns_inst%lmrsun_patch(p) = lmrsunm(nc,nv,nz) + photosyns_inst%lmrsha_patch(p) = lmrsham(nc,nv,nz) + canopystate_inst%laisun_patch(p) = laisunm(nc,nv,nz) + canopystate_inst%laisha_patch(p) = laisham(nc,nv,nz) + end if + end do ! nv + end do ! np + end do ! nz + end do ! nc + + + + ! call CLM routines that are needed prior to Ecosystem Dynamics call + + call active_layer_inst%alt_calc(filter(1)%num_soilc, filter(1)%soilc, & + temperature_inst) + + call bgc_vegetation_inst%InitEachTimeStep(bounds, filter(1)%num_soilc, filter(1)%soilc) + + call bgc_vegetation_inst%InitGridcellBalance(bounds, & + filter(1)%num_allc, filter(1)%allc, & + filter(1)%num_soilc, filter(1)%soilc, & + filter(1)%num_soilp, filter(1)%soilp, & + soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenstate_inst) + + call bgc_vegetation_inst%InitColumnBalance(bounds, & + filter(1)%num_allc, filter(1)%allc, & + filter(1)%num_soilc, filter(1)%soilc, & + filter(1)%num_soilp, filter(1)%soilp, & + soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenstate_inst) + + ! Ecosystem Dynamics calculations + ! jkolassa: This call contains most of the CLM ecosystem dynamics + ! calculations, including soil biogeochemistry, carbon/nitrogen state and + ! flux updates, fire, etc. + call bgc_vegetation_inst%EcosystemDynamicsPreDrainage(bounds, & + filter(1)%num_soilc, filter(1)%soilc, & + filter(1)%num_soilp, filter(1)%soilp, & + filter(1)%num_actfirec, filter(1)%actfirec, & + filter(1)%num_actfirep, filter(1)%actfirep, & + filter(1)%num_pcropp, filter(1)%pcropp, & + filter(1)%num_exposedvegp, filter(1)%exposedvegp, & + filter(1)%num_noexposedvegp, filter(1)%noexposedvegp, & + doalb, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_state_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & + active_layer_inst, & + atm2lnd_inst, water_inst%waterstatebulk_inst, & + water_inst%waterdiagnosticbulk_inst, water_inst%waterfluxbulk_inst, & + water_inst%wateratm2lndbulk_inst, canopystate_inst, soilstate_inst, temperature_inst, & + crop_inst, ch4_inst, & + photosyns_inst, saturated_excess_runoff_inst, energyflux_inst, & + nutrient_competition_method, fireemis_inst) + + + ! jkolassa: This call is mostly to compute the nitrogen leaching, summary states and fluxes + ! and the vegetation structural updates + call bgc_vegetation_inst%EcosystemDynamicsPostDrainage(bounds, & + filter(1)%num_allc, filter(1)%allc, & + filter(1)%num_soilc, filter(1)%soilc, & + filter(1)%num_soilp, filter(1)%soilp, & + filter(1)%num_actfirec, filter(1)%actfirec, & + filter(1)%num_actfirep, filter(1)%actfirep, & + doalb, crop_inst, & + soilstate_inst, soilbiogeochem_state_inst, & + water_inst%waterstatebulk_inst, water_inst%waterdiagnosticbulk_inst, & + water_inst%waterfluxbulk_inst, frictionvel_inst, canopystate_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst) + + +! check carbon and nitrogen balances except on first time step + if(.not.first) then + call bgc_vegetation_inst%BalanceCheck( & + bounds, filter(1)%num_soilc, filter(1)%soilc, & + soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenflux_inst, atm2lnd_inst ) + else + !first = .false. + end if + + grc%prev_dayl = grc%dayl ! set previous day length for following time steps (dayl itself is computed in GridComp) + + +! map CLM outputs to Catchment space + + n = 0 + p = 0 + do nc = 1,nch ! catchment tile loop + + nppg(nc) = 0. + gppg(nc) = 0. + srg(nc) = 0. + arg(nc) = 0. + hrg(nc) = 0. + burn(nc) = 0. + closs(nc) = 0. + som_closs(nc) = 0. + nfire(nc) = 0. + root(nc) = 0. + vegc(nc) = 0. + ndeployg(nc) = 0. + leafng(nc) = 0. + leafcg(nc) = 0. + sminn_to_npoolg(nc) = 0. + totvegng(nc) = 0. + retransng(nc) = 0. + retransn_to_npoolg(nc) = 0. + rootcg(nc) = 0. + denitg(nc) = 0. + sminn_leachedg(nc) = 0. + sminng(nc) = 0. + col_fire_nlossg(nc) = 0. + gross_nming(nc) = 0. + net_nming(nc) = 0. + nfix_to_sminng(nc) = 0. + actual_immobg(nc) = 0. + fpgg(nc) = 0. + fpig(nc) = 0. + sminn_to_plantg(nc) = 0. + ndep_to_sminng(nc) = 0. + totlitng(nc) = 0. + totsomng(nc) = 0. + fuelcg(nc) = 0. + totlitcg(nc) = 0. + cwdcg(nc) = 0. + xsmr(nc) = 0. + + neeg(nc) = bgc_vegetation_inst%cnveg_carbonflux_inst%nee_grc(nc) + + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + colc(nc,nz) = bgc_vegetation_inst%cnveg_carbonstate_inst%totc_col(n) + srg(nc) = srg(nc) + bgc_vegetation_inst%cnveg_carbonflux_inst%sr_col(n)*CN_zone_weight(nz) + arg(nc) = arg(nc) + bgc_vegetation_inst%cnveg_carbonflux_inst%ar_col(n)*CN_zone_weight(nz) + hrg(nc) = hrg(nc) + soilbiogeochem_carbonflux_inst%hr_col(n)*CN_zone_weight(nz) + burn(nc) = burn(nc) + bgc_vegetation_inst%cnveg_state_inst%farea_burned_col(n)*CN_zone_weight(nz) + closs(nc) = closs(nc) + bgc_vegetation_inst%cnveg_carbonflux_inst%fire_closs_col(n)*CN_zone_weight(nz) + som_closs(nc) = som_closs(nc) + soilbiogeochem_carbonflux_inst%somc_fire_col(n)*CN_zone_weight(nz) + nfire(nc) = nfire(nc) + bgc_vegetation_inst%cnveg_state_inst%nfire_col(n)*CN_zone_weight(nz) + denitg(nc) = denitg(nc) + soilbiogeochem_nitrogenflux_inst%denit_col(n)*CN_zone_weight(nz) + sminn_leachedg(nc) = sminn_leachedg(nc) + soilbiogeochem_nitrogenflux_inst%sminn_leached_col(n)*CN_zone_weight(nz) + sminng(nc) = sminng(nc) + soilbiogeochem_nitrogenstate_inst%sminn_col(n)*CN_zone_weight(nz) + col_fire_nlossg(nc) = col_fire_nlossg(nc) + bgc_vegetation_inst%cnveg_nitrogenflux_inst%fire_nloss_col(n)*CN_zone_weight(nz) + gross_nming(nc) = gross_nming(nc) + soilbiogeochem_nitrogenflux_inst%gross_nmin_col(n)*CN_zone_weight(nz) + net_nming(nc) = net_nming(nc) + soilbiogeochem_nitrogenflux_inst%net_nmin_col(n)*CN_zone_weight(nz) + nfix_to_sminng(nc) = nfix_to_sminng(nc) + soilbiogeochem_nitrogenflux_inst%nfix_to_sminn_col(n)*CN_zone_weight(nz) + actual_immobg(nc) = actual_immobg(nc) + soilbiogeochem_nitrogenflux_inst%actual_immob_col(n)*CN_zone_weight(nz) + fpgg(nc) = fpgg(nc) + soilbiogeochem_state_inst%fpg_col(n)*CN_zone_weight(nz) + fpig(nc) = fpig(nc) + soilbiogeochem_state_inst%fpi_col(n)*CN_zone_weight(nz) + sminn_to_plantg(nc) = sminn_to_plantg(nc) + soilbiogeochem_nitrogenflux_inst%sminn_to_plant_col(n)*CN_zone_weight(nz) + ndep_to_sminng(nc) = ndep_to_sminng(nc) + soilbiogeochem_nitrogenflux_inst%ndep_to_sminn_col(n)*CN_zone_weight(nz) + totlitng(nc) = totlitng(nc) + soilbiogeochem_nitrogenstate_inst%totlitn_col(n)*CN_zone_weight(nz) + totsomng(nc) = totsomng(nc) + soilbiogeochem_nitrogenstate_inst%totsomn_col(n)*CN_zone_weight(nz) + fuelcg(nc) = fuelcg(nc) + bgc_vegetation_inst%cnveg_carbonstate_inst%fuelc_col(n)*CN_zone_weight(nz) + totlitcg(nc) = totlitcg(nc) + soilbiogeochem_carbonstate_inst%totlitc_col(n)*CN_zone_weight(nz) + cwdcg(nc) = cwdcg(nc) + soilbiogeochem_carbonstate_inst%cwdc_col(n)*CN_zone_weight(nz) + + do np = 0,numpft ! PFT index loop + p = p + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==np .and. fveg(nc,nv,nz)>1.e-4) then + + zlai(nc,nv,nz) = canopystate_inst%elai_patch(p) + zsai(nc,nv,nz) = canopystate_inst%esai_patch(p) + ztai(nc,nv,nz) = canopystate_inst%tlai_patch(p) + + pwtgcell = fveg(nc,nv,nz)*CN_zone_weight(nz) ! PFT weight in catchment tile + nppg(nc) = nppg(nc) + bgc_vegetation_inst%cnveg_carbonflux_inst%npp_patch(p)*pwtgcell + gppg(nc) = gppg(nc) + bgc_vegetation_inst%cnveg_carbonflux_inst%gpp_patch(p)*pwtgcell + root(nc) = root(nc) + (bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_storage_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_xfer_patch(p) & + )*pwtgcell + vegc(nc) = vegc(nc) + bgc_vegetation_inst%cnveg_carbonstate_inst%totvegc_patch(p)*pwtgcell + ndeployg(nc) = ndeployg(nc) + bgc_vegetation_inst%cnveg_nitrogenflux_inst%ndeploy_patch(p)*pwtgcell + leafng(nc) = leafng(nc) + bgc_vegetation_inst%cnveg_nitrogenstate_inst%leafn_patch(p)*pwtgcell + leafcg(nc) = leafcg(nc) + bgc_vegetation_inst%cnveg_carbonstate_inst%leafc_patch(p)*pwtgcell + sminn_to_npoolg(nc) = sminn_to_npoolg(nc) + bgc_vegetation_inst%cnveg_nitrogenflux_inst%sminn_to_npool_patch(p)*pwtgcell + totvegng(nc) = totvegng(nc) + bgc_vegetation_inst%cnveg_nitrogenstate_inst%totvegn_patch(p)*pwtgcell + retransng(nc) = retransng(nc) + bgc_vegetation_inst%cnveg_nitrogenstate_inst%retransn_patch(p)*pwtgcell + retransn_to_npoolg(nc) = retransn_to_npoolg(nc) + bgc_vegetation_inst%cnveg_nitrogenflux_inst%retransn_to_npool_patch(p)*pwtgcell + rootcg(nc) = rootcg(nc) + (bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_storage_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_xfer_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_storage_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_xfer_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_storage_patch(p) & + + bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_xfer_patch(p) & + )*pwtgcell + + xsmr(nc) = xsmr(nc) + bgc_vegetation_inst%cnveg_carbonstate_inst%xsmrpool_patch(p)*pwtgcell + end if + end do ! nv + end do !np + end do ! nz + end do ! nc + + end subroutine CN_Driver + +!------------------------------------------------ + subroutine CN_exit(nch,ityp,fveg,cncol,cnpft) + + ! INPUT + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + + ! OUTPUT + real, dimension(nch,num_zon,var_col), intent(out) :: cncol ! column-level restart variables + real, dimension(nch,num_zon,num_veg,var_pft), intent(out) :: cnpft ! PFT-level restart variables + + ! LOCAL + +! type(bounds_type) :: bounds +! type(soilbiogeochem_carbonflux_type) :: soilbiogeochem_carbonflux_inst +! type(soilbiogeochem_nitrogenflux_type) :: soilbiogeochem_nitrogenflux_inst +! type(gridcell_type) :: grc +! type(cn_vegetation_type) :: bgc_vegetation_inst +!! type(cnveg_state_type) :: cnveg_state_inst +! type(soilbiogeochem_carbonstate_type) :: soilbiogeochem_carbonstate_inst +! type(soilbiogeochem_nitrogenstate_type):: soilbiogeochem_nitrogenstate_inst +! type(soilbiogeochem_state_type) :: soilbiogeochem_state_inst +! type(cnveg_carbonflux_type) :: cnveg_carbonflux_inst +! type(cnveg_carbonstate_type) :: cnveg_carbonstate_inst +! type(cnveg_nitrogenflux_type) :: cnveg_nitrogenflux_inst +! type(cnveg_nitrogenstate_type) :: cnveg_nitrogenstate_inst +! type(cn_products_type) :: c_products_inst +! type(cn_products_type) :: n_products_inst + + integer :: n, p, nv, nc, nz, np, nd + integer, dimension(8) :: decomp_cpool_cncol_index = (/ 3, 4, 5, 2, 10, 11, 12, 13 /) + integer, dimension(8) :: decomp_npool_cncol_index = (/ 18, 19, 20, 17,25, 26, 27, 28 /) + !---------------- + + n = 0 + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + cncol(nc,nz, 1) = soilbiogeochem_carbonstate_inst%ctrunc_vr_col(n,1) + + do nd = 1,ndecomp_pools + ! jkolassa: accounting for fact that pool order in CNCOL is different from CTSM + cncol(nc,nz,decomp_cpool_cncol_index(nd)) = soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col (n,1,nd) + cncol(nc,nz,decomp_npool_cncol_index(nd)) = soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col (n,1,nd) + end do + + cncol(nc,nz, 6) = bgc_vegetation_inst%cnveg_carbonstate_inst%totvegc_col (n) + ! jkolassa: variables below transitioned from being column-level to being gridcell-level in CLM; + ! assuming here that quantities are spread over zones according to zone weight + cncol(nc,nz, 7) = bgc_vegetation_inst%c_products_inst%prod100_grc(nc)*CN_zone_weight(nz) + cncol(nc,nz, 8) = bgc_vegetation_inst%c_products_inst%prod100_grc(nc)*CN_zone_weight(nz) + cncol(nc,nz, 9) = bgc_vegetation_inst%cnveg_carbonstate_inst%seedc_grc(nc)*CN_zone_weight(nz) + cncol(nc,nz,14) = bgc_vegetation_inst%cnveg_carbonstate_inst%totc_col (n) + cncol(nc,nz,15) = soilbiogeochem_carbonstate_inst%totlitc_col (n) + cncol(nc,nz,16) = soilbiogeochem_nitrogenstate_inst%ntrunc_vr_col (n,1) + + + cncol(nc,nz,21) = bgc_vegetation_inst%n_products_inst%prod100_grc(nc)*CN_zone_weight(nz) + cncol(nc,nz,22) = bgc_vegetation_inst%n_products_inst%prod100_grc(nc)*CN_zone_weight(nz) + cncol(nc,nz,23) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%seedn_grc(nc)*CN_zone_weight(nz) + cncol(nc,nz,24) = soilbiogeochem_nitrogenstate_inst%sminn_vr_col (n,1) + cncol(nc,nz,29) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%totn_col (n) + cncol(nc,nz,30) = soilbiogeochem_state_inst%fpg_col (n) + cncol(nc,nz,31) = bgc_vegetation_inst%cnveg_state_inst%annsum_counter_col (n) + cncol(nc,nz,32) = bgc_vegetation_inst%cnveg_state_inst%annavg_t2m_col (n) + cncol(nc,nz,33) = bgc_vegetation_inst%cnveg_carbonflux_inst%annsum_npp_col (n) + cncol(nc,nz,34) = bgc_vegetation_inst%cnveg_state_inst%farea_burned_col (n) + cncol(nc,nz,35) = soilbiogeochem_state_inst%fpi_col (n) + cncol(nc,nz,36) = soilbiogeochem_nitrogenstate_inst%smin_no3_col (n) + cncol(nc,nz,37) = soilbiogeochem_nitrogenstate_inst%smin_nh4_col (n) + + + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + cnpft(nc,nz,nv, 1) = bgc_vegetation_inst%cnveg_carbonstate_inst%cpool_patch (np) + cnpft(nc,nz,nv, 2) = bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_patch (np) + cnpft(nc,nz,nv, 3) = bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_storage_patch (np) + cnpft(nc,nz,nv, 4) = bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_xfer_patch (np) + cnpft(nc,nz,nv, 5) = bgc_vegetation_inst%cnveg_carbonstate_inst%deadstemc_patch (np) + cnpft(nc,nz,nv, 6) = bgc_vegetation_inst%cnveg_carbonstate_inst%deadstemc_storage_patch (np) + cnpft(nc,nz,nv, 7) = bgc_vegetation_inst%cnveg_carbonstate_inst%deadstemc_xfer_patch (np) + cnpft(nc,nz,nv, 8) = bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_patch (np) + cnpft(nc,nz,nv, 9) = bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_storage_patch (np) + cnpft(nc,nz,nv, 10) = bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_xfer_patch (np) + cnpft(nc,nz,nv, 11) = bgc_vegetation_inst%cnveg_carbonstate_inst%gresp_storage_patch (np) + cnpft(nc,nz,nv, 12) = bgc_vegetation_inst%cnveg_carbonstate_inst%gresp_xfer_patch (np) + cnpft(nc,nz,nv, 13) = bgc_vegetation_inst%cnveg_carbonstate_inst%leafc_patch (np) + cnpft(nc,nz,nv, 14) = bgc_vegetation_inst%cnveg_carbonstate_inst%leafc_storage_patch (np) + cnpft(nc,nz,nv, 15) = bgc_vegetation_inst%cnveg_carbonstate_inst%leafc_xfer_patch (np) + cnpft(nc,nz,nv, 16) = bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_patch (np) + cnpft(nc,nz,nv, 17) = bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_storage_patch (np) + cnpft(nc,nz,nv, 18) = bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_xfer_patch (np) + cnpft(nc,nz,nv, 19) = bgc_vegetation_inst%cnveg_carbonstate_inst%livestemc_patch (np) + cnpft(nc,nz,nv, 20) = bgc_vegetation_inst%cnveg_carbonstate_inst%livestemc_storage_patch (np) + cnpft(nc,nz,nv, 21) = bgc_vegetation_inst%cnveg_carbonstate_inst%livestemc_xfer_patch (np) + cnpft(nc,nz,nv, 22) = bgc_vegetation_inst%cnveg_carbonstate_inst%ctrunc_patch (np) + cnpft(nc,nz,nv, 23) = bgc_vegetation_inst%cnveg_carbonstate_inst%xsmrpool_patch (np) + cnpft(nc,nz,nv, 24) = bgc_vegetation_inst%cnveg_state_inst%annavg_t2m_patch (np) + cnpft(nc,nz,nv, 25) = bgc_vegetation_inst%cnveg_state_inst%annmax_retransn_patch (np) + cnpft(nc,nz,nv, 26) = bgc_vegetation_inst%cnveg_carbonflux_inst%annsum_npp_patch (np) + cnpft(nc,nz,nv, 27) = bgc_vegetation_inst%cnveg_state_inst%annsum_potential_gpp_patch (np) + cnpft(nc,nz,nv, 28) = grc%dayl (nc) ! jkolassa Dec 2023: dayl is a gridcell =-level variable in CLM, but is stored as patch-level variable in CatcCN restart + cnpft(nc,nz,nv, 29) = bgc_vegetation_inst%cnveg_state_inst%days_active_patch (np) + cnpft(nc,nz,nv, 30) = bgc_vegetation_inst%cnveg_state_inst%dormant_flag_patch (np) + cnpft(nc,nz,nv, 31) = bgc_vegetation_inst%cnveg_state_inst%offset_counter_patch (np) + cnpft(nc,nz,nv, 32) = bgc_vegetation_inst%cnveg_state_inst%offset_fdd_patch (np) + cnpft(nc,nz,nv, 33) = bgc_vegetation_inst%cnveg_state_inst%offset_flag_patch (np) + cnpft(nc,nz,nv, 34) = bgc_vegetation_inst%cnveg_state_inst%offset_swi_patch (np) + cnpft(nc,nz,nv, 35) = bgc_vegetation_inst%cnveg_state_inst%onset_counter_patch (np) + cnpft(nc,nz,nv, 36) = bgc_vegetation_inst%cnveg_state_inst%onset_fdd_patch (np) + cnpft(nc,nz,nv, 37) = bgc_vegetation_inst%cnveg_state_inst%onset_flag_patch (np) + cnpft(nc,nz,nv, 38) = bgc_vegetation_inst%cnveg_state_inst%onset_gdd_patch (np) + cnpft(nc,nz,nv, 39) = bgc_vegetation_inst%cnveg_state_inst%onset_gddflag_patch (np) + cnpft(nc,nz,nv, 40) = bgc_vegetation_inst%cnveg_state_inst%onset_swi_patch (np) + cnpft(nc,nz,nv, 41) = bgc_vegetation_inst%cnveg_carbonflux_inst%prev_frootc_to_litter_patch (np) + cnpft(nc,nz,nv, 42) = bgc_vegetation_inst%cnveg_carbonflux_inst%prev_leafc_to_litter_patch (np) + cnpft(nc,nz,nv, 43) = bgc_vegetation_inst%cnveg_state_inst%tempavg_t2m_patch (np) + cnpft(nc,nz,nv, 44) = bgc_vegetation_inst%cnveg_state_inst%tempmax_retransn_patch (np) + cnpft(nc,nz,nv, 45) = bgc_vegetation_inst%cnveg_carbonflux_inst%tempsum_npp_patch (np) + cnpft(nc,nz,nv, 46) = bgc_vegetation_inst%cnveg_state_inst%tempsum_potential_gpp_patch (np) + cnpft(nc,nz,nv, 47) = bgc_vegetation_inst%cnveg_carbonflux_inst%xsmrpool_recover_patch (np) + cnpft(nc,nz,nv, 48) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadcrootn_patch (np) + cnpft(nc,nz,nv, 49) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadcrootn_storage_patch (np) + cnpft(nc,nz,nv, 50) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadcrootn_xfer_patch (np) + cnpft(nc,nz,nv, 51) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadstemn_patch (np) + cnpft(nc,nz,nv, 52) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadstemn_storage_patch (np) + cnpft(nc,nz,nv, 53) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadstemn_xfer_patch (np) + cnpft(nc,nz,nv, 54) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%frootn_patch (np) + cnpft(nc,nz,nv, 55) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%frootn_storage_patch (np) + cnpft(nc,nz,nv, 56) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%frootn_xfer_patch (np) + cnpft(nc,nz,nv, 57) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%leafn_patch (np) + cnpft(nc,nz,nv, 58) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%leafn_storage_patch (np) + cnpft(nc,nz,nv, 59) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%leafn_xfer_patch (np) + cnpft(nc,nz,nv, 60) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%livecrootn_patch (np) + cnpft(nc,nz,nv, 61) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%livecrootn_storage_patch (np) + cnpft(nc,nz,nv, 62) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%livecrootn_xfer_patch (np) + cnpft(nc,nz,nv, 63) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%livestemn_patch (np) + cnpft(nc,nz,nv, 64) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%livestemn_storage_patch (np) + cnpft(nc,nz,nv, 65) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%livestemn_xfer_patch (np) + cnpft(nc,nz,nv, 66) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%npool_patch (np) + cnpft(nc,nz,nv, 67) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%ntrunc_patch (np) + cnpft(nc,nz,nv, 68) = bgc_vegetation_inst%cnveg_nitrogenstate_inst%retransn_patch (np) + cnpft(nc,nz,nv, 69) = canopystate_inst%elai_patch (np) + cnpft(nc,nz,nv, 70) = canopystate_inst%esai_patch (np) + cnpft(nc,nz,nv, 71) = canopystate_inst%hbot_patch (np) + cnpft(nc,nz,nv, 72) = canopystate_inst%htop_patch (np) + cnpft(nc,nz,nv, 73) = canopystate_inst%tlai_patch (np) + cnpft(nc,nz,nv, 74) = canopystate_inst%tsai_patch (np) + cnpft(nc,nz,nv, 75) = bgc_vegetation_inst%cnveg_nitrogenflux_inst%plant_ndemand_patch (np) + cnpft(nc,nz,nv, 76) = canopystate_inst%vegwp_patch (np,1) + cnpft(nc,nz,nv, 77) = canopystate_inst%vegwp_patch (np,2) + cnpft(nc,nz,nv, 78) = canopystate_inst%vegwp_patch (np,3) + cnpft(nc,nz,nv, 79) = canopystate_inst%vegwp_patch (np,4) + cnpft(nc,nz,nv, 80) = bgc_vegetation_inst%cnveg_carbonflux_inst%annsum_litfall_patch (np) + cnpft(nc,nz,nv, 81) = bgc_vegetation_inst%cnveg_carbonflux_inst%tempsum_litfall_patch (np) + endif + + end do ! defined veg loop + end do ! PFT index loop + end do ! CN zone loop + end do ! catchment tile loop + + return + + end subroutine CN_exit + +!-------------------------- + subroutine get_CN_LAI(nch,ityp,fveg,elai,esai,tlai,tsai) + + ! ARGUMENTS + + ! INPUT/OUTPUT + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + real, dimension(nch,num_veg,num_zon), intent(out) :: elai ! exposed leaf-area index + real, dimension(nch,num_veg,num_zon), intent(out), optional :: esai ! exposed stem-area index + real, dimension(nch,num_veg,num_zon), intent(out), optional :: tlai ! total leaf-area index + real, dimension(nch,num_veg,num_zon), intent(out), optional :: tsai ! total stem-area index + + ! LOCAL + integer :: n, p, nv, nc, nz, np + +! real(r8), pointer :: elai_clm(:) +! real(r8), pointer :: esai_clm(:) +! real(r8), pointer :: tlai_clm(:) +! real(r8), pointer :: tsai_clm(:) + + !------------------------------ + associate(& + elai_clm => canopystate_inst%elai_patch , & + esai_clm => canopystate_inst%esai_patch , & + tlai_clm => canopystate_inst%tlai_patch , & + tsai_clm => canopystate_inst%tsai_patch & + ) + + elai = 0. + if(present(esai)) esai = 0. + if(present(tlai)) tlai = 0. + if(present(tsai)) tsai = 0. + + n = 0 + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + +! extract LAI & SAI from CN clmtype +! --------------------------------- + if(ityp(nc,nv,nz)==p .and. ityp(nc,nv,nz)>0 .and. fveg(nc,nv,nz)>1.e-4) then + elai(nc,nv,nz) = elai_clm(np) + if(present(esai)) esai(nc,nv,nz) = esai_clm(np) + if(present(tlai)) tlai(nc,nv,nz) = tlai_clm(np) + if(present(tsai)) tsai(nc,nv,nz) = tsai_clm(np) + endif + + end do ! defined veg loop + end do ! PFT index loop + end do ! CN zone loop + end do ! catchment tile loop + + end associate + + end subroutine get_CN_LAI +!--------------------------- + +! subroutine FireMethodInit(bounds,paramfile) +! +! use MAPL , only : NetCDF4_FileFormatter +! +! +! type(bounds_type), intent(in) :: bounds +! character(300), intent(in) :: paramfile +! +! type(Netcdf4_fileformatter) :: ncid +! integer :: rc, status +! !-------------------------------- +! +! call create_cnfire_method(cnfire_method) +! call cnfire_method%FireInit(bounds) +! +! call ncid%open(trim(paramfile),pFIO_READ, __RC__) +! call cnfire_method%CNFireReadParams( ncid ) +! call ncid%close(rc=status) +! +! end subroutine FireMethodInit +end module CNCLM_DriverMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_EnergyFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_EnergyFluxType.F90 new file mode 100755 index 000000000..8d4b00da1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_EnergyFluxType.F90 @@ -0,0 +1,239 @@ +module EnergyFluxType + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! Energy flux data structure + ! + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use nanMod , only : nan + use clm_varcon , only : spval + use clm_varctl , only : use_biomass_heat_storage + use decompMod , only : bounds_type + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use clm_varpar , only: nlevgrnd + + ! + implicit none + save + private +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + type, public :: energyflux_type + + ! Fluxes + real(r8), pointer :: eflx_sh_stem_patch (:) ! patch sensible heat flux from stem (W/m**2) [+ to atm] + real(r8), pointer :: eflx_h2osfc_to_snow_col (:) ! col snow melt to h2osfc heat flux (W/m**2) + real(r8), pointer :: eflx_sh_grnd_patch (:) ! patch sensible heat flux from ground (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_veg_patch (:) ! patch sensible heat flux from leaves (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_snow_patch (:) ! patch sensible heat flux from snow (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_soil_patch (:) ! patch sensible heat flux from soil (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_h2osfc_patch (:) ! patch sensible heat flux from surface water (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_tot_patch (:) ! patch total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_tot_u_patch (:) ! patch urban total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_tot_r_patch (:) ! patch rural total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_precip_conversion_col(:) ! col sensible heat flux from precipitation conversion (W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_tot_patch (:) ! patch total latent heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_tot_u_patch (:) ! patch urban total latent heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_tot_r_patch (:) ! patch rural total latent heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_vegt_patch (:) ! patch transpiration heat flux from veg (W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_vege_patch (:) ! patch evaporation heat flux from veg (W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_grnd_patch (:) ! patch evaporation heat flux from ground (W/m**2) [+ to atm] + real(r8), pointer :: eflx_soil_grnd_patch (:) ! patch soil heat flux (W/m**2) [+ = into soil] + real(r8), pointer :: eflx_soil_grnd_u_patch (:) ! patch urban soil heat flux (W/m**2) [+ = into soil] + real(r8), pointer :: eflx_soil_grnd_r_patch (:) ! patch rural soil heat flux (W/m**2) [+ = into soil] + real(r8), pointer :: eflx_lwrad_net_patch (:) ! patch net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8), pointer :: eflx_lwrad_net_r_patch (:) ! patch rural net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8), pointer :: eflx_lwrad_net_u_patch (:) ! patch urban net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8), pointer :: eflx_lwrad_out_patch (:) ! patch emitted infrared (longwave) radiation (W/m**2) + real(r8), pointer :: eflx_lwrad_out_r_patch (:) ! patch rural emitted infrared (longwave) rad (W/m**2) + real(r8), pointer :: eflx_lwrad_out_u_patch (:) ! patch urban emitted infrared (longwave) rad (W/m**2) + real(r8), pointer :: eflx_snomelt_col (:) ! col snow melt heat flux (W/m**2) + real(r8), pointer :: eflx_snomelt_r_col (:) ! col rural snow melt heat flux (W/m**2) + real(r8), pointer :: eflx_snomelt_u_col (:) ! col urban snow melt heat flux (W/m**2) + real(r8), pointer :: eflx_gnet_patch (:) ! patch net heat flux into ground (W/m**2) + real(r8), pointer :: eflx_grnd_lake_patch (:) ! patch net heat flux into lake / snow surface, excluding light transmission (W/m**2) + real(r8), pointer :: eflx_dynbal_grc (:) ! grc dynamic land cover change conversion energy flux (W/m**2) + real(r8), pointer :: eflx_bot_col (:) ! col heat flux from beneath the soil or ice column (W/m**2) + real(r8), pointer :: eflx_fgr12_col (:) ! col ground heat flux between soil layers 1 and 2 (W/m**2) + real(r8), pointer :: eflx_fgr_col (:,:) ! col (rural) soil downward heat flux (W/m2) (1:nlevgrnd) (pos upward; usually eflx_bot >= 0) + real(r8), pointer :: eflx_building_heat_errsoi_col(:) ! col heat flux to interior surface of walls and roof for errsoi check (W m-2) + real(r8), pointer :: eflx_urban_ac_col (:) ! col urban air conditioning flux (W/m**2) + real(r8), pointer :: eflx_urban_heat_col (:) ! col urban heating flux (W/m**2) + real(r8), pointer :: eflx_anthro_patch (:) ! patch total anthropogenic heat flux (W/m**2) + real(r8), pointer :: eflx_traffic_patch (:) ! patch traffic sensible heat flux (W/m**2) + real(r8), pointer :: eflx_wasteheat_patch (:) ! patch sensible heat flux from domestic heating/cooling sources of waste heat (W/m**2) + real(r8), pointer :: eflx_heat_from_ac_patch (:) ! patch sensible heat flux put back into canyon due to removal by AC (W/m**2) + real(r8), pointer :: eflx_traffic_lun (:) ! lun traffic sensible heat flux (W/m**2) + real(r8), pointer :: eflx_wasteheat_lun (:) ! lun sensible heat flux from domestic heating/cooling sources of waste heat (W/m**2) + real(r8), pointer :: eflx_heat_from_ac_lun (:) ! lun sensible heat flux to be put back into canyon due to removal by AC (W/m**2) + real(r8), pointer :: eflx_building_lun (:) ! lun building heat flux from change in interior building air temperature (W/m**2) + real(r8), pointer :: eflx_urban_ac_lun (:) ! lun urban air conditioning flux (W/m**2) + real(r8), pointer :: eflx_urban_heat_lun (:) ! lun urban heating flux (W/m**2) + + ! Derivatives of energy fluxes + real(r8), pointer :: dgnetdT_patch (:) ! patch derivative of net ground heat flux wrt soil temp (W/m**2 K) + real(r8), pointer :: netrad_patch (:) ! col net radiation (W/m**2) [+ = to sfc] + real(r8), pointer :: cgrnd_patch (:) ! col deriv. of soil energy flux wrt to soil temp [W/m2/k] + real(r8), pointer :: cgrndl_patch (:) ! col deriv. of soil latent heat flux wrt soil temp [W/m**2/k] + real(r8), pointer :: cgrnds_patch (:) ! col deriv. of soil sensible heat flux wrt soil temp [W/m2/k] + + ! Canopy radiation + real(r8), pointer :: dlrad_patch (:) ! col downward longwave radiation below the canopy [W/m2] + real(r8), pointer :: ulrad_patch (:) ! col upward longwave radiation above the canopy [W/m2] + + ! Wind Stress + real(r8), pointer :: taux_patch (:) ! patch wind (shear) stress: e-w (kg/m/s**2) + real(r8), pointer :: tauy_patch (:) ! patch wind (shear) stress: n-s (kg/m/s**2) + + ! Conductance + real(r8), pointer :: canopy_cond_patch (:) ! patch tracer conductance for canopy [m/s] + + ! Transpiration + real(r8), pointer :: btran_patch (:) ! patch transpiration wetness factor (0 to 1) + real(r8), pointer :: btran_min_patch (:) ! patch daily minimum transpiration wetness factor (0 to 1) + real(r8), pointer :: btran_min_inst_patch (:) ! patch instantaneous daily minimum transpiration wetness factor (0 to 1) + real(r8), pointer :: bsun_patch (:) ! patch sunlit canopy transpiration wetness factor (0 to 1) + real(r8), pointer :: bsha_patch (:) ! patch shaded canopy transpiration wetness factor (0 to 1) + + ! Roots + real(r8), pointer :: rresis_patch (:,:) ! patch root resistance by layer (0-1) (nlevgrnd) + + ! Latent heat + real(r8), pointer :: htvp_col (:) ! latent heat of vapor of water (or sublimation) [j/kg] + + ! Canopy heat + real(r8), pointer :: dhsdt_canopy_patch (:) ! patch change in heat content of canopy (leaf+stem) (W/m**2) [+ to atm] + + ! Balance Checks + real(r8), pointer :: errsoi_patch (:) ! soil/lake energy conservation error (W/m**2) + real(r8), pointer :: errsoi_col (:) ! soil/lake energy conservation error (W/m**2) + real(r8), pointer :: errseb_patch (:) ! surface energy conservation error (W/m**2) + real(r8), pointer :: errseb_col (:) ! surface energy conservation error (W/m**2) + real(r8), pointer :: errsol_patch (:) ! solar radiation conservation error (W/m**2) + real(r8), pointer :: errsol_col (:) ! solar radiation conservation error (W/m**2) + real(r8), pointer :: errlon_patch (:) ! longwave radiation conservation error (W/m**2) + real(r8), pointer :: errlon_col (:) ! longwave radiation conservation error (W/m**2) + + + contains + + procedure , public :: Init + + end type energyflux_type + type(energyflux_type), public, target, save :: energyflux_inst + +contains + +!--------------------------------------------- + subroutine Init(this, bounds) + + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(energyflux_type) :: this + + !LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begl, endl + integer :: begg, endg + !-------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + begl = bounds%begl ; endl= bounds%endl + begg = bounds%begg ; endg = bounds%endg + + allocate( this%eflx_h2osfc_to_snow_col (begc:endc)) ; this%eflx_h2osfc_to_snow_col (:) = nan + allocate( this%eflx_sh_snow_patch (begp:endp)) ; this%eflx_sh_snow_patch (:) = nan + allocate( this%eflx_sh_soil_patch (begp:endp)) ; this%eflx_sh_soil_patch (:) = nan + allocate( this%eflx_sh_h2osfc_patch (begp:endp)) ; this%eflx_sh_h2osfc_patch (:) = nan + allocate( this%eflx_sh_tot_patch (begp:endp)) ; this%eflx_sh_tot_patch (:) = nan + allocate( this%eflx_sh_tot_u_patch (begp:endp)) ; this%eflx_sh_tot_u_patch (:) = nan + allocate( this%eflx_sh_tot_r_patch (begp:endp)) ; this%eflx_sh_tot_r_patch (:) = nan + allocate( this%eflx_sh_grnd_patch (begp:endp)) ; this%eflx_sh_grnd_patch (:) = nan + allocate( this%eflx_sh_stem_patch (begp:endp)) ; this%eflx_sh_stem_patch (:) = nan + allocate( this%eflx_sh_veg_patch (begp:endp)) ; this%eflx_sh_veg_patch (:) = nan + allocate( this%eflx_sh_precip_conversion_col(begc:endc)) ; this%eflx_sh_precip_conversion_col(:) = nan + allocate( this%eflx_lh_tot_u_patch (begp:endp)) ; this%eflx_lh_tot_u_patch (:) = nan + allocate( this%eflx_lh_tot_patch (begp:endp)) ; this%eflx_lh_tot_patch (:) = nan + allocate( this%eflx_lh_tot_r_patch (begp:endp)) ; this%eflx_lh_tot_r_patch (:) = nan + allocate( this%eflx_lh_grnd_patch (begp:endp)) ; this%eflx_lh_grnd_patch (:) = nan + allocate( this%eflx_lh_vege_patch (begp:endp)) ; this%eflx_lh_vege_patch (:) = nan + allocate( this%eflx_lh_vegt_patch (begp:endp)) ; this%eflx_lh_vegt_patch (:) = nan + allocate( this%eflx_soil_grnd_patch (begp:endp)) ; this%eflx_soil_grnd_patch (:) = nan + allocate( this%eflx_soil_grnd_u_patch (begp:endp)) ; this%eflx_soil_grnd_u_patch (:) = nan + allocate( this%eflx_soil_grnd_r_patch (begp:endp)) ; this%eflx_soil_grnd_r_patch (:) = nan + allocate( this%eflx_lwrad_net_patch (begp:endp)) ; this%eflx_lwrad_net_patch (:) = nan + allocate( this%eflx_lwrad_net_u_patch (begp:endp)) ; this%eflx_lwrad_net_u_patch (:) = nan + allocate( this%eflx_lwrad_net_r_patch (begp:endp)) ; this%eflx_lwrad_net_r_patch (:) = nan + allocate( this%eflx_lwrad_out_patch (begp:endp)) ; this%eflx_lwrad_out_patch (:) = nan + allocate( this%eflx_lwrad_out_u_patch (begp:endp)) ; this%eflx_lwrad_out_u_patch (:) = nan + allocate( this%eflx_lwrad_out_r_patch (begp:endp)) ; this%eflx_lwrad_out_r_patch (:) = nan + allocate( this%eflx_gnet_patch (begp:endp)) ; this%eflx_gnet_patch (:) = nan + allocate( this%eflx_grnd_lake_patch (begp:endp)) ; this%eflx_grnd_lake_patch (:) = nan + allocate( this%eflx_dynbal_grc (begg:endg)) ; this%eflx_dynbal_grc (:) = nan + allocate( this%eflx_bot_col (begc:endc)) ; this%eflx_bot_col (:) = nan + allocate( this%eflx_snomelt_col (begc:endc)) ; this%eflx_snomelt_col (:) = nan + allocate( this%eflx_snomelt_r_col (begc:endc)) ; this%eflx_snomelt_r_col (:) = nan + allocate( this%eflx_snomelt_u_col (begc:endc)) ; this%eflx_snomelt_u_col (:) = nan + allocate( this%eflx_fgr12_col (begc:endc)) ; this%eflx_fgr12_col (:) = nan + allocate( this%eflx_fgr_col (begc:endc, 1:nlevgrnd)) ; this%eflx_fgr_col (:,:) = nan + allocate( this%eflx_building_heat_errsoi_col (begc:endc)) ; this%eflx_building_heat_errsoi_col(:)= nan + allocate( this%eflx_urban_ac_col (begc:endc)) ; this%eflx_urban_ac_col (:) = nan + allocate( this%eflx_urban_heat_col (begc:endc)) ; this%eflx_urban_heat_col (:) = nan + allocate( this%eflx_wasteheat_patch (begp:endp)) ; this%eflx_wasteheat_patch (:) = nan + allocate( this%eflx_traffic_patch (begp:endp)) ; this%eflx_traffic_patch (:) = nan + allocate( this%eflx_heat_from_ac_patch (begp:endp)) ; this%eflx_heat_from_ac_patch (:) = nan + allocate( this%eflx_heat_from_ac_lun (begl:endl)) ; this%eflx_heat_from_ac_lun (:) = nan + allocate( this%eflx_building_lun (begl:endl)) ; this%eflx_building_lun (:) = nan + allocate( this%eflx_urban_ac_lun (begl:endl)) ; this%eflx_urban_ac_lun (:) = nan + allocate( this%eflx_urban_heat_lun (begl:endl)) ; this%eflx_urban_heat_lun (:) = nan + allocate( this%eflx_traffic_lun (begl:endl)) ; this%eflx_traffic_lun (:) = nan + allocate( this%eflx_wasteheat_lun (begl:endl)) ; this%eflx_wasteheat_lun (:) = nan + allocate( this%eflx_anthro_patch (begp:endp)) ; this%eflx_anthro_patch (:) = nan + + allocate( this%dgnetdT_patch (begp:endp)) ; this%dgnetdT_patch (:) = nan + allocate( this%cgrnd_patch (begp:endp)) ; this%cgrnd_patch (:) = nan + allocate( this%cgrndl_patch (begp:endp)) ; this%cgrndl_patch (:) = nan + allocate( this%cgrnds_patch (begp:endp)) ; this%cgrnds_patch (:) = nan + allocate( this%dlrad_patch (begp:endp)) ; this%dlrad_patch (:) = nan + allocate( this%ulrad_patch (begp:endp)) ; this%ulrad_patch (:) = nan + allocate( this%netrad_patch (begp:endp)) ; this%netrad_patch (:) = nan + + allocate( this%taux_patch (begp:endp)) ; this%taux_patch (:) = nan + allocate( this%tauy_patch (begp:endp)) ; this%tauy_patch (:) = nan + + allocate( this%canopy_cond_patch (begp:endp)) ; this%canopy_cond_patch (:) = nan + + allocate( this%htvp_col (begc:endc)) ; this%htvp_col (:) = nan + + allocate( this%dhsdt_canopy_patch (begp:endp)) ; this%dhsdt_canopy_patch (:) = nan + + allocate(this%rresis_patch (begp:endp,1:nlevgrnd)) ; this%rresis_patch (:,:) = nan + allocate(this%btran_patch (begp:endp)) ; this%btran_patch (:) = nan + allocate(this%btran_min_patch (begp:endp)) ; this%btran_min_patch (:) = nan + allocate(this%btran_min_inst_patch (begp:endp)) ; this%btran_min_inst_patch (:) = nan + allocate( this%bsun_patch (begp:endp)) ; this%bsun_patch (:) = nan + allocate( this%bsha_patch (begp:endp)) ; this%bsha_patch (:) = nan + allocate( this%errsoi_patch (begp:endp)) ; this%errsoi_patch (:) = nan + allocate( this%errsoi_col (begc:endc)) ; this%errsoi_col (:) = nan + allocate( this%errseb_patch (begp:endp)) ; this%errseb_patch (:) = nan + allocate( this%errseb_col (begc:endc)) ; this%errseb_col (:) = nan + allocate( this%errsol_patch (begp:endp)) ; this%errsol_patch (:) = nan + allocate( this%errsol_col (begc:endc)) ; this%errsol_col (:) = nan + allocate( this%errlon_patch (begp:endp)) ; this%errlon_patch (:) = nan + allocate( this%errlon_col (begc:endc)) ; this%errlon_col (:) = nan + + + end subroutine Init + +end module EnergyFluxType + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_FireDataBaseType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_FireDataBaseType.F90 new file mode 100755 index 000000000..1a4ad1fb9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_FireDataBaseType.F90 @@ -0,0 +1,106 @@ +module FireDataBaseType + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! module for handling of fire data + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8, CL => shr_kind_CL + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog + use fileutils , only : getavu, relavu + use abortutils , only : endrun + use decompMod , only : bounds_type + use FireMethodType , only : fire_method_type + ! + implicit none + private + ! + ! !PUBLIC TYPES: + public :: fire_base_type + + ! + type, abstract, extends(fire_method_type) :: fire_base_type + private + ! !PRIVATE MEMBER DATA: + + real(r8), public, pointer :: forc_lnfm(:) ! Lightning frequency + real(r8), public, pointer :: forc_hdm(:) ! Human population density + + contains + ! + ! !PUBLIC MEMBER FUNCTIONS: + procedure, public :: FireInit => BaseFireInit ! Initialization of Fire + procedure, public :: BaseFireInit ! Initialization of Fire + procedure(FireReadNML_interface), public, deferred :: FireReadNML ! Read in namelist for Fire + procedure(need_lightning_and_popdens_interface), public, deferred :: & + need_lightning_and_popdens ! Returns true if need lightning & popdens + ! + end type fire_base_type + + !------------------------------------------------------------------------- + + abstract interface + !----------------------------------------------------------------------- + function need_lightning_and_popdens_interface(this) result(need_lightning_and_popdens) + ! + ! !DESCRIPTION: + ! Returns true if need lightning and popdens, false otherwise + ! + ! USES + import :: fire_base_type + ! + ! !ARGUMENTS: + class(fire_base_type), intent(in) :: this + logical :: need_lightning_and_popdens ! function result + !----------------------------------------------------------------------- + end function need_lightning_and_popdens_interface + end interface + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + subroutine FireReadNML_interface( this, NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for Fire + ! + ! !USES: + ! + ! !ARGUMENTS: + class(fire_base_type) :: this + character(len=*), intent(in) :: NLFilename ! Namelist filename + end subroutine FireReadNML_interface + + !----------------------------------------------------------------------- + subroutine BaseFireInit( this, bounds) + ! + ! !DESCRIPTION: + ! Initialize CN Fire module + ! !USES: + use nanMod , only : nan + ! + ! !ARGUMENTS: + class(fire_base_type) :: this + type(bounds_type), intent(in) :: bounds + !character(len=*), intent(in) :: NLFilename + !----------------------------------------------------------------------- + + if ( this%need_lightning_and_popdens() ) then + ! Allocate lightning forcing data + allocate( this%forc_lnfm(bounds%begg:bounds%endg) ) + this%forc_lnfm(bounds%begg:) = nan + ! Allocate pop dens forcing data + allocate( this%forc_hdm(bounds%begg:bounds%endg) ) + this%forc_hdm(bounds%begg:) = nan + end if + + end subroutine BaseFireInit + + +end module FireDataBaseType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_FrictionVelocityMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_FrictionVelocityMod.F90 new file mode 100755 index 000000000..5cfa4db40 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_FrictionVelocityMod.F90 @@ -0,0 +1,141 @@ +module FrictionVelocityMod + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Calculation of the friction velocity, relation for potential + ! temperature and humidity profiles of surface boundary layer. + ! + ! !USES: +#include "shr_assert.h" + use shr_kind_mod , only : r8 => shr_kind_r8 + use nanMod , only : nan + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_const_mod , only : SHR_CONST_PI + use decompMod , only : bounds_type + use clm_varcon , only : spval + use clm_varctl , only : use_cn, use_luna + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use landunit_varcon , only : istsoil, istcrop, istice_mec, istwet + use ncdio_pio , only : file_desc_t + use paramUtilMod , only : readNcdioScalar + use atm2lndType , only : atm2lnd_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use CanopyStateType , only : canopystate_type + ! + ! !PUBLIC TYPES: + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: frictionvel_type + private + + ! Scalar parameters + real(r8), public :: zetamaxstable = -999._r8 ! Max value zeta ("height" used in Monin-Obukhov theory) can go to under stable conditions + real(r8) :: zsno = -999._r8 ! Momentum roughness length for snow (m) + real(r8) :: zlnd = -999._r8 ! Momentum roughness length for soil, glacier, wetland (m) + + ! Roughness length/resistance for friction velocity calculation + + real(r8), pointer, public :: forc_hgt_u_patch (:) ! patch wind forcing height (10m+z0m+d) (m) + real(r8), pointer, public :: forc_hgt_t_patch (:) ! patch temperature forcing height (10m+z0m+d) (m) + real(r8), pointer, public :: forc_hgt_q_patch (:) ! patch specific humidity forcing height (10m+z0m+d) (m) + real(r8), pointer, public :: u10_patch (:) ! patch 10-m wind (m/s) (for dust model) + real(r8), pointer, public :: u10_clm_patch (:) ! patch 10-m wind (m/s) (for clm_map2gcell) + real(r8), pointer, public :: va_patch (:) ! patch atmospheric wind speed plus convective velocity (m/s) + real(r8), pointer, public :: vds_patch (:) ! patch deposition velocity term (m/s) (for dry dep SO4, NH4NO3) + real(r8), pointer, public :: fv_patch (:) ! patch friction velocity (m/s) (for dust model) + real(r8), pointer, public :: rb1_patch (:) ! patch aerodynamical resistance (s/m) (for dry deposition of chemical tracers) + real(r8), pointer, public :: rb10_patch (:) ! 10-day mean patch aerodynamical resistance (s/m) (for LUNA model) + real(r8), pointer, public :: ram1_patch (:) ! patch aerodynamical resistance (s/m) + real(r8), pointer, public :: z0mv_patch (:) ! patch roughness length over vegetation, momentum [m] + real(r8), pointer, public :: z0hv_patch (:) ! patch roughness length over vegetation, sensible heat [m] + real(r8), pointer, public :: z0qv_patch (:) ! patch roughness length over vegetation, latent heat [m] + real(r8), pointer, public :: z0mg_col (:) ! col roughness length over ground, momentum [m] + real(r8), pointer, public :: z0hg_col (:) ! col roughness length over ground, sensible heat [m] + real(r8), pointer, public :: z0qg_col (:) ! col roughness length over ground, latent heat [m] + ! variables to add history output from CanopyFluxesMod + real(r8), pointer, public :: rah1_patch (:) ! patch sensible heat flux resistance [s/m] + real(r8), pointer, public :: rah2_patch (:) ! patch below-canopy sensible heat flux resistance [s/m] + real(r8), pointer, public :: raw1_patch (:) ! patch moisture flux resistance [s/m] + real(r8), pointer, public :: raw2_patch (:) ! patch below-canopy moisture flux resistance [s/m] + real(r8), pointer, public :: ustar_patch (:) ! patch friction velocity [m/s] + real(r8), pointer, public :: um_patch (:) ! patch wind speed including the stablity effect [m/s] + real(r8), pointer, public :: uaf_patch (:) ! patch canopy air speed [m/s] + real(r8), pointer, public :: taf_patch (:) ! patch canopy air temperature [K] + real(r8), pointer, public :: qaf_patch (:) ! patch canopy humidity [kg/kg] + real(r8), pointer, public :: obu_patch (:) ! patch Monin-Obukhov length [m] + real(r8), pointer, public :: zeta_patch (:) ! patch dimensionless stability parameter + real(r8), pointer, public :: vpd_patch (:) ! patch vapor pressure deficit [Pa] + real(r8), pointer, public :: num_iter_patch (:) ! patch number of iterations + real(r8), pointer, public :: z0m_actual_patch (:) ! patch roughness length actually used in flux calculations, momentum [m] + + contains + + procedure , public :: Init + + end type frictionvel_type + type(frictionvel_type), public, target, save :: frictionvel_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init( this, bounds) + + ! use shr_infnan_mod , only : nan => shr_infnan_nan + + type(bounds_type), intent(in) :: bounds + class(frictionvel_type) :: this + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + allocate(this%forc_hgt_u_patch (begp:endp)) ; this%forc_hgt_u_patch (:) = nan + allocate(this%forc_hgt_t_patch (begp:endp)) ; this%forc_hgt_t_patch (:) = nan + allocate(this%forc_hgt_q_patch (begp:endp)) ; this%forc_hgt_q_patch (:) = nan + allocate(this%u10_patch (begp:endp)) ; this%u10_patch (:) = nan + allocate(this%u10_clm_patch (begp:endp)) ; this%u10_clm_patch (:) = nan + allocate(this%va_patch (begp:endp)) ; this%va_patch (:) = nan + allocate(this%vds_patch (begp:endp)) ; this%vds_patch (:) = nan + allocate(this%fv_patch (begp:endp)) ; this%fv_patch (:) = nan + allocate(this%rb1_patch (begp:endp)) ; this%rb1_patch (:) = nan + allocate(this%rb10_patch (begp:endp)) ; this%rb10_patch (:) = spval + allocate(this%ram1_patch (begp:endp)) ; this%ram1_patch (:) = nan + allocate(this%z0mv_patch (begp:endp)) ; this%z0mv_patch (:) = nan + allocate(this%z0hv_patch (begp:endp)) ; this%z0hv_patch (:) = nan + allocate(this%z0qv_patch (begp:endp)) ; this%z0qv_patch (:) = nan + allocate(this%z0mg_col (begc:endc)) ; this%z0mg_col (:) = nan + allocate(this%z0qg_col (begc:endc)) ; this%z0qg_col (:) = nan + allocate(this%z0hg_col (begc:endc)) ; this%z0hg_col (:) = nan + allocate(this%rah1_patch (begp:endp)) ; this%rah1_patch (:) = nan + allocate(this%rah2_patch (begp:endp)) ; this%rah2_patch (:) = nan + allocate(this%raw1_patch (begp:endp)) ; this%raw1_patch (:) = nan + allocate(this%raw2_patch (begp:endp)) ; this%raw2_patch (:) = nan + allocate(this%um_patch (begp:endp)) ; this%um_patch (:) = nan + allocate(this%uaf_patch (begp:endp)) ; this%uaf_patch (:) = nan + allocate(this%taf_patch (begp:endp)) ; this%taf_patch (:) = nan + allocate(this%qaf_patch (begp:endp)) ; this%qaf_patch (:) = nan + allocate(this%ustar_patch (begp:endp)) ; this%ustar_patch (:) = nan + allocate(this%obu_patch (begp:endp)) ; this%obu_patch (:) = nan + allocate(this%zeta_patch (begp:endp)) ; this%zeta_patch (:) = nan + allocate(this%vpd_patch (begp:endp)) ; this%vpd_patch (:) = nan + allocate(this%num_iter_patch (begp:endp)) ; this%num_iter_patch (:) = nan + allocate(this%z0m_actual_patch (begp:endp)) ; this%z0m_actual_patch (:) = nan + + end subroutine Init + + +end module FrictionVelocityMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_GridcellType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_GridcellType.F90 new file mode 100755 index 000000000..9b2d7524e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_GridcellType.F90 @@ -0,0 +1,107 @@ +module GridcellType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8, MAPL_PI + use nanMod , only : nan + use decompMod , only : bounds_type + use clm_varcon , only : ispval, max_lunit + use clm_varpar , only : numpft, num_zon, num_veg, var_pft + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: gridcell_type + + ! topological mapping functionality, local 1d gdc arrays + integer , pointer :: gindex (:) ! global index + real(r8), pointer :: area (:) ! total land area, gridcell (km^2) + real(r8), pointer :: lat (:) ! latitude (radians) + real(r8), pointer :: lon (:) ! longitude (radians) + real(r8), pointer :: latdeg (:) ! latitude (degrees) + real(r8), pointer :: londeg (:) ! longitude (degrees) + logical , pointer :: active (:) ! just needed for symmetry with other subgrid types + + integer, pointer :: nbedrock (:) ! index of uppermost bedrock layer + + ! Daylength + real(r8) , pointer :: max_dayl (:) ! maximum daylength for this grid cell (s) + real(r8) , pointer :: dayl (:) ! daylength (seconds) + real(r8) , pointer :: prev_dayl (:) ! daylength from previous timestep (seconds) + + ! indices into landunit-level arrays for landunits in this grid cell (ispval implies + ! this landunit doesn't exist on this grid cell) [1:max_lunit, begg:endg] + ! (note that the spatial dimension is last here, in contrast to most 2-d variables; + ! this is for efficiency, since most loops will go over g in the outer loop, and + ! landunit type in the inner loop) + integer , pointer :: landunit_indices (:,:) + + contains + + procedure, public :: Init + + end type gridcell_type + type(gridcell_type), public, target :: grc + + contains + +!----------------------------------------------- + subroutine Init(this, bounds, nch, cnpft, lats, lons) + + ! !DESCRIPTION: +! Initialize CTSM gridcell type needed for calling CTSM routines +! jk Apr 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made +! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect +! +! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + real, dimension(nch,num_zon,num_veg,var_pft), intent(in) :: cnpft ! pft-level (patch-level) restart variable array + real, dimension(nch), intent(in) :: lats ! Catchment tile latitudes in radians + real, dimension(nch), intent(in) :: lons ! Catchment tile longitudes in radians + class(gridcell_type) :: this + + !LOCAL + integer :: begg, endg + integer :: nc + !---------------------------- + + begg = bounds%begg; endg = bounds%endg + + + ! The following is set in InitGridCells + allocate(this%gindex (begg:endg)) ; this%gindex (:) = ispval + allocate(this%area (begg:endg)) ; this%area (:) = nan + allocate(this%lat (begg:endg)) ; this%lat (:) = nan + allocate(this%lon (begg:endg)) ; this%lon (:) = nan + allocate(this%latdeg (begg:endg)) ; this%latdeg (:) = nan + allocate(this%londeg (begg:endg)) ; this%londeg (:) = nan + allocate(this%active (begg:endg)) ; this%active (:) = .true. + allocate(this%nbedrock (begg:endg)) ; this%nbedrock (:) = ispval + + ! This is initiailized in module DayLength + allocate(this%max_dayl (begg:endg)) ; this%max_dayl (:) = nan + allocate(this%dayl (begg:endg)) ; this%dayl (:) = nan + allocate(this%prev_dayl (begg:endg)) ; this%prev_dayl (:) = nan + + allocate(this%landunit_indices(1:max_lunit, begg:endg)); this%landunit_indices(:,:) = ispval + + ! initialize variables from restart file or set to cold start value + + do nc = 1,nch ! catchment tile loop + + this%lat (nc) = lats(nc) + this%lon (nc) = lons(nc) + this%latdeg (nc) = lats(nc) / MAPL_PI * 180. + this%londeg (nc) = lons(nc) / MAPL_PI * 180. + this%londeg (nc) = this%londeg(nc)+180 ! convert from [-180 180] to [0 360] + this%dayl (nc) = cnpft (nc,1,1, 28) ! variable used to be patch level and is now gridcell level; assume all patches in gridcell have same day length + + this%prev_dayl(nc) = this%dayl(nc) ! following previous Catchment-CN versions, daylength of previous day is initialized as daylength of current day; changed for subsequent time steps in CN_DriverMod + + end do ! nc + end subroutine Init +end module GridcellType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_LandunitType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_LandunitType.F90 new file mode 100755 index 000000000..e020e7f1d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_LandunitType.F90 @@ -0,0 +1,129 @@ +module LandunitType + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Landunit data type allocation + ! -------------------------------------------------------- + ! landunits types can have values of (see landunit_varcon.F90) + ! -------------------------------------------------------- + ! 1 => (istsoil) soil (vegetated or bare soil landunit) + ! 2 => (istcrop) crop (only for crop configuration) + ! 3 => (UNUSED) (formerly non-multiple elevation class land ice; currently unused) + ! 4 => (istice_mec) land ice (multiple elevation classes) + ! 5 => (istdlak) deep lake + ! 6 => (istwet) wetland + ! 7 => (isturb_tbd) urban tbd + ! 8 => (isturb_hd) urban hd + ! 9 => (isturb_md) urban md + ! + use shr_kind_mod , only : r8 => shr_kind_r8 + use nanMod , only : nan + use clm_varcon , only : ispval + use decompMod , only : bounds_type + use clm_varpar , only : NUM_ZON, numpft + + ! !PUBLIC TYPES: + implicit none + save + private + + ! PUBLIC MEMBER FUNCTIONS: + + ! + type, public :: landunit_type + ! g/l/c/p hierarchy, local g/l/c/p cells only + integer , pointer :: gridcell (:) ! index into gridcell level quantities + real(r8), pointer :: wtgcell (:) ! weight (relative to gridcell) + integer , pointer :: coli (:) ! beginning column index per landunit + integer , pointer :: colf (:) ! ending column index for each landunit + integer , pointer :: ncolumns (:) ! number of columns for each landunit + integer , pointer :: patchi (:) ! beginning patch index for each landunit + integer , pointer :: patchf (:) ! ending patch index for each landunit + integer , pointer :: npatches (:) ! number of patches for each landunit + + ! topological mapping functionality + integer , pointer :: itype (:) ! landunit type + logical , pointer :: ifspecial (:) ! true=>landunit is not vegetated + logical , pointer :: lakpoi (:) ! true=>lake point + logical , pointer :: urbpoi (:) ! true=>urban point + logical , pointer :: glcmecpoi (:) ! true=>glacier_mec point + logical , pointer :: active (:) ! true=>do computations on this landunit + + ! urban properties + real(r8), pointer :: canyon_hwr (:) ! urban landunit canyon height to width ratio (-) + real(r8), pointer :: wtroad_perv (:) ! urban landunit weight of pervious road column to total road (-) + real(r8), pointer :: wtlunit_roof (:) ! weight of roof with respect to urban landunit (-) + real(r8), pointer :: ht_roof (:) ! height of urban roof (m) + real(r8), pointer :: z_0_town (:) ! urban landunit momentum roughness length (m) + real(r8), pointer :: z_d_town (:) ! urban landunit displacement height (m) + + contains + + procedure, public :: Init + + end type landunit_type + ! Singleton instance of the landunitType + type(landunit_type), public, target :: lun !geomorphological landunits + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, nch) + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Allocate memory and initialize to signalling NaN to require + ! data be properly initialized somewhere else. + ! + ! !ARGUMENTS: + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + class(landunit_type) :: this + + !LOCAL + integer :: begl,endl + integer :: nc + !------------------------------------------------------------------------ + + begl = bounds%begl ; endl = bounds%endl + + ! The following is set in InitGridCellsMod + allocate(this%gridcell (begl:endl)); this%gridcell (:) = ispval + allocate(this%wtgcell (begl:endl)); this%wtgcell (:) = nan + allocate(this%coli (begl:endl)); this%coli (:) = ispval + allocate(this%colf (begl:endl)); this%colf (:) = ispval + allocate(this%ncolumns (begl:endl)); this%ncolumns (:) = ispval + allocate(this%patchi (begl:endl)); this%patchi (:) = ispval + allocate(this%patchf (begl:endl)); this%patchf (:) = ispval + allocate(this%npatches (begl:endl)); this%npatches (:) = ispval + allocate(this%itype (begl:endl)); this%itype (:) = ispval + allocate(this%ifspecial (begl:endl)); this%ifspecial (:) = .false. + allocate(this%lakpoi (begl:endl)); this%lakpoi (:) = .false. + allocate(this%urbpoi (begl:endl)); this%urbpoi (:) = .false. + allocate(this%glcmecpoi (begl:endl)); this%glcmecpoi (:) = .false. + + ! The following is initialized in routine setActive in module reweightMod + allocate(this%active (begl:endl)) + + ! The following is set in routine urbanparams_inst%Init in module UrbanParamsType + allocate(this%canyon_hwr (begl:endl)); this%canyon_hwr (:) = nan + allocate(this%wtroad_perv (begl:endl)); this%wtroad_perv (:) = nan + allocate(this%ht_roof (begl:endl)); this%ht_roof (:) = nan + allocate(this%wtlunit_roof (begl:endl)); this%wtlunit_roof (:) = nan + allocate(this%z_0_town (begl:endl)); this%z_0_town (:) = nan + allocate(this%z_d_town (begl:endl)); this%z_d_town (:) = nan + + do nc = 1,nch ! catchment tile loop + + this%gridcell(nc) = nc + this%patchi(nc) = (numpft+1)*num_zon*(nc-1) + 1 + this%patchf(nc) = (numpft+1)*num_zon*nc + this%coli(nc) = (num_zon)*(nc-1) + 1 + this%colf(nc) = num_zon*nc + this%itype(nc) = 1 ! set land unit type so bare or vegetated soil everywhere + end do + + end subroutine Init + +end module LandunitType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_OzoneBaseMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_OzoneBaseMod.F90 new file mode 100755 index 000000000..b7f8a775f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_OzoneBaseMod.F90 @@ -0,0 +1,64 @@ +module OzoneBaseMod + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use decompMod , only : bounds_type + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: ozone_base_type + + ! Public data members + ! These should be treated as read-only by other modules (except that they can be + ! modified by extensions of the ozone_base_type) + real(r8), pointer, public :: o3coefvsha_patch(:) ! ozone coefficient for photosynthesis, shaded leaves (0 - 1) + real(r8), pointer, public :: o3coefvsun_patch(:) ! ozone coefficient for photosynthesis, sunlit leaves (0 - 1) + real(r8), pointer, public :: o3coefgsha_patch(:) ! ozone coefficient for conductance, shaded leaves (0 - 1) + real(r8), pointer, public :: o3coefgsun_patch(:) ! ozone coefficient for conductance, sunlit leaves (0 - 1) + + contains + + procedure, public :: Init + + end type ozone_base_type + type(ozone_base_type), public, target, save :: ozone_inst + +contains + +!------------------------------------------------ + subroutine Init(this, bounds) + + ! !DESCRIPTION: + ! Initialize CTSM ozone base type needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(ozone_base_type) :: this + + ! LOCAL + integer :: begp, endp + !----------------------- + + begp = bounds%begp ; endp = bounds%endp + + allocate(this%o3coefvsha_patch(begp:endp)) ; this%o3coefvsha_patch(:) = nan + allocate(this%o3coefvsun_patch(begp:endp)) ; this%o3coefvsun_patch(:) = nan + allocate(this%o3coefgsha_patch(begp:endp)) ; this%o3coefgsha_patch(:) = nan + allocate(this%o3coefgsun_patch(begp:endp)) ; this%o3coefgsun_patch(:) = nan + + this%o3coefvsha_patch = 1. + this%o3coefvsun_patch = 1. + this%o3coefgsha_patch = 1. + this%o3coefgsun_patch = 1. + + end subroutine Init + +end module OzoneBaseMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_PatchType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_PatchType.F90 new file mode 100755 index 000000000..3d509ca30 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_PatchType.F90 @@ -0,0 +1,152 @@ +module PatchType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use decompMod , only : bounds_type + use clm_varcon , only : ispval + use clm_varctl , only : use_fates + use clm_varpar , only : numpft, NUM_ZON, NUM_VEG, CN_zone_weight + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Patch data type allocation + ! -------------------------------------------------------- + ! patch types can have values of + ! -------------------------------------------------------- + ! 0 => not_vegetated + ! 1 => needleleaf_evergreen_temperate_tree + ! 2 => needleleaf_evergreen_boreal_tree + ! 3 => needleleaf_deciduous_boreal_tree + ! 4 => broadleaf_evergreen_tropical_tree + ! 5 => broadleaf_evergreen_temperate_tree + ! 6 => broadleaf_deciduous_tropical_tree + ! 7 => broadleaf_deciduous_temperate_tree + ! 8 => broadleaf_deciduous_boreal_tree + ! 9 => broadleaf_evergreen_shrub + ! 10 => broadleaf_deciduous_temperate_shrub + ! 11 => broadleaf_deciduous_boreal_shrub + ! 12 => c3_arctic_grass + ! 13 => c3_non-arctic_grass + ! 14 => c4_grass + ! 15 => c3_crop + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: patch_type + + ! g/l/c/p hierarchy, local g/l/c/p cells only + integer , pointer :: column (:) ! index into column level quantities + real(r8), pointer :: wtcol (:) ! weight (relative to column) + integer , pointer :: landunit (:) ! index into landunit level quantities + real(r8), pointer :: wtlunit (:) ! weight (relative to landunit) + integer , pointer :: gridcell (:) ! index into gridcell level quantities + real(r8), pointer :: wtgcell (:) ! weight (relative to gridcell) + + ! Non-ED only + integer , pointer :: itype (:) ! patch vegetation + integer , pointer :: mxy (:) ! m index for laixy(i,j,m),etc. (undefined for special landunits) + logical , pointer :: active (:) ! true=>do computations on this patch + + ! fates only + logical , pointer :: is_veg (:) ! This is an ACTIVE fates patch + logical , pointer :: is_bareground (:) + real(r8), pointer :: wt_ed (:) !TODO mv ? can this be removed + + + logical, pointer :: is_fates (:) ! true for patch vector space reserved + ! for FATES. + ! this is static and is true for all + ! patches within fates jurisdiction + ! including patches which are not currently + ! associated with a FATES linked-list patch + + contains + + procedure, public :: Init + + end type patch_type + type(patch_type), public, target :: patch + + contains + +!---------------------------------------------------- + subroutine Init(this, bounds, nch, ityp, fveg) + + ! !ARGUMENTS: + implicit none + + ! INPUT: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + class(patch_type) :: this + + ! LOCAL: + integer :: begp,endp + integer :: np, nc, nz, p, nv, n + !------------------------------- + + begp = bounds%begp + endp = bounds%endp + + allocate(this%gridcell (begp:endp)); this%gridcell (:) = ispval + allocate(this%wtgcell (begp:endp)); this%wtgcell (:) = nan + + allocate(this%landunit (begp:endp)); this%landunit (:) = ispval + allocate(this%wtlunit (begp:endp)); this%wtlunit (:) = nan + + allocate(this%column (begp:endp)); this%column (:) = ispval + allocate(this%wtcol (begp:endp)); this%wtcol (:) = nan + + allocate(this%mxy (begp:endp)); this%mxy (:) = ispval + allocate(this%active (begp:endp)); this%active (:) = .false. + + ! TODO (MV, 10-17-14): The following must be commented out because + ! currently the logic checking if patch%itype(p) is not equal to noveg + ! is used in RootBiogeophysMod in zeng2001_rootfr- a filter is not used + ! in that routine - which would elimate this problem + + allocate(this%itype (begp:endp)); this%itype (:) = ispval + + allocate(this%is_fates (begp:endp)); this%is_fates (:) = .false. + + if (use_fates) then + allocate(this%is_veg (begp:endp)); this%is_veg (:) = .false. + allocate(this%is_bareground (begp:endp)); this%is_bareground (:) = .false. + allocate(this%wt_ed (begp:endp)); this%wt_ed (:) = nan + end if + + ! initialize values from restart files + + np = 0 + n = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + do p = 0,numpft ! PFT index loop + np = np + 1 + this%itype(np) = p + this%wtcol(np) = 0. + this%column(np) = n + this%gridcell(np) = nc + this%wtgcell(np) = 0. + this%landunit(np) = nc + this%wtlunit(np) = 0. + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + this%active(np) = .true. + this%wtcol(np) = this%wtcol(np) + fveg(nc,nv,nz) + this%wtgcell(np) = this%wtgcell(np) + (fveg(nc,nv,nz)*CN_zone_weight(nz)) + this%wtlunit(np) = this%wtlunit(np) + (fveg(nc,nv,nz)*CN_zone_weight(nz)) + end if + end do ! nv + end do ! p + end do ! nz + end do ! nc + end subroutine Init +end module PatchType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SaturatedExcessRunoffMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SaturatedExcessRunoffMod.F90 new file mode 100755 index 000000000..745d0d212 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SaturatedExcessRunoffMod.F90 @@ -0,0 +1,69 @@ +module SaturatedExcessRunoffMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Type and associated routines for calculating surface runoff due to saturated surface + ! + ! This also includes calculations of fsat (fraction of each column that is saturated) + ! + ! !USES: +#include "shr_assert.h" + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun + use clm_varcon , only : spval + use nanMod , only : nan + + implicit none + save + private + + ! !PUBLIC TYPES: + + type, public :: saturated_excess_runoff_type + private + ! Public data members + ! Note: these should be treated as read-only by other modules + real(r8), pointer, public :: fsat_col(:) ! fractional area with water table at surface + + ! Private data members + integer :: fsat_method + real(r8), pointer :: fcov_col(:) ! fractional impermeable area + + contains + + procedure, public :: Init + + end type saturated_excess_runoff_type + + type, private :: params_type + real(r8) :: fff ! Decay factor for fractional saturated area (1/m) + end type params_type + type(params_type), private :: params_inst + +contains + +!-------------------------------------------------------------- + subroutine Init(this, bounds) + + ! !USES: + ! + ! !ARGUMENTS: + implicit none + ! INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(saturated_excess_runoff_type) :: this + + ! LOCAL + integer :: begc, endc + !------------------------------- + + begc = bounds%begc; endc= bounds%endc + + allocate(this%fsat_col(begc:endc)) ; this%fsat_col(:) = nan + allocate(this%fcov_col(begc:endc)) ; this%fcov_col(:) = nan + + end subroutine Init + +end module SaturatedExcessRunoffMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCarbonFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCarbonFluxType.F90 new file mode 100755 index 000000000..e03bf4ea0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCarbonFluxType.F90 @@ -0,0 +1,398 @@ +module SoilBiogeochemCarbonFluxType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevcan, ndecomp_cascade_outtransitions + use clm_varpar , only : nlevdecomp_full, nlevgrnd, nlevdecomp, nlevsoi, ndecomp_pools_vr + use clm_varctl , only : use_fates, use_soil_matrixcn, use_vertsoilc + use clm_varcon , only : spval, ispval, dzsoi_decomp + use decompMod , only : bounds_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: soilbiogeochem_carbonflux_type + + ! fire fluxes + real(r8), pointer :: somc_fire_col (:) ! (gC/m2/s) carbon emissions due to peat burning + + ! decomposition fluxes + real(r8), pointer :: decomp_cpools_sourcesink_col (:,:,:) ! change in decomposing c pools. Used to update concentrations concurrently with vertical transport (gC/m3/timestep) + real(r8), pointer :: decomp_cascade_hr_vr_col (:,:,:) ! vertically-resolved het. resp. from decomposing C pools (gC/m3/s) + real(r8), pointer :: decomp_cascade_hr_col (:,:) ! vertically-integrated (diagnostic) het. resp. from decomposing C pools (gC/m2/s) + real(r8), pointer :: decomp_cascade_ctransfer_vr_col (:,:,:) ! vertically-resolved C transferred along deomposition cascade (gC/m3/s) + real(r8), pointer :: decomp_cascade_ctransfer_col (:,:) ! vertically-integrated (diagnostic) C transferred along decomposition cascade (gC/m2/s) + real(r8), pointer :: decomp_k_col (:,:,:) ! rate constant for decomposition (1./sec) +! for soil-matrix + real(r8), pointer :: hr_vr_col (:,:) ! (gC/m3/s) total vertically-resolved het. resp. from decomposing C pools + real(r8), pointer :: o_scalar_col (:,:) ! fraction by which decomposition is limited by anoxia + real(r8), pointer :: w_scalar_col (:,:) ! fraction by which decomposition is limited by moisture availability + real(r8), pointer :: t_scalar_col (:,:) ! fraction by which decomposition is limited by temperature + real(r8), pointer :: som_c_leached_col (:) ! (gC/m^2/s) total SOM C loss from vertical transport + real(r8), pointer :: decomp_cpools_leached_col (:,:) ! (gC/m^2/s) C loss from vertical transport from each decomposing C pool + real(r8), pointer :: decomp_cpools_transport_tendency_col (:,:,:) ! (gC/m^3/s) C tendency due to vertical transport in decomposing C pools + + ! nitrif_denitrif + real(r8), pointer :: phr_vr_col (:,:) ! (gC/m3/s) potential hr (not N-limited) + real(r8), pointer :: fphr_col (:,:) ! fraction of potential heterotrophic respiration + + real(r8), pointer :: hr_col (:) ! (gC/m2/s) total heterotrophic respiration + real(r8), pointer :: lithr_col (:) ! (gC/m2/s) litter heterotrophic respiration + real(r8), pointer :: somhr_col (:) ! (gC/m2/s) soil organic matter heterotrophic res + real(r8), pointer :: cwdhr_col (:) ! (gC/m2/s) coarse woody debris heterotrophic res + real(r8), pointer :: soilc_change_col (:) ! (gC/m2/s) FUN used soil C + + + ! fluxes to receive carbon inputs from FATES + real(r8), pointer :: FATES_c_to_litr_lab_c_col (:,:) ! total labile litter coming from ED. gC/m3/s + real(r8), pointer :: FATES_c_to_litr_cel_c_col (:,:) ! total cellulose litter coming from ED. gC/m3/s + real(r8), pointer :: FATES_c_to_litr_lig_c_col (:,:) ! total lignin litter coming from ED. gC/m3/s + + ! track tradiagonal matrix + real(r8), pointer :: matrix_decomp_fire_k_col (:,:) ! decomposition rate due to fire (gC*m3)/(gC*m3*step)) + real(r8), pointer :: tri_ma_vr (:,:) ! vertical C transfer rate in sparse matrix format (gC*m3)/(gC*m3*step)) + + +! type(sparse_matrix_type) :: AKsoilc ! A*K for C transfers between pools +! type(sparse_matrix_type) :: AVsoil ! V for C and N transfers between soil layers +! type(sparse_matrix_type) :: AKfiresoil ! Kfire for CN transfers from soil to atm due to fire +! type(sparse_matrix_type) :: AKallsoilc ! (A*K+V-Kfire) for soil C cycle +! integer :: NE_AKallsoilc ! Number of entries in AKallsoilc, Automatically generated by functions SPMP_* +! integer,pointer,dimension(:) :: RI_AKallsoilc ! Row numbers of entries in AKallsoilc, Automatically generated by functions SPMP_* +! integer,pointer,dimension(:) :: CI_AKallsoilc ! Column numbers of entries in AKallsoilc, Automatically generated by functions SPMP_* +! integer,pointer,dimension(:) :: RI_a ! Row numbers of all entries from AKsoilc, Automatically generated by SetValueA +! integer,pointer,dimension(:) :: CI_a ! Column numbers of all entries from AKsoilc, Automatically generated by SetValueA +! +! type(diag_matrix_type) :: Ksoil ! CN turnover rate in different soil pools and layers +! type(diag_matrix_type) :: Xdiagsoil ! Temporary C and N state variable to calculate accumulation transfers +! +! type(vector_type) :: matrix_Cinput ! C input to different soil compartments (pools and layers) (gC/m3/step) + + contains + + procedure , public :: SetValues + procedure , public :: Summary + procedure , public :: Init + + end type soilbiogeochem_carbonflux_type + type(soilbiogeochem_carbonflux_type), public, target, save :: soilbiogeochem_carbonflux_inst + +contains + +!-------------------------------------------------------------- + subroutine Init(this, bounds) + + type(bounds_type), intent(in) :: bounds + class(soilbiogeochem_carbonflux_type) :: this + ! + ! !LOCAL VARIABLES: + integer :: begp,endp + integer :: begc,endc,Ntrans,Ntrans_diag + + !------------------------------------------------------------------------ + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + allocate(this%t_scalar_col (begc:endc,1:nlevdecomp_full)); this%t_scalar_col (:,:) =spval + allocate(this%w_scalar_col (begc:endc,1:nlevdecomp_full)); this%w_scalar_col (:,:) =spval + allocate(this%o_scalar_col (begc:endc,1:nlevdecomp_full)); this%o_scalar_col (:,:) =spval + allocate(this%phr_vr_col (begc:endc,1:nlevdecomp_full)); this%phr_vr_col (:,:) =nan + allocate(this%fphr_col (begc:endc,1:nlevgrnd)) ; this%fphr_col (:,:) =nan + allocate(this%som_c_leached_col (begc:endc)) ; this%som_c_leached_col (:) =spval + allocate(this%somc_fire_col (begc:endc)) ; this%somc_fire_col (:) =nan + allocate(this%hr_vr_col (begc:endc,1:nlevdecomp_full)); this%hr_vr_col (:,:) =nan + + allocate(this%decomp_cpools_sourcesink_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%decomp_cpools_sourcesink_col(:,:,:)= nan + + allocate(this%decomp_cascade_hr_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) + this%decomp_cascade_hr_vr_col(:,:,:)= spval + + allocate(this%decomp_cascade_hr_col(begc:endc,1:ndecomp_cascade_transitions)) + this%decomp_cascade_hr_col(:,:)= nan + + allocate(this%decomp_cascade_ctransfer_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) + this%decomp_cascade_ctransfer_vr_col(:,:,:)= nan + + allocate(this%decomp_cascade_ctransfer_col(begc:endc,1:ndecomp_cascade_transitions)) + this%decomp_cascade_ctransfer_col(:,:)= nan + + allocate(this%decomp_k_col(begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) + this%decomp_k_col(:,:,:)= spval + + allocate(this%decomp_cpools_leached_col(begc:endc,1:ndecomp_pools)) + this%decomp_cpools_leached_col(:,:)= nan + + allocate(this%decomp_cpools_transport_tendency_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%decomp_cpools_transport_tendency_col(:,:,:)= nan + + allocate(this%hr_col (begc:endc)) ; this%hr_col (:) = nan + allocate(this%lithr_col (begc:endc)) ; this%lithr_col (:) = nan + allocate(this%somhr_col (begc:endc)) ; this%somhr_col (:) = nan + allocate(this%cwdhr_col (begc:endc)) ; this%cwdhr_col (:) = nan + allocate(this%soilc_change_col (begc:endc)) ; this%soilc_change_col (:) = nan + +! if(use_soil_matrixcn)then +! allocate(this%matrix_decomp_fire_k_col(begc:endc,1:nlevdecomp*ndecomp_pools)); this%matrix_decomp_fire_k_col(:,:)= nan +! Ntrans = (ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp +! call this%AKsoilc%InitSM (ndecomp_pools*nlevdecomp,begc,endc,Ntrans+ndecomp_pools*nlevdecomp) +! call this%AVsoil%InitSM (ndecomp_pools*nlevdecomp,begc,endc,decomp_cascade_con%Ntri_setup) +! call this%AKfiresoil%InitSM (ndecomp_pools*nlevdecomp,begc,endc,ndecomp_pools*nlevdecomp) +! call this%AKallsoilc%InitSM (ndecomp_pools*nlevdecomp,begc,endc,Ntrans+decomp_cascade_con%Ntri_setup+nlevdecomp) +! this%NE_AKallsoilc = Ntrans+ndecomp_pools*nlevdecomp+decomp_cascade_con%Ntri_setup+ndecomp_pools*nlevdecomp +! allocate(this%RI_AKallsoilc(1:this%NE_AKallsoilc)); this%RI_AKallsoilc(1:this%NE_AKallsoilc)=-9999 +! allocate(this%CI_AKallsoilc(1:this%NE_AKallsoilc)); this%CI_AKallsoilc(1:this%NE_AKallsoilc)=-9999 +! Ntrans_diag = (ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp+ndecomp_pools_vr +! allocate(this%RI_a(1:Ntrans_diag)); this%RI_a(1:Ntrans_diag) = -9999 +! allocate(this%CI_a(1:Ntrans_diag)); this%CI_a(1:Ntrans_diag) = -9999 +! call this%Ksoil%InitDM (ndecomp_pools*nlevdecomp,begc,endc) +! call this%Xdiagsoil%InitDM (ndecomp_pools*nlevdecomp,begc,endc) +! call this%matrix_Cinput%InitV(ndecomp_pools*nlevdecomp,begc,endc) +! end if + if(use_soil_matrixcn .and. use_vertsoilc)then + allocate(this%tri_ma_vr(begc:endc,1:decomp_cascade_con%Ntri_setup)) + else + allocate(this%tri_ma_vr(1,1)); this%tri_ma_vr(:,:) = nan + end if + if ( use_fates ) then + ! initialize these variables to be zero rather than a bad number since they are not zeroed every timestep (due to a need for them to persist) + + allocate(this%FATES_c_to_litr_lab_c_col(begc:endc,1:nlevdecomp_full)) + this%FATES_c_to_litr_lab_c_col(begc:endc,1:nlevdecomp_full) = 0._r8 + + allocate(this%FATES_c_to_litr_cel_c_col(begc:endc,1:nlevdecomp_full)) + this%FATES_c_to_litr_cel_c_col(begc:endc,1:nlevdecomp_full) = 0._r8 + + allocate(this%FATES_c_to_litr_lig_c_col(begc:endc,1:nlevdecomp_full)) + this%FATES_c_to_litr_lig_c_col(begc:endc,1:nlevdecomp_full) = 0._r8 + + endif + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine SetValues ( this, num_column, filter_column, value_column) + ! + ! !DESCRIPTION: + ! Set carbon fluxes + ! + ! !ARGUMENTS: + class (soilbiogeochem_carbonflux_type) :: this + integer , intent(in) :: num_column + integer , intent(in) :: filter_column(:) + real(r8), intent(in) :: value_column + ! + ! !LOCAL VARIABLES: + integer :: fi,i ! loop index + integer :: j,k,l ! indices + !------------------------------------------------------------------------ + + do l = 1, ndecomp_cascade_transitions + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%decomp_cascade_hr_col(i,l) = value_column + this%decomp_cascade_hr_vr_col(i,j,l) = value_column + this%decomp_cascade_ctransfer_col(i,l) = value_column + this%decomp_cascade_ctransfer_vr_col(i,j,l) = value_column + this%decomp_k_col(i,j,l) = value_column + end do + end do + end do + + + do k = 1, ndecomp_pools + do fi = 1,num_column + i = filter_column(fi) + this%decomp_cpools_leached_col(i,k) = value_column + end do + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%decomp_cpools_transport_tendency_col(i,j,k) = value_column + this%decomp_cpools_sourcesink_col(i,j,k) = value_column + end do + end do + end do + +! for matrix + if(use_soil_matrixcn)then + do k = 1, ndecomp_pools + do j = 1, nlevdecomp + do fi = 1,num_column + i = filter_column(fi) + this%matrix_decomp_fire_k_col(i,j+nlevdecomp*(k-1)) = value_column + end do + end do + end do + ! call this%matrix_Cinput%SetValueV_scaler(num_column,filter_column(1:num_column),value_column) + ! IMPORTANT NOTE: Although it looks like the following if appears to be + ! backwards (it should be 'if use_versoilc'), fixing it causes Carbon + ! balance checks to fail. EBK 10/21/2019 + ! Both use_vertsoilc and .not. use_vertsoilc should reset tri_ma_vr to 0. + ! Because single soil layer still add V matrix but as a zero matrix. CL 10/23/2019 + if(use_vertsoilc)then + do k = 1,decomp_cascade_con%Ntri_setup + do fi = 1,num_column + i = filter_column(fi) + this%tri_ma_vr(i,k) = value_column + end do + end do + end if + end if + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%hr_vr_col(i,j) = value_column + end do + end do + + do fi = 1,num_column + i = filter_column(fi) + this%hr_col(i) = value_column + this%somc_fire_col(i) = value_column + this%som_c_leached_col(i) = value_column + this%somhr_col(i) = value_column + this%cwdhr_col(i) = value_column + this%lithr_col(i) = value_column + this%soilc_change_col(i) = value_column + end do + + ! NOTE: do not zero the fates to BGC C flux variables since they need to persist from the daily fates timestep s to the half-hourly BGC timesteps. I.e. FATES_c_to_litr_lab_c_col, FATES_c_to_litr_cel_c_col, FATES_c_to_litr_lig_c_col + + end subroutine SetValues + + !----------------------------------------------------------------------- + subroutine Summary(this, bounds, num_soilc, filter_soilc) + ! + ! !DESCRIPTION: + ! On the radiation time step, column-level carbon summary calculations + ! + ! !USES: + ! !ARGUMENTS: + class(soilbiogeochem_carbonflux_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + ! + ! !LOCAL VARIABLES: + integer :: c,j,k,l + integer :: fc + !----------------------------------------------------------------------- + + do fc = 1,num_soilc + c = filter_soilc(fc) + this%som_c_leached_col(c) = 0._r8 + end do + + ! vertically integrate HR and decomposition cascade fluxes + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%decomp_cascade_hr_col(c,k) = & + this%decomp_cascade_hr_col(c,k) + & + this%decomp_cascade_hr_vr_col(c,j,k) * dzsoi_decomp(j) + + this%decomp_cascade_ctransfer_col(c,k) = & + this%decomp_cascade_ctransfer_col(c,k) + & + this%decomp_cascade_ctransfer_vr_col(c,j,k) * dzsoi_decomp(j) + end do + end do + end do + + ! total heterotrophic respiration, vertically resolved (HR) + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%hr_vr_col(c,j) = 0._r8 + end do + end do + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%hr_vr_col(c,j) = & + this%hr_vr_col(c,j) + & + this%decomp_cascade_hr_vr_col(c,j,k) + end do + end do + end do + + ! add up all vertical transport tendency terms and calculate total som leaching loss as the sum of these + do l = 1, ndecomp_pools + do fc = 1,num_soilc + c = filter_soilc(fc) + this%decomp_cpools_leached_col(c,l) = 0._r8 + end do + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%decomp_cpools_leached_col(c,l) = this%decomp_cpools_leached_col(c,l) + & + this%decomp_cpools_transport_tendency_col(c,j,l) * dzsoi_decomp(j) + end do + end do + do fc = 1,num_soilc + c = filter_soilc(fc) + this%som_c_leached_col(c) = this%som_c_leached_col(c) + this%decomp_cpools_leached_col(c,l) + end do + end do + + + ! soil organic matter heterotrophic respiration + associate(is_soil => decomp_cascade_con%is_soil) ! TRUE => pool is a soil pool + do k = 1, ndecomp_cascade_transitions + if ( is_soil(decomp_cascade_con%cascade_donor_pool(k)) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + this%somhr_col(c) = this%somhr_col(c) + this%decomp_cascade_hr_col(c,k) + end do + end if + end do + end associate + + ! litter heterotrophic respiration (LITHR) + associate(is_litter => decomp_cascade_con%is_litter) ! TRUE => pool is a litter pool + do k = 1, ndecomp_cascade_transitions + if ( is_litter(decomp_cascade_con%cascade_donor_pool(k)) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + this%lithr_col(c) = this%lithr_col(c) + this%decomp_cascade_hr_col(c,k) + end do + end if + end do + end associate + + ! coarse woody debris heterotrophic respiration (CWDHR) + associate(is_cwd => decomp_cascade_con%is_cwd) ! TRUE => pool is a cwd pool + do k = 1, ndecomp_cascade_transitions + if ( is_cwd(decomp_cascade_con%cascade_donor_pool(k)) ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + this%cwdhr_col(c) = this%cwdhr_col(c) + this%decomp_cascade_hr_col(c,k) + end do + end if + end do + end associate + + ! total heterotrophic respiration (HR) + do fc = 1,num_soilc + c = filter_soilc(fc) + + this%hr_col(c) = & + this%lithr_col(c) + & + this%cwdhr_col(c) + & + this%somhr_col(c) + + end do + + end subroutine Summary + +end module SoilBiogeochemCarbonFluxType + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCarbonStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCarbonStateType.F90 new file mode 100755 index 000000000..17a6add25 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCarbonStateType.F90 @@ -0,0 +1,385 @@ +module SoilBiogeochemCarbonStateType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use nanMod , only : nan + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevcan + use clm_varpar , only : nlevdecomp_full, nlevdecomp, nlevsoi, & + NUM_ZON, VAR_COL + use clm_varcon , only : spval, ispval, dzsoi_decomp, zisoi, zsoi, c3_r2 + use clm_varctl , only : iulog, use_vertsoilc, use_fates, use_soil_matrixcn, use_century_decomp + use decompMod , only : bounds_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: soilbiogeochem_carbonstate_type + + ! all c pools involved in decomposition + real(r8), pointer :: decomp_cpools_vr_col (:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools + real(r8), pointer :: decomp0_cpools_vr_col(:,:,:) ! (gC/m3) vertically-resolved C baseline (initial value of this year) in decomposing (litter, cwd, soil) pools in dimension (col,nlev,npools) + real(r8), pointer :: decomp_cpools_vr_SASUsave_col(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools + real(r8), pointer :: decomp_soilc_vr_col (:,:) ! (gC/m3) vertically-resolved decomposing total soil c pool + real(r8), pointer :: ctrunc_vr_col (:,:) ! (gC/m3) vertically-resolved column-level sink for C truncation + + ! summary (diagnostic) state variables, not involved in mass balance + real(r8), pointer :: ctrunc_col (:) ! (gC/m2) column-level sink for C truncation + real(r8), pointer :: totlitc_col (:) ! (gC/m2) total litter carbon + real(r8), pointer :: totlitc_1m_col (:) ! (gC/m2) total litter carbon to 1 meter + real(r8), pointer :: totsomc_col (:) ! (gC/m2) total soil organic matter carbon + real(r8), pointer :: totsomc_1m_col (:) ! (gC/m2) total soil organic matter carbon to 1 meter + real(r8), pointer :: cwdc_col (:) ! (gC/m2) coarse woody debris C (diagnostic) + real(r8), pointer :: decomp_cpools_1m_col (:,:) ! (gC/m2) Diagnostic: decomposing (litter, cwd, soil) c pools to 1 meter + real(r8), pointer :: decomp_cpools_col (:,:) ! (gC/m2) decomposing (litter, cwd, soil) c pools + real(r8), pointer :: dyn_cbal_adjustments_col(:) ! (gC/m2) adjustments to each column made in this timestep via dynamic column area adjustments (note: this variable only makes sense at the column-level: it is meaningless if averaged to the gridcell-level) + integer :: restart_file_spinup_state ! spinup state as read from restart file, for determining whether to enter or exit spinup mode. + real(r8) :: totvegcthresh ! threshold for total vegetation carbon to zero out decomposition pools + + ! Matrix-cn + real(r8), pointer :: matrix_cap_decomp_cpools_col (:,:) ! (gC/m2) C capacity in decomposing (litter, cwd, soil) N pools in dimension (col,npools) + real(r8), pointer :: matrix_cap_decomp_cpools_vr_col (:,:,:) ! (gC/m3) vertically-resolved C capacity in decomposing (litter, cwd, soil) pools in dimension(col,nlev,npools) + real(r8), pointer :: in_acc (:,:) ! (gC/m3/yr) accumulated litter fall C input per year in dimension(col,nlev*npools) + real(r8), pointer :: in_acc_2d (:,:,:) ! (gC/m3/yr) accumulated litter fall C input per year in dimension(col,nlev,npools) + real(r8), pointer :: tran_acc (:,:,:) ! (gC/m3/yr) accumulated C transfers from j to i (col,i,j) per year in dimension(col,nlev*npools,nlev*npools) + real(r8), pointer :: vert_up_tran_acc (:,:,:) ! (gC/m3/yr) accumulated upward vertical C transport in dimension(col,nlev,npools) + real(r8), pointer :: vert_down_tran_acc (:,:,:) ! (gC/m3/yr) accumulated downward vertical C transport in dimension(col,nlev,npools) + real(r8), pointer :: exit_acc (:,:,:) ! (gC/m3/yr) accumulated exit C in dimension(col,nlev,npools) + real(r8), pointer :: hori_tran_acc (:,:,:) ! (gC/m3/yr) accumulated C transport between pools at the same level in dimension(col,nlev,ntransfers) + ! type(sparse_matrix_type) :: AKXcacc ! (gC/m3/yr) accumulated N transfers from j to i (col,i,j) per year in dimension(col,nlev*npools,nlev*npools) in sparse matrix type + ! type(vector_type) :: matrix_Cinter ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools in dimension(col,nlev*npools) in vector type + + contains + + procedure , public :: Summary + procedure , public :: SetTotVgCThresh + procedure , public :: Init + + + end type soilbiogeochem_carbonstate_type + type(soilbiogeochem_carbonstate_type), public, target, save :: soilbiogeochem_carbonstate_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + +contains + +!------------------------------------------- + subroutine Init(this, bounds, nch, cncol) + + ! + ! !ARGUMENTS: + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of tiles + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + class(soilbiogeochem_carbonstate_type) :: this + ! + ! !LOCAL VARIABLES: + integer :: begc,endc + integer :: n, nc, nz, np + integer, dimension(8) :: decomp_cpool_cncol_index = (/ 3, 4, 5, 2, 10, 11, 12, 13 /) + !----------------------------------- + + begc = bounds%begc ; endc = bounds%endc + + allocate( this%decomp_cpools_col (begc :endc,1:ndecomp_pools)) ; this%decomp_cpools_col (:,:) = nan + allocate( this%decomp_cpools_1m_col (begc :endc,1:ndecomp_pools)) ; this%decomp_cpools_1m_col (:,:) = nan + if(use_soil_matrixcn)then + allocate( this%matrix_cap_decomp_cpools_col (begc :endc,1:ndecomp_pools)) ; this%matrix_cap_decomp_cpools_col (:,:) = nan + end if + + allocate( this%ctrunc_vr_col(begc :endc,1:nlevdecomp_full)) ; + this%ctrunc_vr_col (:,:) = nan + + allocate(this%decomp_cpools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%decomp_cpools_vr_col(:,:,:)= nan + !matrix-spinup + if(use_soil_matrixcn)then + allocate(this%matrix_cap_decomp_cpools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%matrix_cap_decomp_cpools_vr_col(:,:,:)= nan + allocate(this%decomp0_cpools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%decomp0_cpools_vr_col(:,:,:)= nan + allocate(this%decomp_cpools_vr_SASUsave_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%decomp_cpools_vr_SASUsave_col(:,:,:)= nan + allocate(this%in_acc(begc:endc,1:nlevdecomp*ndecomp_pools)) + this%in_acc(:,:)= nan + allocate(this%tran_acc(begc:endc,1:nlevdecomp*ndecomp_pools,1:nlevdecomp*ndecomp_pools)) + this%tran_acc(:,:,:)= nan + + allocate(this%in_acc_2d(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%in_acc_2d(:,:,:)= nan + allocate(this%vert_up_tran_acc(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%vert_up_tran_acc(:,:,:)= nan + allocate(this%vert_down_tran_acc(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%vert_down_tran_acc(:,:,:)= nan + allocate(this%exit_acc(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%exit_acc(:,:,:)= nan + allocate(this%hori_tran_acc(begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) + this%hori_tran_acc(:,:,:)= nan + ! jkolassa May 2022: comment out the two functions below as currently use_soil_matrixcn = .false. + !call this%AKXcacc%InitSM(ndecomp_pools*nlevdecomp,begc,endc,decomp_cascade_con%n_all_entries) + !call this%matrix_Cinter%InitV (ndecomp_pools*nlevdecomp,begc,endc) + end if + allocate(this%decomp_soilc_vr_col(begc:endc,1:nlevdecomp_full)) + this%decomp_soilc_vr_col(:,:)= nan + + allocate(this%ctrunc_col (begc :endc)) ; this%ctrunc_col (:) = nan + if ( .not. use_fates ) then + allocate(this%cwdc_col (begc :endc)) ; this%cwdc_col (:) = nan + endif + allocate(this%totlitc_col (begc :endc)) ; this%totlitc_col (:) = nan + allocate(this%totsomc_col (begc :endc)) ; this%totsomc_col (:) = nan + allocate(this%totlitc_1m_col (begc :endc)) ; this%totlitc_1m_col (:) = nan + allocate(this%totsomc_1m_col (begc :endc)) ; this%totsomc_1m_col (:) = nan + allocate(this%dyn_cbal_adjustments_col (begc:endc)) ; this%dyn_cbal_adjustments_col (:) = nan + + this%restart_file_spinup_state = huge(1) + + ! initialize variables from restart file or set to cold start value + n = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + this%ctrunc_vr_col (n,1:nlevdecomp_full) = cncol(nc,nz,1) + this%totlitc_col (n) = cncol(nc,nz,15) + + do np = 1,ndecomp_pools + ! jkolassa May 2022: accounting for fact that pool order in CNCOL is different from CTSM + this%decomp_cpools_col (n,np) = cncol(nc,nz,decomp_cpool_cncol_index(np)) + this%decomp_cpools_1m_col (n,np) = cncol(nc,nz,decomp_cpool_cncol_index(np)) + ! jkolassa May 2022: loop has to be added below if we add more biogeochemical (or soil) layers + this%decomp_cpools_vr_col (n,1,np) = cncol(nc,nz,decomp_cpool_cncol_index(np)) + end do !np + + ! sum soil carbon pools + if (use_century_decomp) then + this%totsomc_col (n) = this%decomp_cpools_col(n,5) + this%decomp_cpools_col(n,6) & + + this%decomp_cpools_col(n,7) + else + this%totsomc_col (n) = this%decomp_cpools_col(n,5) + this%decomp_cpools_col(n,6) & + + this%decomp_cpools_col(n,7) + this%decomp_cpools_col(n,8) + end if + end do !nz + end do ! nc + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine Summary(this, bounds, num_allc, filter_allc) + ! + ! !DESCRIPTION: + ! Perform column-level carbon summary calculations + ! + ! !ARGUMENTS: + class(soilbiogeochem_carbonstate_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all active columns + ! + ! !LOCAL VARIABLES: + integer :: c,j,k,l ! indices + integer :: fc ! filter indices + real(r8) :: maxdepth ! depth to integrate soil variables + !----------------------------------------------------------------------- + + ! vertically integrate each of the decomposing C pools + do l = 1, ndecomp_pools + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_cpools_col(c,l) = 0._r8 + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_col(c,l) = 0._r8 + end if + end do + end do + do l = 1, ndecomp_pools + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_cpools_col(c,l) = & + this%decomp_cpools_col(c,l) + & + this%decomp_cpools_vr_col(c,j,l) * dzsoi_decomp(j) + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_col(c,l) = & + this%matrix_cap_decomp_cpools_col(c,l) + & + this%matrix_cap_decomp_cpools_vr_col(c,j,l) * dzsoi_decomp(j) + end if + end do + end do + end do + + if ( nlevdecomp > 1) then + + ! vertically integrate each of the decomposing C pools to 1 meter + maxdepth = 1._r8 + do l = 1, ndecomp_pools + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_cpools_1m_col(c,l) = 0._r8 + end do + end do + do l = 1, ndecomp_pools + do j = 1, nlevdecomp + if ( zisoi(j) <= maxdepth ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_cpools_1m_col(c,l) = & + this%decomp_cpools_1m_col(c,l) + & + this%decomp_cpools_vr_col(c,j,l) * dzsoi_decomp(j) + end do + elseif ( zisoi(j-1) < maxdepth ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_cpools_1m_col(c,l) = & + this%decomp_cpools_1m_col(c,l) + & + this%decomp_cpools_vr_col(c,j,l) * (maxdepth - zisoi(j-1)) + end do + endif + end do + end do + + endif + + ! Add soil carbon pools together to produce vertically-resolved decomposing total soil c pool + if ( nlevdecomp_full > 1 ) then + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_soilc_vr_col(c,j) = 0._r8 + end do + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_soil(l) ) then + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_soilc_vr_col(c,j) = this%decomp_soilc_vr_col(c,j) + & + this%decomp_cpools_vr_col(c,j,l) + end do + end do + end if + end do + end if + + ! truncation carbon + do fc = 1,num_allc + c = filter_allc(fc) + this%ctrunc_col(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%ctrunc_col(c) = & + this%ctrunc_col(c) + & + this%ctrunc_vr_col(c,j) * dzsoi_decomp(j) + end do + end do + + ! total litter carbon in the top meter (TOTLITC_1m) + if ( nlevdecomp > 1) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totlitc_1m_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_litter(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totlitc_1m_col(c) = this%totlitc_1m_col(c) + & + this%decomp_cpools_1m_col(c,l) + end do + endif + end do + end if + + ! total soil organic matter carbon in the top meter (TOTSOMC_1m) + if ( nlevdecomp > 1) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totsomc_1m_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_soil(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totsomc_1m_col(c) = this%totsomc_1m_col(c) + this%decomp_cpools_1m_col(c,l) + end do + end if + end do + end if + + ! total litter carbon (TOTLITC) + do fc = 1,num_allc + c = filter_allc(fc) + this%totlitc_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_litter(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totlitc_col(c) = this%totlitc_col(c) + this%decomp_cpools_col(c,l) + end do + endif + end do + + + ! total soil organic matter carbon (TOTSOMC) + do fc = 1,num_allc + c = filter_allc(fc) + this%totsomc_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_soil(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totsomc_col(c) = this%totsomc_col(c) + this%decomp_cpools_col(c,l) + end do + end if + end do + + ! coarse woody debris carbon + if (.not. use_fates ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%cwdc_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_cwd(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%cwdc_col(c) = this%cwdc_col(c) + this%decomp_cpools_col(c,l) + end do + end if + end do + + end if + + end subroutine Summary + + !------------------------------------------------------------------------ + subroutine SetTotVgCThresh(this, totvegcthresh) + + class(soilbiogeochem_carbonstate_type) :: this + real(r8) , intent(in) :: totvegcthresh + character(len=512) :: msg + + if ( totvegcthresh <= 0.0_r8 )then + call endrun(msg=' ERROR totvegcthresh is zero or negative and should be > 0'//& + errMsg(sourcefile, __LINE__)) + end if + this%totvegcthresh = totvegcthresh + + end subroutine SetTotVgCThresh + + + !----------------------------------------------------------------------- + +end module SoilBiogeochemCarbonStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCompetitionMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCompetitionMod.F90 new file mode 100755 index 000000000..76c1da3ac --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemCompetitionMod.F90 @@ -0,0 +1,948 @@ +module SoilBiogeochemCompetitionMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Resolve plant/heterotroph competition for mineral N + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varcon , only : dzsoi_decomp + use clm_varctl , only : use_nitrif_denitrif + use abortutils , only : endrun + use decompMod , only : bounds_type + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + ! use SoilBiogeochemNitrogenUptakeMod , only : SoilBiogeochemNitrogenUptake + use ColumnType , only : col + use CNVegstateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegnitrogenstateType , only : cnveg_nitrogenstate_type + use CNVegnitrogenfluxType , only : cnveg_nitrogenflux_type + !use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterFluxBulkType , only : waterfluxbulk_type + use TemperatureType , only : temperature_type + use SoilStateType , only : soilstate_type + use CanopyStateType , only : CanopyState_type + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: readParams + public :: SoilBiogeochemCompetitionInit ! Initialization + public :: SoilBiogeochemCompetition ! run method + + type :: params_type + real(r8) :: bdnr ! bulk denitrification rate (1/s) + real(r8) :: compet_plant_no3 ! (unitless) relative compettiveness of plants for NO3 + real(r8) :: compet_plant_nh4 ! (unitless) relative compettiveness of plants for NH4 + real(r8) :: compet_decomp_no3 ! (unitless) relative competitiveness of immobilizers for NO3 + real(r8) :: compet_decomp_nh4 ! (unitless) relative competitiveness of immobilizers for NH4 + real(r8) :: compet_denit ! (unitless) relative competitiveness of denitrifiers for NO3 + real(r8) :: compet_nit ! (unitless) relative competitiveness of nitrifiers for NH4 + end type params_type + ! + type(params_type), private :: params_inst ! params_inst is populated in readParamsMod + ! + ! !PUBLIC DATA MEMBERS: + character(len=* ), public, parameter :: suplnAll='ALL' ! Supplemental Nitrogen for all PFT's + character(len=* ), public, parameter :: suplnNon='NONE' ! No supplemental Nitrogen + character(len=15), public :: suplnitro = suplnNon ! Supplemental Nitrogen mode + ! + ! !PRIVATE DATA MEMBERS: + real(r8) :: dt ! decomp timestep (seconds) + real(r8) :: bdnr ! bulk denitrification rate (1/s) + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !USES: + use ncdio_pio , only : file_desc_t,ncd_io + + ! !ARGUMENTS: + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNAllocParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in parameter + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + ! read in parameters + + tString='bdnr' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%bdnr=tempr + + tString='compet_plant_no3' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%compet_plant_no3=tempr + + tString='compet_plant_nh4' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%compet_plant_nh4=tempr + + tString='compet_decomp_no3' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%compet_decomp_no3=tempr + + tString='compet_decomp_nh4' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%compet_decomp_nh4=tempr + + tString='compet_denit' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%compet_denit=tempr + + tString='compet_nit' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%compet_nit=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemCompetitionInit ( bounds) + ! + ! !DESCRIPTION: + ! + ! !USES: + use clm_varcon , only: secspday + use clm_time_manager, only: get_step_size_real + use clm_varctl , only: iulog, cnallocate_carbon_only_set + use nanMod , only: nan + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'SoilBiogeochemCompetitionInit' + logical :: carbon_only + !----------------------------------------------------------------------- + + ! set time steps + dt = get_step_size_real() + + ! set space-and-time parameters from parameter file + bdnr = params_inst%bdnr * (dt/secspday) + + ! Change namelist settings into private logical variables + select case(suplnitro) + case(suplnNon) + carbon_only = .false. + case(suplnAll) + carbon_only = .true. + case default + write(iulog,*) 'Supplemental Nitrogen flag (suplnitro) can only be: ', & + suplnNon, ' or ', suplnAll + call endrun(msg='ERROR: supplemental Nitrogen flag is not correct'//& + errMsg(sourcefile, __LINE__)) + end select + + call cnallocate_carbon_only_set(carbon_only) + + end subroutine SoilBiogeochemCompetitionInit + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemCompetition (bounds, num_soilc, filter_soilc,num_soilp, filter_soilp, waterstatebulk_inst, & + waterfluxbulk_inst, temperature_inst,soilstate_inst, & + cnveg_state_inst,cnveg_carbonstate_inst, & + cnveg_carbonflux_inst,cnveg_nitrogenstate_inst,cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, & + soilbiogeochem_state_inst, soilbiogeochem_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst,canopystate_inst) + ! + ! !USES: + use clm_varctl , only: cnallocate_carbon_only, iulog + use clm_varpar , only: nlevdecomp, ndecomp_cascade_transitions + use clm_varcon , only: nitrif_n2o_loss_frac + use CNSharedParamsMod, only: use_fun + use CNFUNMod , only: CNFUN + use subgridAveMod , only: p2c + use perf_mod , only : t_startf, t_stopf + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + type(temperature_type) , intent(in) :: temperature_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(canopystate_type) , intent(inout) :: canopystate_inst +! + ! + ! !LOCAL VARIABLES: + integer :: c,p,l,pi,j ! indices + integer :: fc ! filter column index + logical :: local_use_fun ! local version of use_fun + real(r8) :: compet_plant_no3 ! (unitless) relative compettiveness of plants for NO3 + real(r8) :: compet_plant_nh4 ! (unitless) relative compettiveness of plants for NH4 + real(r8) :: compet_decomp_no3 ! (unitless) relative competitiveness of immobilizers for NO3 + real(r8) :: compet_decomp_nh4 ! (unitless) relative competitiveness of immobilizers for NH4 + real(r8) :: compet_denit ! (unitless) relative competitiveness of denitrifiers for NO3 + real(r8) :: compet_nit ! (unitless) relative competitiveness of nitrifiers for NH4 + real(r8) :: fpi_no3_vr(bounds%begc:bounds%endc,1:nlevdecomp) ! fraction of potential immobilization supplied by no3(no units) + real(r8) :: fpi_nh4_vr(bounds%begc:bounds%endc,1:nlevdecomp) ! fraction of potential immobilization supplied by nh4 (no units) + real(r8) :: sum_nh4_demand(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8) :: sum_nh4_demand_scaled(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8) :: sum_no3_demand(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8) :: sum_no3_demand_scaled(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8) :: sum_ndemand_vr(bounds%begc:bounds%endc, 1:nlevdecomp) !total column N demand (gN/m3/s) at a given level + real(r8) :: nuptake_prof(bounds%begc:bounds%endc, 1:nlevdecomp) + real(r8) :: sminn_tot(bounds%begc:bounds%endc) + integer :: nlimit(bounds%begc:bounds%endc,0:nlevdecomp) !flag for N limitation + integer :: nlimit_no3(bounds%begc:bounds%endc,0:nlevdecomp) !flag for NO3 limitation + integer :: nlimit_nh4(bounds%begc:bounds%endc,0:nlevdecomp) !flag for NH4 limitation + real(r8) :: residual_sminn_vr(bounds%begc:bounds%endc, 1:nlevdecomp) + real(r8) :: residual_sminn(bounds%begc:bounds%endc) + real(r8) :: residual_smin_nh4_vr(bounds%begc:bounds%endc, 1:nlevdecomp) + real(r8) :: residual_smin_no3_vr(bounds%begc:bounds%endc, 1:nlevdecomp) + real(r8) :: residual_smin_nh4(bounds%begc:bounds%endc) + real(r8) :: residual_smin_no3(bounds%begc:bounds%endc) + real(r8) :: residual_plant_ndemand(bounds%begc:bounds%endc) + real(r8) :: sminn_to_plant_new(bounds%begc:bounds%endc) + !----------------------------------------------------------------------- + + associate( & + fpg => soilbiogeochem_state_inst%fpg_col , & ! Output: [real(r8) (:) ] fraction of potential gpp (no units) + fpi => soilbiogeochem_state_inst%fpi_col , & ! Output: [real(r8) (:) ] fraction of potential immobilization (no units) + fpi_vr => soilbiogeochem_state_inst%fpi_vr_col , & ! Output: [real(r8) (:,:) ] fraction of potential immobilization (no units) + nfixation_prof => soilbiogeochem_state_inst%nfixation_prof_col , & ! Output: [real(r8) (:,:) ] + plant_ndemand => soilbiogeochem_state_inst%plant_ndemand_col , & ! Input: [real(r8) (:) ] column-level plant N demand + + sminn_vr => soilbiogeochem_nitrogenstate_inst%sminn_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral N + smin_nh4_vr => soilbiogeochem_nitrogenstate_inst%smin_nh4_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral NH4 + smin_no3_vr => soilbiogeochem_nitrogenstate_inst%smin_no3_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral NO3 + + pot_f_nit_vr => soilbiogeochem_nitrogenflux_inst%pot_f_nit_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3/s) potential soil nitrification flux + pot_f_denit_vr => soilbiogeochem_nitrogenflux_inst%pot_f_denit_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3/s) potential soil denitrification flux + f_nit_vr => soilbiogeochem_nitrogenflux_inst%f_nit_vr_col , & ! Output: [real(r8) (:,:) ] (gN/m3/s) soil nitrification flux + f_denit_vr => soilbiogeochem_nitrogenflux_inst%f_denit_vr_col , & ! Output: [real(r8) (:,:) ] (gN/m3/s) soil denitrification flux + potential_immob => soilbiogeochem_nitrogenflux_inst%potential_immob_col , & ! Output: [real(r8) (:) ] + actual_immob => soilbiogeochem_nitrogenflux_inst%actual_immob_col , & ! Output: [real(r8) (:) ] + sminn_to_plant => soilbiogeochem_nitrogenflux_inst%sminn_to_plant_col , & ! Output: [real(r8) (:) ] + sminn_to_denit_excess_vr => soilbiogeochem_nitrogenflux_inst%sminn_to_denit_excess_vr_col , & ! Output: [real(r8) (:,:) ] + actual_immob_no3_vr => soilbiogeochem_nitrogenflux_inst%actual_immob_no3_vr_col , & ! Output: [real(r8) (:,:) ] + actual_immob_nh4_vr => soilbiogeochem_nitrogenflux_inst%actual_immob_nh4_vr_col , & ! Output: [real(r8) (:,:) ] + smin_no3_to_plant_vr => soilbiogeochem_nitrogenflux_inst%smin_no3_to_plant_vr_col , & ! Output: [real(r8) (:,:) ] + smin_nh4_to_plant_vr => soilbiogeochem_nitrogenflux_inst%smin_nh4_to_plant_vr_col , & ! Output: [real(r8) (:,:) ] + n2_n2o_ratio_denit_vr => soilbiogeochem_nitrogenflux_inst%n2_n2o_ratio_denit_vr_col , & ! Output: [real(r8) (:,:) ] ratio of N2 to N2O production by denitrification [gN/gN] + f_n2o_denit_vr => soilbiogeochem_nitrogenflux_inst%f_n2o_denit_vr_col , & ! Output: [real(r8) (:,:) ] flux of N2O from denitrification [gN/m3/s] + f_n2o_nit_vr => soilbiogeochem_nitrogenflux_inst%f_n2o_nit_vr_col , & ! Output: [real(r8) (:,:) ] flux of N2O from nitrification [gN/m3/s] + supplement_to_sminn_vr => soilbiogeochem_nitrogenflux_inst%supplement_to_sminn_vr_col , & ! Output: [real(r8) (:,:) ] + sminn_to_plant_vr => soilbiogeochem_nitrogenflux_inst%sminn_to_plant_vr_col , & ! Output: [real(r8) (:,:) ] + potential_immob_vr => soilbiogeochem_nitrogenflux_inst%potential_immob_vr_col , & ! Input: [real(r8) (:,:) ] + actual_immob_vr => soilbiogeochem_nitrogenflux_inst%actual_immob_vr_col , & ! Output: [real(r8) (:,:) ] + sminn_to_plant_fun_vr => soilbiogeochem_nitrogenflux_inst%sminn_to_plant_fun_vr_col , & ! Iutput: [real(r8) (:) ] Total layer soil N uptake of FUN (gN/m2/s) + sminn_to_plant_fun_no3_vr => soilbiogeochem_nitrogenflux_inst%sminn_to_plant_fun_no3_vr_col, & ! Iutput: [real(r8) (:) ] Total layer no3 uptake of FUN (gN/m2/s) + sminn_to_plant_fun_nh4_vr => soilbiogeochem_nitrogenflux_inst%sminn_to_plant_fun_nh4_vr_col & ! Iutput: [real(r8) (:) ] Total layer nh4 uptake of FUN (gN/m2/s) + ) + + ! calcualte nitrogen uptake profile + ! nuptake_prof(:,:) = nan + ! call SoilBiogelchemNitrogenUptakeProfile(bounds, & + ! nlevdecomp, num_soilc, filter_soilc, & + ! sminn_vr, dzsoi_decomp, nfixation_prof, nuptake_prof) + + ! column loops to resolve plant/heterotroph competition for mineral N + + sminn_to_plant_new(bounds%begc:bounds%endc) = 0._r8 + + local_use_fun = use_fun + + if (.not. use_nitrif_denitrif) then + + ! init sminn_tot + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_tot(c) = 0. + end do + + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_tot(c) = sminn_tot(c) + sminn_vr(c,j) * dzsoi_decomp(j) + end do + end do + + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + if (sminn_tot(c) > 0.) then + nuptake_prof(c,j) = sminn_vr(c,j) / sminn_tot(c) + else + nuptake_prof(c,j) = nfixation_prof(c,j) + endif + end do + end do + + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sum_ndemand_vr(c,j) = plant_ndemand(c) * nuptake_prof(c,j) + potential_immob_vr(c,j) + end do + end do + + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + l = col%landunit(c) + if (sum_ndemand_vr(c,j)*dt < sminn_vr(c,j)) then + + ! N availability is not limiting immobilization or plant + ! uptake, and both can proceed at their potential rates + nlimit(c,j) = 0 + fpi_vr(c,j) = 1.0_r8 + actual_immob_vr(c,j) = potential_immob_vr(c,j) + sminn_to_plant_vr(c,j) = plant_ndemand(c) * nuptake_prof(c,j) + else if ( cnallocate_carbon_only()) then !.or. & + ! this code block controls the addition of N to sminn pool + ! to eliminate any N limitation, when Carbon_Only is set. This lets the + ! model behave essentially as a carbon-only model, but with the + ! benefit of keeping track of the N additions needed to + ! eliminate N limitations, so there is still a diagnostic quantity + ! that describes the degree of N limitation at steady-state. + + nlimit(c,j) = 1 + fpi_vr(c,j) = 1.0_r8 + actual_immob_vr(c,j) = potential_immob_vr(c,j) + sminn_to_plant_vr(c,j) = plant_ndemand(c) * nuptake_prof(c,j) + supplement_to_sminn_vr(c,j) = sum_ndemand_vr(c,j) - (sminn_vr(c,j)/dt) + else + ! N availability can not satisfy the sum of immobilization and + ! plant growth demands, so these two demands compete for available + ! soil mineral N resource. + + nlimit(c,j) = 1 + if (sum_ndemand_vr(c,j) > 0.0_r8) then + actual_immob_vr(c,j) = (sminn_vr(c,j)/dt)*(potential_immob_vr(c,j) / sum_ndemand_vr(c,j)) + else + actual_immob_vr(c,j) = 0.0_r8 + end if + + if (potential_immob_vr(c,j) > 0.0_r8) then + fpi_vr(c,j) = actual_immob_vr(c,j) / potential_immob_vr(c,j) + else + fpi_vr(c,j) = 0.0_r8 + end if + + sminn_to_plant_vr(c,j) = (sminn_vr(c,j)/dt) - actual_immob_vr(c,j) + end if + end do + end do + + if ( local_use_fun ) then + call t_startf( 'CNFUN' ) + call CNFUN(bounds,num_soilc,filter_soilc,num_soilp,filter_soilp,waterstatebulk_inst, & + waterfluxbulk_inst,temperature_inst,soilstate_inst,cnveg_state_inst,cnveg_carbonstate_inst,& + cnveg_carbonflux_inst,cnveg_nitrogenstate_inst,cnveg_nitrogenflux_inst ,& + soilbiogeochem_nitrogenflux_inst,soilbiogeochem_carbonflux_inst,canopystate_inst, & + soilbiogeochem_nitrogenstate_inst) + call p2c(bounds, nlevdecomp, & + cnveg_nitrogenflux_inst%sminn_to_plant_fun_vr_patch(bounds%begp:bounds%endp,1:nlevdecomp),& + soilbiogeochem_nitrogenflux_inst%sminn_to_plant_fun_vr_col(bounds%begc:bounds%endc,1:nlevdecomp), & + 'unity') + call t_stopf( 'CNFUN' ) + end if + + ! sum up N fluxes to plant + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant(c) = sminn_to_plant(c) + sminn_to_plant_vr(c,j) * dzsoi_decomp(j) + if ( local_use_fun ) then + if (sminn_to_plant_fun_vr(c,j).gt.sminn_to_plant_vr(c,j)) then + sminn_to_plant_fun_vr(c,j) = sminn_to_plant_vr(c,j) + end if + end if + end do + end do + + ! give plants a second pass to see if there is any mineral N left over with which to satisfy residual N demand. + do fc=1,num_soilc + c = filter_soilc(fc) + residual_sminn(c) = 0._r8 + end do + + ! sum up total N left over after initial plant and immobilization fluxes + do fc=1,num_soilc + c = filter_soilc(fc) + residual_plant_ndemand(c) = plant_ndemand(c) - sminn_to_plant(c) + end do + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + if (residual_plant_ndemand(c) > 0._r8 ) then + if (nlimit(c,j) .eq. 0) then + residual_sminn_vr(c,j) = max(sminn_vr(c,j) - (actual_immob_vr(c,j) + sminn_to_plant_vr(c,j) ) * dt, 0._r8) + residual_sminn(c) = residual_sminn(c) + residual_sminn_vr(c,j) * dzsoi_decomp(j) + else + residual_sminn_vr(c,j) = 0._r8 + endif + endif + end do + end do + + ! distribute residual N to plants + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + if ( residual_plant_ndemand(c) > 0._r8 .and. residual_sminn(c) > 0._r8 .and. nlimit(c,j) .eq. 0) then + sminn_to_plant_vr(c,j) = sminn_to_plant_vr(c,j) + residual_sminn_vr(c,j) * & + min(( residual_plant_ndemand(c) * dt ) / residual_sminn(c), 1._r8) / dt + endif + end do + end do + + ! re-sum up N fluxes to plant + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant(c) = sminn_to_plant(c) + sminn_to_plant_vr(c,j) * dzsoi_decomp(j) + if ( .not. local_use_fun ) then + sum_ndemand_vr(c,j) = potential_immob_vr(c,j) + sminn_to_plant_vr(c,j) + else + sminn_to_plant_new(c) = sminn_to_plant_new(c) + sminn_to_plant_fun_vr(c,j) * dzsoi_decomp(j) + sum_ndemand_vr(c,j) = potential_immob_vr(c,j) + sminn_to_plant_fun_vr(c,j) + end if + end do + end do + + ! under conditions of excess N, some proportion is assumed to + ! be lost to denitrification, in addition to the constant + ! proportion lost in the decomposition pathways + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + if ( .not. local_use_fun ) then + if ((sminn_to_plant_vr(c,j) + actual_immob_vr(c,j))*dt < sminn_vr(c,j)) then + sminn_to_denit_excess_vr(c,j) = max(bdnr*((sminn_vr(c,j)/dt) - sum_ndemand_vr(c,j)),0._r8) + else + sminn_to_denit_excess_vr(c,j) = 0._r8 + endif + else + if ((sminn_to_plant_fun_vr(c,j) + actual_immob_vr(c,j))*dt < sminn_vr(c,j)) then + sminn_to_denit_excess_vr(c,j) = max(bdnr*((sminn_vr(c,j)/dt) - sum_ndemand_vr(c,j)),0._r8) + else + sminn_to_denit_excess_vr(c,j) = 0._r8 + endif + end if + end do + end do + + ! sum up N fluxes to immobilization + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + actual_immob(c) = actual_immob(c) + actual_immob_vr(c,j) * dzsoi_decomp(j) + potential_immob(c) = potential_immob(c) + potential_immob_vr(c,j) * dzsoi_decomp(j) + end do + end do + + do fc=1,num_soilc + c = filter_soilc(fc) + ! calculate the fraction of potential growth that can be + ! acheived with the N available to plants + if (plant_ndemand(c) > 0.0_r8) then + if ( .not. local_use_fun ) then + fpg(c) = sminn_to_plant(c) / plant_ndemand(c) + else + fpg(c) = sminn_to_plant_new(c) / plant_ndemand(c) + end if + else + fpg(c) = 1.0_r8 + end if + + ! calculate the fraction of immobilization realized (for diagnostic purposes) + if (potential_immob(c) > 0.0_r8) then + fpi(c) = actual_immob(c) / potential_immob(c) + else + fpi(c) = 1.0_r8 + end if + end do + + else !----------NITRIF_DENITRIF-------------! + + ! column loops to resolve plant/heterotroph/nitrifier/denitrifier competition for mineral N + !read constants from external netcdf file + compet_plant_no3 = params_inst%compet_plant_no3 + compet_plant_nh4 = params_inst%compet_plant_nh4 + compet_decomp_no3 = params_inst%compet_decomp_no3 + compet_decomp_nh4 = params_inst%compet_decomp_nh4 + compet_denit = params_inst%compet_denit + compet_nit = params_inst%compet_nit + + ! init total mineral N pools + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_tot(c) = 0. + end do + + ! sum up total mineral N pools + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_tot(c) = sminn_tot(c) + (smin_no3_vr(c,j) + smin_nh4_vr(c,j)) * dzsoi_decomp(j) + end do + end do + + ! define N uptake profile for initial vertical distribution of plant N uptake, assuming plant seeks N from where it is most abundant + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + if (sminn_tot(c) > 0.) then + nuptake_prof(c,j) = sminn_vr(c,j) / sminn_tot(c) + else + nuptake_prof(c,j) = nfixation_prof(c,j) + endif + end do + end do + + ! main column/vertical loop + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + l = col%landunit(c) + + ! first compete for nh4 + sum_nh4_demand(c,j) = plant_ndemand(c) * nuptake_prof(c,j) + potential_immob_vr(c,j) + pot_f_nit_vr(c,j) + sum_nh4_demand_scaled(c,j) = plant_ndemand(c)* nuptake_prof(c,j) * compet_plant_nh4 + & + potential_immob_vr(c,j)*compet_decomp_nh4 + pot_f_nit_vr(c,j)*compet_nit + + if (sum_nh4_demand(c,j)*dt < smin_nh4_vr(c,j)) then + + ! NH4 availability is not limiting immobilization or plant + ! uptake, and all can proceed at their potential rates + nlimit_nh4(c,j) = 0 + fpi_nh4_vr(c,j) = 1.0_r8 + actual_immob_nh4_vr(c,j) = potential_immob_vr(c,j) + !RF added new term. + + f_nit_vr(c,j) = pot_f_nit_vr(c,j) + + if ( .not. local_use_fun ) then + smin_nh4_to_plant_vr(c,j) = plant_ndemand(c) * nuptake_prof(c,j) + else + smin_nh4_to_plant_vr(c,j) = smin_nh4_vr(c,j)/dt - actual_immob_nh4_vr(c,j) - f_nit_vr(c,j) + end if + + else + + ! NH4 availability can not satisfy the sum of immobilization, nitrification, and + ! plant growth demands, so these three demands compete for available + ! soil mineral NH4 resource. + nlimit_nh4(c,j) = 1 + if (sum_nh4_demand(c,j) > 0.0_r8) then + ! RF microbes compete based on the hypothesised plant demand. + actual_immob_nh4_vr(c,j) = min((smin_nh4_vr(c,j)/dt)*(potential_immob_vr(c,j)* & + compet_decomp_nh4 / sum_nh4_demand_scaled(c,j)), potential_immob_vr(c,j)) + + f_nit_vr(c,j) = min((smin_nh4_vr(c,j)/dt)*(pot_f_nit_vr(c,j)*compet_nit / & + sum_nh4_demand_scaled(c,j)), pot_f_nit_vr(c,j)) + + if ( .not. local_use_fun ) then + smin_nh4_to_plant_vr(c,j) = min((smin_nh4_vr(c,j)/dt)*(plant_ndemand(c)* & + nuptake_prof(c,j)*compet_plant_nh4 / sum_nh4_demand_scaled(c,j)), plant_ndemand(c)*nuptake_prof(c,j)) + + else + ! RF added new term. send rest of N to plant - which decides whether it should pay or not? + smin_nh4_to_plant_vr(c,j) = smin_nh4_vr(c,j)/dt - actual_immob_nh4_vr(c,j) - f_nit_vr(c,j) + end if + + else + actual_immob_nh4_vr(c,j) = 0.0_r8 + smin_nh4_to_plant_vr(c,j) = 0.0_r8 + f_nit_vr(c,j) = 0.0_r8 + end if + + if (potential_immob_vr(c,j) > 0.0_r8) then + fpi_nh4_vr(c,j) = actual_immob_nh4_vr(c,j) / potential_immob_vr(c,j) + else + fpi_nh4_vr(c,j) = 0.0_r8 + end if + + end if + + + + if(.not.local_use_fun)then + sum_no3_demand(c,j) = (plant_ndemand(c)*nuptake_prof(c,j)-smin_nh4_to_plant_vr(c,j)) + & + (potential_immob_vr(c,j)-actual_immob_nh4_vr(c,j)) + pot_f_denit_vr(c,j) + sum_no3_demand_scaled(c,j) = (plant_ndemand(c)*nuptake_prof(c,j) & + -smin_nh4_to_plant_vr(c,j))*compet_plant_no3 + & + (potential_immob_vr(c,j)-actual_immob_nh4_vr(c,j))*compet_decomp_no3 + pot_f_denit_vr(c,j)*compet_denit + else + sum_no3_demand(c,j) = plant_ndemand(c)*nuptake_prof(c,j) + & + (potential_immob_vr(c,j)-actual_immob_nh4_vr(c,j)) + pot_f_denit_vr(c,j) + sum_no3_demand_scaled(c,j) = (plant_ndemand(c)*nuptake_prof(c,j))*compet_plant_no3 + & + (potential_immob_vr(c,j)-actual_immob_nh4_vr(c,j))*compet_decomp_no3 + pot_f_denit_vr(c,j)*compet_denit + endif + + + + if (sum_no3_demand(c,j)*dt < smin_no3_vr(c,j)) then + + ! NO3 availability is not limiting immobilization or plant + ! uptake, and all can proceed at their potential rates + nlimit_no3(c,j) = 0 + fpi_no3_vr(c,j) = 1.0_r8 - fpi_nh4_vr(c,j) + actual_immob_no3_vr(c,j) = (potential_immob_vr(c,j)-actual_immob_nh4_vr(c,j)) + + f_denit_vr(c,j) = pot_f_denit_vr(c,j) + + if(.not.local_use_fun)then + smin_no3_to_plant_vr(c,j) = (plant_ndemand(c)*nuptake_prof(c,j)-smin_nh4_to_plant_vr(c,j)) + else + ! This restricts the N uptake of a single layer to the value determined from the total demands and the + ! hypothetical uptake profile above. Which is a strange thing to do, since that is independent of FUN + ! do we need this at all? + smin_no3_to_plant_vr(c,j) = plant_ndemand(c)*nuptake_prof(c,j) + ! RF added new term. send rest of N to plant - which decides whether it should pay or not? + if ( local_use_fun ) then + smin_no3_to_plant_vr(c,j) = smin_no3_vr(c,j)/dt - actual_immob_no3_vr(c,j) - f_denit_vr(c,j) + end if + endif + + else + + ! NO3 availability can not satisfy the sum of immobilization, denitrification, and + ! plant growth demands, so these three demands compete for available + ! soil mineral NO3 resource. + nlimit_no3(c,j) = 1 + + if (sum_no3_demand(c,j) > 0.0_r8) then + if(.not.local_use_fun)then + actual_immob_no3_vr(c,j) = min((smin_no3_vr(c,j)/dt)*((potential_immob_vr(c,j)- & + actual_immob_nh4_vr(c,j))*compet_decomp_no3 / sum_no3_demand_scaled(c,j)), & + potential_immob_vr(c,j)-actual_immob_nh4_vr(c,j)) + + smin_no3_to_plant_vr(c,j) = min((smin_no3_vr(c,j)/dt)*((plant_ndemand(c)* & + nuptake_prof(c,j)-smin_nh4_to_plant_vr(c,j))*compet_plant_no3 / sum_no3_demand_scaled(c,j)), & + plant_ndemand(c)*nuptake_prof(c,j)-smin_nh4_to_plant_vr(c,j)) + + f_denit_vr(c,j) = min((smin_no3_vr(c,j)/dt)*(pot_f_denit_vr(c,j)*compet_denit / & + sum_no3_demand_scaled(c,j)), pot_f_denit_vr(c,j)) + else + actual_immob_no3_vr(c,j) = min((smin_no3_vr(c,j)/dt)*((potential_immob_vr(c,j)- & + actual_immob_nh4_vr(c,j))*compet_decomp_no3 / sum_no3_demand_scaled(c,j)), & + potential_immob_vr(c,j)-actual_immob_nh4_vr(c,j)) + + f_denit_vr(c,j) = min((smin_no3_vr(c,j)/dt)*(pot_f_denit_vr(c,j)*compet_denit / & + sum_no3_demand_scaled(c,j)), pot_f_denit_vr(c,j)) + + smin_no3_to_plant_vr(c,j) = (smin_no3_vr(c,j)/dt)*((plant_ndemand(c)* & + nuptake_prof(c,j)-smin_nh4_to_plant_vr(c,j))*compet_plant_no3 / sum_no3_demand_scaled(c,j)) + + ! RF added new term. send rest of N to plant - which decides whether it should pay or not? + smin_no3_to_plant_vr(c,j) = (smin_no3_vr(c,j) / dt) - actual_immob_no3_vr(c,j) - f_denit_vr(c,j) + + + end if ! use_fun + + else ! no no3 demand. no uptake fluxes. + actual_immob_no3_vr(c,j) = 0.0_r8 + smin_no3_to_plant_vr(c,j) = 0.0_r8 + f_denit_vr(c,j) = 0.0_r8 + + end if !any no3 demand? + + + + + if (potential_immob_vr(c,j) > 0.0_r8) then + fpi_no3_vr(c,j) = actual_immob_no3_vr(c,j) / potential_immob_vr(c,j) + else + fpi_no3_vr(c,j) = 0.0_r8 + end if + + end if + + + + + ! n2o emissions: n2o from nitr is const fraction, n2o from denitr is calculated in nitrif_denitrif + f_n2o_nit_vr(c,j) = f_nit_vr(c,j) * nitrif_n2o_loss_frac + f_n2o_denit_vr(c,j) = f_denit_vr(c,j) / (1._r8 + n2_n2o_ratio_denit_vr(c,j)) + + + ! this code block controls the addition of N to sminn pool + ! to eliminate any N limitation, when Carbon_Only is set. This lets the + ! model behave essentially as a carbon-only model, but with the + ! benefit of keeping track of the N additions needed to + ! eliminate N limitations, so there is still a diagnostic quantity + ! that describes the degree of N limitation at steady-state. + + if ( cnallocate_carbon_only()) then !.or. & + if ( fpi_no3_vr(c,j) + fpi_nh4_vr(c,j) < 1._r8 ) then + fpi_nh4_vr(c,j) = 1.0_r8 - fpi_no3_vr(c,j) + supplement_to_sminn_vr(c,j) = (potential_immob_vr(c,j) & + - actual_immob_no3_vr(c,j)) - actual_immob_nh4_vr(c,j) + ! update to new values that satisfy demand + actual_immob_nh4_vr(c,j) = potential_immob_vr(c,j) - actual_immob_no3_vr(c,j) + end if + if ( smin_no3_to_plant_vr(c,j) + smin_nh4_to_plant_vr(c,j) < plant_ndemand(c)*nuptake_prof(c,j) ) then + supplement_to_sminn_vr(c,j) = supplement_to_sminn_vr(c,j) + & + (plant_ndemand(c)*nuptake_prof(c,j) - smin_no3_to_plant_vr(c,j)) - smin_nh4_to_plant_vr(c,j) ! use old values + smin_nh4_to_plant_vr(c,j) = plant_ndemand(c)*nuptake_prof(c,j) - smin_no3_to_plant_vr(c,j) + end if + sminn_to_plant_vr(c,j) = smin_no3_to_plant_vr(c,j) + smin_nh4_to_plant_vr(c,j) + end if + + ! sum up no3 and nh4 fluxes + fpi_vr(c,j) = fpi_no3_vr(c,j) + fpi_nh4_vr(c,j) + sminn_to_plant_vr(c,j) = smin_no3_to_plant_vr(c,j) + smin_nh4_to_plant_vr(c,j) + actual_immob_vr(c,j) = actual_immob_no3_vr(c,j) + actual_immob_nh4_vr(c,j) + end do + end do + + if ( local_use_fun ) then + call t_startf( 'CNFUN' ) + call CNFUN(bounds,num_soilc,filter_soilc,num_soilp,filter_soilp,waterstatebulk_inst,& + waterfluxbulk_inst,temperature_inst,soilstate_inst,cnveg_state_inst,cnveg_carbonstate_inst,& + cnveg_carbonflux_inst,cnveg_nitrogenstate_inst,cnveg_nitrogenflux_inst ,& + soilbiogeochem_nitrogenflux_inst,soilbiogeochem_carbonflux_inst,canopystate_inst, & + soilbiogeochem_nitrogenstate_inst) + + ! sminn_to_plant_fun is output of actual N uptake from FUN + call p2c(bounds,nlevdecomp, & + cnveg_nitrogenflux_inst%sminn_to_plant_fun_no3_vr_patch(bounds%begp:bounds%endp,1:nlevdecomp),& + soilbiogeochem_nitrogenflux_inst%sminn_to_plant_fun_no3_vr_col(bounds%begc:bounds%endc,1:nlevdecomp),& + 'unity') + + call p2c(bounds,nlevdecomp, & + cnveg_nitrogenflux_inst%sminn_to_plant_fun_nh4_vr_patch(bounds%begp:bounds%endp,1:nlevdecomp),& + soilbiogeochem_nitrogenflux_inst%sminn_to_plant_fun_nh4_vr_col(bounds%begc:bounds%endc,1:nlevdecomp),& + 'unity') + call t_stopf( 'CNFUN' ) + end if + + + + if(.not.local_use_fun)then + do fc=1,num_soilc + c = filter_soilc(fc) + ! sum up N fluxes to plant after initial competition + sminn_to_plant(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant(c) = sminn_to_plant(c) + sminn_to_plant_vr(c,j) * dzsoi_decomp(j) + end do + end do + else + do fc=1,num_soilc + c = filter_soilc(fc) + ! sum up N fluxes to plant after initial competition + sminn_to_plant(c) = 0._r8 !this isn't use in fun. + do j = 1, nlevdecomp + if ((sminn_to_plant_fun_no3_vr(c,j)-smin_no3_to_plant_vr(c,j)).gt.0.0000000000001_r8) then + write(iulog,*) 'problem with limitations on no3 uptake', & + sminn_to_plant_fun_no3_vr(c,j),smin_no3_to_plant_vr(c,j) + call endrun("too much NO3 uptake predicted by FUN") + end if +!KO if ((sminn_to_plant_fun_nh4_vr(c,j)-smin_nh4_to_plant_vr(c,j)).gt.0.0000000000001_r8) then +!KO + if ((sminn_to_plant_fun_nh4_vr(c,j)-smin_nh4_to_plant_vr(c,j)).gt.0.0000001_r8) then +!KO + write(iulog,*) 'problem with limitations on nh4 uptake', & + sminn_to_plant_fun_nh4_vr(c,j),smin_nh4_to_plant_vr(c,j) + call endrun("too much NH4 uptake predicted by FUN") + end if + end do + end do + + end if + + if(.not.local_use_fun)then + ! give plants a second pass to see if there is any mineral N left over with which to satisfy residual N demand. + ! first take frm nh4 pool; then take from no3 pool + do fc=1,num_soilc + c = filter_soilc(fc) + residual_plant_ndemand(c) = plant_ndemand(c) - sminn_to_plant(c) + residual_smin_nh4(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + if (residual_plant_ndemand(c) > 0._r8 ) then + if (nlimit_nh4(c,j) .eq. 0) then + residual_smin_nh4_vr(c,j) = max(smin_nh4_vr(c,j) - (actual_immob_nh4_vr(c,j) + & + smin_nh4_to_plant_vr(c,j) + f_nit_vr(c,j) ) * dt, 0._r8) + + residual_smin_nh4(c) = residual_smin_nh4(c) + residual_smin_nh4_vr(c,j) * dzsoi_decomp(j) + else + residual_smin_nh4_vr(c,j) = 0._r8 + endif + + if ( residual_smin_nh4(c) > 0._r8 .and. nlimit_nh4(c,j) .eq. 0 ) then + smin_nh4_to_plant_vr(c,j) = smin_nh4_to_plant_vr(c,j) + residual_smin_nh4_vr(c,j) * & + min(( residual_plant_ndemand(c) * dt ) / residual_smin_nh4(c), 1._r8) / dt + endif + end if + end do + end do + + ! re-sum up N fluxes to plant after second pass for nh4 + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant_vr(c,j) = smin_nh4_to_plant_vr(c,j) + smin_no3_to_plant_vr(c,j) + sminn_to_plant(c) = sminn_to_plant(c) + (sminn_to_plant_vr(c,j)) * dzsoi_decomp(j) + end do + end do + + ! + ! and now do second pass for no3 + do fc=1,num_soilc + c = filter_soilc(fc) + residual_plant_ndemand(c) = plant_ndemand(c) - sminn_to_plant(c) + residual_smin_no3(c) = 0._r8 + end do + + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + if (residual_plant_ndemand(c) > 0._r8 ) then + if (nlimit_no3(c,j) .eq. 0) then + residual_smin_no3_vr(c,j) = max(smin_no3_vr(c,j) - (actual_immob_no3_vr(c,j) + & + smin_no3_to_plant_vr(c,j) + f_denit_vr(c,j) ) * dt, 0._r8) + residual_smin_no3(c) = residual_smin_no3(c) + residual_smin_no3_vr(c,j) * dzsoi_decomp(j) + else + residual_smin_no3_vr(c,j) = 0._r8 + endif + + if ( residual_smin_no3(c) > 0._r8 .and. nlimit_no3(c,j) .eq. 0) then + smin_no3_to_plant_vr(c,j) = smin_no3_to_plant_vr(c,j) + residual_smin_no3_vr(c,j) * & + min(( residual_plant_ndemand(c) * dt ) / residual_smin_no3(c), 1._r8) / dt + endif + endif + end do + end do + + ! re-sum up N fluxes to plant after second passes of both no3 and nh4 + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant_vr(c,j) = smin_nh4_to_plant_vr(c,j) + smin_no3_to_plant_vr(c,j) + sminn_to_plant(c) = sminn_to_plant(c) + (sminn_to_plant_vr(c,j)) * dzsoi_decomp(j) + end do + end do + + else !use_fun + !calculate maximum N available to plants. + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant_vr(c,j) = smin_nh4_to_plant_vr(c,j) + smin_no3_to_plant_vr(c,j) + sminn_to_plant(c) = sminn_to_plant(c) + (sminn_to_plant_vr(c,j)) * dzsoi_decomp(j) + end do + end do + + + ! add up fun fluxes from SMINN to plant. + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + sminn_to_plant_new(c) = sminn_to_plant_new(c) + & + (sminn_to_plant_fun_no3_vr(c,j) + sminn_to_plant_fun_nh4_vr(c,j)) * dzsoi_decomp(j) + + end do + end do + + + end if !use_f + ! sum up N fluxes to immobilization + do fc=1,num_soilc + c = filter_soilc(fc) + actual_immob(c) = 0._r8 + potential_immob(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc=1,num_soilc + c = filter_soilc(fc) + actual_immob(c) = actual_immob(c) + actual_immob_vr(c,j) * dzsoi_decomp(j) + potential_immob(c) = potential_immob(c) + potential_immob_vr(c,j) * dzsoi_decomp(j) + end do + end do + + + + + do fc=1,num_soilc + c = filter_soilc(fc) + ! calculate the fraction of potential growth that can be + ! acheived with the N available to plants + ! calculate the fraction of immobilization realized (for diagnostic purposes) + if(.not.local_use_fun)then !FUN has no concept of FPG. + + if (plant_ndemand(c) > 0.0_r8) then + fpg(c) = sminn_to_plant(c) / plant_ndemand(c) + else + fpg(c) = 1._r8 + end if + end if + + if (potential_immob(c) > 0.0_r8) then + fpi(c) = actual_immob(c) / potential_immob(c) + else + fpi(c) = 1._r8 + end if + end do ! end of column loops + + end if !end of if_not_use_nitrif_denitrif + + end associate + + end subroutine SoilBiogeochemCompetition + +end module SoilBiogeochemCompetitionMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemDecompCascadeConType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemDecompCascadeConType.F90 new file mode 100755 index 000000000..2ee97754a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemDecompCascadeConType.F90 @@ -0,0 +1,150 @@ +module SoilBiogeochemDecompCascadeConType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevdecomp, & + ndecomp_cascade_outtransitions + use clm_varctl , only : use_soil_matrixcn, iulog + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + public :: init_decomp_cascade_constants + + type, public :: decomp_cascade_type + + character(len=8) , pointer :: cascade_step_name(:) ! name of transition + integer , pointer :: cascade_donor_pool(:) ! which pool is C taken from for a given decomposition step + integer , pointer :: cascade_receiver_pool(:) ! which pool is C added to for a given decomposition step + + !-- properties of each decomposing pool + logical , pointer :: floating_cn_ratio_decomp_pools(:) ! TRUE => pool has fixed C:N ratio + character(len=8) , pointer :: decomp_pool_name_restart(:) ! name of pool for restart files + character(len=8) , pointer :: decomp_pool_name_history(:) ! name of pool for history files + character(len=20) , pointer :: decomp_pool_name_long(:) ! name of pool for netcdf long names + character(len=8) , pointer :: decomp_pool_name_short(:) ! name of pool for netcdf short names + logical , pointer :: is_litter(:) ! TRUE => pool is a litter pool + logical , pointer :: is_soil(:) ! TRUE => pool is a soil pool + logical , pointer :: is_cwd(:) ! TRUE => pool is a cwd pool + real(r8) , pointer :: initial_cn_ratio(:) ! c:n ratio for initialization of pools + real(r8) , pointer :: initial_stock(:) ! initial concentration for seeding at spinup + real(r8) :: initial_stock_soildepth ! soil depth for initial concentration for seeding at spinup + logical , pointer :: is_metabolic(:) ! TRUE => pool is metabolic material + logical , pointer :: is_cellulose(:) ! TRUE => pool is cellulose + logical , pointer :: is_lignin(:) ! TRUE => pool is lignin + real(r8) , pointer :: spinup_factor(:) ! factor by which to scale AD and relevant processes by + + integer,pointer :: spm_tranlist_a(:,:) ! Prescribed subscripts to map 2D variables (transitions,soil layer) to 1D sparse matrix format in a_ma_vr and na_ma_vr + integer,pointer :: A_i(:) ! Prescribed row number of all elements in a_ma_vr + integer,pointer :: A_j(:) ! Prescribed column number of all elements in na_ma_vr + integer,pointer :: tri_i(:) ! Prescribed row index of all entries in AVsoil + integer,pointer :: tri_j(:) ! Prescribed column index of all entries in AVsoil + integer,pointer :: all_i(:) ! Prescribed row index of all entries in AKallsoilc, AKallsoiln, AKXcacc, and AKXnacc + integer,pointer :: all_j(:) ! Prescribed column index of all entries in AKallsoilc, AKallsoiln, AKXcacc, and AKXnacc + + integer,pointer :: list_V_AKVfire (:) ! Saves mapping indices from V to (A*K+V-Kfire) in the addition subroutine SPMP_ABC + integer,pointer :: list_AK_AKVfire(:) ! Saves mapping indices from A*K to (A*K+V-Kfire) in the addition subroutine SPMP_ABC + integer,pointer :: list_fire_AKVfire(:) ! Saves mapping indices from Kfire to (A*K+V-Kfire) in the addition subroutine SPMP_ABC + integer,pointer :: list_AK_AKV (:) ! Saves mapping indices from A*K to (A*K+V) in the addition subroutine SPMP_AB + integer,pointer :: list_V_AKV (:) ! Saves mapping indices from V to (A*K+V) in the addition subroutine SPMP_AB + integer,pointer :: list_Asoilc (:) ! Saves mapping indices from a_ma_vr to AKsoilc + integer,pointer :: list_Asoiln (:) ! Saves mapping indices from na_ma_vr to AKsoiln + + integer, public :: n_all_entries ! Number of all entries in AKallsoilc, AKallsoiln, AKXcacc, and AKXnacc + integer, public :: Ntrans_setup ! Number of horizontal transfers between soil and litter pools + integer, public :: Ntri_setup ! Number of non-zero entries in AVsoil + + end type decomp_cascade_type + + integer, public, parameter :: i_atm = 0 ! for terminal pools (i.e. 100% respiration) (only used for CN not for BGC) + + type(decomp_cascade_type), public, target :: decomp_cascade_con + !------------------------------------------------------------------------ + +contains + + + + !------------------------------------------------------------------------ + subroutine init_decomp_cascade_constants( use_century_decomp ) + ! + ! !DESCRIPTION: + ! Initialize decomposition cascade state + !------------------------------------------------------------------------ + ! !ARGUMENTS: + logical, intent(IN) :: use_century_decomp + ! !LOGAL VARIABLES: + integer :: ibeg ! Beginning index for allocated arrays + !------------------------------------- + + if ( use_century_decomp ) then + ibeg = 1 + else + ibeg = i_atm + end if + !-- properties of each pathway along decomposition cascade + allocate(decomp_cascade_con%cascade_step_name(1:ndecomp_cascade_transitions)) + allocate(decomp_cascade_con%cascade_donor_pool(1:ndecomp_cascade_transitions)) + allocate(decomp_cascade_con%cascade_receiver_pool(1:ndecomp_cascade_transitions)) + + + !-- properties of each decomposing pool + allocate(decomp_cascade_con%floating_cn_ratio_decomp_pools(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%decomp_pool_name_restart(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%decomp_pool_name_history(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%decomp_pool_name_long(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%decomp_pool_name_short(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%is_litter(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%is_soil(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%is_cwd(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%initial_cn_ratio(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%initial_stock(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%is_metabolic(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%is_cellulose(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%is_lignin(ibeg:ndecomp_pools)) + allocate(decomp_cascade_con%spinup_factor(1:ndecomp_pools)) + + if(use_soil_matrixcn)then + allocate(decomp_cascade_con%spm_tranlist_a(1:nlevdecomp,1:ndecomp_cascade_transitions)); decomp_cascade_con%spm_tranlist_a(:,:) = -9999 + allocate(decomp_cascade_con%A_i(1:(ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp));decomp_cascade_con%A_i(:) = -9999 + allocate(decomp_cascade_con%A_j(1:(ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp));decomp_cascade_con%A_j(:) = -9999 + allocate(decomp_cascade_con%tri_i(1:(3*nlevdecomp-2)*(ndecomp_pools-1))); decomp_cascade_con%tri_i(:) = -9999 + allocate(decomp_cascade_con%tri_j(1:(3*nlevdecomp-2)*(ndecomp_pools-1))); decomp_cascade_con%tri_j(:) = -9999 + end if + + !-- properties of each pathway along decomposition cascade + decomp_cascade_con%cascade_step_name(1:ndecomp_cascade_transitions) = '' + decomp_cascade_con%cascade_donor_pool(1:ndecomp_cascade_transitions) = 0 + decomp_cascade_con%cascade_receiver_pool(1:ndecomp_cascade_transitions) = 0 + + + !-- first initialization of properties of each decomposing pool + decomp_cascade_con%floating_cn_ratio_decomp_pools(ibeg:ndecomp_pools) = .false. + decomp_cascade_con%decomp_pool_name_history(ibeg:ndecomp_pools) = '' + decomp_cascade_con%decomp_pool_name_restart(ibeg:ndecomp_pools) = '' + decomp_cascade_con%decomp_pool_name_long(ibeg:ndecomp_pools) = '' + decomp_cascade_con%decomp_pool_name_short(ibeg:ndecomp_pools) = '' + decomp_cascade_con%is_litter(ibeg:ndecomp_pools) = .false. + decomp_cascade_con%is_soil(ibeg:ndecomp_pools) = .false. + decomp_cascade_con%is_cwd(ibeg:ndecomp_pools) = .false. + decomp_cascade_con%initial_cn_ratio(ibeg:ndecomp_pools) = nan + decomp_cascade_con%initial_stock(ibeg:ndecomp_pools) = nan + decomp_cascade_con%initial_stock_soildepth = 0.3 + decomp_cascade_con%is_metabolic(ibeg:ndecomp_pools) = .false. + decomp_cascade_con%is_cellulose(ibeg:ndecomp_pools) = .false. + decomp_cascade_con%is_lignin(ibeg:ndecomp_pools) = .false. + decomp_cascade_con%spinup_factor(1:ndecomp_pools) = nan + + if(use_soil_matrixcn)then + decomp_cascade_con%Ntrans_setup = (ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp + decomp_cascade_con%Ntri_setup = (3*nlevdecomp-2)*(ndecomp_pools - 1) !exclude one cwd + else + decomp_cascade_con%Ntrans_setup = -9999 + decomp_cascade_con%Ntri_setup = -9999 + end if + end subroutine init_decomp_cascade_constants + +end module SoilBiogeochemDecompCascadeConType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemNitrogenFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemNitrogenFluxType.F90 new file mode 100755 index 000000000..df2af17a6 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemNitrogenFluxType.F90 @@ -0,0 +1,621 @@ +module SoilBiogeochemNitrogenFluxType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, ndecomp_cascade_outtransitions + use clm_varpar , only : nlevdecomp_full, nlevdecomp, ndecomp_pools_vr + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_crop, use_soil_matrixcn + use clm_varcon , only : spval, dzsoi_decomp + use decompMod , only : bounds_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: SoilBiogeochem_nitrogenflux_type + + ! deposition fluxes + real(r8), pointer :: ndep_to_sminn_col (:) ! col atmospheric N deposition to soil mineral N (gN/m2/s) + real(r8), pointer :: nfix_to_sminn_col (:) ! col symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) + real(r8), pointer :: ffix_to_sminn_col (:) ! col free living N fixation to soil mineral N (gN/m2/s) + real(r8), pointer :: fert_to_sminn_col (:) ! col fertilizer N to soil mineral N (gN/m2/s) + real(r8), pointer :: soyfixn_to_sminn_col (:) ! col soybean fixation to soil mineral N (gN/m2/s) + + ! decomposition fluxes + real(r8), pointer :: decomp_cascade_ntransfer_vr_col (:,:,:) ! col vert-res transfer of N from donor to receiver pool along decomp. cascade (gN/m3/s) + real(r8), pointer :: decomp_cascade_ntransfer_col (:,:) ! col vert-int (diagnostic) transfer of N from donor to receiver pool along decomp. cascade (gN/m2/s) + real(r8), pointer :: decomp_cascade_sminn_flux_vr_col (:,:,:) ! col vert-res mineral N flux for transition along decomposition cascade (gN/m3/s) + real(r8), pointer :: decomp_cascade_sminn_flux_col (:,:) ! col vert-int (diagnostic) mineral N flux for transition along decomposition cascade (gN/m2/s) + + ! Used to update concentrations concurrently with vertical transport + ! vertically-resolved immobilization fluxes + real(r8), pointer :: potential_immob_vr_col (:,:) ! col vertically-resolved potential N immobilization (gN/m3/s) at each level + real(r8), pointer :: potential_immob_col (:) ! col vert-int (diagnostic) potential N immobilization (gN/m2/s) + real(r8), pointer :: actual_immob_vr_col (:,:) ! col vertically-resolved actual N immobilization (gN/m3/s) at each level + real(r8), pointer :: actual_immob_col (:) ! col vert-int (diagnostic) actual N immobilization (gN/m2/s) + real(r8), pointer :: sminn_to_plant_vr_col (:,:) ! col vertically-resolved plant uptake of soil mineral N (gN/m3/s) + real(r8), pointer :: sminn_to_plant_col (:) ! col vert-int (diagnostic) plant uptake of soil mineral N (gN/m2/s) + real(r8), pointer :: supplement_to_sminn_vr_col (:,:) ! col vertically-resolved supplemental N supply (gN/m3/s) + real(r8), pointer :: supplement_to_sminn_col (:) ! col vert-int (diagnostic) supplemental N supply (gN/m2/s) + real(r8), pointer :: gross_nmin_vr_col (:,:) ! col vertically-resolved gross rate of N mineralization (gN/m3/s) + real(r8), pointer :: gross_nmin_col (:) ! col vert-int (diagnostic) gross rate of N mineralization (gN/m2/s) + real(r8), pointer :: net_nmin_vr_col (:,:) ! col vertically-resolved net rate of N mineralization (gN/m3/s) + real(r8), pointer :: net_nmin_col (:) ! col vert-int (diagnostic) net rate of N mineralization (gN/m2/s) + real(r8), pointer :: sminn_to_plant_fun_col (:) ! col total soil N uptake of FUN (gN/m2/s) + ! ---------- NITRIF_DENITRIF --------------------- + + ! nitrification / denitrification fluxes + real(r8), pointer :: f_nit_vr_col (:,:) ! col (gN/m3/s) soil nitrification flux + real(r8), pointer :: f_denit_vr_col (:,:) ! col (gN/m3/s) soil denitrification flux + real(r8), pointer :: f_nit_col (:) ! col (gN/m2/s) soil nitrification flux + real(r8), pointer :: f_denit_col (:) ! col (gN/m2/s) soil denitrification flux + + real(r8), pointer :: pot_f_nit_vr_col (:,:) ! col (gN/m3/s) potential soil nitrification flux + real(r8), pointer :: pot_f_denit_vr_col (:,:) ! col (gN/m3/s) potential soil denitrification flux + real(r8), pointer :: pot_f_nit_col (:) ! col (gN/m2/s) potential soil nitrification flux + real(r8), pointer :: pot_f_denit_col (:) ! col (gN/m2/s) potential soil denitrification flux + real(r8), pointer :: n2_n2o_ratio_denit_vr_col (:,:) ! col ratio of N2 to N2O production by denitrification [gN/gN] + real(r8), pointer :: f_n2o_denit_vr_col (:,:) ! col flux of N2o from denitrification [gN/m^3/s] + real(r8), pointer :: f_n2o_denit_col (:) ! col flux of N2o from denitrification [gN/m^2/s] + real(r8), pointer :: f_n2o_nit_vr_col (:,:) ! col flux of N2o from nitrification [gN/m^3/s] + real(r8), pointer :: f_n2o_nit_col (:) ! col flux of N2o from nitrification [gN/m^2/s] + + ! immobilization / uptake fluxes + real(r8), pointer :: actual_immob_no3_vr_col (:,:) ! col vertically-resolved actual immobilization of NO3 (gN/m3/s) + real(r8), pointer :: actual_immob_nh4_vr_col (:,:) ! col vertically-resolved actual immobilization of NH4 (gN/m3/s) + real(r8), pointer :: smin_no3_to_plant_vr_col (:,:) ! col vertically-resolved plant uptake of soil NO3 (gN/m3/s) + real(r8), pointer :: smin_nh4_to_plant_vr_col (:,:) ! col vertically-resolved plant uptake of soil NH4 (gN/m3/s) + real(r8), pointer :: actual_immob_no3_col (:) ! col actual immobilization of NO3 (gN/m2/s) + real(r8), pointer :: actual_immob_nh4_col (:) ! col actual immobilization of NH4 (gN/m2/s) + real(r8), pointer :: smin_no3_to_plant_col (:) ! col plant uptake of soil NO3 (gN/m2/s) + real(r8), pointer :: smin_nh4_to_plant_col (:) ! col plant uptake of soil Nh4 (gN/m2/s) + + ! leaching fluxes + real(r8), pointer :: smin_no3_leached_vr_col (:,:) ! col vertically-resolved soil mineral NO3 loss to leaching (gN/m3/s) + real(r8), pointer :: smin_no3_leached_col (:) ! col soil mineral NO3 pool loss to leaching (gN/m2/s) + real(r8), pointer :: smin_no3_runoff_vr_col (:,:) ! col vertically-resolved rate of mineral NO3 loss with runoff (gN/m3/s) + real(r8), pointer :: smin_no3_runoff_col (:) ! col soil mineral NO3 pool loss to runoff (gN/m2/s) + + ! nitrification /denitrification diagnostic quantities + real(r8), pointer :: smin_no3_massdens_vr_col (:,:) ! col (ugN / g soil) soil nitrate concentration + real(r8), pointer :: soil_bulkdensity_col (:,:) ! col (kg soil / m3) bulk density of soil + real(r8), pointer :: k_nitr_t_vr_col (:,:) + real(r8), pointer :: k_nitr_ph_vr_col (:,:) + real(r8), pointer :: k_nitr_h2o_vr_col (:,:) + real(r8), pointer :: k_nitr_vr_col (:,:) + real(r8), pointer :: wfps_vr_col (:,:) + real(r8), pointer :: fmax_denit_carbonsubstrate_vr_col (:,:) + real(r8), pointer :: fmax_denit_nitrate_vr_col (:,:) + real(r8), pointer :: f_denit_base_vr_col (:,:) ! col nitrification and denitrification fluxes + real(r8), pointer :: diffus_col (:,:) ! col diffusivity (m2/s) + real(r8), pointer :: ratio_k1_col (:,:) + real(r8), pointer :: ratio_no3_co2_col (:,:) + real(r8), pointer :: soil_co2_prod_col (:,:) + real(r8), pointer :: fr_WFPS_col (:,:) + + real(r8), pointer :: r_psi_col (:,:) + real(r8), pointer :: anaerobic_frac_col (:,:) + real(r8), pointer :: sminn_to_plant_fun_no3_vr_col (:,:) ! col total layer no3 uptake of FUN (gN/m2/s) + real(r8), pointer :: sminn_to_plant_fun_nh4_vr_col (:,:) ! col total layer nh4 uptake of FUN (gN/m2/s) + !----------- no NITRIF_DENITRIF-------------- + + + ! denitrification fluxes + real(r8), pointer :: sminn_to_denit_decomp_cascade_vr_col (:,:,:) ! col vertically-resolved denitrification along decomp cascade (gN/m3/s) + real(r8), pointer :: sminn_to_denit_decomp_cascade_col (:,:) ! col vertically-integrated (diagnostic) denitrification along decomp cascade (gN/m2/s) + real(r8), pointer :: sminn_to_denit_excess_vr_col (:,:) ! col vertically-resolved denitrification from excess mineral N pool (gN/m3/s) + real(r8), pointer :: sminn_to_denit_excess_col (:) ! col vertically-integrated (diagnostic) denitrification from excess mineral N pool (gN/m2/s) + + ! leaching fluxes + real(r8), pointer :: sminn_leached_vr_col (:,:) ! col vertically-resolved soil mineral N pool loss to leaching (gN/m3/s) + real(r8), pointer :: sminn_leached_col (:) ! col soil mineral N pool loss to leaching (gN/m2/s) + + ! summary (diagnostic) flux variables, not involved in mass balance + real(r8), pointer :: denit_col (:) ! col total rate of denitrification (gN/m2/s) + real(r8), pointer :: ninputs_col (:) ! col column-level N inputs (gN/m2/s) + real(r8), pointer :: noutputs_col (:) ! col column-level N outputs (gN/m2/s) + real(r8), pointer :: som_n_leached_col (:) ! col total SOM N loss from vertical transport (gN/m^2/s) + real(r8), pointer :: decomp_npools_leached_col (:,:) ! col N loss from vertical transport from each decomposing N pool (gN/m^2/s) + real(r8), pointer :: decomp_npools_transport_tendency_col (:,:,:) ! col N tendency due to vertical transport in decomposing N pools (gN/m^3/s) + + ! all n pools involved in decomposition + real(r8), pointer :: decomp_npools_sourcesink_col (:,:,:) ! col (gN/m3) change in decomposing n pools + ! (sum of all additions and subtractions from stateupdate1). + real(r8), pointer :: sminn_to_plant_fun_vr_col (:,:) ! col total layer soil N uptake of FUN (gN/m2/s) + + ! track tradiagonal matrix +! type(sparse_matrix_type) :: AKsoiln ! A*K for N transfers between pools +! type(sparse_matrix_type) :: AKallsoiln ! (A*K+V-Kfire) for soil N cycle + integer :: NE_AKallsoiln ! Number of non-zero entries in AKallsoiln. Automatically generated by functions SPMP_* + integer,pointer,dimension(:) :: RI_AKallsoiln ! Row numbers of entries in AKallsoiln. Automatically generated by functions in SPMP_* + integer,pointer,dimension(:) :: CI_AKallsoiln ! Column numbers of entries in AKallsoiln, Automatically generated by functions in SPMP_* + integer,pointer,dimension(:) :: RI_na ! Row numbers of all entries from AKsoiln. Automatically generated by SetValueA + integer,pointer,dimension(:) :: CI_na ! Column numbers of all entries from AKsoiln. Automatically generated by SetValueA +! type(vector_type) :: matrix_Ninput ! N input to different soil compartments (pools and layers) (gN/m3/step) + + contains + + procedure , public :: SetValues + procedure , public :: Summary + procedure , public :: Init + + end type soilbiogeochem_nitrogenflux_type + type(soilbiogeochem_nitrogenflux_type), public, target, save :: soilbiogeochem_nitrogenflux_inst + +contains + +!-------------------------------------------------------------- + subroutine Init(this, bounds) + + !ARGUMENTS + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(soilbiogeochem_nitrogenflux_type) :: this + ! + ! !LOCAL VARIABLES: + integer :: begc,endc,Ntrans,Ntrans_diag + !------------------------------------------------------------------------ + + begc = bounds%begc; endc = bounds%endc + allocate(this%ndep_to_sminn_col (begc:endc)) ; this%ndep_to_sminn_col (:) = nan + allocate(this%nfix_to_sminn_col (begc:endc)) ; this%nfix_to_sminn_col (:) = nan + allocate(this%ffix_to_sminn_col (begc:endc)) ; this%ffix_to_sminn_col (:) = nan + allocate(this%fert_to_sminn_col (begc:endc)) ; this%fert_to_sminn_col (:) = nan + allocate(this%soyfixn_to_sminn_col (begc:endc)) ; this%soyfixn_to_sminn_col (:) = nan + allocate(this%sminn_to_plant_col (begc:endc)) ; this%sminn_to_plant_col (:) = nan + allocate(this%potential_immob_col (begc:endc)) ; this%potential_immob_col (:) = nan + allocate(this%actual_immob_col (begc:endc)) ; this%actual_immob_col (:) = nan + allocate(this%gross_nmin_col (begc:endc)) ; this%gross_nmin_col (:) = nan + allocate(this%net_nmin_col (begc:endc)) ; this%net_nmin_col (:) = nan + allocate(this%denit_col (begc:endc)) ; this%denit_col (:) = nan + allocate(this%supplement_to_sminn_col (begc:endc)) ; this%supplement_to_sminn_col (:) = nan + allocate(this%ninputs_col (begc:endc)) ; this%ninputs_col (:) = nan + allocate(this%noutputs_col (begc:endc)) ; this%noutputs_col (:) = nan + allocate(this%som_n_leached_col (begc:endc)) ; this%som_n_leached_col (:) = nan + + + allocate(this%r_psi_col (begc:endc,1:nlevdecomp_full)) ; this%r_psi_col (:,:) = spval + allocate(this%anaerobic_frac_col (begc:endc,1:nlevdecomp_full)) ; this%anaerobic_frac_col (:,:) = spval + allocate(this%potential_immob_vr_col (begc:endc,1:nlevdecomp_full)) ; this%potential_immob_vr_col (:,:) = nan + allocate(this%actual_immob_vr_col (begc:endc,1:nlevdecomp_full)) ; this%actual_immob_vr_col (:,:) = nan + allocate(this%sminn_to_plant_vr_col (begc:endc,1:nlevdecomp_full)) ; this%sminn_to_plant_vr_col (:,:) = nan + allocate(this%supplement_to_sminn_vr_col (begc:endc,1:nlevdecomp_full)) ; this%supplement_to_sminn_vr_col (:,:) = nan + allocate(this%gross_nmin_vr_col (begc:endc,1:nlevdecomp_full)) ; this%gross_nmin_vr_col (:,:) = nan + allocate(this%net_nmin_vr_col (begc:endc,1:nlevdecomp_full)) ; this%net_nmin_vr_col (:,:) = nan + allocate(this%sminn_to_plant_fun_col (begc:endc)) ; this%sminn_to_plant_fun_col (:) = nan + allocate(this%sminn_to_plant_fun_vr_col (begc:endc,1:nlevdecomp_full)) ; this%sminn_to_plant_fun_vr_col (:,:) = nan + allocate(this%sminn_to_plant_fun_no3_vr_col (begc:endc,1:nlevdecomp_full)) ; this%sminn_to_plant_fun_no3_vr_col(:,:) = nan + allocate(this%sminn_to_plant_fun_nh4_vr_col (begc:endc,1:nlevdecomp_full)) ; this%sminn_to_plant_fun_nh4_vr_col(:,:) = nan + allocate(this%f_nit_vr_col (begc:endc,1:nlevdecomp_full)) ; this%f_nit_vr_col (:,:) = nan + allocate(this%f_denit_vr_col (begc:endc,1:nlevdecomp_full)) ; this%f_denit_vr_col (:,:) = nan + allocate(this%smin_no3_leached_vr_col (begc:endc,1:nlevdecomp_full)) ; this%smin_no3_leached_vr_col (:,:) = nan + allocate(this%smin_no3_leached_col (begc:endc)) ; this%smin_no3_leached_col (:) = nan + allocate(this%smin_no3_runoff_vr_col (begc:endc,1:nlevdecomp_full)) ; this%smin_no3_runoff_vr_col (:,:) = nan + allocate(this%smin_no3_runoff_col (begc:endc)) ; this%smin_no3_runoff_col (:) = nan + allocate(this%pot_f_nit_vr_col (begc:endc,1:nlevdecomp_full)) ; this%pot_f_nit_vr_col (:,:) = nan + allocate(this%pot_f_nit_col (begc:endc)) ; this%pot_f_nit_col (:) = nan + allocate(this%pot_f_denit_vr_col (begc:endc,1:nlevdecomp_full)) ; this%pot_f_denit_vr_col (:,:) = nan + allocate(this%pot_f_denit_col (begc:endc)) ; this%pot_f_denit_col (:) = nan + allocate(this%actual_immob_no3_vr_col (begc:endc,1:nlevdecomp_full)) ; this%actual_immob_no3_vr_col (:,:) = nan + allocate(this%actual_immob_nh4_vr_col (begc:endc,1:nlevdecomp_full)) ; this%actual_immob_nh4_vr_col (:,:) = nan + allocate(this%smin_no3_to_plant_vr_col (begc:endc,1:nlevdecomp_full)) ; this%smin_no3_to_plant_vr_col (:,:) = nan + allocate(this%smin_nh4_to_plant_vr_col (begc:endc,1:nlevdecomp_full)) ; this%smin_nh4_to_plant_vr_col (:,:) = nan + allocate(this%f_nit_col (begc:endc)) ; this%f_nit_col (:) = nan + allocate(this%f_denit_col (begc:endc)) ; this%f_denit_col (:) = nan + allocate(this%n2_n2o_ratio_denit_vr_col (begc:endc,1:nlevdecomp_full)) ; this%n2_n2o_ratio_denit_vr_col (:,:) = nan + allocate(this%f_n2o_denit_col (begc:endc)) ; this%f_n2o_denit_col (:) = nan + allocate(this%f_n2o_denit_vr_col (begc:endc,1:nlevdecomp_full)) ; this%f_n2o_denit_vr_col (:,:) = nan + allocate(this%f_n2o_nit_col (begc:endc)) ; this%f_n2o_nit_col (:) = nan + allocate(this%f_n2o_nit_vr_col (begc:endc,1:nlevdecomp_full)) ; this%f_n2o_nit_vr_col (:,:) = nan + + + allocate(this%smin_no3_massdens_vr_col (begc:endc,1:nlevdecomp_full)) ; this%smin_no3_massdens_vr_col (:,:) = nan + allocate(this%soil_bulkdensity_col (begc:endc,1:nlevdecomp_full)) ; this%soil_bulkdensity_col (:,:) = nan + allocate(this%k_nitr_t_vr_col (begc:endc,1:nlevdecomp_full)) ; this%k_nitr_t_vr_col (:,:) = nan + allocate(this%k_nitr_ph_vr_col (begc:endc,1:nlevdecomp_full)) ; this%k_nitr_ph_vr_col (:,:) = nan + allocate(this%k_nitr_h2o_vr_col (begc:endc,1:nlevdecomp_full)) ; this%k_nitr_h2o_vr_col (:,:) = nan + allocate(this%k_nitr_vr_col (begc:endc,1:nlevdecomp_full)) ; this%k_nitr_vr_col (:,:) = nan + allocate(this%wfps_vr_col (begc:endc,1:nlevdecomp_full)) ; this%wfps_vr_col (:,:) = nan + allocate(this%f_denit_base_vr_col (begc:endc,1:nlevdecomp_full)) ; this%f_denit_base_vr_col (:,:) = nan + allocate(this%diffus_col (begc:endc,1:nlevdecomp_full)) ; this%diffus_col (:,:) = spval + allocate(this%ratio_k1_col (begc:endc,1:nlevdecomp_full)) ; this%ratio_k1_col (:,:) = nan + allocate(this%ratio_no3_co2_col (begc:endc,1:nlevdecomp_full)) ; this%ratio_no3_co2_col (:,:) = spval + allocate(this%soil_co2_prod_col (begc:endc,1:nlevdecomp_full)) ; this%soil_co2_prod_col (:,:) = nan + allocate(this%fr_WFPS_col (begc:endc,1:nlevdecomp_full)) ; this%fr_WFPS_col (:,:) = spval + + allocate(this%fmax_denit_carbonsubstrate_vr_col (begc:endc,1:nlevdecomp_full)) ; + this%fmax_denit_carbonsubstrate_vr_col (:,:) = nan + allocate(this%fmax_denit_nitrate_vr_col (begc:endc,1:nlevdecomp_full)) ; + this%fmax_denit_nitrate_vr_col (:,:) = nan + + allocate(this%decomp_cascade_ntransfer_vr_col (begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions )) + allocate(this%decomp_cascade_sminn_flux_vr_col (begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions )) + allocate(this%decomp_cascade_ntransfer_col (begc:endc,1:ndecomp_cascade_transitions )) + allocate(this%decomp_cascade_sminn_flux_col (begc:endc,1:ndecomp_cascade_transitions )) + + this%decomp_cascade_ntransfer_vr_col (:,:,:) = nan + this%decomp_cascade_sminn_flux_vr_col (:,:,:) = nan + this%decomp_cascade_ntransfer_col (:,:) = nan + this%decomp_cascade_sminn_flux_col (:,:) = nan + + allocate(this%sminn_to_denit_decomp_cascade_vr_col (begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions )) + allocate(this%sminn_to_denit_decomp_cascade_col (begc:endc,1:ndecomp_cascade_transitions )) + allocate(this%sminn_to_denit_excess_vr_col (begc:endc,1:nlevdecomp_full )) + allocate(this%sminn_to_denit_excess_col (begc:endc )) + allocate(this%sminn_leached_vr_col (begc:endc,1:nlevdecomp_full )) + allocate(this%sminn_leached_col (begc:endc )) + allocate(this%decomp_npools_leached_col (begc:endc,1:ndecomp_pools )) + allocate(this%decomp_npools_transport_tendency_col (begc:endc,1:nlevdecomp_full,1:ndecomp_pools )) + + this%sminn_to_denit_decomp_cascade_vr_col (:,:,:) = nan + this%sminn_to_denit_decomp_cascade_col (:,:) = nan + this%sminn_to_denit_excess_vr_col (:,:) = nan + this%sminn_to_denit_excess_col (:) = nan + this%sminn_leached_vr_col (:,:) = nan + this%sminn_leached_col (:) = nan + this%decomp_npools_leached_col (:,:) = nan + this%decomp_npools_transport_tendency_col (:,:,:) = nan + + allocate(this%decomp_npools_sourcesink_col (begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%decomp_npools_sourcesink_col (:,:,:) = nan + if(use_soil_matrixcn)then + + Ntrans = (ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp + ! call this%AKsoiln%InitSM (ndecomp_pools*nlevdecomp,begc,endc,Ntrans+ndecomp_pools*nlevdecomp) + ! call this%AKallsoiln%InitSM (ndecomp_pools*nlevdecomp,begc,endc,Ntrans+decomp_cascade_con%Ntri_setup+nlevdecomp) + this%NE_AKallsoiln = (Ntrans+nlevdecomp*ndecomp_pools) + (Ntrans+decomp_cascade_con%Ntri_setup + nlevdecomp) + (ndecomp_pools*nlevdecomp) + allocate(this%RI_AKallsoiln(1:this%NE_AKallsoiln)); this%RI_AKallsoiln(1:this%NE_AKallsoiln)=-9999 + allocate(this%CI_AKallsoiln(1:this%NE_AKallsoiln)); this%CI_AKallsoiln(1:this%NE_AKallsoiln)=-9999 + Ntrans_diag = (ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp+ndecomp_pools_vr + allocate(this%RI_na(1:Ntrans_diag)); this%RI_na(1:Ntrans_diag) = -9999 + allocate(this%CI_na(1:Ntrans_diag)); this%CI_na(1:Ntrans_diag) = -9999 + ! call this%matrix_Ninput%InitV (ndecomp_pools*nlevdecomp,begc,endc) + end if + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine SetValues ( this, & + num_column, filter_column, value_column) + ! + ! !DESCRIPTION: + ! Set nitrogen flux variables + ! + ! !ARGUMENTS: + ! !ARGUMENTS: + class(soilbiogeochem_nitrogenflux_type) :: this + integer , intent(in) :: num_column + integer , intent(in) :: filter_column(:) + real(r8), intent(in) :: value_column + ! + ! !LOCAL VARIABLES: + integer :: fi,i,j,k,l ! loop index + !------------------------------------------------------------------------ + + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + + if (.not. use_nitrif_denitrif) then + this%sminn_to_denit_excess_vr_col(i,j) = value_column + this%sminn_leached_vr_col(i,j) = value_column + this%sminn_to_plant_fun_vr_col(i,j) = value_column + else + this%f_nit_vr_col(i,j) = value_column + this%f_denit_vr_col(i,j) = value_column + this%smin_no3_leached_vr_col(i,j) = value_column + this%smin_no3_runoff_vr_col(i,j) = value_column + this%n2_n2o_ratio_denit_vr_col(i,j) = value_column + this%pot_f_nit_vr_col(i,j) = value_column + this%pot_f_denit_vr_col(i,j) = value_column + this%actual_immob_no3_vr_col(i,j) = value_column + this%actual_immob_nh4_vr_col(i,j) = value_column + this%smin_no3_to_plant_vr_col(i,j) = value_column + this%smin_nh4_to_plant_vr_col(i,j) = value_column + this%f_n2o_denit_vr_col(i,j) = value_column + this%f_n2o_nit_vr_col(i,j) = value_column + + this%smin_no3_massdens_vr_col(i,j) = value_column + this%k_nitr_t_vr_col(i,j) = value_column + this%k_nitr_ph_vr_col(i,j) = value_column + this%k_nitr_h2o_vr_col(i,j) = value_column + this%k_nitr_vr_col(i,j) = value_column + this%wfps_vr_col(i,j) = value_column + this%fmax_denit_carbonsubstrate_vr_col(i,j) = value_column + this%fmax_denit_nitrate_vr_col(i,j) = value_column + this%f_denit_base_vr_col(i,j) = value_column + + this%diffus_col(i,j) = value_column + this%ratio_k1_col(i,j) = value_column + this%ratio_no3_co2_col(i,j) = value_column + this%soil_co2_prod_col(i,j) = value_column + this%fr_WFPS_col(i,j) = value_column + this%soil_bulkdensity_col(i,j) = value_column + + this%r_psi_col(i,j) = value_column + this%anaerobic_frac_col(i,j) = value_column + end if + this%potential_immob_vr_col(i,j) = value_column + this%actual_immob_vr_col(i,j) = value_column + this%sminn_to_plant_vr_col(i,j) = value_column + this%supplement_to_sminn_vr_col(i,j) = value_column + this%gross_nmin_vr_col(i,j) = value_column + this%net_nmin_vr_col(i,j) = value_column + this%sminn_to_plant_fun_no3_vr_col(i,j) = value_column + this%sminn_to_plant_fun_nh4_vr_col(i,j) = value_column + end do + end do + + + do fi = 1,num_column + i = filter_column(fi) + + this%ndep_to_sminn_col(i) = value_column + this%nfix_to_sminn_col(i) = value_column + this%ffix_to_sminn_col(i) = value_column + this%fert_to_sminn_col(i) = value_column + this%soyfixn_to_sminn_col(i) = value_column + this%potential_immob_col(i) = value_column + this%actual_immob_col(i) = value_column + this%sminn_to_plant_col(i) = value_column + this%supplement_to_sminn_col(i) = value_column + this%gross_nmin_col(i) = value_column + this%net_nmin_col(i) = value_column + this%denit_col(i) = value_column + this%sminn_to_plant_fun_col(i) = value_column + if (use_nitrif_denitrif) then + this%f_nit_col(i) = value_column + this%pot_f_nit_col(i) = value_column + this%f_denit_col(i) = value_column + this%pot_f_denit_col(i) = value_column + this%f_n2o_denit_col(i) = value_column + this%f_n2o_nit_col(i) = value_column + this%smin_no3_leached_col(i) = value_column + this%smin_no3_runoff_col(i) = value_column + else + this%sminn_to_denit_excess_col(i) = value_column + this%sminn_leached_col(i) = value_column + end if + this%ninputs_col(i) = value_column + this%noutputs_col(i) = value_column + this%som_n_leached_col(i) = value_column + end do + + do k = 1, ndecomp_pools + do fi = 1,num_column + i = filter_column(fi) + this%decomp_npools_leached_col(i,k) = value_column + end do + end do + + if(use_soil_matrixcn)then +! call this%matrix_Ninput%SetValueV_scaler(num_column,filter_column(1:num_column),value_column) + end if + + + do k = 1, ndecomp_pools + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%decomp_npools_transport_tendency_col(i,j,k) = value_column + end do + end do + end do + + do l = 1, ndecomp_cascade_transitions + do fi = 1,num_column + i = filter_column(fi) + this%decomp_cascade_ntransfer_col(i,l) = value_column + this%decomp_cascade_sminn_flux_col(i,l) = value_column + if (.not. use_nitrif_denitrif) then + this%sminn_to_denit_decomp_cascade_col(i,l) = value_column + end if + end do + end do + + do l = 1, ndecomp_cascade_transitions + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%decomp_cascade_ntransfer_vr_col(i,j,l) = value_column + this%decomp_cascade_sminn_flux_vr_col(i,j,l) = value_column + if (.not. use_nitrif_denitrif) then + this%sminn_to_denit_decomp_cascade_vr_col(i,j,l) = value_column + end if + end do + end do + end do + + do k = 1, ndecomp_pools + do j = 1, nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%decomp_npools_sourcesink_col(i,j,k) = value_column + end do + end do + end do + + end subroutine SetValues + + !----------------------------------------------------------------------- + subroutine Summary(this, bounds, num_soilc, filter_soilc) + ! + ! !USES: + use clm_varpar , only: nlevdecomp, ndecomp_cascade_transitions,ndecomp_pools + use clm_varctl , only: use_nitrif_denitrif + ! + ! !ARGUMENTS: + class (soilbiogeochem_nitrogenflux_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + ! + ! !LOCAL VARIABLES: + integer :: c,j,k,l ! indices + integer :: fc ! filter indices + !----------------------------------------------------------------------- + + do fc = 1,num_soilc + c = filter_soilc(fc) + this%denit_col(c) = 0._r8 + this%supplement_to_sminn_col(c) = 0._r8 + this%som_n_leached_col(c) = 0._r8 + end do + + ! vertically integrate decomposing N cascade fluxes and soil mineral N fluxes associated with decomposition cascade + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + this%decomp_cascade_ntransfer_col(c,k) = & + this%decomp_cascade_ntransfer_col(c,k) + & + this%decomp_cascade_ntransfer_vr_col(c,j,k) * dzsoi_decomp(j) + + this%decomp_cascade_sminn_flux_col(c,k) = & + this%decomp_cascade_sminn_flux_col(c,k) + & + this%decomp_cascade_sminn_flux_vr_col(c,j,k) * dzsoi_decomp(j) + end do + end do + end do + + if (.not. use_nitrif_denitrif) then + + ! vertically integrate each denitrification flux + do l = 1, ndecomp_cascade_transitions + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%sminn_to_denit_decomp_cascade_col(c,l) = & + this%sminn_to_denit_decomp_cascade_col(c,l) + & + this%sminn_to_denit_decomp_cascade_vr_col(c,j,l) * dzsoi_decomp(j) + end do + end do + end do + + ! vertically integrate bulk denitrification and leaching flux + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%sminn_to_denit_excess_col(c) = & + this%sminn_to_denit_excess_col(c) + & + this%sminn_to_denit_excess_vr_col(c,j) * dzsoi_decomp(j) + + this%sminn_leached_col(c) = & + this%sminn_leached_col(c) + & + this%sminn_leached_vr_col(c,j) * dzsoi_decomp(j) + end do + end do + + + ! total N denitrification (DENIT) + do l = 1, ndecomp_cascade_transitions + do fc = 1,num_soilc + c = filter_soilc(fc) + this%denit_col(c) = & + this%denit_col(c) + & + this%sminn_to_denit_decomp_cascade_col(c,l) + end do + end do + + do fc = 1,num_soilc + c = filter_soilc(fc) + this%denit_col(c) = & + this%denit_col(c) + & + this%sminn_to_denit_excess_col(c) + end do + + else + + + ! vertically integrate NO3 NH4 N2O fluxes and pools + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! nitrification and denitrification fluxes + this%f_nit_col(c) = & + this%f_nit_col(c) + & + this%f_nit_vr_col(c,j) * dzsoi_decomp(j) + + this%f_denit_col(c) = & + this%f_denit_col(c) + & + this%f_denit_vr_col(c,j) * dzsoi_decomp(j) + + this%pot_f_nit_col(c) = & + this%pot_f_nit_col(c) + & + this%pot_f_nit_vr_col(c,j) * dzsoi_decomp(j) + + this%pot_f_denit_col(c) = & + this%pot_f_denit_col(c) + & + this%pot_f_denit_vr_col(c,j) * dzsoi_decomp(j) + + this%f_n2o_nit_col(c) = & + this%f_n2o_nit_col(c) + & + this%f_n2o_nit_vr_col(c,j) * dzsoi_decomp(j) + + this%f_n2o_denit_col(c) = & + this%f_n2o_denit_col(c) + & + this%f_n2o_denit_vr_col(c,j) * dzsoi_decomp(j) + + ! leaching/runoff flux + this%smin_no3_leached_col(c) = & + this%smin_no3_leached_col(c) + & + this%smin_no3_leached_vr_col(c,j) * dzsoi_decomp(j) + + this%smin_no3_runoff_col(c) = & + this%smin_no3_runoff_col(c) + & + this%smin_no3_runoff_vr_col(c,j) * dzsoi_decomp(j) + + end do + end do + + do fc = 1,num_soilc + c = filter_soilc(fc) + this%denit_col(c) = this%f_denit_col(c) + end do + + end if + + ! supplementary N supplement_to_sminn + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%supplement_to_sminn_col(c) = & + this%supplement_to_sminn_col(c) + & + this%supplement_to_sminn_vr_col(c,j) * dzsoi_decomp(j) + end do + end do + + ! add up all vertical transport tendency terms and calculate total som leaching loss as the sum of these + do l = 1, ndecomp_pools + do fc = 1,num_soilc + c = filter_soilc(fc) + this%decomp_npools_leached_col(c,l) = 0._r8 + end do + + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + this%decomp_npools_leached_col(c,l) = & + this%decomp_npools_leached_col(c,l) + & + this%decomp_npools_transport_tendency_col(c,j,l) * dzsoi_decomp(j) + end do + end do + + do fc = 1,num_soilc + c = filter_soilc(fc) + this%som_n_leached_col(c) = & + this%som_n_leached_col(c) + & + this%decomp_npools_leached_col(c,l) + end do + end do + + end subroutine Summary + +end module SoilBiogeochemNitrogenFluxType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemNitrogenStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemNitrogenStateType.F90 new file mode 100755 index 000000000..cdc196e21 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemNitrogenStateType.F90 @@ -0,0 +1,455 @@ + module SoilBiogeochemNitrogenStateType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use nanMod , only : nan + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevcan + use clm_varpar , only : nlevdecomp_full, nlevdecomp, nlevsoi, & + NUM_ZON, VAR_COL + use clm_varcon , only : spval, dzsoi_decomp, zisoi + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_century_decomp, use_soil_matrixcn + use decompMod , only : bounds_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use LandunitType , only : lun + use ColumnType , only : col + use landunit_varcon , only : istcrop, istsoil + + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: soilbiogeochem_nitrogenstate_type + + real(r8), pointer :: decomp_npools_vr_col (:,:,:) ! col (gN/m3) vertically-resolved decomposing (litter, cwd, soil) N pools + real(r8), pointer :: decomp0_npools_vr_col (:,:,:) ! col (gN/m3) vertically-resolved N baseline (initial value of this year) in decomposing (litter, cwd, soil) pools in dimension (col,nlev,npools) + real(r8), pointer :: decomp_npools_vr_SASUsave_col(:,:,:) ! col (gN/m3) vertically-resolved decomposing (litter, cwd, soil) N pools + + real(r8), pointer :: decomp_soiln_vr_col (:,:) ! col (gN/m3) vertically-resolved decomposing total soil N pool + + real(r8), pointer :: sminn_vr_col (:,:) ! col (gN/m3) vertically-resolved soil mineral N + real(r8), pointer :: ntrunc_vr_col (:,:) ! col (gN/m3) vertically-resolved column-level sink for N truncation + + ! nitrif_denitrif + real(r8), pointer :: smin_no3_vr_col (:,:) ! col (gN/m3) vertically-resolved soil mineral NO3 + real(r8), pointer :: smin_no3_col (:) ! col (gN/m2) soil mineral NO3 pool + real(r8), pointer :: smin_nh4_vr_col (:,:) ! col (gN/m3) vertically-resolved soil mineral NH4 + real(r8), pointer :: smin_nh4_col (:) ! col (gN/m2) soil mineral NH4 pool + + ! summary (diagnostic) state variables, not involved in mass balance + real(r8), pointer :: decomp_npools_col (:,:) ! col (gN/m2) decomposing (litter, cwd, soil) N pools + real(r8), pointer :: decomp_npools_1m_col (:,:) ! col (gN/m2) diagnostic: decomposing (litter, cwd, soil) N pools to 1 meter + real(r8), pointer :: sminn_col (:) ! col (gN/m2) soil mineral N + real(r8), pointer :: ntrunc_col (:) ! col (gN/m2) column-level sink for N truncation + real(r8), pointer :: cwdn_col (:) ! col (gN/m2) Diagnostic: coarse woody debris N + real(r8), pointer :: totlitn_col (:) ! col (gN/m2) total litter nitrogen + real(r8), pointer :: totsomn_col (:) ! col (gN/m2) total soil organic matter nitrogen + real(r8), pointer :: totlitn_1m_col (:) ! col (gN/m2) total litter nitrogen to 1 meter + real(r8), pointer :: totsomn_1m_col (:) ! col (gN/m2) total soil organic matter nitrogen to 1 meter + real(r8), pointer :: dyn_nbal_adjustments_col (:) ! (gN/m2) adjustments to each column made in this timestep via dynamic column adjustments (note: this variable only makes sense at the column-level: it is meaningless if averaged to the gridcell-level) + + ! Track adjustments to no3 and nh4 pools separately, since those aren't included in + ! the N balance check + real(r8), pointer :: dyn_no3bal_adjustments_col (:) ! (gN/m2) NO3 adjustments to each column made in this timestep via dynamic column area adjustments (only makes sense at the column-level: meaningless if averaged to the gridcell-level) + real(r8), pointer :: dyn_nh4bal_adjustments_col (:) ! (gN/m2) NH4 adjustments to each column made in this timestep via dynamic column adjustments (only makes sense at the column-level: meaningless if averaged to the gridcell-level) + real(r8) :: totvegcthresh ! threshold for total vegetation carbon to zero out decomposition pools + + ! Matrix-cn + real(r8), pointer :: matrix_cap_decomp_npools_col (:,:) ! col (gN/m2) N capacity in decomposing (litter, cwd, soil) N pools in dimension (col,npools) + real(r8), pointer :: matrix_cap_decomp_npools_vr_col (:,:,:) ! col (gN/m3) vertically-resolved N capacity in decomposing (litter, cwd, soil) pools in dimension(col,nlev,npools) + real(r8), pointer :: in_nacc (:,:) ! col (gN/m3/yr) accumulated litter fall N input per year in dimension(col,nlev*npools) + real(r8), pointer :: in_nacc_2d (:,:,:) ! col (gN/m3/yr) accumulated litter fall N input per year in dimension(col,nlev,npools) + real(r8), pointer :: tran_nacc (:,:,:) ! col (gN/m3/yr) accumulated N transfers from j to i (col,i,j) per year in dimension(col,nlev*npools,nlev*npools) + real(r8), pointer :: vert_up_tran_nacc (:,:,:) ! col (gN/m3/yr) accumulated upward vertical N transport in dimension(col,nlev,npools) + real(r8), pointer :: vert_down_tran_nacc (:,:,:) ! col (gN/m3/yr) accumulated downward vertical N transport in dimension(col,nlev,npools) + real(r8), pointer :: exit_nacc (:,:,:) ! col (gN/m3/yr) accumulated exit N in dimension(col,nlev,npools) + real(r8), pointer :: hori_tran_nacc (:,:,:) ! col (gN/m3/yr) accumulated N transport between pools at the same level in dimension(col,nlev,ntransfers) + ! type(sparse_matrix_type) :: AKXnacc ! col (gN/m3/yr) accumulated N transfers from j to i (col,i,j) per year in dimension(col,nlev*npools,nlev*npools) in sparse matrix type + ! type(vector_type) :: matrix_Ninter ! col (gN/m3) vertically-resolved decomposing (litter, cwd, soil) N pools in dimension(col,nlev*npools) in vector type + + contains + + procedure , public :: Summary + procedure , public :: SetTotVgCThresh + procedure , public :: Init + + end type soilbiogeochem_nitrogenstate_type + type(soilbiogeochem_nitrogenstate_type), public, target, save :: soilbiogeochem_nitrogenstate_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + +!------------------------------------------- + subroutine Init(this, bounds, nch, cncol) + + ! + ! !ARGUMENTS: + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of tiles + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + class(soilbiogeochem_nitrogenstate_type) :: this + ! + ! !LOCAL VARIABLES: + integer :: begc,endc + integer :: n, nc, nz, np, l, c + integer, dimension(8) :: decomp_npool_cncol_index = (/ 18, 19, 20, 17,25, 26, 27, 28 /) + logical :: no_cn51_rst = .false. + !----------------------------------- + + begc = bounds%begc ; endc = bounds%endc + + allocate(this%sminn_vr_col (begc:endc,1:nlevdecomp_full)) ; this%sminn_vr_col (:,:) = nan + allocate(this%ntrunc_vr_col (begc:endc,1:nlevdecomp_full)) ; this%ntrunc_vr_col (:,:) = nan + allocate(this%smin_no3_vr_col (begc:endc,1:nlevdecomp_full)) ; this%smin_no3_vr_col (:,:) = nan + allocate(this%smin_nh4_vr_col (begc:endc,1:nlevdecomp_full)) ; this%smin_nh4_vr_col (:,:) = nan + allocate(this%smin_no3_col (begc:endc)) ; this%smin_no3_col (:) = nan + allocate(this%smin_nh4_col (begc:endc)) ; this%smin_nh4_col (:) = nan + allocate(this%cwdn_col (begc:endc)) ; this%cwdn_col (:) = nan + allocate(this%sminn_col (begc:endc)) ; this%sminn_col (:) = nan + allocate(this%ntrunc_col (begc:endc)) ; this%ntrunc_col (:) = nan + allocate(this%totlitn_col (begc:endc)) ; this%totlitn_col (:) = nan + allocate(this%totsomn_col (begc:endc)) ; this%totsomn_col (:) = nan + allocate(this%totlitn_1m_col (begc:endc)) ; this%totlitn_1m_col (:) = nan + allocate(this%totsomn_1m_col (begc:endc)) ; this%totsomn_1m_col (:) = nan + allocate(this%dyn_nbal_adjustments_col (begc:endc)) ; this%dyn_nbal_adjustments_col (:) = nan + allocate(this%dyn_no3bal_adjustments_col (begc:endc)) ; this%dyn_no3bal_adjustments_col (:) = nan + allocate(this%dyn_nh4bal_adjustments_col (begc:endc)) ; this%dyn_nh4bal_adjustments_col (:) = nan + allocate(this%decomp_npools_col (begc:endc,1:ndecomp_pools)) ; this%decomp_npools_col (:,:) = nan + allocate(this%decomp_npools_1m_col (begc:endc,1:ndecomp_pools)) ; this%decomp_npools_1m_col (:,:) = nan + if(use_soil_matrixcn)then + allocate(this%matrix_cap_decomp_npools_col (begc:endc,1:ndecomp_pools)) ; this%matrix_cap_decomp_npools_col (:,:) = nan + end if + + allocate(this%decomp_npools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)); + this%decomp_npools_vr_col(:,:,:)= nan + if(use_soil_matrixcn)then + allocate(this%matrix_cap_decomp_npools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)); + this%matrix_cap_decomp_npools_vr_col(:,:,:)= nan +! for matrix-spinup + allocate(this%decomp0_npools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)); + this%decomp0_npools_vr_col(:,:,:)= nan + allocate(this%decomp_npools_vr_SASUsave_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)); + this%decomp_npools_vr_SASUsave_col(:,:,:)= nan + allocate(this%in_nacc(begc:endc,1:nlevdecomp*ndecomp_pools)) + this%in_nacc(:,:)= nan + allocate(this%tran_nacc(begc:endc,1:nlevdecomp*ndecomp_pools,1:nlevdecomp*ndecomp_pools)) + this%tran_nacc(:,:,:)= nan + + allocate(this%in_nacc_2d(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%in_nacc_2d(:,:,:)= nan + allocate(this%vert_up_tran_nacc(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%vert_up_tran_nacc(:,:,:)= nan + allocate(this%vert_down_tran_nacc(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%vert_down_tran_nacc(:,:,:)= nan + allocate(this%exit_nacc(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)) + this%exit_nacc(:,:,:)= nan + allocate(this%hori_tran_nacc(begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) + this%hori_tran_nacc(:,:,:)= nan + !call this%AKXnacc%InitSM(ndecomp_pools*nlevdecomp,begc,endc,decomp_cascade_con%n_all_entries) + !call this%matrix_Ninter%InitV (ndecomp_pools*nlevdecomp,begc,endc) + end if + allocate(this%decomp_soiln_vr_col(begc:endc,1:nlevdecomp_full)) + this%decomp_soiln_vr_col(:,:)= nan + + + ! initialize variables from restart file or set to cold start value + n = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + this%ntrunc_vr_col (n,1:nlevdecomp_full) = cncol(nc,nz,16) + ! jkolassa May 2022: for now nlevdecomp_full = 1; will need to add loop if we introduce more soil layers + this%sminn_vr_col (n,1:nlevdecomp_full) = cncol(nc,nz,24) + this%sminn_col (n) = this%sminn_vr_col(n,1) + + if (no_cn51_rst) then ! jkolassa Nov 2024: when no CN51 restart file is available compute NO3 and NH4 from N + this%smin_no3_col(n) = (1.25/2.25)*this%sminn_col(n) + this%smin_nh4_col(n) = this%sminn_col(n)/2.25 + else + this%smin_no3_col(n) = cncol(nc,nz,36); + this%smin_nh4_col(n) = cncol(nc,nz,37); + end if + + this%smin_no3_vr_col(n,1:nlevdecomp_full) = this%smin_no3_col(n) + this%smin_nh4_vr_col(n,1:nlevdecomp_full) = this%smin_nh4_col(n) + + do np = 1,ndecomp_pools + ! jkolassa May 2022: accounting for fact that pool order in CNCOL is different from CTSM + this%decomp_npools_col (n,np) = cncol(nc,nz,decomp_npool_cncol_index(np)) + this%decomp_npools_1m_col (n,np) = cncol(nc,nz,decomp_npool_cncol_index(np)) + ! jkolassa May 2022: loop has to be added below if we add more biogeochemical (or soil) layers + this%decomp_npools_vr_col (n,1,np) = cncol(nc,nz,decomp_npool_cncol_index(np)) + end do !np + end do !nz + end do + + do c = begc, endc + l = col%landunit(c) + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + + this%totlitn_col(c) = 0._r8 + this%totsomn_col(c) = 0._r8 + this%totlitn_1m_col(c) = 0._r8 + this%totsomn_1m_col(c) = 0._r8 + this%cwdn_col(c) = 0._r8 + + end if + end do + + + + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine Summary(this, bounds, num_allc, filter_allc) + ! + ! !ARGUMENTS: + class (soilbiogeochem_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all active columns + ! + ! !LOCAL VARIABLES: + integer :: c,j,k,l ! indices + integer :: fc ! lake filter indices + real(r8) :: maxdepth ! depth to integrate soil variables + !----------------------------------------------------------------------- + + ! vertically integrate NO3 NH4 N2O pools + if (use_nitrif_denitrif) then + do fc = 1,num_allc + c = filter_allc(fc) + this%smin_no3_col(c) = 0._r8 + this%smin_nh4_col(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%smin_no3_col(c) = & + this%smin_no3_col(c) + & + this%smin_no3_vr_col(c,j) * dzsoi_decomp(j) + + this%smin_nh4_col(c) = & + this%smin_nh4_col(c) + & + this%smin_nh4_vr_col(c,j) * dzsoi_decomp(j) + end do + end do + + end if + + ! vertically integrate each of the decomposing N pools + do l = 1, ndecomp_pools + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_npools_col(c,l) = 0._r8 + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_col(c,l) = 0._r8 + end if + end do + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_npools_col(c,l) = & + this%decomp_npools_col(c,l) + & + this%decomp_npools_vr_col(c,j,l) * dzsoi_decomp(j) + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_col(c,l) = & + this%matrix_cap_decomp_npools_col(c,l) + & + this%matrix_cap_decomp_npools_vr_col(c,j,l) * dzsoi_decomp(j) + end if + end do + end do + end do + + ! for vertically-resolved soil biogeochemistry, calculate some diagnostics of carbon pools to a given depth + if ( nlevdecomp > 1) then + + do l = 1, ndecomp_pools + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_npools_1m_col(c,l) = 0._r8 + end do + end do + + + ! vertically integrate each of the decomposing n pools to 1 meter + maxdepth = 1._r8 + do l = 1, ndecomp_pools + do j = 1, nlevdecomp + if ( zisoi(j) <= maxdepth ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_npools_1m_col(c,l) = & + this%decomp_npools_1m_col(c,l) + & + this%decomp_npools_vr_col(c,j,l) * dzsoi_decomp(j) + end do + elseif ( zisoi(j-1) < maxdepth ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_npools_1m_col(c,l) = & + this%decomp_npools_1m_col(c,l) + & + this%decomp_npools_vr_col(c,j,l) * (maxdepth - zisoi(j-1)) + end do + endif + end do + end do + + + ! Add soil nitrogen pools together to produce vertically-resolved decomposing total soil N pool + if ( nlevdecomp_full > 1 ) then + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_soiln_vr_col(c,j) = 0._r8 + end do + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_soil(l) ) then + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%decomp_soiln_vr_col(c,j) = this%decomp_soiln_vr_col(c,j) + & + this%decomp_npools_vr_col(c,j,l) + end do + end do + end if + end do + end if + + ! total litter nitrogen to 1 meter (TOTLITN_1m) + do fc = 1,num_allc + c = filter_allc(fc) + this%totlitn_1m_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_litter(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totlitn_1m_col(c) = & + this%totlitn_1m_col(c) + & + this%decomp_npools_1m_col(c,l) + end do + end if + end do + + + ! total soil organic matter nitrogen to 1 meter (TOTSOMN_1m) + do fc = 1,num_allc + c = filter_allc(fc) + this%totsomn_1m_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_soil(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totsomn_1m_col(c) = this%totsomn_1m_col(c) + & + this%decomp_npools_1m_col(c,l) + end do + end if + end do + + endif + + ! total litter nitrogen (TOTLITN) + do fc = 1,num_allc + c = filter_allc(fc) + this%totlitn_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_litter(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totlitn_col(c) = & + this%totlitn_col(c) + & + this%decomp_npools_col(c,l) + end do + end if + end do + + + ! total soil organic matter nitrogen (TOTSOMN) + do fc = 1,num_allc + c = filter_allc(fc) + this%totsomn_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_soil(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%totsomn_col(c) = this%totsomn_col(c) + & + this%decomp_npools_col(c,l) + end do + end if + end do + + ! total cwdn + do fc = 1,num_allc + c = filter_allc(fc) + this%cwdn_col(c) = 0._r8 + end do + do l = 1, ndecomp_pools + if ( decomp_cascade_con%is_cwd(l) ) then + do fc = 1,num_allc + c = filter_allc(fc) + this%cwdn_col(c) = this%cwdn_col(c) + & + this%decomp_npools_col(c,l) + end do + end if + end do + + + ! total sminn + do fc = 1,num_allc + c = filter_allc(fc) + this%sminn_col(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%sminn_col(c) = this%sminn_col(c) + & + this%sminn_vr_col(c,j) * dzsoi_decomp(j) + end do + end do + + ! total col_ntrunc + do fc = 1,num_allc + c = filter_allc(fc) + this%ntrunc_col(c) = 0._r8 + end do + do j = 1, nlevdecomp + do fc = 1,num_allc + c = filter_allc(fc) + this%ntrunc_col(c) = this%ntrunc_col(c) + & + this%ntrunc_vr_col(c,j) * dzsoi_decomp(j) + end do + end do + + end subroutine Summary + + !------------------------------------------------------------------------ + subroutine SetTotVgCThresh(this, totvegcthresh) + + class(soilbiogeochem_nitrogenstate_type) :: this + real(r8) , intent(in) :: totvegcthresh + character(len=512) :: msg + + if ( totvegcthresh <= 0.0_r8 )then + call endrun(msg=' Error totvegcthresh is zero or negative and should be > 0'//& + errMsg(sourcefile, __LINE__)) + end if + this%totvegcthresh = totvegcthresh + + end subroutine SetTotVgCThresh + + +end module SoilBiogeochemNitrogenStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemStateType.F90 new file mode 100755 index 000000000..2fd2b29bd --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilBiogeochemStateType.F90 @@ -0,0 +1,142 @@ +#include "MAPL_Generic.h" + +module SoilBiogeochemStateType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevcan, & + nlevsno, nlevgrnd, nlevlak + use clm_varpar , only : nlevdecomp_full, nlevdecomp, nlevsoi, & + VAR_COL, VAR_PFT, num_zon, num_veg, numpft + use clm_varctl , only : use_cn + use clm_varcon , only : spval + use decompMod , only : bounds_type + use MAPL_ExceptionHandling + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + + public :: get_spinup_latitude_term + + ! !PUBLIC TYPES: + type, public :: soilbiogeochem_state_type + + real(r8) , pointer :: leaf_prof_patch (:,:) ! (1/m) profile of leaves (vertical profiles for calculating fluxes) + real(r8) , pointer :: froot_prof_patch (:,:) ! (1/m) profile of fine roots (vertical profiles for calculating fluxes) + real(r8) , pointer :: croot_prof_patch (:,:) ! (1/m) profile of coarse roots (vertical profiles for calculating fluxes) + real(r8) , pointer :: stem_prof_patch (:,:) ! (1/m) profile of stems (vertical profiles for calculating fluxes) + real(r8) , pointer :: fpi_vr_col (:,:) ! (no units) fraction of potential immobilization + real(r8) , pointer :: fpi_col (:) ! (no units) fraction of potential immobilization + real(r8), pointer :: fpg_col (:) ! (no units) fraction of potential gpp + real(r8) , pointer :: rf_decomp_cascade_col (:,:,:) ! (frac) respired fraction in decomposition step + real(r8) , pointer :: pathfrac_decomp_cascade_col (:,:,:) ! (frac) what fraction of C leaving a given pool passes through a given transition + real(r8) , pointer :: nfixation_prof_col (:,:) ! (1/m) profile for N fixation additions + real(r8) , pointer :: ndep_prof_col (:,:) ! (1/m) profile for N fixation additions + real(r8) , pointer :: som_adv_coef_col (:,:) ! (m2/s) SOM advective flux + real(r8) , pointer :: som_diffus_coef_col (:,:) ! (m2/s) SOM diffusivity due to bio/cryo-turbation + real(r8) , pointer :: plant_ndemand_col (:) ! column-level plant N demand + + contains + + procedure, public :: Init + + end type soilbiogeochem_state_type + type(soilbiogeochem_state_type), public, target, save :: soilbiogeochem_state_inst + +contains + +!--------------------------------------- + subroutine Init(this, bounds, nch, cncol, cnpft, ityp, fveg, rc) + + ! + ! !ARGUMENTS: + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,NUM_VEG,NUM_ZON),intent(in) :: ityp ! PFT index + real, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: fveg ! PFT fraction + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + real, dimension(nch,NUM_ZON,NUM_VEG,VAR_PFT), intent(in) :: cnpft ! gkw: PFT CN restart + class(soilbiogeochem_state_type) :: this + integer, optional, intent(out) :: rc + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc,endc + integer :: n, nc, nz, np, nv, p + !----------------------------------- + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + + allocate(this%leaf_prof_patch (begp:endp,1:nlevdecomp_full)) ; this%leaf_prof_patch (:,:) = spval + allocate(this%froot_prof_patch (begp:endp,1:nlevdecomp_full)) ; this%froot_prof_patch (:,:) = spval + allocate(this%croot_prof_patch (begp:endp,1:nlevdecomp_full)) ; this%croot_prof_patch (:,:) = spval + allocate(this%stem_prof_patch (begp:endp,1:nlevdecomp_full)) ; this%stem_prof_patch (:,:) = spval + allocate(this%fpi_vr_col (begc:endc,1:nlevdecomp_full)) ; this%fpi_vr_col (:,:) = nan + allocate(this%fpi_col (begc:endc)) ; this%fpi_col (:) = nan + allocate(this%fpg_col (begc:endc)) ; this%fpg_col (:) = nan + allocate(this%nfixation_prof_col (begc:endc,1:nlevdecomp_full)) ; this%nfixation_prof_col (:,:) = spval + allocate(this%ndep_prof_col (begc:endc,1:nlevdecomp_full)) ; this%ndep_prof_col (:,:) = spval + allocate(this%som_adv_coef_col (begc:endc,1:nlevdecomp_full)) ; this%som_adv_coef_col (:,:) = spval + allocate(this%som_diffus_coef_col (begc:endc,1:nlevdecomp_full)) ; this%som_diffus_coef_col (:,:) = spval + allocate(this%plant_ndemand_col (begc:endc)) ; this%plant_ndemand_col (:) = nan + + allocate(this%rf_decomp_cascade_col(begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions)); + this%rf_decomp_cascade_col(:,:,:) = nan + + allocate(this%pathfrac_decomp_cascade_col(begc:endc,1:nlevdecomp_full,1:ndecomp_cascade_transitions)); + this%pathfrac_decomp_cascade_col(:,:,:) = nan + + ! initialize variables from restart file or set to cold start value + n = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + n = n + 1 + + this%fpg_col(n) = cncol(nc,nz, 30) + this%fpi_col(n) = cncol(nc,nz, 35) + + do np = 1,nlevdecomp_full + this%fpi_vr_col(n,np) = cncol(nc,nz, 35) + end do + + this%plant_ndemand_col(n) = 0._r8 + do p = 0,numpft ! PFT index loop + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + this%plant_ndemand_col(n) = this%plant_ndemand_col(n) + cnpft(nc,nz,nv, 75) + end if + end do ! nv + end do ! p + end do !nz + end do ! nc + + end subroutine Init + +!----------------------------------------------- + function get_spinup_latitude_term(latitude) result(ans) + + !!DESCRIPTION: + ! calculate a logistic function to scale spinup factors so that spinup is more accelerated in high latitude regions + ! + ! !REVISION HISTORY + ! charlie koven, nov. 2015 + ! + ! !ARGUMENTS: + real(r8), intent(in) :: latitude + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + + ans = 1._r8 + 50._r8 / ( 1._r8 + exp(-0.15_r8 * (abs(latitude) - 60._r8) ) ) + + return + end function get_spinup_latitude_term + +end module SoilBiogeochemStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilStateType.F90 new file mode 100755 index 000000000..40e8089c9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SoilStateType.F90 @@ -0,0 +1,163 @@ +module SoilStateType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varpar , only : nlevsoi, nlevgrnd, nlevmaxurbgrnd, & + nlayer, nlevsno + use clm_varcon , only : spval + use nanMod , only : nan + use decompMod , only : bounds_type + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + type, public :: soilstate_type + + ! sand/ clay/ organic matter + real(r8), pointer :: sandfrac_patch (:) ! patch sand fraction + real(r8), pointer :: clayfrac_patch (:) ! patch clay fraction + real(r8), pointer :: mss_frc_cly_vld_col (:) ! col mass fraction clay limited to 0.20 + real(r8), pointer :: cellorg_col (:,:) ! col organic matter for gridcell containing column (1:nlevsoi) + real(r8), pointer :: cellsand_col (:,:) ! sand value for gridcell containing column (1:nlevsoi) + real(r8), pointer :: cellclay_col (:,:) ! clay value for gridcell containing column (1:nlevsoi) + real(r8), pointer :: bd_col (:,:) ! col bulk density of dry soil material [kg/m^3] (CN) + + ! hydraulic properties + real(r8), pointer :: hksat_col (:,:) ! col hydraulic conductivity at saturation (mm H2O /s) + real(r8), pointer :: hksat_min_col (:,:) ! col mineral hydraulic conductivity at saturation (hksat) (mm/s) + real(r8), pointer :: hk_l_col (:,:) ! col hydraulic conductivity (mm/s) + real(r8), pointer :: smp_l_col (:,:) ! col soil matric potential (mm) + real(r8), pointer :: smpmin_col (:) ! col restriction for min of soil potential (mm) + real(r8), pointer :: bsw_col (:,:) ! col Clapp and Hornberger "b" (nlevgrnd) + real(r8), pointer :: watsat_col (:,:) ! col volumetric soil water at saturation (porosity) + real(r8), pointer :: watdry_col (:,:) ! col btran parameter for btran = 0 + real(r8), pointer :: watopt_col (:,:) ! col btran parameter for btran = 1 + real(r8), pointer :: watfc_col (:,:) ! col volumetric soil water at field capacity (nlevsoi) + real(r8), pointer :: sucsat_col (:,:) ! col minimum soil suction (mm) (nlevgrnd) + real(r8), pointer :: dsl_col (:) ! col dry surface layer thickness (mm) + real(r8), pointer :: soilresis_col (:) ! col soil evaporative resistance S&L14 (s/m) + real(r8), pointer :: soilbeta_col (:) ! col factor that reduces ground evaporation L&P1992(-) + real(r8), pointer :: soilalpha_col (:) ! col factor that reduces ground saturated specific humidity (-) + real(r8), pointer :: soilalpha_u_col (:) ! col urban factor that reduces ground saturated specific humidity (-) + real(r8), pointer :: soilpsi_col (:,:) ! col soil water potential in each soil layer (MPa) (CN) + real(r8), pointer :: psiwilt_col (:,:) ! col soil water potential at wilting point (added by jkolassa to use for assessing water stress instead of globally constant value) + real(r8), pointer :: wtfact_col (:) ! col maximum saturated fraction for a gridcell + real(r8), pointer :: porosity_col (:,:) ! col soil porisity (1-bulk_density/soil_density) (VIC) + real(r8), pointer :: eff_porosity_col (:,:) ! col effective porosity = porosity - vol_ice (nlevgrnd) + real(r8), pointer :: gwc_thr_col (:) ! col threshold soil moisture based on clay content +!scs: vangenuchten + real(r8), pointer :: msw_col (:,:) ! col vanGenuchtenClapp "m" + real(r8), pointer :: nsw_col (:,:) ! col vanGenuchtenClapp "n" + real(r8), pointer :: alphasw_col (:,:) ! col vanGenuchtenClapp "nalpha" + real(r8), pointer :: watres_col (:,:) ! residual soil water content + ! thermal conductivity / heat capacity + real(r8), pointer :: thk_col (:,:) ! col thermal conductivity of each layer [W/m-K] + real(r8), pointer :: tkmg_col (:,:) ! col thermal conductivity, soil minerals [W/m-K] (new) (nlevgrnd) + real(r8), pointer :: tkdry_col (:,:) ! col thermal conductivity, dry soil (W/m/Kelvin) (nlevgrnd) + real(r8), pointer :: tksatu_col (:,:) ! col thermal conductivity, saturated soil [W/m-K] (new) (nlevgrnd) + real(r8), pointer :: csol_col (:,:) ! col heat capacity, soil solids (J/m**3/Kelvin) (nlevgrnd) + + ! roots + real(r8), pointer :: rootr_patch (:,:) ! patch effective fraction of roots in each soil layer (SMS method only) (nlevgrnd) + real(r8), pointer :: rootr_col (:,:) ! col effective fraction of roots in each soil layer (SMS method only) (nlevgrnd) + real(r8), pointer :: rootfr_col (:,:) ! col fraction of roots in each soil layer (nlevgrnd) + real(r8), pointer :: rootfr_patch (:,:) ! patch fraction of roots for water in each soil layer (nlevgrnd) + real(r8), pointer :: crootfr_patch (:,:) ! patch fraction of roots for carbon in each soil layer (nlevgrnd) + real(r8), pointer :: root_depth_patch (:) ! root depth + real(r8), pointer :: rootr_road_perv_col (:,:) ! col effective fraction of roots in each soil layer of urban pervious road + real(r8), pointer :: rootfr_road_perv_col (:,:) ! col effective fraction of roots in each soil layer of urban pervious road + real(r8), pointer :: k_soil_root_patch (:,:) ! patch soil-root interface conductance [mm/s] + real(r8), pointer :: root_conductance_patch(:,:) ! patch root conductance [mm/s] + real(r8), pointer :: soil_conductance_patch(:,:) ! patch soil conductance [mm/s] + + contains + + procedure, public :: Init + +end type soilstate_type +type(soilstate_type), public, target, save :: soilstate_inst + +contains + +!----------------------------------------------------------- + subroutine Init(this, bounds) + + ! !DESCRIPTION: + ! Initialize CTSM soil state type needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + !INPUT + type(bounds_type), intent(in) :: bounds + class(soilstate_type) :: this + + !LOCAL + integer :: begp, endp + integer :: begc, endc + !----------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + + allocate(this%mss_frc_cly_vld_col (begc:endc)) ; this%mss_frc_cly_vld_col (:) = nan + allocate(this%sandfrac_patch (begp:endp)) ; this%sandfrac_patch (:) = 0.5 ! jkolassa: temporary; replace with Catchment soil texture + allocate(this%clayfrac_patch (begp:endp)) ; this%clayfrac_patch (:) = 0.5 ! jkolassa: temporary; replace with Catchment soil texture + allocate(this%cellorg_col (begc:endc,nlevsoi)) ; this%cellorg_col (:,:) = nan + allocate(this%cellsand_col (begc:endc,nlevsoi)) ; this%cellsand_col (:,:) = 0.5*100. ! jkolassa: temporary; replace with Catchment soil texture + allocate(this%cellclay_col (begc:endc,nlevsoi)) ; this%cellclay_col (:,:) = 0.5*100. ! jkolassa: temporary; replace with Catchment soil texture + allocate(this%bd_col (begc:endc,nlevgrnd)) ; this%bd_col (:,:) = nan + + allocate(this%hksat_col (begc:endc,nlevgrnd)) ; this%hksat_col (:,:) = spval + allocate(this%hksat_min_col (begc:endc,nlevgrnd)) ; this%hksat_min_col (:,:) = spval + allocate(this%hk_l_col (begc:endc,nlevgrnd)) ; this%hk_l_col (:,:) = nan + allocate(this%smp_l_col (begc:endc,nlevgrnd)) ; this%smp_l_col (:,:) = nan + allocate(this%smpmin_col (begc:endc)) ; this%smpmin_col (:) = nan + + allocate(this%bsw_col (begc:endc,nlevgrnd)) ; this%bsw_col (:,:) = nan + allocate(this%watsat_col (begc:endc,nlevmaxurbgrnd)) ; this%watsat_col (:,:) = nan + allocate(this%watdry_col (begc:endc,nlevgrnd)) ; this%watdry_col (:,:) = spval + allocate(this%watopt_col (begc:endc,nlevgrnd)) ; this%watopt_col (:,:) = spval + allocate(this%watfc_col (begc:endc,nlevgrnd)) ; this%watfc_col (:,:) = nan + allocate(this%sucsat_col (begc:endc,nlevgrnd)) ; this%sucsat_col (:,:) = spval + allocate(this%dsl_col (begc:endc)) ; this%dsl_col (:) = spval!nan + allocate(this%soilresis_col (begc:endc)) ; this%soilresis_col (:) = spval!nan + allocate(this%soilbeta_col (begc:endc)) ; this%soilbeta_col (:) = nan + allocate(this%soilalpha_col (begc:endc)) ; this%soilalpha_col (:) = nan + allocate(this%soilalpha_u_col (begc:endc)) ; this%soilalpha_u_col (:) = nan + allocate(this%soilpsi_col (begc:endc,nlevgrnd)) ; this%soilpsi_col (:,:) = nan + allocate(this%psiwilt_col (begc:endc,nlevgrnd)) ; this%psiwilt_col (:,:) = nan + allocate(this%wtfact_col (begc:endc)) ; this%wtfact_col (:) = nan + allocate(this%porosity_col (begc:endc,nlayer)) ; this%porosity_col (:,:) = spval + allocate(this%eff_porosity_col (begc:endc,nlevgrnd)) ; this%eff_porosity_col (:,:) = spval + allocate(this%gwc_thr_col (begc:endc)) ; this%gwc_thr_col (:) = nan + + allocate(this%thk_col (begc:endc,-nlevsno+1:nlevmaxurbgrnd)) ; this%thk_col (:,:) = nan + allocate(this%tkmg_col (begc:endc,nlevgrnd)) ; this%tkmg_col (:,:) = nan + allocate(this%tkdry_col (begc:endc,nlevgrnd)) ; this%tkdry_col (:,:) = nan + allocate(this%tksatu_col (begc:endc,nlevgrnd)) ; this%tksatu_col (:,:) = nan + allocate(this%csol_col (begc:endc,nlevgrnd)) ; this%csol_col (:,:) = nan + + allocate(this%rootr_patch (begp:endp,1:nlevgrnd)) ; this%rootr_patch (:,:) = nan + allocate(this%root_depth_patch (begp:endp)) ; this%root_depth_patch (:) = nan + allocate(this%rootr_col (begc:endc,nlevgrnd)) ; this%rootr_col (:,:) = nan + allocate(this%rootr_road_perv_col (begc:endc,1:nlevgrnd)) ; this%rootr_road_perv_col (:,:) = nan + allocate(this%rootfr_patch (begp:endp,1:nlevgrnd)) ; this%rootfr_patch (:,:) = nan + allocate(this%crootfr_patch (begp:endp,1:nlevgrnd)) ; this%crootfr_patch (:,:) = nan + allocate(this%rootfr_col (begc:endc,1:nlevgrnd)) ; this%rootfr_col (:,:) = nan + allocate(this%rootfr_road_perv_col (begc:endc,1:nlevgrnd)) ; this%rootfr_road_perv_col (:,:) = nan + allocate(this%k_soil_root_patch (begp:endp,1:nlevsoi)) ; this%k_soil_root_patch (:,:) = nan + allocate(this%root_conductance_patch(begp:endp,1:nlevsoi)) ; this%root_conductance_patch (:,:) = nan + allocate(this%soil_conductance_patch(begp:endp,1:nlevsoi)) ; this%soil_conductance_patch (:,:) = nan + allocate(this%msw_col (begc:endc,1:nlevgrnd)) ; this%msw_col (:,:) = nan + allocate(this%nsw_col (begc:endc,1:nlevgrnd)) ; this%nsw_col (:,:) = nan + allocate(this%alphasw_col (begc:endc,1:nlevgrnd)) ; this%alphasw_col (:,:) = nan + allocate(this%watres_col (begc:endc,1:nlevgrnd)) ; this%watres_col (:,:) = nan + + end subroutine Init + +end module SoilStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SolarAbsorbedType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SolarAbsorbedType.F90 new file mode 100755 index 000000000..9a5a6c28b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SolarAbsorbedType.F90 @@ -0,0 +1,149 @@ +module SolarAbsorbedType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varcon , only : spval + use clm_varpar , only : nlevcan, numrad, nlevsno + use clm_varctl , only : use_luna + use nanMod , only : nan + use decompMod , only : bounds_type + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: solarabs_type + + ! Solar reflected + real(r8), pointer :: fsr_patch (:) ! patch solar radiation reflected (W/m**2) + real(r8), pointer :: fsrSF_patch (:) ! diagnostic snow-free patch solar radiation reflected (W/m**2) + real(r8), pointer :: ssre_fsr_patch (:) ! snow radiative effect on patch solar radiation reflected (W/m**2) + ! Solar Absorbed + real(r8), pointer :: fsa_patch (:) ! patch solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsa_u_patch (:) ! patch urban solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsa_r_patch (:) ! patch rural solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: parsun_z_patch (:,:) ! patch absorbed PAR for sunlit leaves in canopy layer (W/m**2) + real(r8), pointer :: parsha_z_patch (:,:) ! patch absorbed PAR for shaded leaves in canopy layer (W/m**2) + real(r8), pointer :: par240d_z_patch (:,:) ! 10-day running mean of daytime patch absorbed PAR for leaves in canopy layer (W/m**2) + real(r8), pointer :: par240x_z_patch (:,:) ! 10-day running mean of maximum patch absorbed PAR for leaves in canopy layer (W/m**2) + real(r8), pointer :: par24d_z_patch (:,:) ! daily accumulated absorbed PAR for leaves in canopy layer from midnight to current step(J/m**2) + real(r8), pointer :: par24x_z_patch (:,:) ! daily max of patch absorbed PAR for leaves in canopy layer from midnight to current step(W/m**2) + real(r8), pointer :: sabg_soil_patch (:) ! patch solar radiation absorbed by soil (W/m**2) + real(r8), pointer :: sabg_snow_patch (:) ! patch solar radiation absorbed by snow (W/m**2) + real(r8), pointer :: sabg_patch (:) ! patch solar radiation absorbed by ground (W/m**2) + real(r8), pointer :: sabg_chk_patch (:) ! patch fsno weighted sum (W/m**2) + real(r8), pointer :: sabg_lyr_patch (:,:) ! patch absorbed radiation in each snow layer and top soil layer (pft,lyr) [W/m2] + real(r8), pointer :: sabg_pen_patch (:) ! patch (rural) shortwave radiation penetrating top soisno layer [W/m2] + + real(r8), pointer :: sub_surf_abs_SW_patch (:) ! patch fraction of solar radiation absorbed below first snow layer + real(r8), pointer :: sabv_patch (:) ! patch solar radiation absorbed by vegetation (W/m**2) + + real(r8), pointer :: sabs_roof_dir_lun (:,:) ! lun direct solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_roof_dif_lun (:,:) ! lun diffuse solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_sunwall_dir_lun (:,:) ! lun direct solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_sunwall_dif_lun (:,:) ! lun diffuse solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dir_lun (:,:) ! lun direct solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dif_lun (:,:) ! lun diffuse solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_improad_dir_lun (:,:) ! lun direct solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_improad_dif_lun (:,:) ! lun diffuse solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dir_lun (:,:) ! lun direct solar absorbed by pervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dif_lun (:,:) ! lun diffuse solar absorbed by pervious road per unit ground area per unit incident flux + + ! Currently needed by lake code + ! TODO (MV 8/20/2014) should be moved in the future + real(r8), pointer :: fsds_nir_d_patch (:) ! patch incident direct beam nir solar radiation (W/m**2) + real(r8), pointer :: fsds_nir_i_patch (:) ! patch incident diffuse nir solar radiation (W/m**2) + real(r8), pointer :: fsds_nir_d_ln_patch (:) ! patch incident direct beam nir solar radiation at local noon (W/m**2) + real(r8), pointer :: fsr_nir_d_patch (:) ! patch reflected direct beam nir solar radiation (W/m**2) + real(r8), pointer :: fsr_nir_i_patch (:) ! patch reflected diffuse nir solar radiation (W/m**2) + real(r8), pointer :: fsr_nir_d_ln_patch (:) ! patch reflected direct beam nir solar radiation at local noon (W/m**2) + ! optional diagnostic fluxes: + real(r8), pointer :: fsrSF_nir_d_patch (:) ! snow-free patch reflected direct beam nir solar radiation (W/m**2) + real(r8), pointer :: fsrSF_nir_i_patch (:) ! snow-free patch reflected diffuse nir solar radiation (W/m**2) + real(r8), pointer :: fsrSF_nir_d_ln_patch (:) ! snow-free patch reflected direct beam nir solar radiation at local noon (W/m**2) + real(r8), pointer :: ssre_fsr_nir_d_patch (:) ! snow-free patch reflected direct beam nir solar radiation (W/m**2) + real(r8), pointer :: ssre_fsr_nir_i_patch (:) ! snow-free patch reflected diffuse nir solar radiation (W/m**2) + real(r8), pointer :: ssre_fsr_nir_d_ln_patch(:) ! snow-free patch reflected direct beam nir solar radiation at local noon (W/m**2) + + contains + + procedure, public :: Init + + end type solarabs_type + type(solarabs_type), public, target, save :: solarabs_inst + +contains + +!------------------------------------------------------ + subroutine Init(this, bounds) + + ! !DESCRIPTION: + ! Initialize CTSM solar absorbed type needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(solarabs_type) :: this + + !LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begl, endl + !--------------------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + begl = bounds%begl ; endl = bounds%endl + + allocate(this%fsa_patch (begp:endp)) ; this%fsa_patch (:) = nan + allocate(this%fsa_u_patch (begp:endp)) ; this%fsa_u_patch (:) = nan + allocate(this%fsa_r_patch (begp:endp)) ; this%fsa_r_patch (:) = nan + allocate(this%parsun_z_patch (begp:endp,1:nlevcan)) ; this%parsun_z_patch (:,:) = nan + allocate(this%parsha_z_patch (begp:endp,1:nlevcan)) ; this%parsha_z_patch (:,:) = nan + if(use_luna)then + allocate(this%par240d_z_patch (begp:endp,1:nlevcan)) ; this%par240d_z_patch (:,:) = spval + allocate(this%par240x_z_patch (begp:endp,1:nlevcan)) ; this%par240x_z_patch (:,:) = spval + allocate(this%par24d_z_patch (begp:endp,1:nlevcan)) ; this%par24d_z_patch (:,:) = spval + allocate(this%par24x_z_patch (begp:endp,1:nlevcan)) ; this%par24x_z_patch (:,:) = spval + endif + allocate(this%sabv_patch (begp:endp)) ; this%sabv_patch (:) = nan + allocate(this%sabg_patch (begp:endp)) ; this%sabg_patch (:) = nan + allocate(this%sabg_lyr_patch (begp:endp,-nlevsno+1:1)) ; this%sabg_lyr_patch (:,:) = nan + allocate(this%sabg_pen_patch (begp:endp)) ; this%sabg_pen_patch (:) = nan + allocate(this%sabg_soil_patch (begp:endp)) ; this%sabg_soil_patch (:) = nan + allocate(this%sabg_snow_patch (begp:endp)) ; this%sabg_snow_patch (:) = nan + allocate(this%sabg_chk_patch (begp:endp)) ; this%sabg_chk_patch (:) = nan + allocate(this%sabs_roof_dir_lun (begl:endl,1:numrad)) ; this%sabs_roof_dir_lun (:,:) = nan + allocate(this%sabs_roof_dif_lun (begl:endl,1:numrad)) ; this%sabs_roof_dif_lun (:,:) = nan + allocate(this%sabs_sunwall_dir_lun (begl:endl,1:numrad)) ; this%sabs_sunwall_dir_lun (:,:) = nan + allocate(this%sabs_sunwall_dif_lun (begl:endl,1:numrad)) ; this%sabs_sunwall_dif_lun (:,:) = nan + allocate(this%sabs_shadewall_dir_lun (begl:endl,1:numrad)) ; this%sabs_shadewall_dir_lun (:,:) = nan + allocate(this%sabs_shadewall_dif_lun (begl:endl,1:numrad)) ; this%sabs_shadewall_dif_lun (:,:) = nan + allocate(this%sabs_improad_dir_lun (begl:endl,1:numrad)) ; this%sabs_improad_dir_lun (:,:) = nan + allocate(this%sabs_improad_dif_lun (begl:endl,1:numrad)) ; this%sabs_improad_dif_lun (:,:) = nan + allocate(this%sabs_perroad_dir_lun (begl:endl,1:numrad)) ; this%sabs_perroad_dir_lun (:,:) = nan + allocate(this%sabs_perroad_dif_lun (begl:endl,1:numrad)) ; this%sabs_perroad_dif_lun (:,:) = nan + allocate(this%sub_surf_abs_SW_patch (begp:endp)) ; this%sub_surf_abs_SW_patch (:) = nan + allocate(this%fsr_patch (begp:endp)) ; this%fsr_patch (:) = nan + allocate(this%fsr_nir_d_patch (begp:endp)) ; this%fsr_nir_d_patch (:) = nan + allocate(this%fsr_nir_i_patch (begp:endp)) ; this%fsr_nir_i_patch (:) = nan + allocate(this%fsr_nir_d_ln_patch (begp:endp)) ; this%fsr_nir_d_ln_patch (:) = nan + allocate(this%fsrSF_patch (begp:endp)) ; this%fsrSF_patch (:) = nan + allocate(this%fsrSF_nir_d_patch (begp:endp)) ; this%fsrSF_nir_d_patch (:) = nan + allocate(this%fsrSF_nir_i_patch (begp:endp)) ; this%fsrSF_nir_i_patch (:) = nan + allocate(this%fsrSF_nir_d_ln_patch (begp:endp)) ; this%fsrSF_nir_d_ln_patch (:) = nan + allocate(this%ssre_fsr_patch (begp:endp)) ; this%ssre_fsr_patch (:) = nan + allocate(this%ssre_fsr_nir_d_patch (begp:endp)) ; this%ssre_fsr_nir_d_patch (:) = nan + allocate(this%ssre_fsr_nir_i_patch (begp:endp)) ; this%ssre_fsr_nir_i_patch (:) = nan + allocate(this%ssre_fsr_nir_d_ln_patch(begp:endp)) ; this%ssre_fsr_nir_d_ln_patch(:) = nan + allocate(this%fsds_nir_d_patch (begp:endp)) ; this%fsds_nir_d_patch (:) = nan + allocate(this%fsds_nir_i_patch (begp:endp)) ; this%fsds_nir_i_patch (:) = nan + allocate(this%fsds_nir_d_ln_patch (begp:endp)) ; this%fsds_nir_d_ln_patch (:) = nan + + end subroutine Init + +end module SolarAbsorbedType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SurfaceAlbedoType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SurfaceAlbedoType.F90 new file mode 100755 index 000000000..02527c4bf --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_SurfaceAlbedoType.F90 @@ -0,0 +1,175 @@ +module SurfaceAlbedoType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use clm_varpar , only : numrad, nlevcan, nlevsno, numpft, num_zon, num_veg, & + var_col, var_pft + use clm_varcon , only : spval, ispval + use decompMod , only : bounds_type + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + type, public :: surfalb_type + + real(r8), pointer :: coszen_col (:) ! col cosine of solar zenith angle + real(r8), pointer :: albd_patch (:,:) ! patch surface albedo (direct) (numrad) + real(r8), pointer :: albi_patch (:,:) ! patch surface albedo (diffuse) (numrad) + real(r8), pointer :: albdSF_patch (:,:) ! patch snow-free surface albedo (direct) (numrad) + real(r8), pointer :: albiSF_patch (:,:) ! patch snow-free surface albedo (diffuse) (numrad) + real(r8), pointer :: albgrd_pur_col (:,:) ! col pure snow ground direct albedo (numrad) + real(r8), pointer :: albgri_pur_col (:,:) ! col pure snow ground diffuse albedo (numrad) + real(r8), pointer :: albgrd_bc_col (:,:) ! col ground direct albedo without BC (numrad) + real(r8), pointer :: albgri_bc_col (:,:) ! col ground diffuse albedo without BC (numrad) + real(r8), pointer :: albgrd_oc_col (:,:) ! col ground direct albedo without OC (numrad) + real(r8), pointer :: albgri_oc_col (:,:) ! col ground diffuse albedo without OC (numrad) + real(r8), pointer :: albgrd_dst_col (:,:) ! col ground direct albedo without dust (numrad) + real(r8), pointer :: albgri_dst_col (:,:) ! col ground diffuse albedo without dust (numrad) + real(r8), pointer :: albgrd_col (:,:) ! col ground albedo (direct) (numrad) + real(r8), pointer :: albgri_col (:,:) ! col ground albedo (diffuse) (numrad) + real(r8), pointer :: albsod_col (:,:) ! col soil albedo: direct (col,bnd) [frc] + real(r8), pointer :: albsoi_col (:,:) ! col soil albedo: diffuse (col,bnd) [frc] + real(r8), pointer :: albsnd_hst_col (:,:) ! col snow albedo, direct , for history files (col,bnd) [frc] + real(r8), pointer :: albsni_hst_col (:,:) ! col snow albedo, diffuse, for history files (col,bnd) [frc] + + real(r8), pointer :: ftdd_patch (:,:) ! patch down direct flux below canopy per unit direct flx (numrad) + real(r8), pointer :: ftid_patch (:,:) ! patch down diffuse flux below canopy per unit direct flx (numrad) + real(r8), pointer :: ftii_patch (:,:) ! patch down diffuse flux below canopy per unit diffuse flx (numrad) + real(r8), pointer :: fabd_patch (:,:) ! patch flux absorbed by canopy per unit direct flux (numrad) + real(r8), pointer :: fabd_sun_patch (:,:) ! patch flux absorbed by sunlit canopy per unit direct flux (numrad) + real(r8), pointer :: fabd_sha_patch (:,:) ! patch flux absorbed by shaded canopy per unit direct flux (numrad) + real(r8), pointer :: fabi_patch (:,:) ! patch flux absorbed by canopy per unit diffuse flux (numrad) + real(r8), pointer :: fabi_sun_patch (:,:) ! patch flux absorbed by sunlit canopy per unit diffuse flux (numrad) + real(r8), pointer :: fabi_sha_patch (:,:) ! patch flux absorbed by shaded canopy per unit diffuse flux (numrad) + real(r8), pointer :: fabd_sun_z_patch (:,:) ! patch absorbed sunlit leaf direct PAR (per unit lai+sai) for each canopy layer + real(r8), pointer :: fabd_sha_z_patch (:,:) ! patch absorbed shaded leaf direct PAR (per unit lai+sai) for each canopy layer + real(r8), pointer :: fabi_sun_z_patch (:,:) ! patch absorbed sunlit leaf diffuse PAR (per unit lai+sai) for each canopy layer + real(r8), pointer :: fabi_sha_z_patch (:,:) ! patch absorbed shaded leaf diffuse PAR (per unit lai+sai) for each canopy layer + real(r8), pointer :: flx_absdv_col (:,:) ! col absorbed flux per unit incident direct flux: VIS (col,lyr) [frc] + real(r8), pointer :: flx_absdn_col (:,:) ! col absorbed flux per unit incident direct flux: NIR (col,lyr) [frc] + real(r8), pointer :: flx_absiv_col (:,:) ! col absorbed flux per unit incident diffuse flux: VIS (col,lyr) [frc] + real(r8), pointer :: flx_absin_col (:,:) ! col absorbed flux per unit incident diffuse flux: NIR (col,lyr) [frc] + + real(r8) , pointer :: fsun_z_patch (:,:) ! patch patch sunlit fraction of canopy layer + real(r8) , pointer :: tlai_z_patch (:,:) ! patch tlai increment for canopy layer + real(r8) , pointer :: tsai_z_patch (:,:) ! patch tsai increment for canopy layer + integer , pointer :: ncan_patch (:) ! patch number of canopy layers + integer , pointer :: nrad_patch (:) ! patch number of canopy layers, above snow for radiative transfer + real(r8) , pointer :: vcmaxcintsun_patch (:) ! patch leaf to canopy scaling coefficient, sunlit leaf vcmax + real(r8) , pointer :: vcmaxcintsha_patch (:) ! patch leaf to canopy scaling coefficient, shaded leaf vcmax + + contains + + procedure, public :: Init + +end type surfalb_type +type(surfalb_type), public, target, save :: surfalb_inst + +contains + +!--------------------------------------------------- + subroutine Init(this, bounds, nch, cncol, cnpft) + + ! !DESCRIPTION: +! Initialize CTSM surface albedo needed for calling CTSM routines +! jk Apr 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made +! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect +! +! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + real, dimension(nch,num_zon,var_col), intent(in) :: cncol ! column-level restart variable array + real, dimension(nch,num_zon,num_veg,var_pft), intent(in) :: cnpft ! pft-level (patch-level) restart variable array + class(surfalb_type) :: this + + ! LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: np, nc, nz, p, nv, n + !------------------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + + allocate(this%coszen_col (begc:endc)) ; this%coszen_col (:) = nan + allocate(this%albgrd_col (begc:endc,numrad)) ; this%albgrd_col (:,:) = nan + allocate(this%albgri_col (begc:endc,numrad)) ; this%albgri_col (:,:) = nan + allocate(this%albsnd_hst_col (begc:endc,numrad)) ; this%albsnd_hst_col (:,:) = spval + allocate(this%albsni_hst_col (begc:endc,numrad)) ; this%albsni_hst_col (:,:) = spval + allocate(this%albsod_col (begc:endc,numrad)) ; this%albsod_col (:,:) = spval + allocate(this%albsoi_col (begc:endc,numrad)) ; this%albsoi_col (:,:) = spval + allocate(this%albgrd_pur_col (begc:endc,numrad)) ; this%albgrd_pur_col (:,:) = nan + allocate(this%albgri_pur_col (begc:endc,numrad)) ; this%albgri_pur_col (:,:) = nan + allocate(this%albgrd_bc_col (begc:endc,numrad)) ; this%albgrd_bc_col (:,:) = nan + allocate(this%albgri_bc_col (begc:endc,numrad)) ; this%albgri_bc_col (:,:) = nan + allocate(this%albgrd_oc_col (begc:endc,numrad)) ; this%albgrd_oc_col (:,:) = nan + allocate(this%albgri_oc_col (begc:endc,numrad)) ; this%albgri_oc_col (:,:) = nan + allocate(this%albgrd_dst_col (begc:endc,numrad)) ; this%albgrd_dst_col (:,:) = nan + allocate(this%albgri_dst_col (begc:endc,numrad)) ; this%albgri_dst_col (:,:) = nan + allocate(this%albd_patch (begp:endp,numrad)) ; this%albd_patch (:,:) = nan + allocate(this%albi_patch (begp:endp,numrad)) ; this%albi_patch (:,:) = nan + allocate(this%albdSF_patch (begp:endp,numrad)) ; this%albdSF_patch (:,:) = nan + allocate(this%albiSF_patch (begp:endp,numrad)) ; this%albiSF_patch (:,:) = nan + allocate(this%ftdd_patch (begp:endp,numrad)) ; this%ftdd_patch (:,:) = nan + allocate(this%ftid_patch (begp:endp,numrad)) ; this%ftid_patch (:,:) = nan + allocate(this%ftii_patch (begp:endp,numrad)) ; this%ftii_patch (:,:) = nan + allocate(this%fabd_patch (begp:endp,numrad)) ; this%fabd_patch (:,:) = nan + allocate(this%fabd_sun_patch (begp:endp,numrad)) ; this%fabd_sun_patch (:,:) = nan + allocate(this%fabd_sha_patch (begp:endp,numrad)) ; this%fabd_sha_patch (:,:) = nan + allocate(this%fabi_patch (begp:endp,numrad)) ; this%fabi_patch (:,:) = nan + allocate(this%fabi_sun_patch (begp:endp,numrad)) ; this%fabi_sun_patch (:,:) = nan + allocate(this%fabi_sha_patch (begp:endp,numrad)) ; this%fabi_sha_patch (:,:) = nan + allocate(this%fabd_sun_z_patch (begp:endp,nlevcan)) ; this%fabd_sun_z_patch (:,:) = 0._r8 + allocate(this%fabd_sha_z_patch (begp:endp,nlevcan)) ; this%fabd_sha_z_patch (:,:) = 0._r8 + allocate(this%fabi_sun_z_patch (begp:endp,nlevcan)) ; this%fabi_sun_z_patch (:,:) = 0._r8 + allocate(this%fabi_sha_z_patch (begp:endp,nlevcan)) ; this%fabi_sha_z_patch (:,:) = 0._r8 + allocate(this%flx_absdv_col (begc:endc,-nlevsno+1:1)) ; this%flx_absdv_col (:,:) = spval + allocate(this%flx_absdn_col (begc:endc,-nlevsno+1:1)) ; this%flx_absdn_col (:,:) = spval + allocate(this%flx_absiv_col (begc:endc,-nlevsno+1:1)) ; this%flx_absiv_col (:,:) = spval + allocate(this%flx_absin_col (begc:endc,-nlevsno+1:1)) ; this%flx_absin_col (:,:) = spval + + allocate(this%fsun_z_patch (begp:endp,nlevcan)) ; this%fsun_z_patch (:,:) = 0._r8 + allocate(this%tlai_z_patch (begp:endp,nlevcan)) ; this%tlai_z_patch (:,:) = 0._r8 + allocate(this%tsai_z_patch (begp:endp,nlevcan)) ; this%tsai_z_patch (:,:) = 0._r8 + allocate(this%ncan_patch (begp:endp)) ; this%ncan_patch (:) = 0 + allocate(this%nrad_patch (begp:endp)) ; this%nrad_patch (:) = 0 + allocate(this%vcmaxcintsun_patch (begp:endp)) ; this%vcmaxcintsun_patch (:) = nan + allocate(this%vcmaxcintsha_patch (begp:endp)) ; this%vcmaxcintsha_patch (:) = nan + + ! initialize variables from restart files + + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + do p = 0,numpft ! PFT index loop + np = np + 1 + + this%nrad_patch(np) = 1 + + do nv = 1,num_veg ! defined veg loop + do n = 1,nlevcan + this%tlai_z_patch(np,n) = cnpft(nc,nz,nv, 73) + if (isnan(this%tlai_z_patch(np,n))) then + this%tlai_z_patch(np,n) = 0. + end if + this%tsai_z_patch(np,n) = cnpft(nc,nz,nv, 74) + if (isnan(this%tsai_z_patch(np,n))) then + this%tsai_z_patch(np,n) = 0. + end if + this%vcmaxcintsha_patch(np) = 1._r8 + this%vcmaxcintsun_patch(np) = 1._r8 + end do + end do !nv + end do ! p + end do ! nz + end do ! nc + + end subroutine Init + +end module SurfaceAlbedoType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_TemperatureType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_TemperatureType.F90 new file mode 100755 index 000000000..337caa2d3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_TemperatureType.F90 @@ -0,0 +1,243 @@ +module TemperatureType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varpar , only : nlevsno, nlevgrnd, nlevlak, nlevurb, nlevmaxurbgrnd + use clm_varctl , only : use_fates, use_luna + use clm_varcon , only : spval, ispval + use nanMod , only : nan + use decompMod , only : bounds_type + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + type, public :: temperature_type + + ! Temperatures + real(r8), pointer :: t_stem_patch (:) ! patch stem temperatu\re (Kelvin) + real(r8), pointer :: t_veg_patch (:) ! patch vegetation temperature (Kelvin) + real(r8), pointer :: t_skin_patch (:) ! patch skin temperature (Kelvin) + real(r8), pointer :: t_veg_day_patch (:) ! patch daytime accumulative vegetation temperature (Kelvinx*nsteps), LUNA specific, from midnight to current step + real(r8), pointer :: t_veg_night_patch (:) ! patch night-time accumulative vegetation temperature (Kelvin*nsteps), LUNA specific, from midnight to current step + real(r8), pointer :: t_veg10_day_patch (:) ! 10 day running mean of patch daytime time vegetation temperature (Kelvin), LUNA specific, but can be reused + real(r8), pointer :: t_veg10_night_patch (:) ! 10 day running mean of patch night time vegetation temperature (Kelvin), LUNA specific, but can be reused + integer, pointer :: ndaysteps_patch (:) ! number of daytime steps accumulated from mid-night, LUNA specific + integer, pointer :: nnightsteps_patch (:) ! number of nighttime steps accumulated from mid-night, LUNA specific + real(r8), pointer :: t_h2osfc_col (:) ! col surface water temperature + real(r8), pointer :: t_h2osfc_bef_col (:) ! col surface water temperature from time-step before + real(r8), pointer :: t_ssbef_col (:,:) ! col soil/snow temperature before update (-nlevsno+1:nlevgrnd) + real(r8), pointer :: t_soisno_col (:,:) ! col soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + real(r8), pointer :: tsl_col (:) ! col temperature of near-surface soil layer (Kelvin) + real(r8), pointer :: t_soi10cm_col (:) ! col soil temperature in top 10cm of soil (Kelvin) + real(r8), pointer :: t_soi17cm_col (:) ! col soil temperature in top 17cm of soil (Kelvin) + real(r8), pointer :: t_sno_mul_mss_col (:) ! col snow temperature multiplied by layer mass, layer sum (K * kg/m2) + real(r8), pointer :: t_lake_col (:,:) ! col lake temperature (Kelvin) (1:nlevlak) + real(r8), pointer :: t_grnd_col (:) ! col ground temperature (Kelvin) + real(r8), pointer :: t_grnd_r_col (:) ! col rural ground temperature (Kelvin) + real(r8), pointer :: t_grnd_u_col (:) ! col urban ground temperature (Kelvin) (needed by Hydrology2Mod) + real(r8), pointer :: t_building_lun (:) ! lun internal building air temperature (K) + real(r8), pointer :: t_roof_inner_lun (:) ! lun roof inside surface temperature (K) + real(r8), pointer :: t_sunw_inner_lun (:) ! lun sunwall inside surface temperature (K) + real(r8), pointer :: t_shdw_inner_lun (:) ! lun shadewall inside surface temperature (K) + real(r8), pointer :: t_floor_lun (:) ! lun floor temperature (K) + real(r8), pointer :: snot_top_col (:) ! col temperature of top snow layer [K] + real(r8), pointer :: dTdz_top_col (:) ! col temperature gradient in top layer [K m-1] + real(r8), pointer :: dt_veg_patch (:) ! patch change in t_veg, last iteration (Kelvin) + + real(r8), pointer :: dt_grnd_col (:) ! col change in t_grnd, last iteration (Kelvin) + real(r8), pointer :: thv_col (:) ! col virtual potential temperature (kelvin) + real(r8), pointer :: thm_patch (:) ! patch intermediate variable (forc_t+0.0098*forc_hgt_t_patch) + real(r8), pointer :: t_a10_patch (:) ! patch 10-day running mean of the 2 m temperature (K) + real(r8), pointer :: soila10_patch (:) ! patch 10-day running mean of the soil layer 3 temperature (K) + real(r8), pointer :: t_a10min_patch (:) ! patch 10-day running mean of min 2-m temperature + real(r8), pointer :: t_a5min_patch (:) ! patch 5-day running mean of min 2-m temperature + + real(r8), pointer :: taf_lun (:) ! lun urban canopy air temperature (K) + + real(r8), pointer :: t_ref2m_patch (:) ! patch 2 m height surface air temperature (Kelvin) + real(r8), pointer :: t_ref2m_r_patch (:) ! patch rural 2 m height surface air temperature (Kelvin) + real(r8), pointer :: t_ref2m_u_patch (:) ! patch urban 2 m height surface air temperature (Kelvin) + real(r8), pointer :: t_ref2m_min_patch (:) ! patch daily minimum of average 2 m height surface air temperature (K) + real(r8), pointer :: t_ref2m_min_r_patch (:) ! patch daily minimum of average 2 m height surface air temperature - rural(K) + real(r8), pointer :: t_ref2m_min_u_patch (:) ! patch daily minimum of average 2 m height surface air temperature - urban (K) + real(r8), pointer :: t_ref2m_max_patch (:) ! patch daily maximum of average 2 m height surface air temperature (K) + real(r8), pointer :: t_ref2m_max_r_patch (:) ! patch daily maximum of average 2 m height surface air temperature - rural(K) + real(r8), pointer :: t_ref2m_max_u_patch (:) ! patch daily maximum of average 2 m height surface air temperature - urban (K) + real(r8), pointer :: t_ref2m_min_inst_patch (:) ! patch instantaneous daily min of average 2 m height surface air temp (K) + real(r8), pointer :: t_ref2m_min_inst_r_patch (:) ! patch instantaneous daily min of average 2 m height surface air temp - rural (K) + real(r8), pointer :: t_ref2m_min_inst_u_patch (:) ! patch instantaneous daily min of average 2 m height surface air temp - urban (K) + real(r8), pointer :: t_ref2m_max_inst_patch (:) ! patch instantaneous daily max of average 2 m height surface air temp (K) + real(r8), pointer :: t_ref2m_max_inst_r_patch (:) ! patch instantaneous daily max of average 2 m height surface air temp - rural (K) + real(r8), pointer :: t_ref2m_max_inst_u_patch (:) ! patch instantaneous daily max of average 2 m height surface air temp - urban (K) + + ! Accumulated quantities + ! + ! TODO(wjs, 2014-08-05) Move these to the module(s) where they are used, to improve + ! modularity. In cases where they are used by two completely different modules, + ! which only use the same variable out of convenience, introduce a duplicate (point + ! being: that way one parameterization is free to change the exact meaning of its + ! accumulator without affecting the other). + ! + real(r8), pointer :: t_veg24_patch (:) ! patch 24hr average vegetation temperature (K) + real(r8), pointer :: t_veg240_patch (:) ! patch 240hr average vegetation temperature (Kelvin) + real(r8), pointer :: gdd0_patch (:) ! patch growing degree-days base 0C from planting (ddays) + real(r8), pointer :: gdd8_patch (:) ! patch growing degree-days base 8C from planting (ddays) + real(r8), pointer :: gdd10_patch (:) ! patch growing degree-days base 10C from planting (ddays) + real(r8), pointer :: gdd020_patch (:) ! patch 20-year average of gdd0 (ddays) + real(r8), pointer :: gdd820_patch (:) ! patch 20-year average of gdd8 (ddays) + real(r8), pointer :: gdd1020_patch (:) ! patch 20-year average of gdd10 (ddays) + + ! Heat content + real(r8), pointer :: beta_col (:) ! coefficient of convective velocity [-] + ! For the following dynbal baseline variable: positive values are subtracted to avoid + ! counting liquid water content of "virtual" states; negative values are added to + ! account for missing states in the model. + real(r8), pointer :: dynbal_baseline_heat_col (:) ! baseline heat content subtracted from each column's total heat calculation [J/m^2] + real(r8), pointer :: heat1_grc (:) ! grc initial gridcell total heat content + real(r8), pointer :: heat2_grc (:) ! grc post land cover change total heat content + real(r8), pointer :: liquid_water_temp1_grc (:) ! grc initial weighted average liquid water temperature (K) + real(r8), pointer :: liquid_water_temp2_grc (:) ! grc post land cover change weighted average liquid water temperature (K) + + ! Flags + integer , pointer :: imelt_col (:,:) ! flag for melting (=1), freezing (=2), Not=0 (-nlevsno+1:nlevgrnd) + + ! Emissivities + real(r8), pointer :: emv_patch (:) ! patch vegetation emissivity + real(r8), pointer :: emg_col (:) ! col ground emissivity + + ! Misc + real(r8), pointer :: xmf_col (:) ! total latent heat of phase change of ground water + real(r8), pointer :: xmf_h2osfc_col (:) ! latent heat of phase change of surface water + real(r8), pointer :: fact_col (:,:) ! used in computing tridiagonal matrix + real(r8), pointer :: c_h2osfc_col (:) ! heat capacity of surface water + + contains + + procedure, public :: Init + +end type temperature_type +type(temperature_type), public, target, save :: temperature_inst + + contains + +!------------------------------------------------------------------- + subroutine Init(this, bounds) + + ! !DESCRIPTION: +! Initialize CTSM temperature (forcing type) needed for calling CTSM routines +! jk Apr 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made +! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect +! +! !ARGUMENTS: + implicit none + type(bounds_type), intent(in) :: bounds + class(temperature_type) :: this + + ! LOCAL + integer :: begp, endp + integer :: begg, endg + integer :: begc, endc + integer :: begl, endl + !------------------------ + + begp = bounds%begp ; endp = bounds%endp + begg = bounds%begg ; endg = bounds%endg + begc = bounds%begc ; endc = bounds%endc + begl = bounds%begl ; endl = bounds%endl + + ! Temperatures + allocate(this%t_stem_patch (begp:endp)) ; this%t_stem_patch (:) = nan + allocate(this%t_veg_patch (begp:endp)) ; this%t_veg_patch (:) = nan + allocate(this%t_skin_patch (begp:endp)) ; this%t_skin_patch (:) = nan + if(use_luna) then + allocate(this%t_veg_day_patch (begp:endp)) ; this%t_veg_day_patch (:) = spval + allocate(this%t_veg_night_patch (begp:endp)) ; this%t_veg_night_patch (:) = spval + allocate(this%t_veg10_day_patch (begp:endp)) ; this%t_veg10_day_patch (:) = spval + allocate(this%t_veg10_night_patch (begp:endp)) ; this%t_veg10_night_patch (:) = spval + allocate(this%ndaysteps_patch (begp:endp)) ; this%ndaysteps_patch (:) = ispval + allocate(this%nnightsteps_patch (begp:endp)) ; this%nnightsteps_patch (:) = ispval + endif + allocate(this%t_h2osfc_col (begc:endc)) ; this%t_h2osfc_col (:) = nan + allocate(this%t_h2osfc_bef_col (begc:endc)) ; this%t_h2osfc_bef_col (:) = nan + allocate(this%t_ssbef_col (begc:endc,-nlevsno+1:nlevmaxurbgrnd)) ; this%t_ssbef_col (:,:) = nan + allocate(this%t_soisno_col (begc:endc,-nlevsno+1:nlevmaxurbgrnd)) ; this%t_soisno_col (:,:) = nan + allocate(this%t_lake_col (begc:endc,1:nlevlak)) ; this%t_lake_col (:,:) = nan + allocate(this%t_grnd_col (begc:endc)) ; this%t_grnd_col (:) = nan + allocate(this%t_grnd_r_col (begc:endc)) ; this%t_grnd_r_col (:) = nan + allocate(this%t_grnd_u_col (begc:endc)) ; this%t_grnd_u_col (:) = nan + allocate(this%t_building_lun (begl:endl)) ; this%t_building_lun (:) = nan + allocate(this%t_roof_inner_lun (begl:endl)) ; this%t_roof_inner_lun (:) = nan + allocate(this%t_sunw_inner_lun (begl:endl)) ; this%t_sunw_inner_lun (:) = nan + allocate(this%t_shdw_inner_lun (begl:endl)) ; this%t_shdw_inner_lun (:) = nan + allocate(this%t_floor_lun (begl:endl)) ; this%t_floor_lun (:) = nan + allocate(this%snot_top_col (begc:endc)) ; this%snot_top_col (:) = nan + allocate(this%dTdz_top_col (begc:endc)) ; this%dTdz_top_col (:) = nan + allocate(this%dt_veg_patch (begp:endp)) ; this%dt_veg_patch (:) = nan + + allocate(this%tsl_col (begc:endc)) ; this%tsl_col (:) = nan + allocate(this%t_sno_mul_mss_col (begc:endc)) ; this%t_sno_mul_mss_col (:) = nan + allocate(this%tsl_col (begc:endc)) ; this%tsl_col (:) = nan + allocate(this%t_soi10cm_col (begc:endc)) ; this%t_soi10cm_col (:) = nan + allocate(this%t_soi17cm_col (begc:endc)) ; this%t_soi17cm_col (:) = spval + allocate(this%dt_grnd_col (begc:endc)) ; this%dt_grnd_col (:) = nan + allocate(this%thv_col (begc:endc)) ; this%thv_col (:) = nan + allocate(this%thm_patch (begp:endp)) ; this%thm_patch (:) = nan + allocate(this%t_a10_patch (begp:endp)) ; this%t_a10_patch (:) = nan + allocate(this%soila10_patch (begp:endp)) ; this%soila10_patch (:) = nan + allocate(this%t_a10min_patch (begp:endp)) ; this%t_a10min_patch (:) = nan + allocate(this%t_a5min_patch (begp:endp)) ; this%t_a5min_patch (:) = nan + + allocate(this%taf_lun (begl:endl)) ; this%taf_lun (:) = nan + + allocate(this%t_ref2m_patch (begp:endp)) ; this%t_ref2m_patch (:) = nan + allocate(this%t_ref2m_r_patch (begp:endp)) ; this%t_ref2m_r_patch (:) = nan + allocate(this%t_ref2m_u_patch (begp:endp)) ; this%t_ref2m_u_patch (:) = nan + allocate(this%t_ref2m_min_patch (begp:endp)) ; this%t_ref2m_min_patch (:) = nan + allocate(this%t_ref2m_min_r_patch (begp:endp)) ; this%t_ref2m_min_r_patch (:) = nan + allocate(this%t_ref2m_min_u_patch (begp:endp)) ; this%t_ref2m_min_u_patch (:) = nan + allocate(this%t_ref2m_max_patch (begp:endp)) ; this%t_ref2m_max_patch (:) = nan + allocate(this%t_ref2m_max_r_patch (begp:endp)) ; this%t_ref2m_max_r_patch (:) = nan + allocate(this%t_ref2m_max_u_patch (begp:endp)) ; this%t_ref2m_max_u_patch (:) = nan + allocate(this%t_ref2m_max_inst_patch (begp:endp)) ; this%t_ref2m_max_inst_patch (:) = nan + allocate(this%t_ref2m_max_inst_r_patch (begp:endp)) ; this%t_ref2m_max_inst_r_patch (:) = nan + allocate(this%t_ref2m_max_inst_u_patch (begp:endp)) ; this%t_ref2m_max_inst_u_patch (:) = nan + allocate(this%t_ref2m_min_inst_patch (begp:endp)) ; this%t_ref2m_min_inst_patch (:) = nan + allocate(this%t_ref2m_min_inst_r_patch (begp:endp)) ; this%t_ref2m_min_inst_r_patch (:) = nan + allocate(this%t_ref2m_min_inst_u_patch (begp:endp)) ; this%t_ref2m_min_inst_u_patch (:) = nan + + ! Accumulated fields + allocate(this%t_veg24_patch (begp:endp)) ; this%t_veg24_patch (:) = nan + allocate(this%t_veg240_patch (begp:endp)) ; this%t_veg240_patch (:) = nan + allocate(this%gdd0_patch (begp:endp)) ; this%gdd0_patch (:) = spval + allocate(this%gdd8_patch (begp:endp)) ; this%gdd8_patch (:) = spval + allocate(this%gdd10_patch (begp:endp)) ; this%gdd10_patch (:) = spval + allocate(this%gdd020_patch (begp:endp)) ; this%gdd020_patch (:) = spval + allocate(this%gdd820_patch (begp:endp)) ; this%gdd820_patch (:) = spval + allocate(this%gdd1020_patch (begp:endp)) ; this%gdd1020_patch (:) = spval + + ! Heat content + allocate(this%beta_col (begc:endc)) ; this%beta_col (:) = nan + allocate(this%dynbal_baseline_heat_col (begc:endc)) ; this%dynbal_baseline_heat_col (:) = nan + allocate(this%heat1_grc (begg:endg)) ; this%heat1_grc (:) = nan + allocate(this%heat2_grc (begg:endg)) ; this%heat2_grc (:) = nan + allocate(this%liquid_water_temp1_grc (begg:endg)) ; this%liquid_water_temp1_grc (:) = nan + allocate(this%liquid_water_temp2_grc (begg:endg)) ; this%liquid_water_temp2_grc (:) = nan + + ! flags + allocate(this%imelt_col (begc:endc,-nlevsno+1:nlevmaxurbgrnd)) ; this%imelt_col (:,:) = huge(1) + + ! emissivities + allocate(this%emv_patch (begp:endp)) ; this%emv_patch (:) = nan + allocate(this%emg_col (begc:endc)) ; this%emg_col (:) = nan + + allocate(this%xmf_col (begc:endc)) ; this%xmf_col (:) = nan + allocate(this%xmf_h2osfc_col (begc:endc)) ; this%xmf_h2osfc_col (:) = nan + allocate(this%fact_col (begc:endc, -nlevsno+1:nlevmaxurbgrnd)) ; this%fact_col (:,:) = nan + allocate(this%c_h2osfc_col (begc:endc)) ; this%c_h2osfc_col (:) = nan + + end subroutine Init + +end module TemperatureType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterDiagnosticBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterDiagnosticBulkType.F90 new file mode 100755 index 000000000..41d77879d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterDiagnosticBulkType.F90 @@ -0,0 +1,140 @@ +module WaterDiagnosticBulkType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varpar , only : nlevgrnd, nlevsno, nlevcan + use clm_varcon , only : spval + use nanMod , only : nan + use decompMod , only : bounds_type + use WaterDiagnosticType, only : waterdiagnostic_type + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + type, extends(waterdiagnostic_type), public :: waterdiagnosticbulk_type + + real(r8), pointer :: h2osno_total_col (:) ! col total snow water (mm H2O) + real(r8), pointer :: snow_depth_col (:) ! col snow height of snow covered area (m) + real(r8), pointer :: snow_5day_col (:) ! col snow height 5 day avg + real(r8), pointer :: snowdp_col (:) ! col area-averaged snow height (m) + real(r8), pointer :: snow_layer_unity_col (:,:) ! value 1 for each snow layer, used for history diagnostics + real(r8), pointer :: bw_col (:,:) ! col partial density of water in the snow pack (ice + liquid) [kg/m3] + + real(r8), pointer :: h2osoi_liq_tot_col (:) ! vertically summed col liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) + real(r8), pointer :: h2osoi_ice_tot_col (:) ! vertically summed col ice lens (kg/m2) (new) (-nlevsno+1:nlevgrnd) + real(r8), pointer :: air_vol_col (:,:) ! col air filled porosity + real(r8), pointer :: h2osoi_liqvol_col (:,:) ! col volumetric liquid water content (v/v) + real(r8), pointer :: swe_old_col (:,:) ! col initial snow water + + real(r8), pointer :: snw_rds_col (:,:) ! col snow grain radius (col,lyr) [m^-6, microns] + real(r8), pointer :: snw_rds_top_col (:) ! col snow grain radius (top layer) [m^-6, microns] + real(r8), pointer :: h2osno_top_col (:) ! col top-layer mass of snow [kg] + real(r8), pointer :: sno_liq_top_col (:) ! col snow liquid water fraction (mass), top layer [fraction] + + real(r8), pointer :: iwue_ln_patch (:) ! patch intrinsic water use efficiency near local noon (umolCO2/molH2O) + real(r8), pointer :: vpd_ref2m_patch (:) ! patch 2 m height surface vapor pressure deficit (Pa) + real(r8), pointer :: rh_ref2m_patch (:) ! patch 2 m height surface relative humidity (%) + real(r8), pointer :: rh_ref2m_r_patch (:) ! patch 2 m height surface relative humidity - rural (%) + real(r8), pointer :: rh_ref2m_u_patch (:) ! patch 2 m height surface relative humidity - urban (%) + real(r8), pointer :: rh_af_patch (:) ! patch fractional humidity of canopy air (dimensionless) ! private + real(r8), pointer :: rh10_af_patch (:) ! 10-day mean patch fractional humidity of canopy air (dimensionless) + real(r8), pointer :: dqgdT_col (:) ! col d(qg)/dT + + ! Fractions + real(r8), pointer :: frac_sno_col (:) ! col fraction of ground covered by snow (0 to 1) + real(r8), pointer :: frac_sno_eff_col (:) ! col fraction of ground covered by snow (0 to 1) (note: this can be 1 even if there is no snow, but should be ignored in the no-snow case) + real(r8), pointer :: frac_iceold_col (:,:) ! col fraction of ice relative to the tot water (new) (-nlevsno+1:nlevgrnd) + real(r8), pointer :: frac_h2osfc_col (:) ! col fractional area with surface water greater than zero + real(r8), pointer :: frac_h2osfc_nosnow_col (:) ! col fractional area with surface water greater than zero (if no snow present) + real(r8), pointer :: wf_col (:) ! col soil water as frac. of whc for top 0.05 m (0-1) + real(r8), pointer :: wf2_col (:) ! col soil water as frac. of whc for top 0.17 m (0-1) + real(r8), pointer :: fwet_patch (:) ! patch canopy fraction that is wet (0 to 1) + real(r8), pointer :: fcansno_patch (:) ! patch canopy fraction that is snow covered (0 to 1) + real(r8), pointer :: fdry_patch (:) ! patch canopy fraction of foliage that is green and dry [-] (new) + + ! Summed fluxes + real(r8), pointer :: qflx_prec_intr_patch (:) ! patch interception of precipitation (mm H2O/s) + real(r8), pointer :: qflx_prec_grnd_col (:) ! col water onto ground including canopy runoff (mm H2O/s) + + contains + + procedure, public :: InitBulk + +end type waterdiagnosticbulk_type +!type(waterdiagnosticbulk_type), public, target, save :: waterdiagnosticbulk_inst + +contains + +!----------------------------------------------- + subroutine InitBulk(this, bounds) + + ! !DESCRIPTION: + ! Initialize CTSM type for water diagnostic variables that just apply to bulk water and are needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + !INPUT + type(bounds_type), intent(in) :: bounds + class(waterdiagnosticbulk_type), intent(inout) :: this + + !LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begl, endl + integer :: begg, endg + !---------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + begl = bounds%begl ; endl = bounds%endl + begg = bounds%begg ; endg = bounds%endg + + call this%Init(bounds) + + allocate(this%h2osno_total_col (begc:endc)) ; this%h2osno_total_col (:) = nan + allocate(this%snow_depth_col (begc:endc)) ; this%snow_depth_col (:) = nan + allocate(this%snow_5day_col (begc:endc)) ; this%snow_5day_col (:) = nan + allocate(this%snowdp_col (begc:endc)) ; this%snowdp_col (:) = nan + allocate(this%snow_layer_unity_col (begc:endc,-nlevsno+1:0)) ; this%snow_layer_unity_col (:,:) = nan + allocate(this%bw_col (begc:endc,-nlevsno+1:0)) ; this%bw_col (:,:) = nan + allocate(this%air_vol_col (begc:endc, 1:nlevgrnd)) ; this%air_vol_col (:,:) = nan + allocate(this%h2osoi_liqvol_col (begc:endc,-nlevsno+1:nlevgrnd)) ; this%h2osoi_liqvol_col (:,:) = nan + allocate(this%h2osoi_ice_tot_col (begc:endc)) ; this%h2osoi_ice_tot_col (:) = nan + allocate(this%h2osoi_liq_tot_col (begc:endc)) ; this%h2osoi_liq_tot_col (:) = nan + allocate(this%swe_old_col (begc:endc,-nlevsno+1:0)) ; this%swe_old_col (:,:) = nan + + allocate(this%snw_rds_col (begc:endc,-nlevsno+1:0)) ; this%snw_rds_col (:,:) = nan + allocate(this%snw_rds_top_col (begc:endc)) ; this%snw_rds_top_col (:) = nan + allocate(this%h2osno_top_col (begc:endc)) ; this%h2osno_top_col (:) = nan + allocate(this%sno_liq_top_col (begc:endc)) ; this%sno_liq_top_col (:) = nan + + allocate(this%dqgdT_col (begc:endc)) ; this%dqgdT_col (:) = nan + allocate(this%iwue_ln_patch (begp:endp)) ; this%iwue_ln_patch (:) = nan + allocate(this%vpd_ref2m_patch (begp:endp)) ; this%vpd_ref2m_patch (:) = nan + allocate(this%rh_ref2m_patch (begp:endp)) ; this%rh_ref2m_patch (:) = nan + allocate(this%rh_ref2m_u_patch (begp:endp)) ; this%rh_ref2m_u_patch (:) = nan + allocate(this%rh_ref2m_r_patch (begp:endp)) ; this%rh_ref2m_r_patch (:) = nan + allocate(this%rh_af_patch (begp:endp)) ; this%rh_af_patch (:) = nan + allocate(this%rh10_af_patch (begp:endp)) ; this%rh10_af_patch (:) = spval + + allocate(this%frac_sno_col (begc:endc)) ; this%frac_sno_col (:) = nan + allocate(this%frac_sno_eff_col (begc:endc)) ; this%frac_sno_eff_col (:) = nan + allocate(this%frac_iceold_col (begc:endc,-nlevsno+1:nlevgrnd)) ; this%frac_iceold_col (:,:) = nan + allocate(this%frac_h2osfc_col (begc:endc)) ; this%frac_h2osfc_col (:) = nan + allocate(this%frac_h2osfc_nosnow_col (begc:endc)) ; this%frac_h2osfc_nosnow_col (:) = nan + allocate(this%wf_col (begc:endc)) ; this%wf_col (:) = nan + allocate(this%wf2_col (begc:endc)) ; this%wf2_col (:) = nan + allocate(this%fwet_patch (begp:endp)) ; this%fwet_patch (:) = nan + allocate(this%fcansno_patch (begp:endp)) ; this%fcansno_patch (:) = nan + allocate(this%fdry_patch (begp:endp)) ; this%fdry_patch (:) = nan + allocate(this%qflx_prec_intr_patch (begp:endp)) ; this%qflx_prec_intr_patch (:) = nan + allocate(this%qflx_prec_grnd_col (begc:endc)) ; this%qflx_prec_grnd_col (:) = nan + + end subroutine InitBulk + +end module WaterDiagnosticBulkType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterDiagnosticType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterDiagnosticType.F90 new file mode 100755 index 000000000..25536d7b3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterDiagnosticType.F90 @@ -0,0 +1,98 @@ +module WaterDiagnosticType + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Defines a derived type containing water diagnostic variables that apply to both bulk + ! water and water tracers. Diagnostic variables are neither fundamental state variables + ! nor fluxes between those fundamental states, but are typically derived from those + ! states and/or fluxes. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use clm_varcon , only : spval + use LandunitType , only : lun + use WaterStateType, only : waterstate_type + use WaterFluxType, only : waterflux_type + ! + implicit none + save + private + ! + ! !PUBLIC TYPES: + type, public :: waterdiagnostic_type + + real(r8), pointer :: snowice_col (:) ! col average snow ice lens + real(r8), pointer :: snowliq_col (:) ! col average snow liquid water + + real(r8), pointer :: h2ocan_patch (:) ! patch total canopy water (liq+ice) (mm H2O) + real(r8), pointer :: total_plant_stored_h2o_col(:) ! col water that is bound in plants, including roots, sapwood, leaves, etc + ! in most cases, the vegetation scheme does not have a dynamic + ! water storage in plants, and thus 0.0 is a suitable for the trivial case. + ! When FATES is coupled in with plant hydraulics turned on, this storage + ! term is set to non-zero. (kg/m2 H2O) + + real(r8), pointer :: h2osoi_liqice_10cm_col (:) ! col liquid water + ice lens in top 10cm of soil (kg/m2) + real(r8), pointer :: tws_grc (:) ! grc total water storage (mm H2O) + real(r8), pointer :: q_ref2m_patch (:) ! patch 2 m height surface specific humidity (kg/kg) + real(r8), pointer :: qg_snow_col (:) ! col ground specific humidity [kg/kg] + real(r8), pointer :: qg_soil_col (:) ! col ground specific humidity [kg/kg] + real(r8), pointer :: qg_h2osfc_col (:) ! col ground specific humidity [kg/kg] + real(r8), pointer :: qg_col (:) ! col ground specific humidity [kg/kg] + real(r8), pointer :: qaf_lun (:) ! lun urban canopy air specific humidity (kg/kg) + + contains + + procedure, public :: Init + + end type waterdiagnostic_type + + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + ! !ARGUMENTS: + class(waterdiagnostic_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + allocate(this%h2ocan_patch (begp:endp)) + this%h2ocan_patch(begp:endp) = spval + + allocate(this%h2osoi_liqice_10cm_col (begc:endc)) + this%h2osoi_liqice_10cm_col(begc:endc) = spval + + allocate(this%tws_grc (begg:endg)) + this%tws_grc(begg:endg) = spval + + allocate(this%q_ref2m_patch (begp:endp)) + this%q_ref2m_patch(begp:endp) = spval + + ! Snow properties - these will be vertically averaged over the snow profile + + allocate(this%snowliq_col (begc:endc)) + this%snowliq_col(begc:endc) = spval + + allocate(this%snowice_col (begc:endc)) + this%snowice_col(begc:endc) = spval + + end subroutine Init + +end module WaterDiagnosticType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterFluxBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterFluxBulkType.F90 new file mode 100755 index 000000000..6061a9a16 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterFluxBulkType.F90 @@ -0,0 +1,112 @@ +module WaterFluxBulkType + + use MAPL_ConstantsMod , ONLY : r8 => MAPL_R8 + use nanMod , only : nan + use clm_varpar , only : nlevsno, nlevsoi + use clm_varcon , only : spval + use MAPL_ExceptionHandling + use WaterFluxType , only : waterflux_type + use decompMod , only : bounds_type + + implicit none + + ! !PUBLIC TYPES: + type, extends(waterflux_type), public :: waterfluxbulk_type + ! water fluxes are in units or mm/s + + real(r8), pointer :: qflx_phs_neg_col (:) ! col sum of negative hydraulic redistribution fluxes (mm H2O/s) [+] + + real(r8), pointer :: qflx_snowindunload_patch (:) ! patch canopy snow wind unloading (mm H2O /s) + real(r8), pointer :: qflx_snotempunload_patch (:) ! patch canopy snow temp unloading (mm H2O /s) + + real(r8), pointer :: qflx_ev_snow_patch (:) ! patch evaporation heat flux from snow (mm H2O/s) [+ to atm] + real(r8), pointer :: qflx_ev_snow_col (:) ! col evaporation heat flux from snow (mm H2O/s) [+ to atm] + real(r8), pointer :: qflx_ev_soil_patch (:) ! patch evaporation heat flux from soil (mm H2O/s) [+ to atm] + real(r8), pointer :: qflx_ev_soil_col (:) ! col evaporation heat flux from soil (mm H2O/s) [+ to atm] + real(r8), pointer :: qflx_ev_h2osfc_patch (:) ! patch evaporation heat flux from soil (mm H2O/s) [+ to atm] + real(r8), pointer :: qflx_ev_h2osfc_col (:) ! col evaporation heat flux from soil (mm H2O/s) [+ to atm] + + real(r8), pointer :: qflx_adv_col (:,:) ! col advective flux across different soil layer interfaces [mm H2O/s] [+ downward] + real(r8), pointer :: qflx_rootsoi_col (:,:) ! col root and soil water exchange [mm H2O/s] [+ into root] + real(r8), pointer :: qflx_hydr_redist_patch (:) ! patch hydraulic redistribution [mm H2O/s] + real(r8), pointer :: qflx_sat_excess_surf_col (:) ! col surface runoff due to saturated surface (mm H2O /s) + real(r8), pointer :: qflx_infl_excess_col (:) ! col infiltration excess runoff (mm H2O /s) + real(r8), pointer :: qflx_infl_excess_surf_col(:) ! col surface runoff due to infiltration excess (mm H2O /s) + real(r8), pointer :: qflx_h2osfc_surf_col (:) ! col surface water runoff (mm H2O /s) + real(r8), pointer :: qflx_in_soil_col (:) ! col surface input to soil (mm/s) + real(r8), pointer :: qflx_in_soil_limited_col (:) ! col surface input to soil, limited by max infiltration rate (mm/s) + real(r8), pointer :: qflx_h2osfc_drain_col (:) ! col bottom drainage from h2osfc (mm/s) + real(r8), pointer :: qflx_top_soil_to_h2osfc_col(:) ! col portion of qflx_top_soil going to h2osfc, minus evaporation (mm/s) + real(r8), pointer :: qflx_in_h2osfc_col(:) ! col total surface input to h2osfc + real(r8), pointer :: qflx_deficit_col (:) ! col water deficit to keep non-negative liquid water content (mm H2O) + real(r8), pointer :: qflx_snomelt_lyr_col (:,:) ! col snow melt in each layer (mm H2O /s) + real(r8), pointer :: qflx_drain_vr_col (:,:) ! col liquid water losted as drainage (m /time step) + + ! ET accumulation + real(r8), pointer :: AnnEt (:) ! Annual average ET flux mmH20/s + + contains + + procedure , public :: InitBulk + + end type waterfluxbulk_type +! type(waterfluxbulk_type), public, target, save :: waterfluxbulk_inst + +contains + +!--------------------------------------------- + subroutine InitBulk(this, bounds) + + ! !DESCRIPTION: + ! Initialize CTSM type for water flux bulk variables that just apply to bulk water and are needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(waterfluxbulk_type), intent(inout) :: this + + !LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + call this%Init(bounds) + + allocate(this%qflx_snowindunload_patch (begp:endp)) ; this%qflx_snowindunload_patch (:) = nan + allocate(this%qflx_snotempunload_patch (begp:endp)) ; this%qflx_snotempunload_patch (:) = nan + allocate(this%qflx_hydr_redist_patch (begp:endp)) ; this%qflx_hydr_redist_patch (:) = nan + allocate(this%qflx_phs_neg_col (begc:endc)) ; this%qflx_phs_neg_col (:) = nan + + allocate( this%qflx_ev_snow_patch (begp:endp)) ; this%qflx_ev_snow_patch (:) = nan + allocate( this%qflx_ev_snow_col (begc:endc)) ; this%qflx_ev_snow_col (:) = nan + allocate( this%qflx_ev_soil_patch (begp:endp)) ; this%qflx_ev_soil_patch (:) = nan + allocate( this%qflx_ev_soil_col (begc:endc)) ; this%qflx_ev_soil_col (:) = nan + allocate( this%qflx_ev_h2osfc_patch (begp:endp)) ; this%qflx_ev_h2osfc_patch (:) = nan + allocate( this%qflx_ev_h2osfc_col (begc:endc)) ; this%qflx_ev_h2osfc_col (:) = nan + + allocate(this%qflx_drain_vr_col (begc:endc,1:nlevsoi)) ; this%qflx_drain_vr_col (:,:) = nan + allocate(this%qflx_adv_col (begc:endc,0:nlevsoi)) ; this%qflx_adv_col (:,:) = nan + allocate(this%qflx_rootsoi_col (begc:endc,1:nlevsoi)) ; this%qflx_rootsoi_col (:,:) = nan + allocate(this%qflx_sat_excess_surf_col (begc:endc)) ; this%qflx_sat_excess_surf_col (:) = nan + allocate(this%qflx_infl_excess_col (begc:endc)) ; this%qflx_infl_excess_col (:) = nan + allocate(this%qflx_in_soil_col (begc:endc)) ; this%qflx_in_soil_col (:) = nan + allocate(this%qflx_in_soil_limited_col (begc:endc)) ; this%qflx_in_soil_limited_col (:) = nan + allocate(this%qflx_h2osfc_drain_col (begc:endc)) ; this%qflx_h2osfc_drain_col (:) = nan + allocate(this%qflx_top_soil_to_h2osfc_col(begc:endc)) ; this%qflx_top_soil_to_h2osfc_col(:) = nan + allocate(this%qflx_in_h2osfc_col (begc:endc)) ; this%qflx_in_h2osfc_col(:) = nan + allocate(this%qflx_infl_excess_surf_col(begc:endc)) ; this%qflx_infl_excess_surf_col(:) = nan + allocate(this%qflx_h2osfc_surf_col (begc:endc)) ; this%qflx_h2osfc_surf_col (:) = nan + allocate(this%qflx_snomelt_lyr_col (begc:endc,-nlevsno+1:0)) ; this%qflx_snomelt_lyr_col (:,:) = nan + allocate(this%qflx_deficit_col (begc:endc)) ; this%qflx_deficit_col (:) = nan + allocate(this%AnnET (begc:endc)) ; this%AnnET (:) = nan + + end subroutine InitBulk +end module WaterFluxBulkType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterFluxType.F90 new file mode 100755 index 000000000..7bf885cc0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterFluxType.F90 @@ -0,0 +1,274 @@ +module WaterFluxType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use clm_varpar , only : nlevsno, nlevsoi + use clm_varcon , only : spval + use LandunitType , only : lun + use ColumnType , only : col + use netcdf + use MAPL_ExceptionHandling + use decompMod , only : bounds_type + use AnnualFluxDribbler, only : annual_flux_dribbler_type + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + type, public :: waterflux_type + + ! water fluxes are in units or mm/s + + real(r8), pointer :: qflx_through_snow_patch (:) ! patch canopy throughfall of snow (mm H2O/s) + real(r8), pointer :: qflx_through_liq_patch (:) ! patch canopy throughfal of liquid (rain+irrigation) (mm H2O/s) + real(r8), pointer :: qflx_intercepted_snow_patch(:) ! patch canopy interception of snow (mm H2O/s) + real(r8), pointer :: qflx_intercepted_liq_patch(:) ! patch canopy interception of liquid (rain+irrigation) (mm H2O/s) + real(r8), pointer :: qflx_snocanfall_patch(:) ! patch rate of excess canopy snow falling off canopy (mm H2O/s) + real(r8), pointer :: qflx_liqcanfall_patch(:) ! patch rate of excess canopy liquid falling off canopy (mm H2O/s) + real(r8), pointer :: qflx_snow_unload_patch(:) ! patch rate of canopy snow unloading (mm H2O/s) + real(r8), pointer :: qflx_liq_grnd_col (:) ! col liquid (rain+irrigation) on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_snow_grnd_col (:) ! col snow on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_rain_plus_snomelt_col(:) ! col rain plus snow melt falling on the soil (mm/s) + real(r8), pointer :: qflx_solidevap_from_top_layer_patch(:) ! patch rate of ice evaporated from top soil or snow layer (sublimation) (mm H2O /s) [+] + real(r8), pointer :: qflx_solidevap_from_top_layer_col(:) ! col rate of ice evaporated from top soil or snow layer (sublimation) (mm H2O /s) [+] + real(r8), pointer :: qflx_evap_soi_patch (:) ! patch soil evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_soi_col (:) ! col soil evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_veg_patch (:) ! patch vegetation evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_veg_col (:) ! col vegetation evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_can_patch (:) ! patch evaporation from leaves and stems (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_can_col (:) ! col evaporation from leaves and stems (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_tot_patch (:) ! patch pft_qflx_evap_soi + pft_qflx_evap_veg + qflx_tran_veg + real(r8), pointer :: qflx_evap_tot_col (:) ! col col_qflx_evap_soi + col_qflx_evap_veg + qflx_tran_veg + real(r8), pointer :: qflx_liqevap_from_top_layer_patch(:) ! patch rate of liquid water evaporated from top soil or snow layer (mm H2O/s) [+] + real(r8), pointer :: qflx_liqevap_from_top_layer_col(:) ! col rate of liquid water evaporated from top soil or snow layer (mm H2O/s) [+] + + ! In the snow capping parametrization excess mass above h2osno_max is removed. A breakdown of mass into liquid + ! and solid fluxes is done, these are represented by qflx_snwcp_liq_col and qflx_snwcp_ice_col. + real(r8), pointer :: qflx_snwcp_liq_col (:) ! col excess liquid h2o due to snow capping (outgoing) (mm H2O /s) + real(r8), pointer :: qflx_snwcp_ice_col (:) ! col excess solid h2o due to snow capping (outgoing) (mm H2O /s) + real(r8), pointer :: qflx_snwcp_discarded_liq_col(:) ! col excess liquid h2o due to snow capping, which we simply discard in order to reset the snow pack (mm H2O /s) + real(r8), pointer :: qflx_snwcp_discarded_ice_col(:) ! col excess solid h2o due to snow capping, which we simply discard in order to reset the snow pack (mm H2O /s) + real(r8), pointer :: qflx_glcice_col(:) ! col net flux of new glacial ice (growth - melt) (mm H2O/s), passed to GLC; only valid inside the do_smb_c filter + real(r8), pointer :: qflx_glcice_frz_col (:) ! col ice growth (positive definite) (mm H2O/s); only valid inside the do_smb_c filter + real(r8), pointer :: qflx_glcice_melt_col(:) ! col ice melt (positive definite) (mm H2O/s); only valid inside the do_smb_c filter + real(r8), pointer :: qflx_glcice_dyn_water_flux_col(:) ! col water flux needed for balance check due to glc_dyn_runoff_routing (mm H2O/s) (positive means addition of water to the system); valid for all columns + + real(r8), pointer :: qflx_tran_veg_patch (:) ! patch vegetation transpiration (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_tran_veg_col (:) ! col vegetation transpiration (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_soliddew_to_top_layer_patch(:) ! patch rate of solid water deposited on top soil or snow layer (frost) (mm H2O /s) [+] + real(r8), pointer :: qflx_soliddew_to_top_layer_col(:) ! col rate of solid water deposited on top soil or snow layer (frost) (mm H2O /s) [+] (+ = to atm); usually eflx_bot >= 0) + real(r8), pointer :: qflx_liqdew_to_top_layer_patch(:) ! patch rate of liquid water deposited on top soil or snow layer (dew) (mm H2O /s) [+] + real(r8), pointer :: qflx_liqdew_to_top_layer_col(:) ! col rate of liquid water deposited on top soil or snow layer (dew) (mm H2O /s) [+] + + real(r8), pointer :: qflx_infl_col (:) ! col infiltration (mm H2O /s) + real(r8), pointer :: qflx_surf_col (:) ! col total surface runoff (mm H2O /s) + real(r8), pointer :: qflx_drain_col (:) ! col sub-surface runoff (mm H2O /s) + real(r8), pointer :: qflx_drain_perched_col (:) ! col sub-surface runoff from perched wt (mm H2O /s) + real(r8), pointer :: qflx_top_soil_col (:) ! col net water input into soil from top (mm/s) + real(r8), pointer :: qflx_floodc_col (:) ! col flood water flux at column level + real(r8), pointer :: qflx_sl_top_soil_col (:) ! col liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) + real(r8), pointer :: qflx_snomelt_col (:) ! col snow melt (mm H2O /s) + real(r8), pointer :: qflx_qrgwl_col (:) ! col qflx_surf at glaciers, wetlands, lakes + real(r8), pointer :: qflx_runoff_col (:) ! col total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s) + real(r8), pointer :: qflx_runoff_r_col (:) ! col Rural total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s) + real(r8), pointer :: qflx_runoff_u_col (:) ! col urban total runoff (qflx_drain+qflx_surf) (mm H2O /s) + real(r8), pointer :: qflx_rsub_sat_col (:) ! col soil saturation excess [mm/s] + real(r8), pointer :: qflx_snofrz_lyr_col (:,:) ! col snow freezing rate (positive definite) (col,lyr) [kg m-2 s-1] + real(r8), pointer :: qflx_snofrz_col (:) ! col column-integrated snow freezing rate (positive definite) (col) [kg m-2 s-1] + real(r8), pointer :: qflx_snow_drain_col (:) ! col drainage from snow pack + real(r8), pointer :: qflx_ice_runoff_snwcp_col(:) ! col solid runoff from snow capping (mm H2O /s) + real(r8), pointer :: qflx_ice_runoff_xs_col (:) ! col solid runoff from excess ice in soil (mm H2O /s) + + real(r8), pointer :: qflx_h2osfc_to_ice_col (:) ! col conversion of h2osfc to ice + real(r8), pointer :: qflx_snow_h2osfc_col (:) ! col snow falling on surface water + real(r8), pointer :: qflx_too_small_h2osfc_to_soil_col(:) ! col h2osfc transferred to soil if h2osfc is below some threshold (mm H2O /s) + real(r8), pointer :: qflx_snow_percolation_col(:,:) ! col liquid percolation out of the bottom of snow layer j (mm H2O /s) + + ! Dynamic land cover change + real(r8), pointer :: qflx_liq_dynbal_grc (:) ! grc liq dynamic land cover change conversion runoff flux + real(r8), pointer :: qflx_ice_dynbal_grc (:) ! grc ice dynamic land cover change conversion runoff flux + + real(r8), pointer :: qflx_sfc_irrig_col (:) ! col surface irrigation flux (mm H2O/s) [+] + real(r8), pointer :: qflx_gw_uncon_irrig_col (:) ! col unconfined groundwater irrigation flux (mm H2O/s) + real(r8), pointer :: qflx_gw_uncon_irrig_lyr_col(:,:) ! col unconfined groundwater irrigation flux, separated by layer (mm H2O/s) + real(r8), pointer :: qflx_gw_con_irrig_col (:) ! col confined groundwater irrigation flux (mm H2O/s) + real(r8), pointer :: qflx_irrig_drip_patch (:) ! patch drip irrigation + real(r8), pointer :: qflx_irrig_sprinkler_patch(:) ! patch sprinkler irrigation + + ! Objects that help convert once-per-year dynamic land cover changes into fluxes + ! that are dribbled throughout the year + type(annual_flux_dribbler_type) :: qflx_liq_dynbal_dribbler + type(annual_flux_dribbler_type) :: qflx_ice_dynbal_dribbler + + contains + + procedure, public :: Init + + end type waterflux_type + !type(waterflux_type), public, target, save :: waterflux_inst + +contains + +!--------------------------------------------- + subroutine Init(this, bounds) + + ! !DESCRIPTION: + ! Initialize CTSM type for water flux variables that just apply to bulk water and are needed for calling CTSM routines + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + + ! !USES: + use landunit_varcon, only : istsoil, istcrop + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(waterflux_type), intent(inout) :: this + + !LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + integer :: c, l + !-------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + begg = bounds%begg ; endg = bounds%endg + + allocate(this%qflx_through_liq_patch(begp:endp)) + allocate(this%qflx_through_snow_patch(begp:endp)) + allocate(this%qflx_liqcanfall_patch(begp:endp)) + allocate(this%qflx_snocanfall_patch(begp:endp)) + allocate(this%qflx_snow_unload_patch(begp:endp)) + allocate(this%qflx_top_soil_col(begc:endc)) + allocate(this%qflx_infl_col(begc:endc)) + allocate(this%qflx_surf_col(begc:endc)) + allocate(this%qflx_qrgwl_col(begc:endc)) + allocate(this%qflx_drain_col(begc:endc)) + allocate(this%qflx_drain_perched_col(begc:endc)) + allocate(this%qflx_liq_dynbal_grc(begg:endg)) + allocate(this%qflx_ice_dynbal_grc(begg:endg)) + allocate(this%qflx_runoff_col(begc:endc)) + allocate(this%qflx_runoff_u_col(begc:endc)) + allocate(this%qflx_runoff_r_col(begc:endc)) + allocate(this%qflx_snomelt_col(begc:endc)) + allocate(this%qflx_snofrz_col(begc:endc)) + allocate(this%qflx_snofrz_lyr_col(begc:endc,-nlevsno+1:0)) + allocate(this%qflx_snow_drain_col(begc:endc)) + allocate(this%qflx_evap_soi_patch(begp:endp)) + allocate(this%qflx_evap_can_patch(begp:endp)) + allocate(this%qflx_tran_veg_patch(begp:endp)) + allocate(this%qflx_snwcp_liq_col(begc:endc)) + allocate(this%qflx_snwcp_ice_col(begc:endc)) + allocate(this%qflx_glcice_col(begc:endc)) + allocate(this%qflx_glcice_frz_col(begc:endc)) + allocate(this%qflx_glcice_melt_col(begc:endc)) + allocate(this%qflx_liq_grnd_col(begc:endc)) + allocate(this%qflx_snow_grnd_col(begc:endc)) + allocate(this%qflx_liqevap_from_top_layer_patch(begp:endp)) + allocate(this%qflx_evap_veg_patch(begp:endp)) + allocate(this%qflx_evap_tot_patch(begp:endp)) + allocate(this%qflx_liqdew_to_top_layer_patch(begp:endp)) + allocate(this%qflx_solidevap_from_top_layer_patch(begp:endp)) + allocate(this%qflx_soliddew_to_top_layer_patch(begp:endp)) + allocate(this%qflx_rsub_sat_col(begc:endc)) + allocate(this%qflx_h2osfc_to_ice_col(begc:endc)) + allocate(this%qflx_sfc_irrig_col(begc:endc)) + allocate(this%qflx_gw_uncon_irrig_col(begc:endc)) + allocate(this%qflx_gw_con_irrig_col(begc:endc)) + allocate(this%qflx_irrig_drip_patch(begp:endp)) + allocate(this%qflx_irrig_sprinkler_patch(begp:endp)) + + allocate(this%qflx_liqevap_from_top_layer_col(begc:endc)) + allocate(this%qflx_liqdew_to_top_layer_col(begc:endc)) + allocate(this%qflx_soliddew_to_top_layer_col(begc:endc)) + allocate(this%qflx_ice_runoff_xs_col(begc:endc)) + allocate(this%qflx_glcice_dyn_water_flux_col(begc:endc)) + allocate(this%qflx_gw_uncon_irrig_lyr_col(begc:endc,1:nlevsoi)) + + this%qflx_through_liq_patch(begp:endp) = spval + this%qflx_through_snow_patch(begp:endp) = spval + this%qflx_liqcanfall_patch(begp:endp) = spval + this%qflx_snocanfall_patch(begp:endp) = spval + this%qflx_snow_unload_patch(begp:endp) = spval + this%qflx_top_soil_col(begc:endc) = spval + this%qflx_infl_col(begc:endc) = spval + this%qflx_surf_col(begc:endc) = spval + this%qflx_qrgwl_col(begc:endc) = spval + this%qflx_drain_col(begc:endc) = spval + this%qflx_drain_perched_col(begc:endc) = spval + this%qflx_liq_dynbal_grc(begg:endg) = spval + this%qflx_ice_dynbal_grc(begg:endg) = spval + this%qflx_runoff_col(begc:endc) = spval + this%qflx_runoff_u_col(begc:endc) = spval + this%qflx_runoff_r_col(begc:endc) = spval + this%qflx_snomelt_col(begc:endc) = spval + this%qflx_snofrz_col(begc:endc) = spval + this%qflx_snofrz_lyr_col(begc:endc,-nlevsno+1:0) = spval + this%qflx_snow_drain_col(begc:endc) = spval + this%qflx_evap_soi_patch(begp:endp) = spval + this%qflx_evap_can_patch(begp:endp) = spval + this%qflx_tran_veg_patch(begp:endp) = spval + this%qflx_snwcp_liq_col(begc:endc) = spval + this%qflx_snwcp_ice_col(begc:endc) = spval + this%qflx_glcice_col(begc:endc) = spval + this%qflx_glcice_frz_col(begc:endc) = spval + this%qflx_glcice_melt_col(begc:endc) = spval + this%qflx_liq_grnd_col(begc:endc) = spval + this%qflx_snow_grnd_col(begc:endc) = spval + this%qflx_liqevap_from_top_layer_patch(begp:endp) = spval + this%qflx_evap_veg_patch(begp:endp) = spval + this%qflx_evap_tot_patch(begp:endp) = spval + this%qflx_liqdew_to_top_layer_patch(begp:endp) = spval + this%qflx_solidevap_from_top_layer_patch(begp:endp) = spval + this%qflx_soliddew_to_top_layer_patch(begp:endp) = spval + this%qflx_rsub_sat_col(begc:endc) = spval + this%qflx_h2osfc_to_ice_col(begc:endc) = spval + this%qflx_sfc_irrig_col(begc:endc) = spval + this%qflx_gw_uncon_irrig_col(begc:endc) = spval + this%qflx_gw_con_irrig_col(begc:endc) = spval + this%qflx_irrig_drip_patch(begp:endp) = spval + this%qflx_irrig_sprinkler_patch(begp:endp) = spval + + ! assign cold start values for variables where it is needed + + this%qflx_snocanfall_patch(bounds%begp:bounds%endp) = 0.0_r8 + this%qflx_liqcanfall_patch(bounds%begp:bounds%endp) = 0.0_r8 + this%qflx_snow_unload_patch(bounds%begp:bounds%endp) = 0.0_r8 + + this%qflx_liqevap_from_top_layer_patch(bounds%begp:bounds%endp) = 0.0_r8 + this%qflx_liqdew_to_top_layer_patch(bounds%begp:bounds%endp) = 0.0_r8 + this%qflx_soliddew_to_top_layer_patch (bounds%begp:bounds%endp) = 0.0_r8 + + this%qflx_sfc_irrig_col (bounds%begc:bounds%endc) = 0.0_r8 + this%qflx_gw_uncon_irrig_col (bounds%begc:bounds%endc) = 0.0_r8 + this%qflx_gw_uncon_irrig_lyr_col(bounds%begc:bounds%endc,:) = 0.0_r8 + this%qflx_gw_con_irrig_col (bounds%begc:bounds%endc) = 0.0_r8 + this%qflx_irrig_drip_patch (bounds%begp:bounds%endp) = 0.0_r8 + this%qflx_irrig_sprinkler_patch (bounds%begp:bounds%endp) = 0.0_r8 + + this%qflx_liqevap_from_top_layer_col(bounds%begc:bounds%endc) = 0.0_r8 + this%qflx_liqdew_to_top_layer_col(bounds%begc:bounds%endc) = 0.0_r8 + this%qflx_soliddew_to_top_layer_col (bounds%begc:bounds%endc) = 0.0_r8 + this%qflx_snow_drain_col(bounds%begc:bounds%endc) = 0._r8 + this%qflx_ice_runoff_xs_col(bounds%begc:bounds%endc) = 0._r8 + this%qflx_glcice_dyn_water_flux_col(bounds%begc:bounds%endc) = 0._r8 + this%qflx_tran_veg_patch(bounds%begp:bounds%endp) = 0._r8 + this%qflx_evap_veg_patch(bounds%begp:bounds%endp) = 0._r8 + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%qflx_drain_col(c) = 0._r8 + this%qflx_surf_col(c) = 0._r8 + end if + end do + + end subroutine Init + +end module WaterFluxType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterStateBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterStateBulkType.F90 new file mode 100755 index 000000000..4f9e59a03 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterStateBulkType.F90 @@ -0,0 +1,69 @@ +module WaterStateBulkType + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Defines a derived type containing water state variables that just apply to bulk + ! water. Note that this type extends the base waterstate_type, so the full + ! waterstatebulk_type contains the union of the fields defined here and the fields + ! defined in waterstate_type. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use clm_varpar , only : nlevmaxurbgrnd, nlevsno + use clm_varcon , only : spval + use WaterStateType , only : waterstate_type + use nanMod , only : nan + ! + implicit none + save + private + +! !PUBLIC MEMBER FUNCTIONS: + ! + ! !PUBLIC TYPES: + type, extends(waterstate_type), public :: waterstatebulk_type + + real(r8), pointer :: snow_persistence_col (:) ! col length of time that ground has had non-zero snow thickness (sec) + real(r8), pointer :: int_snow_col (:) ! col integrated snowfall (mm H2O) + + contains + + procedure , public :: InitBulk + + end type waterstatebulk_type +! type(waterstatebulk_type), public, target, save :: waterstatebulk_inst + +contains + +!--------------------------------------------- + subroutine InitBulk(this, bounds) + + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(waterstatebulk_type), intent(inout) :: this + + !LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begl, endl + integer :: begg, endg + !-------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + begl = bounds%begl ; endl= bounds%endl + begg = bounds%begg ; endg = bounds%endg + + call this%Init(bounds) + + allocate(this%snow_persistence_col (begc:endc)) ; this%snow_persistence_col (:) = nan + allocate(this%int_snow_col (begc:endc)) ; this%int_snow_col (:) = nan + + end subroutine InitBulk + +end module WaterStateBulkType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterStateType.F90 new file mode 100755 index 000000000..fe0ba4f39 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterStateType.F90 @@ -0,0 +1,95 @@ +module WaterStateType + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Defines a derived type containing water state variables that apply to both bulk water + ! and water tracers. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use decompMod , only : bounds_type + use clm_varpar , only : nlevgrnd, nlevsoi, nlevurb, nlevmaxurbgrnd, nlevsno + use clm_varcon , only : spval + use LandunitType , only : lun + use ColumnType , only : col + use nanMod , only : nan + + implicit none + save + private +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + ! !PUBLIC TYPES: + type, public :: waterstate_type + + real(r8), pointer :: h2osno_no_layers_col (:) ! col snow that is not resolved into layers; this is non-zero only if there is too little snow for there to be explicit snow layers (mm H2O) + real(r8), pointer :: h2osoi_liq_col (:,:) ! col liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) + real(r8), pointer :: h2osoi_ice_col (:,:) ! col ice lens (kg/m2) (new) (-nlevsno+1:nlevgrnd) + real(r8), pointer :: h2osoi_vol_col (:,:) ! col volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (nlevgrnd) + real(r8), pointer :: h2osoi_vol_prs_grc (:,:) ! grc volumetric soil water prescribed (0<=h2osoi_vol<=watsat) [m3/m3] (nlevgrnd) + real(r8), pointer :: h2osfc_col (:) ! col surface water (mm H2O) + real(r8), pointer :: snocan_patch (:) ! patch canopy snow water (mm H2O) + real(r8), pointer :: liqcan_patch (:) ! patch canopy liquid water (mm H2O) + + real(r8), pointer :: wa_col (:) ! col water in the unconfined aquifer (mm) + + ! For the following dynbal baseline variables: positive values are subtracted to + ! avoid counting liquid water content of "virtual" states; negative values are added + ! to account for missing states in the model. + real(r8), pointer :: dynbal_baseline_liq_col(:) ! baseline liquid water content subtracted from each column's total liquid water calculation (mm H2O) + real(r8), pointer :: dynbal_baseline_ice_col(:) ! baseline ice content subtracted from each column's total ice calculation (mm H2O) + + real(r8) :: aquifer_water_baseline ! baseline value for water in the unconfined aquifer (wa_col) for this bulk / tracer (mm) + + contains + + procedure , public :: Init + + end type waterstate_type + ! type(waterstate_type), public, target, save :: waterstate_inst + +contains + +!--------------------------------------------- + subroutine Init(this, bounds) + + ! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + class(waterstate_type), intent(inout) :: this + + !LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begl, endl + integer :: begg, endg + !-------------------- + + begp = bounds%begp ; endp = bounds%endp + begc = bounds%begc ; endc = bounds%endc + begl = bounds%begl ; endl= bounds%endl + begg = bounds%begg ; endg = bounds%endg + + allocate( this%h2osfc_col (begc:endc)) ; this%h2osfc_col(begc:endc) = 0._r8 + allocate( this%snocan_patch (begp:endp)) ; this%snocan_patch(begp:endp) = 0._r8 + allocate( this%liqcan_patch (begp:endp)) ; this%liqcan_patch(begp:endp) = 0._r8 + + allocate(this%h2osoi_vol_col(begc:endc,1:nlevmaxurbgrnd)) ; this%h2osoi_vol_col(begc:endc, 1:) = spval + allocate(this%h2osoi_vol_prs_grc(begg:endg,1:nlevgrnd)) ; this%h2osoi_vol_prs_grc(begg:endg, 1:) = spval + allocate(this%h2osoi_liq_col(begc:endc,-nlevsno+1:nlevmaxurbgrnd)) ; this%h2osoi_liq_col(begc:endc,-nlevsno+1:) = spval + allocate(this%h2osoi_ice_col(begc:endc,-nlevsno+1:nlevmaxurbgrnd)) ; this%h2osoi_ice_col(bounds%begc:bounds%endc,-nlevsno+1:) = spval + + allocate( this%wa_col (begc:endc)) ; this%wa_col(begc:endc) = spval + allocate( this%h2osno_no_layers_col (begc:endc)) ; this%h2osno_no_layers_col(begc:endc) = nan + allocate( this%dynbal_baseline_liq_col (begc:endc)); this%dynbal_baseline_liq_col(begc:endc) = nan + allocate( this%dynbal_baseline_ice_col (begc:endc)); this%dynbal_baseline_ice_col(begc:endc) = nan + + end subroutine Init +end module WaterStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterType.F90 new file mode 100755 index 000000000..7178e03a3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_WaterType.F90 @@ -0,0 +1,214 @@ +module WaterType + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Container for derived types relating to water, both for bulk water and for isotopes + ! and other tracers. + ! + ! Variables pertaining to bulk water can be accessed in two ways: + ! + ! (1) Using water_inst%water*bulk_inst + ! + ! (2) As one of the indices in water_inst%bulk_and_tracers(:)%water*_inst + ! + ! Method (1) is greatly preferable when you are just operating on bulk water. Method + ! (2) is just meant to be used when you are doing the same operation on bulk water + ! and all water tracers. + ! + ! To loop through bulk and all tracers, use code like this: + ! do i = water_inst%bulk_and_tracers_beg, water_inst%bulk_and_tracers_end + ! associate( & + ! waterflux_inst => water_inst%bulk_and_tracers(i)%waterflux_inst, & + ! [and other associations, as necessary]) + ! [Do calculations involving waterflux_inst, etc.] + ! end associate + ! end do + ! + ! To loop through all tracers (not bulk), use code like this: + ! do i = water_inst%tracers_beg, water_inst%tracers_end + ! associate( & + ! waterflux_inst => water_inst%bulk_and_tracers(i)%waterflux_inst, & + ! [and other associations, as necessary]) + ! [Do calculations involving waterflux_inst, etc.] + ! end associate + ! end do + ! + ! To loop through all isotopes (not bulk or other water tracers), use code like this: + ! type(water_info_isotope_type), pointer :: iso_info + ! + ! do i = water_inst%tracers_beg, water_inst%tracers_end + ! if (water_inst%IsIsotope(i)) then + ! call water_inst%GetIsotopeInfo(i, iso_info) + ! associate( & + ! waterflux_inst => water_inst%bulk_and_tracers(i)%waterflux_inst, & + ! [and other associations, as necessary]) + ! [Do calculations involving iso_info, waterflux_inst, etc.] + ! end associate + ! end if + ! end do + ! + ! The associate statements given above aren't crucial. If the block of code refers to + ! multiple instances (waterstate, waterflux, etc.), but only refers to each one once or + ! twice, it can be best to just have: + ! associate(bulk_or_tracer => water_inst%bulk_and_tracers(i)) + ! + ! !USES: +#include "shr_assert.h" + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use decompMod , only : bounds_type + use clm_varctl , only : iulog + use clm_varpar , only : nlevsno + use ncdio_pio , only : file_desc_t + use WaterFluxBulkType , only : waterfluxbulk_type + use WaterFluxType , only : waterflux_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterStateType , only : waterstate_type + use WaterDiagnosticType , only : waterdiagnostic_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type +! use WaterBalanceType , only : waterbalance_type +! use WaterInfoBaseType , only : water_info_base_type +! use WaterInfoBulkType , only : water_info_bulk_type +! use WaterInfoTracerType , only : water_info_tracer_type +! use WaterInfoIsotopeType , only : water_info_isotope_type +! use Waterlnd2atmType , only : waterlnd2atm_type +! use Waterlnd2atmBulkType , only : waterlnd2atmbulk_type + use Wateratm2lndType , only : wateratm2lnd_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + ! use WaterTracerContainerType , only : water_tracer_container_type + ! use WaterTracerUtils , only : CompareBulkToTracer, SetTracerToBulkTimesRatio + + implicit none + private + + ! + ! !PRIVATE TYPES: + + ! This type holds instances needed for bulk water or for a single tracer + type, private :: bulk_or_tracer_type + private + + ! ------------------------------------------------------------------------ + ! Public data members + ! ------------------------------------------------------------------------ + + class(waterflux_type) , pointer, public :: waterflux_inst + class(waterstate_type) , pointer, public :: waterstate_inst + class(waterdiagnostic_type) , pointer, public :: waterdiagnostic_inst + ! class(waterbalance_type) , pointer, public :: waterbalance_inst + ! class(waterlnd2atm_type) , pointer, public :: waterlnd2atm_inst + class(wateratm2lnd_type) , pointer, public :: wateratm2lnd_inst + + ! ------------------------------------------------------------------------ + ! Private data members + ! ------------------------------------------------------------------------ + + ! logical :: is_isotope = .false. + ! class(water_info_base_type) , pointer :: info + ! type(water_tracer_container_type) :: vars + + end type bulk_or_tracer_type + + ! + ! !PUBLIC TYPES: + +! ! water_params_type is public for the sake of unit tests +! type, public :: water_params_type +! private +! +! ! Whether we add tracers that are used for the tracer consistency checks +! logical :: enable_consistency_checks +! +! ! Whether we add tracers that are used for isotopes +! logical :: enable_isotopes +! end type water_params_type + + type, public :: water_type + private + + ! ------------------------------------------------------------------------ + ! Public data members + ! ------------------------------------------------------------------------ + + ! indices into the bulk_and_tracers array + integer, public :: bulk_and_tracers_beg ! first index when looping over bulk & tracers + integer, public :: bulk_and_tracers_end ! last index when looping over bulk & tracers + integer, public :: tracers_beg ! first index when looping over just tracers + integer, public :: tracers_end ! last index when looping over just tracers + integer, public :: i_bulk ! index of bulk in arrays that contain both bulk and tracers + + type(waterfluxbulk_type), pointer, public :: waterfluxbulk_inst + type(waterstatebulk_type), pointer, public :: waterstatebulk_inst + type(waterdiagnosticbulk_type), pointer, public :: waterdiagnosticbulk_inst + ! type(waterbalance_type), pointer, public :: waterbalancebulk_inst + ! type(waterlnd2atmbulk_type), pointer, public :: waterlnd2atmbulk_inst + type(wateratm2lndbulk_type), pointer, public :: wateratm2lndbulk_inst + + type(bulk_or_tracer_type), public :: bulk_and_tracers(1) + + ! ------------------------------------------------------------------------ + ! Private data members + ! ------------------------------------------------------------------------ + + ! type(water_params_type) :: params + integer :: bulk_tracer_index ! index of the tracer that replicates bulk water (-1 if it doesn't exist) + + contains + ! Public routines + procedure, public :: Init + + end type water_type + type(water_type), public, target, save :: water_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + + !----------------------------------------------------------------------- + subroutine Init(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize all water variables + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Init' + !----------------------------------------------------------------------- + + allocate(this%waterfluxbulk_inst) + this%bulk_and_tracers(1)%waterflux_inst => this%waterfluxbulk_inst + + allocate(this%waterstatebulk_inst) + this%bulk_and_tracers(1)%waterstate_inst => this%waterstatebulk_inst + + allocate(this%waterdiagnosticbulk_inst) + this%bulk_and_tracers(1)%waterdiagnostic_inst => this%waterdiagnosticbulk_inst + + allocate(this%wateratm2lndbulk_inst) + this%bulk_and_tracers(1)%wateratm2lnd_inst => this%wateratm2lndbulk_inst + + allocate(waterflux_type :: this%bulk_and_tracers(1)%waterflux_inst) + allocate(waterdiagnostic_type :: this%bulk_and_tracers(1)%waterdiagnostic_inst) + allocate(waterstate_type :: this%bulk_and_tracers(1)%waterstate_inst) + allocate(wateratm2lnd_type :: this%bulk_and_tracers(1)%wateratm2lnd_inst) + + call this%bulk_and_tracers(1)%waterflux_inst%Init (bounds) + call this%bulk_and_tracers(1)%wateratm2lnd_inst%Init (bounds) + call this%bulk_and_tracers(1)%waterstate_inst%Init (bounds) + call this%waterfluxbulk_inst%InitBulk (bounds) + call this%waterdiagnosticbulk_inst%InitBulk (bounds) + call this%wateratm2lndbulk_inst%InitBulk (bounds) + call this%waterstatebulk_inst%InitBulk (bounds) + + + end subroutine Init + + +end module WaterType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_Wateratm2lndBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_Wateratm2lndBulkType.F90 new file mode 100755 index 000000000..8f92193b0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_Wateratm2lndBulkType.F90 @@ -0,0 +1,89 @@ +module Wateratm2lndBulkType + + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Defines a derived type containing water atm2lnd variables that just apply to bulk + ! water. Note that this type extends the base wateratm2lnd_type, so the full + ! wateratm2lndbulk_type contains the union of the fields defined here and the fields + ! defined in wateratm2lnd_type. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun + use PatchType , only : patch + use clm_varctl , only : iulog, use_fates, use_cn, use_cndv + use clm_varcon , only : spval + use WaterAtm2lndType , only : wateratm2lnd_type + + implicit none + save + private + + ! !PUBLIC MEMBER FUNCTIONS: + ! + ! !PUBLIC TYPES: + type, extends(wateratm2lnd_type), public :: wateratm2lndbulk_type + + real(r8), pointer :: volrmch_grc (:) ! rof volr main channel (m3) + real(r8), pointer :: volr_grc (:) ! rof volr total volume (m3) + real(r8), pointer :: forc_rh_grc (:) ! atmospheric relative humidity (%) + real(r8) , pointer :: prec365_col (:) ! col 365-day running mean of tot. precipitation (see comment in UpdateAccVars regarding why this is col-level despite other prec accumulators being patch-level) + real(r8) , pointer :: prec60_patch (:) ! patch 60-day running mean of tot. precipitation (mm/s) + real(r8) , pointer :: prec10_patch (:) ! patch 10-day running mean of tot. precipitation (mm/s) + real(r8) , pointer :: rh30_patch (:) ! patch 30-day running mean of relative humidity + real(r8) , pointer :: prec24_patch (:) ! patch 24-hour running mean of tot. precipitation (mm/s) + real(r8) , pointer :: rh24_patch (:) ! patch 24-hour running mean of relative humidity + + contains + + procedure, public :: InitBulk + + end type wateratm2lndbulk_type + + contains + + !------------------------------------------------------------------------ + subroutine InitBulk(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use nanMod , only : nan + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + class(wateratm2lndbulk_type), intent(inout) :: this + + ! + ! !LOCAL VARIABLES: + real(r8) :: ival = 0.0_r8 ! initial value + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + call this%Init(bounds) + + allocate(this%volr_grc (begg:endg)) ; this%volr_grc (:) = ival + allocate(this%volrmch_grc (begg:endg)) ; this%volrmch_grc (:) = ival + allocate(this%forc_rh_grc (begg:endg)) ; this%forc_rh_grc (:) = ival + allocate(this%prec365_col (begc:endc)) ; this%prec365_col (:) = nan + allocate(this%prec60_patch (begp:endp)) ; this%prec60_patch(:) = spval + allocate(this%prec10_patch (begp:endp)) ; this%prec10_patch(:) = spval + allocate(this%rh30_patch (begp:endp)) ; this%rh30_patch (:) = spval + if (use_fates) then + allocate(this%prec24_patch (begp:endp)) ; this%prec24_patch(:) = nan + allocate(this%rh24_patch (begp:endp)) ; this%rh24_patch (:) = nan + end if + + + end subroutine InitBulk +end module Wateratm2lndBulkType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_Wateratm2lndType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_Wateratm2lndType.F90 new file mode 100755 index 000000000..d70183036 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_Wateratm2lndType.F90 @@ -0,0 +1,81 @@ +module Wateratm2lndType + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Defines a derived type containing water atm2lnd variables that apply to both bulk water + ! and water tracers. + ! + ! !USES: +#include "shr_assert.h" + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use clm_varcon , only : spval + + implicit none + save + private + + ! !PUBLIC MEMBER FUNCTIONS: + ! + ! !PUBLIC TYPES: + type, public :: wateratm2lnd_type + + real(r8), pointer :: forc_q_not_downscaled_grc (:) ! not downscaled atm specific humidity (kg/kg) + real(r8), pointer :: forc_rain_not_downscaled_grc (:) ! not downscaled atm rain rate [mm/s] + real(r8), pointer :: forc_snow_not_downscaled_grc (:) ! not downscaled atm snow rate [mm/s] + real(r8), pointer :: forc_q_downscaled_col (:) ! downscaled atm specific humidity (kg/kg) + real(r8), pointer :: forc_flood_grc (:) ! rof flood (mm/s) + real(r8), pointer :: forc_rain_downscaled_col (:) ! downscaled atm rain rate [mm/s] + real(r8), pointer :: forc_snow_downscaled_col (:) ! downscaled atm snow rate [mm/s] + + real(r8), pointer :: rain_to_snow_conversion_col (:) ! amount of rain converted to snow via precipitation repartitioning (mm/s) + real(r8), pointer :: snow_to_rain_conversion_col (:) ! amount of snow converted to rain via precipitation repartitioning (mm/s) + + contains + + procedure, public :: Init + + end type wateratm2lnd_type +! type(wateratm2lnd_type), public, target, save :: wateratm2lnd_inst + + contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + ! + ! !DESCRIPTION: + ! + ! !USES: + use nanMod , only : nan + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + class(wateratm2lnd_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: begg, endg + !------------------------------------------------------------------------ + + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + allocate(this%forc_q_not_downscaled_grc (begg:endg)) + allocate(this%forc_rain_not_downscaled_grc (begg:endg)) + allocate(this%forc_snow_not_downscaled_grc (begg:endg)) + allocate(this%forc_q_downscaled_col (begc:endc)) + allocate(this%forc_flood_grc (begg:endg)) + allocate(this%forc_rain_downscaled_col (begc:endc)) + allocate(this%forc_snow_downscaled_col (begc:endc)) + allocate(this%rain_to_snow_conversion_col (begc:endc)) + allocate(this%snow_to_rain_conversion_col (begc:endc)) + + this%forc_rain_not_downscaled_grc(begg:endg) = spval + this%forc_snow_not_downscaled_grc(begg:endg) = spval + this%forc_q_downscaled_col(begc:endc) = spval + this%forc_flood_grc(begg:endg) = spval + this%forc_rain_downscaled_col(begc:endc) = spval + this%forc_snow_downscaled_col(begc:endc) = spval + + end subroutine Init +end module Wateratm2lndType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_atm2lndType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_atm2lndType.F90 new file mode 100755 index 000000000..3478e1977 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_atm2lndType.F90 @@ -0,0 +1,148 @@ +module atm2lndType + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varpar , only : numrad + use clm_varctl , only : use_fates, use_luna + use nanMod , only : nan + use decompMod , only : bounds_type + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + ! + type, public :: atm2lnd_type + + ! atm->lnd not downscaled + real(r8), pointer :: forc_u_grc (:) => null() ! atm wind speed, east direction (m/s) + real(r8), pointer :: forc_v_grc (:) => null() ! atm wind speed, north direction (m/s) + real(r8), pointer :: forc_wind_grc (:) => null() ! atmospheric wind speed + real(r8), pointer :: forc_hgt_grc (:) => null() ! atmospheric reference height (m) + real(r8), pointer :: forc_topo_grc (:) => null() ! atmospheric surface height (m) + real(r8), pointer :: forc_hgt_u_grc (:) => null() ! obs height of wind [m] (new) + real(r8), pointer :: forc_hgt_t_grc (:) => null() ! obs height of temperature [m] (new) + real(r8), pointer :: forc_hgt_q_grc (:) => null() ! obs height of humidity [m] (new) + real(r8), pointer :: forc_vp_grc (:) => null() ! atmospheric vapor pressure (Pa) + real(r8), pointer :: forc_pco2_grc (:) => null() ! CO2 partial pressure (Pa) + real(r8), pointer :: forc_pco2_240_patch (:) => null() ! 10-day mean CO2 partial pressure (Pa) + real(r8), pointer :: forc_solad_grc (:,:) => null() ! direct beam radiation (numrad) (vis=forc_sols , nir=forc_soll ) + real(r8), pointer :: forc_solai_grc (:,:) => null() ! diffuse radiation (numrad) (vis=forc_solsd, nir=forc_solld) + real(r8), pointer :: forc_solar_grc (:) => null() ! incident solar radiation + real(r8), pointer :: forc_ndep_grc (:) => null() ! nitrogen deposition rate (gN/m2/s) + real(r8), pointer :: forc_pc13o2_grc (:) => null() ! C13O2 partial pressure (Pa) + real(r8), pointer :: forc_po2_grc (:) => null() ! O2 partial pressure (Pa) + real(r8), pointer :: forc_po2_240_patch (:) => null() ! 10-day mean O2 partial pressure (Pa) + real(r8), pointer :: forc_aer_grc (:,:) => null() ! aerosol deposition array + real(r8), pointer :: forc_pch4_grc (:) => null() ! CH4 partial pressure (Pa) + + real(r8), pointer :: forc_t_not_downscaled_grc (:) => null() ! not downscaled atm temperature (Kelvin) + real(r8), pointer :: forc_th_not_downscaled_grc (:) => null() ! not downscaled atm potential temperature (Kelvin) + real(r8), pointer :: forc_pbot_not_downscaled_grc (:) => null() ! not downscaled atm pressure (Pa) + real(r8), pointer :: forc_pbot240_downscaled_patch (:) => null() ! 10-day mean downscaled atm pressure (Pa) + real(r8), pointer :: forc_rho_not_downscaled_grc (:) => null() ! not downscaled atm density (kg/m**3) + real(r8), pointer :: forc_lwrad_not_downscaled_grc (:) => null() ! not downscaled atm downwrd IR longwave radiation (W/m**2) + + ! atm->lnd downscaled + real(r8), pointer :: forc_t_downscaled_col (:) => null() ! downscaled atm temperature (Kelvin) + real(r8), pointer :: forc_th_downscaled_col (:) => null() ! downscaled atm potential temperature (Kelvin) + real(r8), pointer :: forc_pbot_downscaled_col (:) => null() ! downscaled atm pressure (Pa) + real(r8), pointer :: forc_rho_downscaled_col (:) => null() ! downscaled atm density (kg/m**3) + real(r8), pointer :: forc_lwrad_downscaled_col (:) => null() ! downscaled atm downwrd IR longwave radiation (W/m**2) + + + ! time averaged quantities + real(r8) , pointer :: fsd24_patch (:) => null() ! patch 24hr average of direct beam radiation + real(r8) , pointer :: fsd240_patch (:) => null() ! patch 240hr average of direct beam radiation + real(r8) , pointer :: fsi24_patch (:) => null() ! patch 24hr average of diffuse beam radiation + real(r8) , pointer :: fsi240_patch (:) => null() ! patch 240hr average of diffuse beam radiation + real(r8) , pointer :: wind24_patch (:) => null() ! patch 24-hour running mean of wind + real(r8) , pointer :: t_mo_patch (:) => null() ! patch 30-day average temperature (Kelvin) + real(r8) , pointer :: t_mo_min_patch (:) => null() ! patch annual min of t_mo (Kelvin) + + contains + + procedure, public :: Init + +end type atm2lnd_type +type(atm2lnd_type), public, target, save :: atm2lnd_inst + +contains + +!--------------------------------------------------------------------- + subroutine Init(this, bounds) + + ! !DESCRIPTION: +! Initialize CTSM atmosphere2land (forcing type) needed for calling CTSM routines +! jk Apr 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made +! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect +! +! !ARGUMENTS: + implicit none + type(bounds_type), intent(in) :: bounds + class(atm2lnd_type) :: this + + ! LOCAL: + real(r8) :: ival = 0.0_r8 ! initial value + integer :: begg, endg + integer :: begc, endc + integer :: begp, endp + !------------------------------------------------------------------------ + + begg = bounds%begg; endg= bounds%endg + begc = bounds%begc; endc= bounds%endc + begp = bounds%begp; endp= bounds%endp + + + ! atm->lnd + allocate(this%forc_u_grc (begg:endg)) ; this%forc_u_grc (:) = ival + allocate(this%forc_v_grc (begg:endg)) ; this%forc_v_grc (:) = ival + allocate(this%forc_wind_grc (begg:endg)) ; this%forc_wind_grc (:) = ival + allocate(this%forc_hgt_grc (begg:endg)) ; this%forc_hgt_grc (:) = ival + allocate(this%forc_topo_grc (begg:endg)) ; this%forc_topo_grc (:) = ival + allocate(this%forc_hgt_u_grc (begg:endg)) ; this%forc_hgt_u_grc (:) = ival + allocate(this%forc_hgt_t_grc (begg:endg)) ; this%forc_hgt_t_grc (:) = ival + allocate(this%forc_hgt_q_grc (begg:endg)) ; this%forc_hgt_q_grc (:) = ival + allocate(this%forc_vp_grc (begg:endg)) ; this%forc_vp_grc (:) = ival + allocate(this%forc_pco2_grc (begg:endg)) ; this%forc_pco2_grc (:) = ival + allocate(this%forc_solad_grc (begg:endg,numrad)) ; this%forc_solad_grc (:,:) = ival + allocate(this%forc_solai_grc (begg:endg,numrad)) ; this%forc_solai_grc (:,:) = ival + allocate(this%forc_solar_grc (begg:endg)) ; this%forc_solar_grc (:) = ival + allocate(this%forc_ndep_grc (begg:endg)) ; this%forc_ndep_grc (:) = ival + allocate(this%forc_pc13o2_grc (begg:endg)) ; this%forc_pc13o2_grc (:) = ival + allocate(this%forc_po2_grc (begg:endg)) ; this%forc_po2_grc (:) = ival + allocate(this%forc_aer_grc (begg:endg,14)) ; this%forc_aer_grc (:,:) = ival + allocate(this%forc_pch4_grc (begg:endg)) ; this%forc_pch4_grc (:) = ival + if(use_luna)then + allocate(this%forc_pco2_240_patch (begp:endp)) ; this%forc_pco2_240_patch (:) = ival + allocate(this%forc_po2_240_patch (begp:endp)) ; this%forc_po2_240_patch (:) = ival + allocate(this%forc_pbot240_downscaled_patch(begp:endp)) ; this%forc_pbot240_downscaled_patch (:) = ival + end if + ! atm->lnd not downscaled + allocate(this%forc_t_not_downscaled_grc (begg:endg)) ; this%forc_t_not_downscaled_grc (:) = ival + allocate(this%forc_pbot_not_downscaled_grc (begg:endg)) ; this%forc_pbot_not_downscaled_grc (:) = ival + allocate(this%forc_th_not_downscaled_grc (begg:endg)) ; this%forc_th_not_downscaled_grc (:) = ival + allocate(this%forc_rho_not_downscaled_grc (begg:endg)) ; this%forc_rho_not_downscaled_grc (:) = ival + allocate(this%forc_lwrad_not_downscaled_grc (begg:endg)) ; this%forc_lwrad_not_downscaled_grc (:) = ival + + ! atm->lnd downscaled + allocate(this%forc_t_downscaled_col (begc:endc)) ; this%forc_t_downscaled_col (:) = ival + allocate(this%forc_pbot_downscaled_col (begc:endc)) ; this%forc_pbot_downscaled_col (:) = ival + allocate(this%forc_th_downscaled_col (begc:endc)) ; this%forc_th_downscaled_col (:) = ival + allocate(this%forc_rho_downscaled_col (begc:endc)) ; this%forc_rho_downscaled_col (:) = ival + allocate(this%forc_lwrad_downscaled_col (begc:endc)) ; this%forc_lwrad_downscaled_col (:) = ival + + allocate(this%fsd24_patch (begp:endp)) ; this%fsd24_patch (:) = nan + allocate(this%fsd240_patch (begp:endp)) ; this%fsd240_patch (:) = nan + allocate(this%fsi24_patch (begp:endp)) ; this%fsi24_patch (:) = nan + allocate(this%fsi240_patch (begp:endp)) ; this%fsi240_patch (:) = nan + if (use_fates) then + allocate(this%wind24_patch (begp:endp)) ; this%wind24_patch (:) = nan + end if + allocate(this%t_mo_patch (begp:endp)) ; this%t_mo_patch (:) = nan + allocate(this%t_mo_min_patch (begp:endp)) ; this%t_mo_min_patch (:) = nan ! + + end subroutine Init + +end module atm2lndType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ch4Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ch4Mod.F90 new file mode 100755 index 000000000..838fd21aa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_ch4Mod.F90 @@ -0,0 +1,225 @@ +module ch4Mod + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use decompMod , only : bounds_type + use clm_varcon , only : spval + use clm_varpar , only : nlevgrnd, ngases + + ! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + + type, public :: ch4_type + real(r8), pointer, private :: ch4_prod_depth_sat_col (:,:) ! col CH4 production rate from methanotrophs (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_prod_depth_unsat_col (:,:) ! col CH4 production rate from methanotrophs (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_prod_depth_lake_col (:,:) ! col CH4 production rate from methanotrophs (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_oxid_depth_sat_col (:,:) ! col CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_oxid_depth_unsat_col (:,:) ! col CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_oxid_depth_lake_col (:,:) ! col CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_aere_depth_sat_col (:,:) ! col CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_aere_depth_unsat_col (:,:) ! col CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_tran_depth_sat_col (:,:) ! col CH4 loss rate via transpiration in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_tran_depth_unsat_col (:,:) ! col CH4 loss rate via transpiration in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_ebul_depth_sat_col (:,:) ! col CH4 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_ebul_depth_unsat_col (:,:) ! col CH4 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: ch4_ebul_total_sat_col (:) ! col Total col CH4 ebullition (mol/m2/s) + real(r8), pointer, private :: ch4_ebul_total_unsat_col (:) ! col Total col CH4 ebullition (mol/m2/s) + real(r8), pointer, private :: ch4_surf_aere_sat_col (:) ! col CH4 aerenchyma flux to atmosphere (after oxidation) (mol/m2/s) + real(r8), pointer, private :: ch4_surf_aere_unsat_col (:) ! col CH4 aerenchyma flux to atmosphere (after oxidation) (mol/m2/s) + real(r8), pointer, private :: ch4_surf_ebul_sat_col (:) ! col CH4 ebullition flux to atmosphere (after oxidation) (mol/m2/s) + real(r8), pointer, private :: ch4_surf_ebul_unsat_col (:) ! col CH4 ebullition flux to atmosphere (after oxidation) (mol/m2/s) + real(r8), pointer, private :: ch4_surf_ebul_lake_col (:) ! col CH4 ebullition flux to atmosphere (after oxidation) (mol/m2/s) + real(r8), pointer, private :: co2_aere_depth_sat_col (:,:) ! col CO2 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: co2_aere_depth_unsat_col (:,:) ! col CO2 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: o2_oxid_depth_sat_col (:,:) ! col O2 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: o2_oxid_depth_unsat_col (:,:) ! col O2 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: o2_aere_depth_sat_col (:,:) ! col O2 gain rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: o2_aere_depth_unsat_col (:,:) ! col O2 gain rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: co2_decomp_depth_sat_col (:,:) ! col CO2 production during decomposition in each soil layer (nlevsoi) (mol/m3/s) + real(r8), pointer, private :: co2_decomp_depth_unsat_col (:,:) ! col CO2 production during decomposition in each soil layer (nlevsoi) (mol/m3/s) + real(r8), pointer, private :: co2_oxid_depth_sat_col (:,:) ! col CO2 production rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: co2_oxid_depth_unsat_col (:,:) ! col CO2 production rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + real(r8), pointer, private :: conc_o2_lake_col (:,:) ! col O2 conc in each soil layer (mol/m3) (nlevsoi) + real(r8), pointer, private :: conc_ch4_sat_col (:,:) ! col CH4 conc in each soil layer (mol/m3) (nlevsoi) + real(r8), pointer, private :: conc_ch4_unsat_col (:,:) ! col CH4 conc in each soil layer (mol/m3) (nlevsoi) + real(r8), pointer, private :: conc_ch4_lake_col (:,:) ! col CH4 conc in each soil layer (mol/m3) (nlevsoi) + real(r8), pointer, private :: ch4_surf_diff_sat_col (:) ! col CH4 surface flux (mol/m2/s) + real(r8), pointer, private :: ch4_surf_diff_unsat_col (:) ! col CH4 surface flux (mol/m2/s) + real(r8), pointer, private :: ch4_surf_diff_lake_col (:) ! col CH4 surface flux (mol/m2/s) + real(r8), pointer, private :: ch4_dfsat_flux_col (:) ! col CH4 flux to atm due to decreasing fsat (kg C/m^2/s) [+] + + real(r8), pointer, private :: zwt_ch4_unsat_col (:) ! col depth of water table for unsaturated fraction (m) + real(r8), pointer, private :: lake_soilc_col (:,:) ! col total soil organic matter found in level (g C / m^3) (nlevsoi) + real(r8), pointer, private :: totcolch4_col (:) ! col total methane found in soil col (g C / m^2) + real(r8), pointer, private :: totcolch4_grc (:) ! grc total methane found in soil col (g C / m^2) + real(r8), pointer, private :: totcolch4_bef_col (:) ! col total methane found in soil col, start of timestep (g C / m^2) + real(r8), pointer, private :: totcolch4_bef_grc (:) ! grc total methane found in soil col, start of timestep (g C / m^2) + real(r8), pointer, private :: annsum_counter_col (:) ! col seconds since last annual accumulator turnover + real(r8), pointer, private :: tempavg_somhr_col (:) ! col temporary average SOM heterotrophic resp. (gC/m2/s) + real(r8), pointer, private :: annavg_somhr_col (:) ! col annual average SOM heterotrophic resp. (gC/m2/s) + real(r8), pointer, private :: tempavg_finrw_col (:) ! col respiration-weighted annual average of finundated + real(r8), pointer, private :: annavg_finrw_col (:) ! col respiration-weighted annual average of finundated + real(r8), pointer, private :: sif_col (:) ! col (unitless) ratio applied to sat. prod. to account for seasonal inundation + real(r8), pointer, private :: ch4stress_unsat_col (:,:) ! col Ratio of methane available to the total per-timestep methane sinks (nlevsoi) + real(r8), pointer, private :: ch4stress_sat_col (:,:) ! col Ratio of methane available to the total per-timestep methane sinks (nlevsoi) + real(r8), pointer, private :: qflx_surf_lag_col (:) ! col time-lagged surface runoff (mm H2O /s) + real(r8), pointer, private :: finundated_lag_col (:) ! col time-lagged fractional inundated area + real(r8), pointer, private :: layer_sat_lag_col (:,:) ! col Lagged saturation status of soil layer in the unsaturated zone (1 = sat) + real(r8), pointer, private :: pH_col (:) ! col pH values for methane production + ! + real(r8), pointer, private :: dyn_ch4bal_adjustments_col (:) ! adjustments to each column made in this timestep via dynamic column area adjustments (only makes sense at the column-level: meaningless if averaged to the gridcell-level) (g C / m^2) + ! + real(r8), pointer, private :: c_atm_grc (:,:) ! grc atmospheric conc of CH4, O2, CO2 (mol/m3) + real(r8), pointer, private :: ch4co2f_grc (:) ! grc CO2 production from CH4 oxidation (g C/m**2/s) + real(r8), pointer, private :: ch4prodg_grc (:) ! grc average CH4 production (g C/m^2/s) + ! + ! for aerenchyma calculations + real(r8), pointer, private :: annavg_agnpp_patch (:) ! patch (gC/m2/s) annual average aboveground NPP + real(r8), pointer, private :: annavg_bgnpp_patch (:) ! patch (gC/m2/s) annual average belowground NPP + real(r8), pointer, private :: tempavg_agnpp_patch (:) ! patch (gC/m2/s) temp. average aboveground NPP + real(r8), pointer, private :: tempavg_bgnpp_patch (:) ! patch (gC/m2/s) temp. average belowground NPP + ! + ! The following variable reports whether this is the first timestep that includes + ! ch4. It is true in the first timestep of the run, and remains true until the + ! methane code is first run - at which point it becomes false, and remains + ! false. This could be a scalar, but scalars cause problems with threading, so we use + ! a column-level array (column-level for convenience, because it is referenced in + ! column-level loops). + logical , pointer, private :: ch4_first_time_grc (:) ! grc whether this is the first time step that includes ch4 + ! + real(r8), pointer, public :: finundated_col (:) ! col fractional inundated area (excluding dedicated wetland cols) + real(r8), pointer, public :: finundated_pre_snow_col (:) ! col fractional inundated area (excluding dedicated wetland cols) before snow + real(r8), pointer, public :: o2stress_unsat_col (:,:) ! col Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) + real(r8), pointer, public :: o2stress_sat_col (:,:) ! col Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) + real(r8), pointer, public :: conc_o2_sat_col (:,:) ! col O2 conc in each soil layer (mol/m3) (nlevsoi) + real(r8), pointer, public :: conc_o2_unsat_col (:,:) ! col O2 conc in each soil layer (mol/m3) (nlevsoi) + real(r8), pointer, public :: o2_decomp_depth_sat_col (:,:) ! col O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + real(r8), pointer, public :: o2_decomp_depth_unsat_col (:,:) ! col O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + real(r8), pointer, public :: ch4_surf_flux_tot_col (:) ! col CH4 surface flux (to atm) (kg C/m**2/s) + + real(r8), pointer, public :: grnd_ch4_cond_patch (:) ! patch tracer conductance for boundary layer [m/s] + real(r8), pointer, public :: grnd_ch4_cond_col (:) ! col tracer conductance for boundary layer [m/s] +! type(ch4finundatedstream_type), private :: ch4findstream ! ch4 finundated stream data + + contains + + procedure , public :: Init + + end type ch4_type + +type(ch4_type), public, target, save :: ch4_inst + +contains + +!----------------------------------------------------- + subroutine Init(this, bounds) + +! !DESCRIPTION: +! Initialize CTSM CH4 type; dummy for now, since we have use_lch4 set to .false. +! +! !ARGUMENTS: + implicit none + + ! INPUT + type(bounds_type), intent(in) :: bounds + class(ch4_type) :: this + + ! LOCAL + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + !--------------------------------------------- + + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + + allocate(this%ch4_prod_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%ch4_prod_depth_sat_col (:,:) = nan + allocate(this%ch4_prod_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%ch4_prod_depth_unsat_col (:,:) = nan + allocate(this%ch4_prod_depth_lake_col (begc:endc,1:nlevgrnd)) ; this%ch4_prod_depth_lake_col (:,:) = nan + allocate(this%ch4_oxid_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%ch4_oxid_depth_sat_col (:,:) = nan + allocate(this%ch4_oxid_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%ch4_oxid_depth_unsat_col (:,:) = nan + allocate(this%ch4_oxid_depth_lake_col (begc:endc,1:nlevgrnd)) ; this%ch4_oxid_depth_lake_col (:,:) = nan + allocate(this%o2_oxid_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%o2_oxid_depth_sat_col (:,:) = nan + allocate(this%o2_oxid_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%o2_oxid_depth_unsat_col (:,:) = nan + allocate(this%o2_aere_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%o2_aere_depth_sat_col (:,:) = nan + allocate(this%o2_aere_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%o2_aere_depth_unsat_col (:,:) = nan + allocate(this%co2_decomp_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%co2_decomp_depth_sat_col (:,:) = nan + allocate(this%co2_decomp_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%co2_decomp_depth_unsat_col (:,:) = nan + allocate(this%co2_oxid_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%co2_oxid_depth_sat_col (:,:) = nan + allocate(this%co2_oxid_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%co2_oxid_depth_unsat_col (:,:) = nan + allocate(this%ch4_aere_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%ch4_aere_depth_sat_col (:,:) = nan + allocate(this%ch4_aere_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%ch4_aere_depth_unsat_col (:,:) = nan + allocate(this%ch4_tran_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%ch4_tran_depth_sat_col (:,:) = nan + allocate(this%ch4_tran_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%ch4_tran_depth_unsat_col (:,:) = nan + allocate(this%co2_aere_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%co2_aere_depth_sat_col (:,:) = nan + allocate(this%co2_aere_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%co2_aere_depth_unsat_col (:,:) = nan + allocate(this%ch4_surf_aere_sat_col (begc:endc)) ; this%ch4_surf_aere_sat_col (:) = nan + allocate(this%ch4_surf_aere_unsat_col (begc:endc)) ; this%ch4_surf_aere_unsat_col (:) = nan + allocate(this%ch4_ebul_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%ch4_ebul_depth_sat_col (:,:) = nan + allocate(this%ch4_ebul_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%ch4_ebul_depth_unsat_col (:,:) = nan + allocate(this%ch4_ebul_total_sat_col (begc:endc)) ; this%ch4_ebul_total_sat_col (:) = nan + allocate(this%ch4_ebul_total_unsat_col (begc:endc)) ; this%ch4_ebul_total_unsat_col (:) = nan + allocate(this%ch4_surf_ebul_sat_col (begc:endc)) ; this%ch4_surf_ebul_sat_col (:) = nan + allocate(this%ch4_surf_ebul_unsat_col (begc:endc)) ; this%ch4_surf_ebul_unsat_col (:) = nan + allocate(this%ch4_surf_ebul_lake_col (begc:endc)) ; this%ch4_surf_ebul_lake_col (:) = nan + allocate(this%conc_ch4_sat_col (begc:endc,1:nlevgrnd)) ; this%conc_ch4_sat_col (:,:) = spval ! detect file input + allocate(this%conc_ch4_unsat_col (begc:endc,1:nlevgrnd)) ; this%conc_ch4_unsat_col (:,:) = spval ! detect file input + allocate(this%conc_ch4_lake_col (begc:endc,1:nlevgrnd)) ; this%conc_ch4_lake_col (:,:) = nan + allocate(this%ch4_surf_diff_sat_col (begc:endc)) ; this%ch4_surf_diff_sat_col (:) = nan + allocate(this%ch4_surf_diff_unsat_col (begc:endc)) ; this%ch4_surf_diff_unsat_col (:) = nan + allocate(this%ch4_surf_diff_lake_col (begc:endc)) ; this%ch4_surf_diff_lake_col (:) = nan + allocate(this%conc_o2_lake_col (begc:endc,1:nlevgrnd)) ; this%conc_o2_lake_col (:,:) = nan + allocate(this%ch4_dfsat_flux_col (begc:endc)) ; this%ch4_dfsat_flux_col (:) = nan + allocate(this%zwt_ch4_unsat_col (begc:endc)) ; this%zwt_ch4_unsat_col (:) = nan + allocate(this%lake_soilc_col (begc:endc,1:nlevgrnd)) ; this%lake_soilc_col (:,:) = spval !first time-step + allocate(this%totcolch4_col (begc:endc)) ; this%totcolch4_col (:) = nan + allocate(this%totcolch4_grc (begg:endg)) ; this%totcolch4_grc (:) = nan + allocate(this%totcolch4_bef_col (begc:endc)) ; this%totcolch4_bef_col (:) = nan + allocate(this%totcolch4_bef_grc (begg:endg)) ; this%totcolch4_bef_grc (:) = nan + allocate(this%annsum_counter_col (begc:endc)) ; this%annsum_counter_col (:) = nan + allocate(this%tempavg_somhr_col (begc:endc)) ; this%tempavg_somhr_col (:) = nan + allocate(this%annavg_somhr_col (begc:endc)) ; this%annavg_somhr_col (:) = nan + allocate(this%tempavg_finrw_col (begc:endc)) ; this%tempavg_finrw_col (:) = nan + allocate(this%annavg_finrw_col (begc:endc)) ; this%annavg_finrw_col (:) = nan + allocate(this%sif_col (begc:endc)) ; this%sif_col (:) = nan + allocate(this%ch4stress_unsat_col (begc:endc,1:nlevgrnd)) ; this%ch4stress_unsat_col (:,:) = nan + allocate(this%ch4stress_sat_col (begc:endc,1:nlevgrnd)) ; this%ch4stress_sat_col (:,:) = nan + allocate(this%qflx_surf_lag_col (begc:endc)) ; this%qflx_surf_lag_col (:) = nan + allocate(this%finundated_lag_col (begc:endc)) ; this%finundated_lag_col (:) = nan + allocate(this%layer_sat_lag_col (begc:endc,1:nlevgrnd)) ; this%layer_sat_lag_col (:,:) = nan + allocate(this%pH_col (begc:endc)) ; this%pH_col (:) = nan + allocate(this%ch4_surf_flux_tot_col (begc:endc)) ; this%ch4_surf_flux_tot_col (:) = nan + allocate(this%dyn_ch4bal_adjustments_col (begc:endc)) ; this%dyn_ch4bal_adjustments_col (:) = nan + + allocate(this%c_atm_grc (begg:endg,1:ngases)) ; this%c_atm_grc (:,:) = nan + allocate(this%ch4co2f_grc (begg:endg)) ; this%ch4co2f_grc (:) = nan + allocate(this%ch4prodg_grc (begg:endg)) ; this%ch4prodg_grc (:) = nan + + allocate(this%tempavg_agnpp_patch (begp:endp)) ; this%tempavg_agnpp_patch (:) = nan + allocate(this%tempavg_bgnpp_patch (begp:endp)) ; this%tempavg_bgnpp_patch (:) = nan + allocate(this%annavg_agnpp_patch (begp:endp)) ; this%annavg_agnpp_patch (:) = spval ! To detect first year + allocate(this%annavg_bgnpp_patch (begp:endp)) ; this%annavg_bgnpp_patch (:) = spval ! To detect first year + + allocate(this%ch4_first_time_grc (begg:endg)) ; this%ch4_first_time_grc (:) = .true. + + allocate(this%finundated_col (begc:endc)) ; this%finundated_col (:) = nan + allocate(this%finundated_pre_snow_col (begc:endc)) ; this%finundated_pre_snow_col (:) = nan + allocate(this%o2stress_unsat_col (begc:endc,1:nlevgrnd)) ; this%o2stress_unsat_col (:,:) = nan + allocate(this%o2stress_sat_col (begc:endc,1:nlevgrnd)) ; this%o2stress_sat_col (:,:) = nan + allocate(this%conc_o2_sat_col (begc:endc,1:nlevgrnd)) ; this%conc_o2_sat_col (:,:) = nan + allocate(this%conc_o2_unsat_col (begc:endc,1:nlevgrnd)) ; this%conc_o2_unsat_col (:,:) = nan + allocate(this%o2_decomp_depth_sat_col (begc:endc,1:nlevgrnd)) ; this%o2_decomp_depth_sat_col (:,:) = nan + allocate(this%o2_decomp_depth_unsat_col (begc:endc,1:nlevgrnd)) ; this%o2_decomp_depth_unsat_col (:,:) = nan + + allocate(this%grnd_ch4_cond_patch (begp:endp)) ; this%grnd_ch4_cond_patch (:) = nan + allocate(this%grnd_ch4_cond_col (begc:endc)) ; this%grnd_ch4_cond_col (:) = nan + + + end subroutine Init + +end module ch4Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_decompMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_decompMod.F90 new file mode 100755 index 000000000..0f7f812b4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_decompMod.F90 @@ -0,0 +1,142 @@ +module decompMod + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use clm_varpar , only: NUM_ZON, NUM_VEG, numpft + + ! !PUBLIC TYPES: + implicit none + save +! + + ! Define possible bounds subgrid levels + integer, parameter, public :: BOUNDS_SUBGRID_GRIDCELL = 1 + integer, parameter, public :: BOUNDS_SUBGRID_LANDUNIT = 2 + integer, parameter, public :: BOUNDS_SUBGRID_COLUMN = 3 + integer, parameter, public :: BOUNDS_SUBGRID_PATCH = 4 + integer, parameter, public :: BOUNDS_SUBGRID_COHORT = 5 + + ! !PUBLIC MEMBER FUNCTIONS: + + public get_beg ! get beg bound for a given subgrid level + public get_end ! get end bound for a given subgrid level + + type bounds_type + integer :: begg, endg ! beginning and ending gridcell index + integer :: begl, endl ! beginning and ending landunit index + integer :: begc, endc ! beginning and ending column index + integer :: begp, endp ! beginning and ending patch index + integer :: begCohort, endCohort ! beginning and ending cohort indices + + integer :: level ! whether defined on the proc or clump level + integer :: clump_index ! if defined on the clump level, this gives the clump index + + contains + + procedure, public :: Init + + end type bounds_type + type(bounds_type), public, target, save :: bounds + + contains + +!---------------------------------------------------- + subroutine Init(this, nch) + + ! !ARGUMENTS: + implicit none + + ! INPUT: + integer, intent(in) :: nch ! number of Catchment tiles + class(bounds_type) :: this + !---------------------------------- + + this%begg = 1 ; this%endg = nch + this%begl = 1 ; this%endl = nch + this%begc = 1 ; this%endc = nch*NUM_ZON + this%begp = 1 ; this%endp = nch*NUM_ZON*(numpft+1) + + end subroutine Init + + + !----------------------------------------------------------------------- + pure function get_beg(bounds, subgrid_level) result(beg_index) + ! + ! !DESCRIPTION: + ! Get beginning bounds for a given subgrid level + ! + ! subgrid_level should be one of the constants defined in this module: + ! BOUNDS_SUBGRID_GRIDCELL, BOUNDS_SUBGRID_LANDUNIT, etc. + ! + ! Returns -1 for invalid subgrid_level (does not abort in this case, in order to keep + ! this function pure). + ! + ! !USES: + ! + ! !ARGUMENTS: + integer :: beg_index ! function result + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: subgrid_level + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_beg' + !----------------------------------------------------------------------- + + select case (subgrid_level) + case (BOUNDS_SUBGRID_GRIDCELL) + beg_index = bounds%begg + case (BOUNDS_SUBGRID_LANDUNIT) + beg_index = bounds%begl + case (BOUNDS_SUBGRID_COLUMN) + beg_index = bounds%begc + case (BOUNDS_SUBGRID_PATCH) + beg_index = bounds%begp + case (BOUNDS_SUBGRID_COHORT) + beg_index = bounds%begCohort + case default + beg_index = -1 + end select + + end function get_beg + + !----------------------------------------------------------------------- + pure function get_end(bounds, subgrid_level) result(end_index) + ! + ! !DESCRIPTION: + ! Get end bounds for a given subgrid level + ! + ! subgrid_level should be one of the constants defined in this module: + ! BOUNDS_SUBGRID_GRIDCELL, BOUNDS_SUBGRID_LANDUNIT, etc. + ! + ! Returns -1 for invalid subgrid_level (does not abort in this case, in order to keep + ! this function pure). + ! + ! !USES: + ! + ! !ARGUMENTS: + integer :: end_index ! function result + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: subgrid_level + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_end' + !----------------------------------------------------------------------- + + select case (subgrid_level) + case (BOUNDS_SUBGRID_GRIDCELL) + end_index = bounds%endg + case (BOUNDS_SUBGRID_LANDUNIT) + end_index = bounds%endl + case (BOUNDS_SUBGRID_COLUMN) + end_index = bounds%endc + case (BOUNDS_SUBGRID_PATCH) + end_index = bounds%endp + case (BOUNDS_SUBGRID_COHORT) + end_index = bounds%endCohort + case default + end_index = -1 + end select + + end function get_end +end module decompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_dynSubgridControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_dynSubgridControlMod.F90 new file mode 100755 index 000000000..73bca29a4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_dynSubgridControlMod.F90 @@ -0,0 +1,132 @@ +module dynSubgridControlMod + + !--------------------------------------------------------------------------- + ! + ! !DESCRIPTION: + ! Defines a class for storing and querying control flags related to dynamic subgrid + ! operation. + ! + ! Note that this is implemented (essentially) as a singleton, so the only instance of + ! this class is stored in this module. This is done for convenience, to avoid having to + ! pass around the single instance just to query these control flags. + ! + ! !USES: +#include "shr_assert.h" + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: dynSubgridControl_init + public :: get_do_transient_pfts ! return the value of the do_transient_pfts control flag + public :: get_do_transient_crops ! return the value of the do_transient_crops control flag + public :: get_do_harvest ! return the value of the do_harvest control flag + public :: run_has_transient_landcover ! returns true if any aspects of prescribed transient landcover are enabled + ! + ! !PRIVATE TYPES: + type dyn_subgrid_control_type + private + logical :: do_transient_pfts = .false. ! whether to apply transient natural PFTs from dataset + logical :: do_transient_crops = .false. ! whether to apply transient crops from dataset + logical :: do_transient_lakes = .false. ! whether to apply transient lakes from dataset + logical :: do_harvest = .false. ! whether to apply harvest from dataset + + logical :: reset_dynbal_baselines = .false. ! whether to reset baseline values of total column water and energy in the first step of the run + + ! The following is only meant for testing: Whether area changes are allowed at times + ! other than the year boundary. This should only arise in some test configurations + ! where we artificially create changes more frequently so that we can run short + ! tests. This flag is only used for error-checking, not controlling any model + ! behavior. + logical :: for_testing_allow_non_annual_changes = .false. + + ! The following is only meant for testing: If .true., set the dynbal water and + ! energy fluxes to zero. This is needed in some tests where we have daily rather + ! than annual glacier dynamics: if we allow the true dynbal adjustment fluxes in + ! those tests, we end up with sensible heat fluxes of thousands of W m-2 or more, + ! which causes CAM to blow up. However, note that setting it to true will break + ! water and energy conservation! + logical :: for_testing_zero_dynbal_fluxes = .false. + + logical :: initialized = .false. ! whether this object has been initialized + end type dyn_subgrid_control_type + + type(dyn_subgrid_control_type) :: dyn_subgrid_control_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + subroutine dynSubgridControl_init( ) + ! + ! !DESCRIPTION: + ! Initialize the dyn_subgrid_control settings. + ! + ! !USES: + use spmdMod , only : masterproc + ! + ! !ARGUMENTS: + + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'dynSubgridControl_init' + !----------------------------------------------------------------------- + + dyn_subgrid_control_inst%initialized = .true. + + end subroutine dynSubgridControl_init + + !----------------------------------------------------------------------- + logical function get_do_transient_pfts() + ! !DESCRIPTION: + ! Return the value of the do_transient_pfts control flag + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(dyn_subgrid_control_inst%initialized, sourcefile, __LINE__) + + get_do_transient_pfts = dyn_subgrid_control_inst%do_transient_pfts + + end function get_do_transient_pfts + + !----------------------------------------------------------------------- + logical function get_do_transient_crops() + ! !DESCRIPTION: + ! Return the value of the do_transient_crops control flag + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(dyn_subgrid_control_inst%initialized, sourcefile, __LINE__) + + get_do_transient_crops = dyn_subgrid_control_inst%do_transient_crops + + end function get_do_transient_crops + + !----------------------------------------------------------------------- + logical function run_has_transient_landcover() + ! !DESCRIPTION: + ! Returns true if any aspects of prescribed transient landcover are enabled + !----------------------------------------------------------------------- + + run_has_transient_landcover = & + (get_do_transient_pfts() .or. & + get_do_transient_crops()) + end function run_has_transient_landcover + + !----------------------------------------------------------------------- + + logical function get_do_harvest() + ! !DESCRIPTION: + ! Return the value of the do_harvest control flag + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(dyn_subgrid_control_inst%initialized, sourcefile, __LINE__) + + get_do_harvest = dyn_subgrid_control_inst%do_harvest + + end function get_do_harvest + +end module dynSubgridControlMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_filterMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_filterMod.F90 new file mode 100755 index 000000000..12b115400 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_filterMod.F90 @@ -0,0 +1,260 @@ +module filterMod + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan + use decompMod , only : bounds_type + use clm_varpar , only : NUM_ZON, NUM_VEG, numpft + use pftconMod , only : npcropmin + + ! !PUBLIC TYPES: + implicit none + save + +! +! !PUBLIC MEMBER FUNCTIONS: + public allocFilters ! allocate memory for filters + ! PRIVATE + private init_filter_type + + + + type clumpfilter + integer, pointer :: allc(:) ! all columns + integer :: num_allc ! number of points in allc filter + + integer, pointer :: natvegp(:) ! CNDV nat-vegetated (present) filter (pfts) + integer :: num_natvegp ! number of pfts in nat-vegetated filter + + integer, pointer :: pcropp(:) ! prognostic crop filter (pfts) + integer :: num_pcropp ! number of pfts in prognostic crop filter + integer, pointer :: soilnopcropp(:) ! soil w/o prog. crops (pfts) + integer :: num_soilnopcropp ! number of pfts in soil w/o prog crops + + integer, pointer :: lakep(:) ! lake filter (pfts) + integer :: num_lakep ! number of pfts in lake filter + integer, pointer :: nolakep(:) ! non-lake filter (pfts) + integer :: num_nolakep ! number of pfts in non-lake filter + integer, pointer :: lakec(:) ! lake filter (columns) + integer :: num_lakec ! number of columns in lake filter + integer, pointer :: nolakec(:) ! non-lake filter (columns) + integer :: num_nolakec ! number of columns in non-lake filter + + integer, pointer :: soilc(:) ! soil filter (columns) + integer :: num_soilc ! number of columns in soil filter + integer, pointer :: soilp(:) ! soil filter (pfts) + integer :: num_soilp ! number of pfts in soil filter + + integer, pointer :: snowc(:) ! snow filter (columns) + integer :: num_snowc ! number of columns in snow filter + integer, pointer :: nosnowc(:) ! non-snow filter (columns) + integer :: num_nosnowc ! number of columns in non-snow filter + + integer, pointer :: lakesnowc(:) ! snow filter (columns) + integer :: num_lakesnowc ! number of columns in snow filter + integer, pointer :: lakenosnowc(:) ! non-snow filter (columns) + integer :: num_lakenosnowc ! number of columns in non-snow filter + + integer, pointer :: exposedvegp(:) ! patches where frac_veg_nosno is non-zero + integer :: num_exposedvegp ! number of patches in exposedvegp filter + integer, pointer :: noexposedvegp(:)! patches where frac_veg_nosno is 0 (does NOT include lake or urban) + integer :: num_noexposedvegp ! number of patches in noexposedvegp filter + + integer, pointer :: hydrologyc(:) ! hydrology filter (columns) + integer :: num_hydrologyc ! number of columns in hydrology filter + + integer, pointer :: urbanl(:) ! urban filter (landunits) + integer :: num_urbanl ! number of landunits in urban filter + + integer, pointer :: nourbanl(:) ! non-urban filter (landunits) + integer :: num_nourbanl ! number of landunits in non-urban filter + + integer, pointer :: urbanc(:) ! urban filter (columns) + integer :: num_urbanc ! number of columns in urban filter + integer, pointer :: nourbanc(:) ! non-urban filter (columns) + integer :: num_nourbanc ! number of columns in non-urban filter + + integer, pointer :: urbanp(:) ! urban filter (pfts) + integer :: num_urbanp ! number of pfts in urban filter + integer, pointer :: nourbanp(:) ! non-urban filter (pfts) + integer :: num_nourbanp ! number of pfts in non-urban filter + + integer, pointer :: nolakeurbanp(:) ! non-lake, non-urban filter (pfts) + integer :: num_nolakeurbanp ! number of pfts in non-lake, non-urban filter + + integer, pointer :: icemecc(:) ! glacier mec filter (cols) + integer :: num_icemecc ! number of columns in glacier mec filter + + integer, pointer :: do_smb_c(:) ! glacier+bareland SMB calculations-on filter (cols) + integer :: num_do_smb_c ! number of columns in glacier+bareland SMB mec filter + + integer, pointer :: actfirec(:) ! glacier+bareland SMB calculations-on filter (cols) + integer :: num_actfirec ! number of columns in glacier+bareland SMB mec filter + + integer, pointer :: actfirep(:) ! glacier+bareland SMB calculations-on filter (cols) + integer :: num_actfirep ! number of columns in glacier+bareland SMB mec filter + + end type clumpfilter + public clumpfilter + + ! This is the standard set of filters, which should be used in most places in the code. + ! These filters only include 'active' points. + type(clumpfilter), allocatable, public :: filter(:) + +contains + + !------------------------------------------------------------------------ + subroutine allocFilters(bounds, nch, ityp, fveg) + ! + ! !DESCRIPTION: + ! Allocate CLM filters. + ! + ! !REVISION HISTORY: + ! Created by Bill Sacks + + ! !ARGUMENTS: + implicit none + ! INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + + !------------------------------------------------------------------------ + + call init_filter_type(bounds, nch, ityp, fveg, filter) + + + end subroutine allocFilters + +!-------------------------------------------------------------- + subroutine init_filter_type(bounds, nch, ityp, fveg, this_filter) + + ! !DESCRIPTION: + ! Initialize CTSM filters + ! jk Oct 2021: type is allocated and initialized to NaN; values are assigned from Catchment states before calls to CLM subroutines are made + ! this type is only used to be able to pass Catchment states and fluxes to CLM subroutines in the format they expect + ! + ! !ARGUMENTS: + implicit none + ! INPUT/OUTPUT + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + type(clumpfilter), intent(inout), allocatable :: this_filter(:) ! the filter to allocate + + ! LOCAL: + integer :: n, nc ,nz, p, np, nv + + !-------------------------------------- + + if( .not. allocated(this_filter)) then + allocate(this_filter(1)) + end if + + allocate(this_filter(1)%allc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(1)%lakep(bounds%endp-bounds%begp+1)) + allocate(this_filter(1)%nolakep(bounds%endp-bounds%begp+1)) + allocate(this_filter(1)%nolakeurbanp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(1)%lakec(bounds%endc-bounds%begc+1)) + allocate(this_filter(1)%nolakec(bounds%endc-bounds%begc+1)) + + allocate(this_filter(1)%soilc(bounds%endc-bounds%begc+1)) + allocate(this_filter(1)%soilp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(1)%snowc(bounds%endc-bounds%begc+1)) + allocate(this_filter(1)%nosnowc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(1)%lakesnowc(bounds%endc-bounds%begc+1)) + allocate(this_filter(1)%lakenosnowc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(1)%exposedvegp(bounds%endp-bounds%begp+1)) + allocate(this_filter(1)%noexposedvegp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(1)%natvegp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(1)%hydrologyc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(1)%urbanp(bounds%endp-bounds%begp+1)) + allocate(this_filter(1)%nourbanp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(1)%urbanc(bounds%endc-bounds%begc+1)) + allocate(this_filter(1)%nourbanc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(1)%urbanl(bounds%endl-bounds%begl+1)) + allocate(this_filter(1)%nourbanl(bounds%endl-bounds%begl+1)) + + allocate(this_filter(1)%pcropp(bounds%endp-bounds%begp+1)) + allocate(this_filter(1)%soilnopcropp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(1)%icemecc(bounds%endc-bounds%begc+1)) + allocate(this_filter(1)%do_smb_c(bounds%endc-bounds%begc+1)) + + allocate(this_filter(1)%actfirec(bounds%endc-bounds%begc+1)) + allocate(this_filter(1)%actfirep(bounds%endp-bounds%begp+1)) + + this_filter(1)%num_actfirep = 1 + this_filter(1)%num_actfirec = 1 + + ! initialize + + this_filter(1)%num_soilc = 0 + this_filter(1)%num_soilp = 0 + this_filter(1)%num_pcropp = 0 + this_filter(1)%num_exposedvegp = 0 + this_filter(1)%num_noexposedvegp = 0 + this_filter(1)%num_nourbanp = 0 + this_filter(1)%num_allc = 0 + + n = 0 + np = 0 + do nc = 1,nch + do nz = 1,num_zon + n = n + 1 + + this_filter(1)%num_soilc = this_filter(1)%num_soilc + 1 + this_filter(1)%soilc(this_filter(1)%num_soilc) = n + this_filter(1)%num_allc = this_filter(1)%num_allc + 1 + this_filter(1)%allc(this_filter(1)%num_allc) = n + + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p) then + + if (fveg(nc,nv,nz)>1.e-4) then + + this_filter(1)%num_nourbanp = this_filter(1)%num_nourbanp + 1 + this_filter(1)%nourbanp(this_filter(1)%num_nourbanp) = np + + this_filter(1)%num_soilp = this_filter(1)%num_soilp + 1 + this_filter(1)%soilp(this_filter(1)%num_soilp) = np + + ! jkolassa: not sure this is needed, since we do not use prognostic crop information + if(ityp(nc,nv,nz) >= npcropmin) then + this_filter(1)%num_pcropp = this_filter(1)%num_pcropp + 1 + this_filter(1)%pcropp(this_filter(1)%num_pcropp) = np + endif + + +! if (fveg(nc,nv,nz)>1.e-4) then + + this_filter(1)%num_exposedvegp = this_filter(1)%num_exposedvegp + 1 + this_filter(1)%exposedvegp(this_filter(1)%num_exposedvegp) = np + + elseif (fveg(nc,nv,nz)<=1.e-4) then + + this_filter(1)%num_noexposedvegp = this_filter(1)%num_noexposedvegp + 1 + this_filter(1)%noexposedvegp(this_filter(1)%num_noexposedvegp) = np + + end if + end if + end do ! nv + end do !p + end do !nz + end do !nc + + end subroutine init_filter_type +end module filterMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_initVerticalMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_initVerticalMod.F90 new file mode 100755 index 000000000..d883d2f54 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_initVerticalMod.F90 @@ -0,0 +1,93 @@ +module initVerticalMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Initialize vertical components of column datatype + ! + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_sys_mod , only : shr_sys_abort + use decompMod , only : bounds_type + use spmdMod , only : masterproc + use clm_varpar , only : nlevsno, nlevgrnd, nlevlak + use clm_varpar , only : nlevsoi, nlevurb, nlevmaxurbgrnd + use clm_varctl , only : iulog + use clm_varctl , only : use_vertsoilc + use clm_varctl , only : use_fates + use clm_varcon , only : zsoi, dzsoi, zisoi, dzsoi_decomp, spval, ispval + use fileutils , only : getfil + use LandunitType , only : lun + use GridcellType , only : grc + use ColumnType , only : col + use abortUtils , only : endrun + use ncdio_pio + ! + ! !PUBLIC TYPES: + implicit none + save + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + ! public :: initVertical + public :: find_soil_layer_containing_depth + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! + !------------------------------------------------------------------------ + +contains + + !----------------------------------------------------------------------- + subroutine find_soil_layer_containing_depth(depth, layer) + ! + ! !DESCRIPTION: + ! Find the soil layer that contains the given depth + ! + ! Aborts if the given depth doesn't exist in the soil profile + ! + ! We consider the interface between two layers to belong to the layer *above* that + ! interface. This implies that the top interface (at exactly 0 m) is not considered + ! to be part of the soil profile. + ! + ! !ARGUMENTS: + real(r8), intent(in) :: depth ! target depth, m + integer , intent(out) :: layer ! layer containing target depth + ! + ! !LOCAL VARIABLES: + logical :: found + integer :: i + + character(len=*), parameter :: subname = 'find_soil_layer_containing_depth' + !----------------------------------------------------------------------- + + if (depth <= zisoi(0)) then + write(iulog,*) subname, ': ERROR: depth above top of soil' + write(iulog,*) 'depth = ', depth + write(iulog,*) 'zisoi = ', zisoi + call endrun(msg=subname//': depth above top of soil') + end if + + found = .false. + do i = 1, nlevgrnd + if (depth <= zisoi(i)) then + layer = i + found = .true. + exit + end if + end do + + if (.not. found) then + write(iulog,*) subname, ': ERROR: depth below bottom of soil' + write(iulog,*) 'depth = ', depth + write(iulog,*) 'zisoi = ', zisoi + call endrun(msg=subname//': depth below bottom of soil') + end if + + end subroutine find_soil_layer_containing_depth + +end module initVerticalMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_pftconMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_pftconMod.F90 new file mode 100755 index 000000000..bf52e3aab --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_pftconMod.F90 @@ -0,0 +1,1017 @@ +#include "MAPL_Generic.h" + +module pftconMod + + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use nanMod , only : nan, bigint + use clm_varpar , only : mxpft, numrad,nvariants, ivis, inir + use clm_varctl , only : use_flexibleCN, use_cndv + use netcdf + use shr_log_mod , only : errMsg => shr_log_errMsg + use MAPL , only : NetCDF4_FileFormatter, pFIO_READ + use MAPL_ExceptionHandling + use ncdio_pio , only : ncd_io + + ! !PUBLIC TYPES: + implicit none + + INCLUDE 'netcdf.inc' + save +! +! !PUBLIC MEMBER FUNCTIONS: + + +! +! Vegetation type constants +! + integer, public :: noveg = 0 ! Bare + integer, public :: ndllf_evr_tmp_tree = 1 ! Needleleaf evergreen temperate tree + integer, public :: ndllf_evr_brl_tree = 2 ! Needleleaf evergreen boreal tree + integer, public :: ndllf_dcd_brl_tree = 3 ! Needleleaf deciduous boreal tree + integer, public :: nbrdlf_evr_trp_tree = 4 ! Broadleaf evergreen tropical tree + integer, public :: nbrdlf_evr_tmp_tree = 5 ! Broadleaf evergreen temperate tree + integer, public :: nbrdlf_dcd_trp_tree = 6 ! Broadleaf deciduous tropical tree + integer, public :: nbrdlf_dcd_tmp_tree = 7 ! Broadleaf deciduous temperate tree + integer, public :: nbrdlf_dcd_brl_tree = 8 ! Broadleaf deciduous boreal tree + integer, public :: nbrdlf_evr_shrub = 9 ! Broadleaf evergreen temperate shrub + integer, public :: nbrdlf_dcd_tmp_shrub = 10 ! Broadleaf deciduous temperate shrub [moisture + deciduous] + integer, public :: nbrdlf_dcd_brl_shrub = 11 ! Broadleaf deciduous boreal shrub + integer, public :: nc3_arctic_grass = 12 ! Arctic c3 grass + integer, public :: nc3_nonarctic_grass = 13 ! Cool c3 grass [moisture + deciduous] + integer, public :: nc4_grass = 14 ! Warm c4 grass [moisture + deciduous] + integer, public :: nc3crop = 15 ! C3_crop [moisture + deciduous] + integer, public :: npcropmin = 16 ! value for first crop functional type (not including the more generic C3 crop PFT) + + ! variables that do not apply here, but are needed; set to mxpft + 1 in initialization routine + + integer, public :: ntmp_corn ! value for temperate corn, rain fed (rf) + integer, public :: nirrig_tmp_corn ! value for temperate corn, irrigated (ir) + integer, public :: nswheat ! value for spring temperate cereal (rf) + integer, public :: nirrig_swheat ! value for spring temperate cereal (ir) + integer, public :: nwwheat ! value for winter temperate cereal (rf) + integer, public :: nirrig_wwheat ! value for winter temperate cereal (ir) + integer, public :: ntmp_soybean ! value for temperate soybean (rf) + integer, public :: nirrig_tmp_soybean ! value for temperate soybean (ir) + integer, public :: nbarley ! value for spring barley (rf) + integer, public :: nirrig_barley ! value for spring barley (ir) + integer, public :: nwbarley ! value for winter barley (rf) + integer, public :: nirrig_wbarley ! value for winter barley (ir) + integer, public :: nrye ! value for spring rye (rf) + integer, public :: nirrig_rye ! value for spring rye (ir) + integer, public :: nwrye ! value for winter rye (rf) + integer, public :: nirrig_wrye ! value for winter rye (ir) + integer, public :: ncassava ! ...and so on + integer, public :: nirrig_cassava + integer, public :: ncitrus + integer, public :: nirrig_citrus + integer, public :: ncocoa + integer, public :: nirrig_cocoa + integer, public :: ncoffee + integer, public :: nirrig_coffee + integer, public :: ncotton + integer, public :: nirrig_cotton + integer, public :: ndatepalm + integer, public :: nirrig_datepalm + integer, public :: nfoddergrass + integer, public :: nirrig_foddergrass + integer, public :: ngrapes + integer, public :: nirrig_grapes + integer, public :: ngroundnuts + integer, public :: nirrig_groundnuts + integer, public :: nmillet + integer, public :: nirrig_millet + integer, public :: noilpalm + integer, public :: nirrig_oilpalm + integer, public :: npotatoes + integer, public :: nirrig_potatoes + integer, public :: npulses + integer, public :: nirrig_pulses + integer, public :: nrapeseed + integer, public :: nirrig_rapeseed + integer, public :: nrice + integer, public :: nirrig_rice + integer, public :: nsorghum + integer, public :: nirrig_sorghum + integer, public :: nsugarbeet + integer, public :: nirrig_sugarbeet + integer, public :: nsugarcane + integer, public :: nirrig_sugarcane + integer, public :: nsunflower + integer, public :: nirrig_sunflower + integer, public :: nmiscanthus + integer, public :: nirrig_miscanthus + integer, public :: nswitchgrass + integer, public :: nirrig_switchgrass + integer, public :: ntrp_corn !value for tropical corn (rf) + integer, public :: nirrig_trp_corn !value for tropical corn (ir) + integer, public :: ntrp_soybean !value for tropical soybean (rf) + integer, public :: nirrig_trp_soybean !value for tropical soybean (ir) + integer, public :: npcropmax ! value for last prognostic crop in list + integer, public :: nc3irrig ! value for irrigated generic crop (ir) + + ! + type, public :: pftcon_type + + integer , allocatable :: noveg (:) ! value for not vegetated + logical , allocatable :: is_tree (:) ! tree or not? + logical , allocatable :: is_shrub (:) ! shrub or not? + logical , allocatable :: is_grass (:) ! grass or not? + + real(r8), allocatable :: dleaf (:) ! characteristic leaf dimension (m) + real(r8), allocatable :: c3psn (:) ! photosynthetic pathway: 0. = c4, 1. = c3 + real(r8), allocatable :: xl (:) ! leaf/stem orientation index + real(r8), allocatable :: rhol (:,:) ! leaf reflectance: 1=vis, 2=nir + real(r8), allocatable :: rhos (:,:) ! stem reflectance: 1=vis, 2=nir + real(r8), allocatable :: taul (:,:) ! leaf transmittance: 1=vis, 2=nir + real(r8), allocatable :: taus (:,:) ! stem transmittance: 1=vis, 2=nir + real(r8), allocatable :: z0mr (:) ! ratio of momentum roughness length to canopy top height (-) + real(r8), allocatable :: displar (:) ! ratio of displacement height to canopy top height (-) + real(r8), allocatable :: roota_par (:) ! CLM rooting distribution parameter [1/m] + real(r8), allocatable :: rootb_par (:) ! CLM rooting distribution parameter [1/m] + real(r8), allocatable :: crop (:) ! crop pft: 0. = not crop, 1. = crop pft + real(r8), allocatable :: irrigated (:) ! irrigated pft: 0. = not, 1. = irrigated + real(r8), allocatable :: smpso (:) ! soil water potential at full stomatal opening (mm) + real(r8), allocatable :: smpsc (:) ! soil water potential at full stomatal closure (mm) + real(r8), allocatable :: fnitr (:) ! foliage nitrogen limitation factor (-) + + ! CN code + real(r8), allocatable :: dwood (:) ! wood density (gC/m3) + real(r8), allocatable :: slatop (:) ! SLA at top of canopy [m^2/gC] + real(r8), allocatable :: dsladlai (:) ! dSLA/dLAI [m^2/gC] + real(r8), allocatable :: leafcn (:) ! leaf C:N [gC/gN] + real(r8), allocatable :: biofuel_harvfrac (:) ! fraction of stem and leaf cut for harvest, sent to biofuels [unitless] + real(r8), allocatable :: flnr (:) ! fraction of leaf N in Rubisco [no units] + real(r8), allocatable :: woody (:) ! woody lifeform flag (0 or 1) + real(r8), allocatable :: lflitcn (:) ! leaf litter C:N (gC/gN) + real(r8), allocatable :: frootcn (:) ! fine root C:N (gC/gN) + real(r8), allocatable :: livewdcn (:) ! live wood (phloem and ray parenchyma) C:N (gC/gN) + real(r8), allocatable :: deadwdcn (:) ! dead wood (xylem and heartwood) C:N (gC/gN) + real(r8), allocatable :: grperc (:) ! growth respiration parameter + real(r8), allocatable :: grpnow (:) ! growth respiration parameter + real(r8), allocatable :: rootprof_beta (:,:) ! CLM rooting distribution parameter for C and N inputs [unitless] + real(r8), allocatable :: root_radius (:) ! root radius (m) + real(r8), allocatable :: root_density (:) ! root density (gC/m3) + + real(r8), allocatable :: dbh (:) ! diameter at breast height (m) + real(r8), allocatable :: fbw (:) ! fraction of biomass that is water + real(r8), allocatable :: nstem (:) ! stem density (#/m2) + real(r8), allocatable :: taper (:) ! tapering ratio of height:radius_breast_height + real(r8), allocatable :: rstem_per_dbh (:) ! stem resistance per dbh (s/m/m) + real(r8), allocatable :: wood_density (:) ! wood density (kg/m3) + + ! crop + + ! These arrays give information about the merge of unused crop types to the types CLM + ! knows about. mergetoclmpft(m) gives the crop type that CLM uses to simulate input + ! type m (and mergetoclmpft(m) == m implies that CLM simulates crop type m + ! directly). is_pft_known_to_model(m) is true if CLM simulates crop type m, and false + ! otherwise. Note that these do NOT relate to whether irrigation is on or off in a + ! given simulation - that is handled separately. + integer , allocatable :: mergetoclmpft (:) + logical , allocatable :: is_pft_known_to_model (:) + + real(r8), allocatable :: graincn (:) ! grain C:N (gC/gN) + real(r8), allocatable :: mxtmp (:) ! parameter used in accFlds + real(r8), allocatable :: baset (:) ! parameter used in accFlds + real(r8), allocatable :: declfact (:) ! parameter used in CNAllocation + real(r8), allocatable :: bfact (:) ! parameter used in CNAllocation + real(r8), allocatable :: aleaff (:) ! parameter used in CNAllocation + real(r8), allocatable :: arootf (:) ! parameter used in CNAllocation + real(r8), allocatable :: astemf (:) ! parameter used in CNAllocation + real(r8), allocatable :: arooti (:) ! parameter used in CNAllocation + real(r8), allocatable :: fleafi (:) ! parameter used in CNAllocation + real(r8), allocatable :: allconsl (:) ! parameter used in CNAllocation + real(r8), allocatable :: allconss (:) ! parameter used in CNAllocation + real(r8), allocatable :: ztopmx (:) ! parameter used in CNVegStructUpdate + real(r8), allocatable :: laimx (:) ! parameter used in CNVegStructUpdate + real(r8), allocatable :: gddmin (:) ! parameter used in CNPhenology + real(r8), allocatable :: hybgdd (:) ! parameter used in CNPhenology + real(r8), allocatable :: lfemerg (:) ! parameter used in CNPhenology + real(r8), allocatable :: grnfill (:) ! parameter used in CNPhenology + integer , allocatable :: mxmat (:) ! parameter used in CNPhenology + real(r8), allocatable :: mbbopt (:) ! Ball-Berry equation slope used in Photosynthesis + real(r8), allocatable :: medlynslope (:) ! Medlyn equation slope used in Photosynthesis + real(r8), allocatable :: medlynintercept(:) ! Medlyn equation intercept used in Photosynthesis + integer , allocatable :: mnNHplantdate (:) ! minimum planting date for NorthHemisphere (YYYYMMDD) + integer , allocatable :: mxNHplantdate (:) ! maximum planting date for NorthHemisphere (YYYYMMDD) + integer , allocatable :: mnSHplantdate (:) ! minimum planting date for SouthHemisphere (YYYYMMDD) + integer , allocatable :: mxSHplantdate (:) ! maximum planting date for SouthHemisphere (YYYYMMDD) + real(r8), allocatable :: planttemp (:) ! planting temperature used in CNPhenology (K) + real(r8), allocatable :: minplanttemp (:) ! mininum planting temperature used in CNPhenology (K) + real(r8), allocatable :: froot_leaf (:) ! allocation parameter: new fine root C per new leaf C (gC/gC) + real(r8), allocatable :: stem_leaf (:) ! allocation parameter: new stem c per new leaf C (gC/gC) + real(r8), allocatable :: croot_stem (:) ! allocation parameter: new coarse root C per new stem C (gC/gC) + real(r8), allocatable :: flivewd (:) ! allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units) + real(r8), allocatable :: fcur (:) ! allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage + real(r8), allocatable :: fcurdv (:) ! alternate fcur for use with cndv + real(r8), allocatable :: lf_flab (:) ! leaf litter labile fraction + real(r8), allocatable :: lf_fcel (:) ! leaf litter cellulose fraction + real(r8), allocatable :: lf_flig (:) ! leaf litter lignin fraction + real(r8), allocatable :: fr_flab (:) ! fine root litter labile fraction + real(r8), allocatable :: fr_fcel (:) ! fine root litter cellulose fraction + real(r8), allocatable :: fr_flig (:) ! fine root litter lignin fraction + real(r8), allocatable :: leaf_long (:) ! leaf longevity (yrs) + real(r8), allocatable :: evergreen (:) ! binary flag for evergreen leaf habit (0 or 1) + real(r8), allocatable :: stress_decid (:) ! binary flag for stress-deciduous leaf habit (0 or 1) + real(r8), allocatable :: season_decid (:) ! binary flag for seasonal-deciduous leaf habit (0 or 1) +!KO + real(r8), allocatable :: season_decid_temperate(:) ! binary flag for seasonal-deciduous temperate leaf habit (0 or 1) +!KO + real(r8), allocatable :: pconv (:) ! proportion of deadstem to conversion flux + real(r8), allocatable :: pprod10 (:) ! proportion of deadstem to 10-yr product pool + real(r8), allocatable :: pprod100 (:) ! proportion of deadstem to 100-yr product pool + real(r8), allocatable :: pprodharv10 (:) ! harvest mortality proportion of deadstem to 10-yr pool + + ! pft paraemeters for fire code + real(r8), allocatable :: cc_leaf (:) + real(r8), allocatable :: cc_lstem (:) + real(r8), allocatable :: cc_dstem (:) + real(r8), allocatable :: cc_other (:) + real(r8), allocatable :: fm_leaf (:) + real(r8), allocatable :: fm_lstem (:) + real(r8), allocatable :: fm_dstem (:) + real(r8), allocatable :: fm_other (:) + real(r8), allocatable :: fm_root (:) + real(r8), allocatable :: fm_lroot (:) + real(r8), allocatable :: fm_droot (:) + real(r8), allocatable :: fsr_pft (:) + real(r8), allocatable :: fd_pft (:) + real(r8), allocatable :: rswf_min (:) + real(r8), allocatable :: rswf_max (:) + + ! pft parameters for crop code + real(r8), allocatable :: manunitro (:) ! manure + real(r8), allocatable :: fleafcn (:) ! C:N during grain fill; leaf + real(r8), allocatable :: ffrootcn (:) ! C:N during grain fill; fine root + real(r8), allocatable :: fstemcn (:) ! C:N during grain fill; stem + + real(r8), allocatable :: i_vcad (:) + real(r8), allocatable :: s_vcad (:) + real(r8), allocatable :: i_flnr (:) + real(r8), allocatable :: s_flnr (:) + + ! pft parameters for CNDV code (from LPJ subroutine pftparameters) + real(r8), allocatable :: pftpar20 (:) ! tree maximum crown area (m2) + real(r8), allocatable :: pftpar28 (:) ! min coldest monthly mean temperature + real(r8), allocatable :: pftpar29 (:) ! max coldest monthly mean temperature + real(r8), allocatable :: pftpar30 (:) ! min growing degree days (>= 5 deg C) + real(r8), allocatable :: pftpar31 (:) ! upper limit of temperature of the warmest month (twmax) + + ! pft parameters for FUN + real(r8), allocatable :: a_fix (:) ! A BNF parameter + real(r8), allocatable :: b_fix (:) ! A BNF parameter + real(r8), allocatable :: c_fix (:) ! A BNF parameter + real(r8), allocatable :: s_fix (:) ! A BNF parameter + real(r8), allocatable :: akc_active (:) ! A mycorrhizal uptake parameter + real(r8), allocatable :: akn_active (:) ! A mycorrhizal uptake parameter + real(r8), allocatable :: ekc_active (:) ! A mycorrhizal uptake parameter + real(r8), allocatable :: ekn_active (:) ! A mycorrhizal uptake parameter + real(r8), allocatable :: kc_nonmyc (:) ! A non-mycorrhizal uptake parameter + real(r8), allocatable :: kn_nonmyc (:) ! A non-mycorrhizal uptake parameter + real(r8), allocatable :: kr_resorb (:) ! A retrasnlcation parameter + real(r8), allocatable :: perecm (:) ! The fraction of ECM-associated PFT + real(r8), allocatable :: fun_cn_flex_a (:) ! Parameter a of FUN-flexcn link code (def 5) + real(r8), allocatable :: fun_cn_flex_b (:) ! Parameter b of FUN-flexcn link code (def 200) + real(r8), allocatable :: fun_cn_flex_c (:) ! Parameter b of FUN-flexcn link code (def 80) + real(r8), allocatable :: FUN_fracfixers(:) ! Fraction of C that can be used for fixation. + + + ! pft parameters for dynamic root code + real(r8), allocatable :: root_dmx(:) !maximum root depth + + contains + + procedure, public :: init_pftcon_type + + end type pftcon_type + +type(pftcon_type), public, target, save :: pftcon + + integer, public, parameter :: pftname_len = 40 ! max length of pftname + character(len=pftname_len), public :: pftname(0:mxpft) ! PFT description + + real(r8), public, parameter :: reinickerp = 1.6_r8 ! parameter in allometric equation + real(r8), public, parameter :: dwood = 2.5e5_r8 ! cn wood density (gC/m3); lpj:2.0e5 + real(r8), public, parameter :: allom1 = 100.0_r8 ! parameters in + real(r8), public, parameter :: allom2 = 40.0_r8 ! ...allometric + real(r8), public, parameter :: allom3 = 0.5_r8 ! ...equations + real(r8), public, parameter :: allom1s = 250.0_r8 ! modified for shrubs by + real(r8), public, parameter :: allom2s = 8.0_r8 ! X.D.Z +! root radius, density from Bonan, GMD, 2014 + real(r8), public, parameter :: root_density = 0.31e06_r8 !(g biomass / m3 root) + real(r8), public, parameter :: root_radius = 0.29e-03_r8 !(m) + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + +!-------------------------------- + subroutine init_pftcon_type(this) + + ! !DESCRIPTION: +! Initialize CTSM PFT constants +! + use abortutils , only : endrun + +! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + class(pftcon_type) :: this + + + integer :: ierr, clm_varid, status, m, n + logical :: readv ! has variable been read in or not + type(Netcdf4_fileformatter) :: ncid + + real(r8), allocatable, dimension(:) :: read_tmp_1 + real(r8), allocatable, dimension(:,:) :: read_tmp_2 + integer , allocatable, dimension(:) :: read_tmp_3 + + character(len=512) :: msg + character(len=300) :: paramfile + +!--------------------------------------------------------- + + allocate( read_tmp_1 (0:78)) + allocate( read_tmp_2 (0:78,nvariants)) + allocate( read_tmp_3 (0:78)) + + allocate( this%noveg (0:mxpft)); this%noveg (:) = huge(1) + allocate( this%is_tree (0:mxpft)); this%is_tree (:) = .false. + allocate( this%is_shrub (0:mxpft)); this%is_shrub (:) = .false. + allocate( this%is_grass (0:mxpft)); this%is_grass (:) = .false. + + allocate( this%dleaf (0:mxpft) ); this%dleaf (:) = nan !# + allocate( this%c3psn (0:mxpft) ); this%c3psn (:) = nan + allocate( this%xl (0:mxpft) ); this%xl (:) = nan + allocate( this%rhol (0:mxpft,numrad) ); this%rhol (:,:) = nan + allocate( this%rhos (0:mxpft,numrad) ); this%rhos (:,:) = nan + allocate( this%taul (0:mxpft,numrad) ); this%taul (:,:) = nan + allocate( this%taus (0:mxpft,numrad) ); this%taus (:,:) = nan + allocate( this%z0mr (0:mxpft) ); this%z0mr (:) = nan + allocate( this%displar (0:mxpft) ); this%displar (:) = nan + allocate( this%roota_par (0:mxpft) ); this%roota_par(:) = nan + allocate( this%rootb_par (0:mxpft) ); this%rootb_par(:) = nan + allocate( this%crop (0:mxpft) ); this%crop (:) = nan !# + allocate( this%mergetoclmpft (0:mxpft) ); this%mergetoclmpft (:) = bigint !# + allocate( this%is_pft_known_to_model (0:mxpft) ); this%is_pft_known_to_model(:) = .false. !# + allocate( this%irrigated (0:mxpft) ); this%irrigated (:) = nan !# + allocate( this%smpso (0:mxpft) ); this%smpso (:) = nan !# + allocate( this%smpsc (0:mxpft) ); this%smpsc (:) = nan !# + allocate( this%fnitr (0:mxpft) ); this%fnitr (:) = nan !# + allocate( this%slatop (0:mxpft) ); this%slatop (:) = nan + allocate( this%dsladlai (0:mxpft) ); this%dsladlai (:) = nan + allocate( this%leafcn (0:mxpft) ); this%leafcn (:) = nan + allocate( this%biofuel_harvfrac (0:mxpft) ); this%biofuel_harvfrac(:) = nan !# + allocate( this%flnr (0:mxpft) ); this%flnr (:) = nan + allocate( this%woody (0:mxpft) ); this%woody (:) = nan + allocate( this%lflitcn (0:mxpft) ); this%lflitcn (:) = nan + allocate( this%frootcn (0:mxpft) ); this%frootcn (:) = nan + allocate( this%livewdcn (0:mxpft) ); this%livewdcn (:) = nan + allocate( this%deadwdcn (0:mxpft) ); this%deadwdcn (:) = nan + allocate( this%grperc (0:mxpft) ); this%grperc (:) = nan + allocate( this%grpnow (0:mxpft) ); this%grpnow (:) = nan + allocate( this%rootprof_beta (0:mxpft,nvariants) ); this%rootprof_beta(:,:) = nan + allocate( this%graincn (0:mxpft) ); this%graincn (:) = nan + allocate( this%mxtmp (0:mxpft) ); this%mxtmp (:) = nan + allocate( this%baset (0:mxpft) ); this%baset (:) = nan + allocate( this%declfact (0:mxpft) ); this%declfact (:) = nan + allocate( this%bfact (0:mxpft) ); this%bfact (:) = nan + allocate( this%aleaff (0:mxpft) ); this%aleaff (:) = nan + allocate( this%arootf (0:mxpft) ); this%arootf (:) = nan + allocate( this%astemf (0:mxpft) ); this%astemf (:) = nan + allocate( this%arooti (0:mxpft) ); this%arooti (:) = nan + allocate( this%fleafi (0:mxpft) ); this%fleafi (:) = nan + allocate( this%allconsl (0:mxpft) ); this%allconsl (:) = nan + allocate( this%allconss (0:mxpft) ); this%allconss (:) = nan + allocate( this%ztopmx (0:mxpft) ); this%ztopmx (:) = nan + allocate( this%laimx (0:mxpft) ); this%laimx (:) = nan + allocate( this%gddmin (0:mxpft) ); this%gddmin (:) = nan + allocate( this%hybgdd (0:mxpft) ); this%hybgdd (:) = nan + allocate( this%lfemerg (0:mxpft) ); this%lfemerg (:) = nan + allocate( this%grnfill (0:mxpft) ); this%grnfill (:) = nan + allocate( this%mbbopt (0:mxpft) ); this%mbbopt (:) = nan !# + allocate( this%medlynslope (0:mxpft) ); this%medlynslope (:) = nan !# + allocate( this%medlynintercept(0:mxpft) ); this%medlynintercept = nan !# + allocate( this%mxmat (0:mxpft) ); this%mxmat (:) = bigint + allocate( this%mnNHplantdate (0:mxpft) ); this%mnNHplantdate (:) = huge(1) + allocate( this%mxNHplantdate (0:mxpft) ); this%mxNHplantdate (:) = huge(1) + allocate( this%mnSHplantdate (0:mxpft) ); this%mnSHplantdate (:) = huge(1) + allocate( this%mxSHplantdate (0:mxpft) ); this%mxSHplantdate (:) = huge(1) + allocate( this%planttemp (0:mxpft) ); this%planttemp (:) = nan + allocate( this%minplanttemp (0:mxpft) ); this%minplanttemp (:) = nan + allocate( this%froot_leaf (0:mxpft) ); this%froot_leaf (:) = nan + allocate( this%stem_leaf (0:mxpft) ); this%stem_leaf (:) = nan + allocate( this%croot_stem (0:mxpft) ); this%croot_stem (:) = nan + allocate( this%flivewd (0:mxpft) ); this%flivewd (:) = nan + allocate( this%fcur (0:mxpft) ); this%fcur (:) = nan + allocate( this%fcurdv (0:mxpft) ); this%fcurdv (:) = nan !# + allocate( this%lf_flab (0:mxpft) ); this%lf_flab (:) = nan + allocate( this%lf_fcel (0:mxpft) ); this%lf_fcel (:) = nan + allocate( this%lf_flig (0:mxpft) ); this%lf_flig (:) = nan + allocate( this%fr_flab (0:mxpft) ); this%fr_flab (:) = nan + allocate( this%fr_fcel (0:mxpft) ); this%fr_fcel (:) = nan + allocate( this%fr_flig (0:mxpft) ); this%fr_flig (:) = nan + allocate( this%leaf_long (0:mxpft) ); this%leaf_long (:) = nan + allocate( this%evergreen (0:mxpft) ); this%evergreen (:) = nan + allocate( this%stress_decid (0:mxpft) ); this%stress_decid (:) = nan + allocate( this%season_decid (0:mxpft) ); this%season_decid (:) = nan +!KO + allocate( this%season_decid_temperate (0:mxpft) ); this%season_decid_temperate (:) = nan !# +!KO + allocate( this%dwood (0:mxpft) ); this%dwood (:) = nan + allocate( this%root_density (0:mxpft) ); this%root_density (:) = nan !# + allocate( this%root_radius (0:mxpft) ); this%root_radius (:) = nan !# + allocate( this%pconv (0:mxpft) ); this%pconv (:) = nan !# + allocate( this%pprod10 (0:mxpft) ); this%pprod10 (:) = nan !# + allocate( this%pprod100 (0:mxpft) ); this%pprod100 (:) = nan !# + allocate( this%pprodharv10 (0:mxpft) ); this%pprodharv10 (:) = nan !# + allocate( this%cc_leaf (0:mxpft) ); this%cc_leaf (:) = nan + allocate( this%cc_lstem (0:mxpft) ); this%cc_lstem (:) = nan + allocate( this%cc_dstem (0:mxpft) ); this%cc_dstem (:) = nan + allocate( this%cc_other (0:mxpft) ); this%cc_other (:) = nan + allocate( this%fm_leaf (0:mxpft) ); this%fm_leaf (:) = nan + allocate( this%fm_lstem (0:mxpft) ); this%fm_lstem (:) = nan + allocate( this%fm_dstem (0:mxpft) ); this%fm_dstem (:) = nan + allocate( this%fm_other (0:mxpft) ); this%fm_other (:) = nan + allocate( this%fm_root (0:mxpft) ); this%fm_root (:) = nan + allocate( this%fm_lroot (0:mxpft) ); this%fm_lroot (:) = nan + allocate( this%fm_droot (0:mxpft) ); this%fm_droot (:) = nan + allocate( this%fsr_pft (0:mxpft) ); this%fsr_pft (:) = nan + allocate( this%fd_pft (0:mxpft) ); this%fd_pft (:) = nan + allocate( this%rswf_max (0:mxpft) ); this%rswf_max (:) = nan !# + allocate( this%rswf_min (0:mxpft) ); this%rswf_min (:) = nan !# + allocate( this%manunitro (0:mxpft) ); this%manunitro (:) = nan !# + allocate( this%fleafcn (0:mxpft) ); this%fleafcn (:) = nan + allocate( this%ffrootcn (0:mxpft) ); this%ffrootcn (:) = nan + allocate( this%fstemcn (0:mxpft) ); this%fstemcn (:) = nan + allocate( this%i_vcad (0:mxpft) ); this%i_vcad (:) = nan !# + allocate( this%s_vcad (0:mxpft) ); this%s_vcad (:) = nan !# + allocate( this%i_flnr (0:mxpft) ); this%i_flnr (:) = nan !# + allocate( this%s_flnr (0:mxpft) ); this%s_flnr (:) = nan !# + allocate( this%pftpar20 (0:mxpft) ); this%pftpar20 (:) = nan !# + allocate( this%pftpar28 (0:mxpft) ); this%pftpar28 (:) = nan !# + allocate( this%pftpar29 (0:mxpft) ); this%pftpar29 (:) = nan !# + allocate( this%pftpar30 (0:mxpft) ); this%pftpar30 (:) = nan !# + allocate( this%pftpar31 (0:mxpft) ); this%pftpar31 (:) = nan !# + allocate( this%a_fix (0:mxpft) ); this%a_fix (:) = nan !# + allocate( this%b_fix (0:mxpft) ); this%b_fix (:) = nan !# + allocate( this%c_fix (0:mxpft) ); this%c_fix (:) = nan !# + allocate( this%s_fix (0:mxpft) ); this%s_fix (:) = nan !# + allocate( this%akc_active (0:mxpft) ); this%akc_active (:) = nan !# + allocate( this%akn_active (0:mxpft) ); this%akn_active (:) = nan !# + allocate( this%ekc_active (0:mxpft) ); this%ekc_active (:) = nan !# + allocate( this%ekn_active (0:mxpft) ); this%ekn_active (:) = nan !# + allocate( this%kc_nonmyc (0:mxpft) ); this%kc_nonmyc (:) = nan !# + allocate( this%kn_nonmyc (0:mxpft) ); this%kn_nonmyc (:) = nan !# + allocate( this%kr_resorb (0:mxpft) ); this%kr_resorb (:) = nan !# + allocate( this%perecm (0:mxpft) ); this%perecm (:) = nan !# + allocate( this%root_dmx (0:mxpft) ); this%root_dmx (:) = nan !# + allocate( this%fun_cn_flex_a (0:mxpft) ); this%fun_cn_flex_a (:) = nan !# + allocate( this%fun_cn_flex_b (0:mxpft) ); this%fun_cn_flex_b (:) = nan !# + allocate( this%fun_cn_flex_c (0:mxpft) ); this%fun_cn_flex_c (:) = nan !# + allocate( this%FUN_fracfixers(0:mxpft) ); this%FUN_fracfixers (:) = nan !# + allocate( this%dbh (0:mxpft) ); this%dbh (:) = nan !# + allocate( this%fbw (0:mxpft) ); this%fbw (:) = nan !# + allocate( this%nstem (0:mxpft) ); this%nstem (:) = nan !# + allocate( this%taper (0:mxpft) ); this%taper (:) = nan !# + allocate( this%rstem_per_dbh (0:mxpft) ); this%rstem_per_dbh (:) = nan !# + allocate( this%wood_density (0:mxpft) ); this%wood_density (:) = nan !# + + ! jkolassa, Dec 2021: read in parameters from CLM parameter file + ! TO DO: pass parameter file through rc files rather than hardcoding name here + + paramfile = '/discover/nobackup/jkolassa/CLM/parameter_files/ctsm51_params.c210923.nc' + call ncid%open(trim(paramfile),pFIO_READ, RC=status) + + call ncd_io('pftname',pftname, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('z0mr', this%z0mr, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('displar', this%displar, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('dleaf', this%dleaf, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('c3psn', this%c3psn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rholvis', this%rhol(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rholnir', this%rhol(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rhosvis', this%rhos(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rhosnir', this% rhos(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('taulvis', this%taul(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('taulnir', this%taul(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('tausvis', this%taus(:,ivis), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('tausnir', this%taus(:,inir), 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('xl', this%xl, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('roota_par', this%roota_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rootb_par', this%rootb_par, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('slatop', this%slatop, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('dsladlai', this%dsladlai, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('leafcn', this%leafcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('biofuel_harvfrac', this%biofuel_harvfrac, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('flnr', this%flnr, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('smpso', this%smpso, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('smpsc', this%smpsc, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fnitr', this%fnitr, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('woody', this%woody, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('lflitcn', this%lflitcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('frootcn', this%frootcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('livewdcn', this%livewdcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('deadwdcn', this%deadwdcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('grperc', this%grperc, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('grpnow', this%grpnow, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('froot_leaf', this%froot_leaf, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('stem_leaf', this%stem_leaf, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('croot_stem', this%croot_stem, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('flivewd', this%flivewd, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fcur', this%fcur, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + do n = 0,mxpft + if (this%fcur(n)==0.) then + this%fcur(n) = 0.5 + end if + end do + + call ncd_io('fcurdv', this%fcurdv, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('lf_flab', this%lf_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('lf_fcel', this%lf_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('lf_flig', this%lf_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fr_flab', this%fr_flab, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fr_fcel', this%fr_fcel, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fr_flig', this%fr_flig, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('leaf_long', this%leaf_long, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + do n = 0,mxpft + if (this%leaf_long(n) .lt. 1.) then + this%leaf_long(n) = 1. + end if + end do + + + call ncd_io('evergreen', this%evergreen, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('stress_decid', this%stress_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('season_decid', this%season_decid, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + +!KO + call ncd_io('season_decid_temperate', this%season_decid_temperate, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) +!KO + + call ncd_io('pftpar20', this%pftpar20, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('pftpar28', this%pftpar28, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('pftpar29', this%pftpar29, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('pftpar30', this%pftpar30, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('pftpar31', this%pftpar31, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('a_fix', this%a_fix, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('b_fix', this%b_fix, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('c_fix', this%c_fix, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('s_fix', this%s_fix, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('akc_active', this%akc_active, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('akn_active', this%akn_active, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('ekc_active', this%ekc_active, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('ekn_active', this%ekn_active, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('kc_nonmyc', this%kc_nonmyc, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('kn_nonmyc', this%kn_nonmyc, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('kr_resorb', this%kr_resorb, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('perecm', this%perecm, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fun_cn_flex_a', this%fun_cn_flex_a, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fun_cn_flex_b', this%fun_cn_flex_b, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fun_cn_flex_c', this%fun_cn_flex_c, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('FUN_fracfixers', this%FUN_fracfixers, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('manunitro', this%manunitro, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fleafcn', this%fleafcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('ffrootcn', this%ffrootcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fstemcn', this%fstemcn, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rootprof_beta', this%rootprof_beta, 'read', ncid, readvar=readv, posNOTonfile=.true.) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('pconv', this%pconv, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('pprod10', this%pprod10, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('pprodharv10', this%pprodharv10, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('pprod100', this%pprod100, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('graincn', this%graincn, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('mxtmp', this%mxtmp, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('baset', this%baset, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('declfact', this%declfact, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('bfact', this%bfact, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('aleaff', this%aleaff, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('arootf', this%arootf, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('astemf', this%astemf, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('arooti', this%arooti, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fleafi', this%fleafi, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('allconsl', this%allconsl, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('allconss', this%allconss, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('crop', this%crop, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('mergetoclmpft', this%mergetoclmpft, 'read', ncid, readvar=readv) + if ( .not. readv ) then + call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + end if + + call ncd_io('irrigated', this%irrigated, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('ztopmx', this%ztopmx, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('laimx', this%laimx, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('gddmin', this%gddmin, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('hybgdd', this%hybgdd, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('lfemerg', this%lfemerg, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('grnfill', this%grnfill, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('mbbopt', this%mbbopt, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('medlynslope', this%medlynslope, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('medlynintercept', this%medlynintercept, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('mxmat', this%mxmat, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('cc_leaf', this% cc_leaf, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('cc_lstem', this%cc_lstem, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('cc_dstem', this%cc_dstem, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('cc_other', this%cc_other, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fm_leaf', this% fm_leaf, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fm_lstem', this%fm_lstem, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fm_dstem', this%fm_dstem, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fm_other', this%fm_other, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fm_root', this% fm_root, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fm_lroot', this%fm_lroot, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fm_droot', this%fm_droot, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fsr_pft', this% fsr_pft, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('fd_pft', this% fd_pft, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rswf_min', this% rswf_min, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('rswf_max', this% rswf_max, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + call ncd_io('planting_temp', this%planttemp, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('min_planting_temp', this%minplanttemp, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('min_NH_planting_date', this%mnNHplantdate, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('min_SH_planting_date', this%mnSHplantdate, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('max_NH_planting_date', this%mxNHplantdate, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('max_SH_planting_date', this%mxSHplantdate, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + npcropmax = mxpft ! last prognostic crop in list + + ! jkolassa Jan 2023: we do not model these crops, but the below variables are needed + ! for some checks; setting them to mxpft + 1 + ntmp_corn = mxpft + 1 ! value for temperate corn, rain fed (rf) + nirrig_tmp_corn = mxpft + 1 ! value for temperate corn, irrigated (ir) + nswheat = mxpft + 1 ! value for spring temperate cereal (rf) + nirrig_swheat = mxpft + 1 ! value for spring temperate cereal (ir) + nwwheat = mxpft + 1 ! value for winter temperate cereal (rf) + nirrig_wwheat = mxpft + 1 ! value for winter temperate cereal (ir) + ntmp_soybean = mxpft + 1 ! value for temperate soybean (rf) + nirrig_tmp_soybean = mxpft + 1 ! value for temperate soybean (ir) + nbarley = mxpft + 1 ! value for spring barley (rf) + nirrig_barley = mxpft + 1 ! value for spring barley (ir) + nwbarley = mxpft + 1 ! value for winter barley (rf) + nirrig_wbarley = mxpft + 1 ! value for winter barley (ir) + nrye = mxpft + 1 ! value for spring rye (rf) + nirrig_rye = mxpft + 1 ! value for spring rye (ir) + nwrye = mxpft + 1 ! value for winter rye (rf) + nirrig_wrye = mxpft + 1 ! value for winter rye (ir) + ncassava = mxpft + 1 ! ...and so on + nirrig_cassava = mxpft + 1 + ncitrus = mxpft + 1 + nirrig_citrus = mxpft + 1 + ncocoa = mxpft + 1 + nirrig_cocoa = mxpft + 1 + ncoffee = mxpft + 1 + nirrig_coffee = mxpft + 1 + ncotton = mxpft + 1 + nirrig_cotton = mxpft + 1 + ndatepalm = mxpft + 1 + nirrig_datepalm = mxpft + 1 + nfoddergrass = mxpft + 1 + nirrig_foddergrass = mxpft + 1 + ngrapes = mxpft + 1 + nirrig_grapes = mxpft + 1 + ngroundnuts = mxpft + 1 + nirrig_groundnuts = mxpft + 1 + nmillet = mxpft + 1 + nirrig_millet = mxpft + 1 + noilpalm = mxpft + 1 + nirrig_oilpalm = mxpft + 1 + npotatoes = mxpft + 1 + nirrig_potatoes = mxpft + 1 + npulses = mxpft + 1 + nirrig_pulses = mxpft + 1 + nrapeseed = mxpft + 1 + nirrig_rapeseed = mxpft + 1 + nrice = mxpft + 1 + nirrig_rice = mxpft + 1 + nsorghum = mxpft + 1 + nirrig_sorghum = mxpft + 1 + nsugarbeet = mxpft + 1 + nirrig_sugarbeet = mxpft + 1 + nsugarcane = mxpft + 1 + nirrig_sugarcane = mxpft + 1 + nsunflower = mxpft + 1 + nirrig_sunflower = mxpft + 1 + nmiscanthus = mxpft + 1 + nirrig_miscanthus = mxpft + 1 + nswitchgrass = mxpft + 1 + nirrig_switchgrass = mxpft + 1 + ntrp_corn = mxpft + 1 !value for tropical corn (rf) + nirrig_trp_corn = mxpft + 1 !value for tropical corn (ir) + ntrp_soybean = mxpft + 1 !value for tropical soybean (rf) + nirrig_trp_soybean = mxpft + 1 !value for tropical soybean (ir) + npcropmax = mxpft + 1 ! value for last prognostic crop in list + nc3irrig = mxpft + 1 ! value for irrigated generic crop (ir) + + do m = 0,mxpft + this%dwood(m) = dwood + this%root_radius(m) = root_radius + this%root_density(m) = root_density + end do + + ! + ! clm 5 nitrogen variables + ! + if (use_flexibleCN) then + call ncd_io('i_vcad', this%i_vcad, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('s_vcad', this%s_vcad, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('i_flnr', this%i_flnr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + call ncd_io('s_flnr', this%s_flnr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + end if + + call ncd_io('nstem',this%nstem, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + call ncd_io('taper',this%taper, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + + + ! jkolassa, Dec 2021: not using biomass heat storage module, so set the following 4 parameters to 0 + this%dbh = 0.0_r8 + this%fbw = 0.0_r8 + this%rstem_per_dbh = 0.0_r8 + this%wood_density = 0.0_r8 + + ! Set vegetation family identifier (tree/shrub/grass) + do m = 0,mxpft + if (m == ndllf_evr_tmp_tree .or. m == ndllf_evr_brl_tree & + .or. m == ndllf_dcd_brl_tree .or. m == nbrdlf_evr_trp_tree & + .or. m == nbrdlf_evr_tmp_tree .or. m == nbrdlf_dcd_trp_tree & + .or. m == nbrdlf_dcd_tmp_tree .or. m == nbrdlf_dcd_brl_tree) then + this%is_tree(m) = .true. + else + this%is_tree(m) = .false. + endif + if(m == nbrdlf_evr_shrub .or. m == nbrdlf_dcd_tmp_shrub .or. m == nbrdlf_dcd_brl_shrub) then + this%is_shrub(m) = .true. + else + this%is_shrub(m) = .false. + endif + if(m == nc3_arctic_grass .or. m == nc3_nonarctic_grass .or. m == nc4_grass) then + this%is_grass(m) = .true. + else + this%is_grass(m) = .false. + endif + + end do + + if (use_cndv) then + this%fcur(:) = this%fcurdv(:) + end if + + ! jk, Dec 2021: we are not using the crop or irrigation modules at this point, so set the flags to 0 everywhere + + this%irrigated(:) = 0.0_r8 + this%crop(:) = 0.0_r8 + + ! jk Dec 2021: all PFTs are known to model since we are not using the crop model, so set flag to true everywhere + this%is_pft_known_to_model(:) = .true. + + end subroutine init_pftcon_type + +end module pftconMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate1Mod.F90 new file mode 100755 index 000000000..426611390 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate1Mod.F90 @@ -0,0 +1,583 @@ +module CNCStateUpdate1Mod + + !----------------------------------------------------------------------- + ! Module for carbon state variable update, non-mortality fluxes. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : ndecomp_cascade_transitions, nlevdecomp + use clm_time_manager , only : get_step_size_real + use clm_varpar , only : i_met_lit, i_cel_lit, i_lig_lit, i_cwd + use pftconMod , only : npcropmin, nc3crop, pftcon + use abortutils , only : endrun + use decompMod , only : bounds_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CropType , only : crop_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use PatchType , only : patch + use clm_varctl , only : use_fates, use_cn, iulog + use clm_varctl , only : use_matrixcn, use_soil_matrixcn + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: CStateUpdateDynPatch + public :: CStateUpdate0 + public :: CStateUpdate1 + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CStateUpdateDynPatch(bounds, num_soilc_with_inactive, filter_soilc_with_inactive, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst) + ! + ! !DESCRIPTION: + ! Update carbon states based on fluxes from dyn_cnbal_patch + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: num_soilc_with_inactive ! number of columns in soil filter + integer, intent(in) :: filter_soilc_with_inactive(:) ! soil column filter that includes inactive points + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c ! column index + integer :: fc ! column filter index + integer :: g ! gridcell index + integer :: j ! level index + real(r8) :: dt ! time step (seconds) + + character(len=*), parameter :: subname = 'CStateUpdateDynPatch' + !----------------------------------------------------------------------- + + associate( & + cf_veg => cnveg_carbonflux_inst , & + cs_veg => cnveg_carbonstate_inst , & + cs_soil => soilbiogeochem_carbonstate_inst & + ) + + dt = get_step_size_real() + + if (.not. use_fates) then + do j = 1,nlevdecomp + do fc = 1, num_soilc_with_inactive + c = filter_soilc_with_inactive(fc) + cs_soil%decomp_cpools_vr_col(c,j,i_met_lit) = cs_soil%decomp_cpools_vr_col(c,j,i_met_lit) + & + cf_veg%dwt_frootc_to_litr_met_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_cel_lit) = cs_soil%decomp_cpools_vr_col(c,j,i_cel_lit) + & + cf_veg%dwt_frootc_to_litr_cel_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_lig_lit) = cs_soil%decomp_cpools_vr_col(c,j,i_lig_lit) + & + cf_veg%dwt_frootc_to_litr_lig_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_cwd) = cs_soil%decomp_cpools_vr_col(c,j,i_cwd) + & + ( cf_veg%dwt_livecrootc_to_cwdc_col(c,j) + cf_veg%dwt_deadcrootc_to_cwdc_col(c,j) ) * dt + end do + end do + + do g = bounds%begg, bounds%endg + cs_veg%seedc_grc(g) = cs_veg%seedc_grc(g) - cf_veg%dwt_seedc_to_leaf_grc(g) * dt + cs_veg%seedc_grc(g) = cs_veg%seedc_grc(g) - cf_veg%dwt_seedc_to_deadstem_grc(g) * dt + end do + + end if + + ! TODO(wjs, 2017-01-02) Do we need to move some of the FATES fluxes into here (from + ! CStateUpdate1) if use_fates is true? Specifically, some portion or all of the fluxes + ! from these updates in CStateUpdate1: + ! cf_soil%decomp_cpools_sourcesink_col(c,j,i_met_lit) = cf_soil%FATES_c_to_litr_lab_c_col(c,j) * dt + ! cf_soil%decomp_cpools_sourcesink_col(c,j,i_cel_lit) = cf_soil%FATES_c_to_litr_cel_c_col(c,j) * dt + ! cf_soil%decomp_cpools_sourcesink_col(c,j,i_lig_lit) = cf_soil%FATES_c_to_litr_lig_c_col(c,j) * dt + + end associate + + end subroutine CStateUpdateDynPatch + + !----------------------------------------------------------------------- + subroutine CStateUpdate0(num_soilp, filter_soilp, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update cpool carbon state + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + ! + ! !LOCAL VARIABLES: + integer :: p ! indices + integer :: fp ! lake filter indices + real(r8):: dt ! radiation time step (seconds) + !----------------------------------------------------------------------- + + associate( & + cf_veg => cnveg_carbonflux_inst , & + cs_veg => cnveg_carbonstate_inst & + ) + + ! set time steps + dt = get_step_size_real() + + + + ! gross photosynthesis fluxes + do fp = 1,num_soilp + p = filter_soilp(fp) + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) + cf_veg%psnsun_to_cpool_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) + cf_veg%psnshade_to_cpool_patch(p)*dt + end do + + + end associate + + end subroutine CStateUpdate0 + + !----------------------------------------------------------------------- + subroutine CStateUpdate1( num_soilc, filter_soilc, num_soilp, filter_soilp, & + crop_inst, cnveg_carbonflux_inst, cnveg_carbonstate_inst, & + soilbiogeochem_carbonflux_inst, dribble_crophrv_xsmrpool_2atm) + ! + ! !DESCRIPTION: + ! On the radiation time step, update all the prognostic carbon state + ! variables (except for gap-phase mortality and fire fluxes) + ! + use clm_varctl , only : carbon_resp_opt + !use CNVegMatrixMod, only : matrix_update_phc + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(crop_type) , intent(in) :: crop_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst ! See note below for xsmrpool_to_atm_patch + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + logical , intent(in) :: dribble_crophrv_xsmrpool_2atm + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,k,l ! indices + integer :: fp,fc ! filter indices + real(r8) :: dt ! radiation time step (seconds) + real(r8) :: check_cpool + real(r8) :: cpool_delta + real(r8), parameter :: kprod05 = 1.44e-7 ! decay constant for 0.5-year product pool (1/s) (lose ~90% over a half year) + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + + cascade_donor_pool => decomp_cascade_con%cascade_donor_pool , & ! Input: [integer (:) ] which pool is C taken from for a given decomposition step + cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool , & ! Input: [integer (:) ] which pool is C added to for a given decomposition step + + harvdate => crop_inst%harvdate_patch , & ! Input: [integer (:) ] harvest date + + cf_veg => cnveg_carbonflux_inst , & ! Output: + cs_veg => cnveg_carbonstate_inst , & ! Output: + cf_soil => soilbiogeochem_carbonflux_inst & ! Output: + ) + + ! set time steps + dt = get_step_size_real() + + ! Below is the input into the soil biogeochemistry model + + ! plant to litter fluxes + if (.not. use_fates) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if (.not. use_soil_matrixcn) then + ! phenology and dynamic land cover fluxes + cf_soil%decomp_cpools_sourcesink_col(c,j,i_met_lit) = & + cf_veg%phenology_c_to_litr_met_c_col(c,j) *dt + cf_soil%decomp_cpools_sourcesink_col(c,j,i_cel_lit) = & + cf_veg%phenology_c_to_litr_cel_c_col(c,j) *dt + cf_soil%decomp_cpools_sourcesink_col(c,j,i_lig_lit) = & + cf_veg%phenology_c_to_litr_lig_c_col(c,j) *dt + + + ! NOTE(wjs, 2017-01-02) This used to be set to a non-zero value, but the + ! terms have been moved to CStateUpdateDynPatch. I think this is zeroed every + ! time step, but to be safe, I'm explicitly setting it to zero here. + cf_soil%decomp_cpools_sourcesink_col(c,j,i_cwd) = 0._r8 + else +! cf_soil%matrix_Cinput%V(c,j+(i_met_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_met_lit-1)*nlevdecomp) + cf_veg%phenology_c_to_litr_met_c_col(c,j) *dt +! cf_soil%matrix_Cinput%V(c,j+(i_cel_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_cel_lit-1)*nlevdecomp) + cf_veg%phenology_c_to_litr_cel_c_col(c,j) *dt +! cf_soil%matrix_Cinput%V(c,j+(i_lig_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_lig_lit-1)*nlevdecomp) + cf_veg%phenology_c_to_litr_lig_c_col(c,j) *dt + end if + end do + end do + else !use_fates + ! here add all fates litterfall and CWD breakdown to litter fluxes + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + ! TODO(wjs, 2017-01-02) Should some portion or all of the following fluxes + ! be moved to the updates in CStateUpdateDynPatch? + cf_soil%decomp_cpools_sourcesink_col(c,j,i_met_lit) = cf_soil%FATES_c_to_litr_lab_c_col(c,j) * dt + cf_soil%decomp_cpools_sourcesink_col(c,j,i_cel_lit) = cf_soil%FATES_c_to_litr_cel_c_col(c,j) * dt + cf_soil%decomp_cpools_sourcesink_col(c,j,i_lig_lit) = cf_soil%FATES_c_to_litr_lig_c_col(c,j) * dt + end do + end do + endif + + ! litter and SOM HR fluxes + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if (.not. use_soil_matrixcn) then + cf_soil%decomp_cpools_sourcesink_col(c,j,cascade_donor_pool(k)) = & + cf_soil%decomp_cpools_sourcesink_col(c,j,cascade_donor_pool(k)) & + - ( cf_soil%decomp_cascade_hr_vr_col(c,j,k) + cf_soil%decomp_cascade_ctransfer_vr_col(c,j,k)) *dt + end if !not use_soil_matrixcn + end do + end do + end do + do k = 1, ndecomp_cascade_transitions + if ( cascade_receiver_pool(k) /= 0 ) then ! skip terminal transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if (.not. use_soil_matrixcn) then + cf_soil%decomp_cpools_sourcesink_col(c,j,cascade_receiver_pool(k)) = & + cf_soil%decomp_cpools_sourcesink_col(c,j,cascade_receiver_pool(k)) & + + cf_soil%decomp_cascade_ctransfer_vr_col(c,j,k)*dt + end if !not use_soil_matrixcn + end do + end do + end if + end do + + if (.not. use_fates) then +ptch: do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + ! phenology: transfer growth fluxes + if(.not. use_matrixcn)then + ! NOTE: Any changes that go here MUST be applied to the matrix + ! version as well + cs_veg%leafc_patch(p) = cs_veg%leafc_patch(p) + cf_veg%leafc_xfer_to_leafc_patch(p)*dt + cs_veg%leafc_xfer_patch(p) = cs_veg%leafc_xfer_patch(p) - cf_veg%leafc_xfer_to_leafc_patch(p)*dt + cs_veg%frootc_patch(p) = cs_veg%frootc_patch(p) + cf_veg%frootc_xfer_to_frootc_patch(p)*dt + cs_veg%frootc_xfer_patch(p) = cs_veg%frootc_xfer_patch(p) - cf_veg%frootc_xfer_to_frootc_patch(p)*dt + if (woody(ivt(p)) == 1._r8) then + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) + cf_veg%livestemc_xfer_to_livestemc_patch(p)*dt + cs_veg%livestemc_xfer_patch(p) = cs_veg%livestemc_xfer_patch(p) - cf_veg%livestemc_xfer_to_livestemc_patch(p)*dt + cs_veg%deadstemc_patch(p) = cs_veg%deadstemc_patch(p) + cf_veg%deadstemc_xfer_to_deadstemc_patch(p)*dt + cs_veg%deadstemc_xfer_patch(p) = cs_veg%deadstemc_xfer_patch(p) - cf_veg%deadstemc_xfer_to_deadstemc_patch(p)*dt + cs_veg%livecrootc_patch(p) = cs_veg%livecrootc_patch(p) + cf_veg%livecrootc_xfer_to_livecrootc_patch(p)*dt + cs_veg%livecrootc_xfer_patch(p) = cs_veg%livecrootc_xfer_patch(p) - cf_veg%livecrootc_xfer_to_livecrootc_patch(p)*dt + cs_veg%deadcrootc_patch(p) = cs_veg%deadcrootc_patch(p) + cf_veg%deadcrootc_xfer_to_deadcrootc_patch(p)*dt + cs_veg%deadcrootc_xfer_patch(p) = cs_veg%deadcrootc_xfer_patch(p) - cf_veg%deadcrootc_xfer_to_deadcrootc_patch(p)*dt + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) + cf_veg%livestemc_xfer_to_livestemc_patch(p)*dt + cs_veg%livestemc_xfer_patch(p) = cs_veg%livestemc_xfer_patch(p) - cf_veg%livestemc_xfer_to_livestemc_patch(p)*dt + cs_veg%grainc_patch(p) = cs_veg%grainc_patch(p) + cf_veg%grainc_xfer_to_grainc_patch(p)*dt + cs_veg%grainc_xfer_patch(p) = cs_veg%grainc_xfer_patch(p) - cf_veg%grainc_xfer_to_grainc_patch(p)*dt + end if + + ! phenology: litterfall fluxes + cs_veg%leafc_patch(p) = cs_veg%leafc_patch(p) - cf_veg%leafc_to_litter_patch(p)*dt + cs_veg%frootc_patch(p) = cs_veg%frootc_patch(p) - cf_veg%frootc_to_litter_patch(p)*dt + + ! livewood turnover fluxes + if (woody(ivt(p)) == 1._r8) then + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) - cf_veg%livestemc_to_deadstemc_patch(p)*dt + cs_veg%deadstemc_patch(p) = cs_veg%deadstemc_patch(p) + cf_veg%livestemc_to_deadstemc_patch(p)*dt + cs_veg%livecrootc_patch(p) = cs_veg%livecrootc_patch(p) - cf_veg%livecrootc_to_deadcrootc_patch(p)*dt + cs_veg%deadcrootc_patch(p) = cs_veg%deadcrootc_patch(p) + cf_veg%livecrootc_to_deadcrootc_patch(p)*dt + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) - cf_veg%livestemc_to_litter_patch(p)*dt + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) - cf_veg%livestemc_to_biofuelc_patch(p)*dt + cs_veg%leafc_patch(p) = cs_veg%leafc_patch(p) - cf_veg%leafc_to_biofuelc_patch(p)*dt + cs_veg%grainc_patch(p) = cs_veg%grainc_patch(p) & + - (cf_veg%grainc_to_food_patch(p) + cf_veg%grainc_to_seed_patch(p))*dt + cs_veg%cropseedc_deficit_patch(p) = cs_veg%cropseedc_deficit_patch(p) & + - cf_veg%crop_seedc_to_leaf_patch(p) * dt & + + cf_veg%grainc_to_seed_patch(p) * dt + end if + else + ! NOTE: Changes for above that apply for matrix code are in CNPhenology EBK (11/26/2019) + + ! This part below MUST match exactly the code for the non-matrix part + ! above! + if (ivt(p) >= npcropmin) then + cs_veg%cropseedc_deficit_patch(p) = cs_veg%cropseedc_deficit_patch(p) & + - cf_veg%crop_seedc_to_leaf_patch(p) * dt & + + cf_veg%grainc_to_seed_patch(p) * dt + end if + end if !not use_matrixcn + + check_cpool = cs_veg%cpool_patch(p)- cf_veg%psnsun_to_cpool_patch(p)*dt-cf_veg%psnshade_to_cpool_patch(p)*dt + cpool_delta = cs_veg%cpool_patch(p) + + ! maintenance respiration fluxes from cpool + + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_xsmrpool_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%leaf_curmr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%froot_curmr_patch(p)*dt + If (woody(ivt(p)) == 1._r8) then + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%livestem_curmr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%livecroot_curmr_patch(p)*dt + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%livestem_curmr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%grain_curmr_patch(p)*dt + end if + + + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_resp_patch(p)*dt + + !RF Add in the carbon spent on uptake respiration. + cs_veg%cpool_patch(p)= cs_veg%cpool_patch(p) - cf_veg%soilc_change_patch(p)*dt + + ! maintenance respiration fluxes from xsmrpool + cs_veg%xsmrpool_patch(p) = cs_veg%xsmrpool_patch(p) + cf_veg%cpool_to_xsmrpool_patch(p)*dt + cs_veg%xsmrpool_patch(p) = cs_veg%xsmrpool_patch(p) - cf_veg%leaf_xsmr_patch(p)*dt + cs_veg%xsmrpool_patch(p) = cs_veg%xsmrpool_patch(p) - cf_veg%froot_xsmr_patch(p)*dt + if (woody(ivt(p)) == 1._r8) then + cs_veg%xsmrpool_patch(p) = cs_veg%xsmrpool_patch(p) - cf_veg%livestem_xsmr_patch(p)*dt + cs_veg%xsmrpool_patch(p) = cs_veg%xsmrpool_patch(p) - cf_veg%livecroot_xsmr_patch(p)*dt + end if + + ! allocation fluxes + if (carbon_resp_opt == 1) then + cf_veg%cpool_to_leafc_patch(p) = cf_veg%cpool_to_leafc_patch(p) - cf_veg%cpool_to_leafc_resp_patch(p) + cf_veg%cpool_to_leafc_storage_patch(p) = cf_veg%cpool_to_leafc_storage_patch(p) - & + cf_veg%cpool_to_leafc_storage_resp_patch(p) + cf_veg%cpool_to_frootc_patch(p) = cf_veg%cpool_to_frootc_patch(p) - cf_veg%cpool_to_frootc_resp_patch(p) + cf_veg%cpool_to_frootc_storage_patch(p) = cf_veg%cpool_to_frootc_storage_patch(p) & + - cf_veg%cpool_to_frootc_storage_resp_patch(p) + end if + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_leafc_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_leafc_storage_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_frootc_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_frootc_storage_patch(p)*dt + if(.not. use_matrixcn) then + cs_veg%leafc_patch(p) = cs_veg%leafc_patch(p) + cf_veg%cpool_to_leafc_patch(p)*dt + cs_veg%leafc_storage_patch(p) = cs_veg%leafc_storage_patch(p) + cf_veg%cpool_to_leafc_storage_patch(p)*dt + cs_veg%frootc_patch(p) = cs_veg%frootc_patch(p) + cf_veg%cpool_to_frootc_patch(p)*dt + cs_veg%frootc_storage_patch(p) = cs_veg%frootc_storage_patch(p) + cf_veg%cpool_to_frootc_storage_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + if (woody(ivt(p)) == 1._r8) then + if (carbon_resp_opt == 1) then + cf_veg%cpool_to_livecrootc_patch(p) = cf_veg%cpool_to_livecrootc_patch(p) - cf_veg%cpool_to_livecrootc_resp_patch(p) + cf_veg%cpool_to_livecrootc_storage_patch(p) = cf_veg%cpool_to_livecrootc_storage_patch(p) - & + cf_veg%cpool_to_livecrootc_storage_resp_patch(p) + cf_veg%cpool_to_livestemc_patch(p) = cf_veg%cpool_to_livestemc_patch(p) - cf_veg%cpool_to_livestemc_resp_patch(p) + cf_veg%cpool_to_livestemc_storage_patch(p) = cf_veg%cpool_to_livestemc_storage_patch(p) - & + cf_veg%cpool_to_livestemc_storage_resp_patch(p) + end if + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_livestemc_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_livestemc_storage_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_deadstemc_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_deadstemc_storage_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_livecrootc_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_livecrootc_storage_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_deadcrootc_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_deadcrootc_storage_patch(p)*dt + if(.not. use_matrixcn)then + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) + cf_veg%cpool_to_livestemc_patch(p)*dt + cs_veg%livestemc_storage_patch(p) = cs_veg%livestemc_storage_patch(p) + cf_veg%cpool_to_livestemc_storage_patch(p)*dt + cs_veg%deadstemc_patch(p) = cs_veg%deadstemc_patch(p) + cf_veg%cpool_to_deadstemc_patch(p)*dt + cs_veg%deadstemc_storage_patch(p) = cs_veg%deadstemc_storage_patch(p) + cf_veg%cpool_to_deadstemc_storage_patch(p)*dt + cs_veg%livecrootc_patch(p) = cs_veg%livecrootc_patch(p) + cf_veg%cpool_to_livecrootc_patch(p)*dt + cs_veg%livecrootc_storage_patch(p) = cs_veg%livecrootc_storage_patch(p) + cf_veg%cpool_to_livecrootc_storage_patch(p)*dt + cs_veg%deadcrootc_patch(p) = cs_veg%deadcrootc_patch(p) + cf_veg%cpool_to_deadcrootc_patch(p)*dt + cs_veg%deadcrootc_storage_patch(p) = cs_veg%deadcrootc_storage_patch(p) + cf_veg%cpool_to_deadcrootc_storage_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + if (carbon_resp_opt == 1) then + cf_veg%cpool_to_livestemc_patch(p) = cf_veg%cpool_to_livestemc_patch(p) - cf_veg%cpool_to_livestemc_resp_patch(p) + cf_veg%cpool_to_livestemc_storage_patch(p) = cf_veg%cpool_to_livestemc_storage_patch(p) - & + cf_veg%cpool_to_livestemc_storage_resp_patch(p) + end if + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_livestemc_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_livestemc_storage_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_grainc_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_grainc_storage_patch(p)*dt + if(.not. use_matrixcn)then + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) + cf_veg%cpool_to_livestemc_patch(p)*dt + cs_veg%livestemc_storage_patch(p) = cs_veg%livestemc_storage_patch(p) + cf_veg%cpool_to_livestemc_storage_patch(p)*dt + cs_veg%grainc_patch(p) = cs_veg%grainc_patch(p) + cf_veg%cpool_to_grainc_patch(p)*dt + cs_veg%grainc_storage_patch(p) = cs_veg%grainc_storage_patch(p) + cf_veg%cpool_to_grainc_storage_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + end if + + ! growth respiration fluxes for current growth + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_leaf_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_froot_gr_patch(p)*dt + + if (woody(ivt(p)) == 1._r8) then + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_livestem_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_deadstem_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_livecroot_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_deadcroot_gr_patch(p)*dt + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_livestem_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_grain_gr_patch(p)*dt + end if + + ! growth respiration for transfer growth + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - cf_veg%transfer_leaf_gr_patch(p)*dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - cf_veg%transfer_froot_gr_patch(p)*dt + if (woody(ivt(p)) == 1._r8) then + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - cf_veg%transfer_livestem_gr_patch(p)*dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - cf_veg%transfer_deadstem_gr_patch(p)*dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - cf_veg%transfer_livecroot_gr_patch(p)*dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - cf_veg%transfer_deadcroot_gr_patch(p)*dt + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - cf_veg%transfer_livestem_gr_patch(p)*dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - cf_veg%transfer_grain_gr_patch(p)*dt + end if + + ! growth respiration at time of storage + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_leaf_storage_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_froot_storage_gr_patch(p)*dt + + if (woody(ivt(p)) == 1._r8) then + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_livestem_storage_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_deadstem_storage_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_livecroot_storage_gr_patch(p)*dt + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_deadcroot_storage_gr_patch(p)*dt + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_livestem_storage_gr_patch(p)*dt + + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_grain_storage_gr_patch(p)*dt + + end if + + ! growth respiration stored for release during transfer growth + cs_veg%cpool_patch(p) = cs_veg%cpool_patch(p) - cf_veg%cpool_to_gresp_storage_patch(p)*dt + cs_veg%gresp_storage_patch(p) = cs_veg%gresp_storage_patch(p) + cf_veg%cpool_to_gresp_storage_patch(p)*dt + + ! move storage pools into transfer pools + if(.not. use_matrixcn)then + cs_veg%leafc_storage_patch(p) = cs_veg%leafc_storage_patch(p) - cf_veg%leafc_storage_to_xfer_patch(p)*dt + cs_veg%leafc_xfer_patch(p) = cs_veg%leafc_xfer_patch(p) + cf_veg%leafc_storage_to_xfer_patch(p)*dt + cs_veg%frootc_storage_patch(p) = cs_veg%frootc_storage_patch(p) - cf_veg%frootc_storage_to_xfer_patch(p)*dt + cs_veg%frootc_xfer_patch(p) = cs_veg%frootc_xfer_patch(p) + cf_veg%frootc_storage_to_xfer_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + if (woody(ivt(p)) == 1._r8) then + cs_veg%gresp_storage_patch(p) = cs_veg%gresp_storage_patch(p) - cf_veg%gresp_storage_to_xfer_patch(p)*dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) + cf_veg%gresp_storage_to_xfer_patch(p)*dt + if(.not. use_matrixcn)then + cs_veg%livestemc_storage_patch(p) = cs_veg%livestemc_storage_patch(p) - cf_veg%livestemc_storage_to_xfer_patch(p)*dt + cs_veg%livestemc_xfer_patch(p) = cs_veg%livestemc_xfer_patch(p) + cf_veg%livestemc_storage_to_xfer_patch(p)*dt + cs_veg%deadstemc_storage_patch(p) = cs_veg%deadstemc_storage_patch(p) - cf_veg%deadstemc_storage_to_xfer_patch(p)*dt + cs_veg%deadstemc_xfer_patch(p) = cs_veg%deadstemc_xfer_patch(p) + cf_veg%deadstemc_storage_to_xfer_patch(p)*dt + cs_veg%livecrootc_storage_patch(p) = cs_veg%livecrootc_storage_patch(p)- cf_veg%livecrootc_storage_to_xfer_patch(p)*dt + cs_veg%livecrootc_xfer_patch(p) = cs_veg%livecrootc_xfer_patch(p) + cf_veg%livecrootc_storage_to_xfer_patch(p)*dt + cs_veg%deadcrootc_storage_patch(p) = cs_veg%deadcrootc_storage_patch(p)- cf_veg%deadcrootc_storage_to_xfer_patch(p)*dt + cs_veg%deadcrootc_xfer_patch(p) = cs_veg%deadcrootc_xfer_patch(p) + cf_veg%deadcrootc_storage_to_xfer_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + if(.not. use_matrixcn)then + cs_veg%livestemc_storage_patch(p) = cs_veg%livestemc_storage_patch(p) - cf_veg%livestemc_storage_to_xfer_patch(p)*dt + cs_veg%livestemc_xfer_patch(p) = cs_veg%livestemc_xfer_patch(p) + cf_veg%livestemc_storage_to_xfer_patch(p)*dt + cs_veg%grainc_storage_patch(p) = cs_veg%grainc_storage_patch(p) - cf_veg%grainc_storage_to_xfer_patch(p)*dt + cs_veg%grainc_xfer_patch(p) = cs_veg%grainc_xfer_patch(p) + cf_veg%grainc_storage_to_xfer_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + end if + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cs_veg%xsmrpool_patch(p) = cs_veg%xsmrpool_patch(p) - cf_veg%livestem_xsmr_patch(p)*dt + cs_veg%xsmrpool_patch(p) = cs_veg%xsmrpool_patch(p) - cf_veg%grain_xsmr_patch(p)*dt + if (harvdate(p) < 999) then ! beginning at harvest, send to atm + ! TODO (mv, 11-02-2014) the following lines are why the cf_veg is + ! an intent(inout) + ! fluxes should not be updated in this module - not sure where + ! this belongs + ! DML (06-20-2017) While debugging crop isotope code, found that cpool_patch and frootc_patch + ! could occasionally be very small but nonzero numbers after crop harvest, which persists + ! through to next planting and for reasons that could not 100% + ! isolate, caused C12/C13 ratios to occasionally go out of + ! bounds. Zeroing out these small pools and putting them into the flux to the + ! atmosphere solved many of the crop isotope problems + + if ( .not. dribble_crophrv_xsmrpool_2atm ) then + cf_veg%xsmrpool_to_atm_patch(p) = cf_veg%xsmrpool_to_atm_patch(p) + cs_veg%xsmrpool_patch(p)/dt + cf_veg%xsmrpool_to_atm_patch(p) = cf_veg%xsmrpool_to_atm_patch(p) + cs_veg%cpool_patch(p)/dt + if(.not. use_matrixcn)then + cf_veg%xsmrpool_to_atm_patch(p) = cf_veg%xsmrpool_to_atm_patch(p) + cs_veg%frootc_patch(p)/dt + else +! cf_veg%xsmrpool_to_atm_patch(p) = cf_veg%xsmrpool_to_atm_patch(p) & +! + cs_veg%frootc_patch(p) * matrix_update_phc(p,cf_veg%ifroot_to_iout_ph,1._r8/dt,dt,cnveg_carbonflux_inst,.true.,.true.) + end if + ! Save xsmrpool, cpool, frootc to loss state variable for + ! dribbling + else + ! EBK: 10/08/2020 this could potentially change answers by + ! roundoff relative to the baseline (becuase frootc isn't + ! alsto subtracted here) + cs_veg%xsmrpool_loss_patch(p) = cs_veg%xsmrpool_loss_patch(p) + & + cs_veg%xsmrpool_patch(p) + & + cs_veg%cpool_patch(p) + if(.not. use_matrixcn)then + cs_veg%xsmrpool_loss_patch(p) = cs_veg%xsmrpool_loss_patch(p) + cs_veg%frootc_patch(p) + else +! cs_veg%xsmrpool_loss_patch(p) = cs_veg%xsmrpool_loss_patch(p) & +! + cs_veg%frootc_patch(p) * matrix_update_phc(p,cf_veg%ifroot_to_iout_ph,1._r8/dt,dt,cnveg_carbonflux_inst,.true.,.true.) + end if + end if + if (.not. use_matrixcn) then + cs_veg%frootc_patch(p) = 0._r8 + end if + cs_veg%xsmrpool_patch(p) = 0._r8 + cs_veg%cpool_patch(p) = 0._r8 + end if + ! Slowly release xsmrpool to atmosphere + if ( dribble_crophrv_xsmrpool_2atm ) then + ! calculate flux of xsmrpool loss to atm + cf_veg%xsmrpool_to_atm_patch(p) = cs_veg%xsmrpool_loss_patch(p) * kprod05 + + ! update xsmrpool loss state + cs_veg%xsmrpool_loss_patch(p) = cs_veg%xsmrpool_loss_patch(p) - cf_veg%xsmrpool_to_atm_patch(p) * dt + end if + end if + + + end do ptch ! end of patch loop + end if ! end of NOT fates + + end associate + + end subroutine CStateUpdate1 + +end module CNCStateUpdate1Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate2Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate2Mod.F90 new file mode 100755 index 000000000..adbccb71e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate2Mod.F90 @@ -0,0 +1,289 @@ +module CNCStateUpdate2Mod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for carbon state variable update, mortality fluxes. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use clm_time_manager , only : get_step_size_real + use clm_varpar , only : nlevdecomp, i_met_lit, i_cel_lit, i_lig_lit, i_cwd + use CNvegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use SoilBiogeochemCarbonStatetype , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemCarbonFluxtype , only : soilbiogeochem_carbonflux_type + use clm_varctl , only : use_matrixcn, use_soil_matrixcn + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: CStateUpdate2 + public:: CStateUpdate2h + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst, & + soilbiogeochem_carbonflux_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update all the prognostic carbon state + ! variables affected by gap-phase mortality fluxes + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c ,p,j ! indices + integer :: fp,fc ! lake filter indices + real(r8) :: dt ! radiation time step (seconds) + !----------------------------------------------------------------------- + + associate( & + cf_veg => cnveg_carbonflux_inst , & + cs_veg => cnveg_carbonstate_inst , & + + cf_soil => soilbiogeochem_carbonflux_inst, & + cs_soil => soilbiogeochem_carbonstate_inst & + ) + + ! set time steps + dt = get_step_size_real() + + ! column level carbon fluxes from gap-phase mortality + do j = 1,nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! column gap mortality fluxes + if (.not. use_soil_matrixcn)then + cs_soil%decomp_cpools_vr_col(c,j,i_met_lit) = & + cs_soil%decomp_cpools_vr_col(c,j,i_met_lit) + cf_veg%gap_mortality_c_to_litr_met_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_cel_lit) = & + cs_soil%decomp_cpools_vr_col(c,j,i_cel_lit) + cf_veg%gap_mortality_c_to_litr_cel_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_lig_lit) = & + cs_soil%decomp_cpools_vr_col(c,j,i_lig_lit) + cf_veg%gap_mortality_c_to_litr_lig_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_cwd) = & + cs_soil%decomp_cpools_vr_col(c,j,i_cwd) + cf_veg%gap_mortality_c_to_cwdc_col(c,j) * dt + else +! cf_soil%matrix_Cinput%V(c,j+(i_met_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_met_lit-1)*nlevdecomp) + cf_veg%gap_mortality_c_to_litr_met_c_col(c,j) * dt +! cf_soil%matrix_Cinput%V(c,j+(i_cel_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_cel_lit-1)*nlevdecomp) + cf_veg%gap_mortality_c_to_litr_cel_c_col(c,j) * dt +! cf_soil%matrix_Cinput%V(c,j+(i_lig_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_lig_lit-1)*nlevdecomp) + cf_veg%gap_mortality_c_to_litr_lig_c_col(c,j) * dt +! cf_soil%matrix_Cinput%V(c,j+(i_cwd-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_cwd-1)*nlevdecomp) + cf_veg%gap_mortality_c_to_cwdc_col(c,j) * dt + end if !soil_matrix + end do + end do + + ! patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + + cs_veg%gresp_storage_patch(p) = cs_veg%gresp_storage_patch(p) & + - cf_veg%m_gresp_storage_to_litter_patch(p) * dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) & + - cf_veg%m_gresp_xfer_to_litter_patch(p) * dt + if(.not. use_matrixcn)then + ! patch-level carbon fluxes from gap-phase mortality + ! displayed pools + cs_veg%leafc_patch(p) = cs_veg%leafc_patch(p) & + - cf_veg%m_leafc_to_litter_patch(p) * dt + cs_veg%frootc_patch(p) = cs_veg%frootc_patch(p) & + - cf_veg%m_frootc_to_litter_patch(p) * dt + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) & + - cf_veg%m_livestemc_to_litter_patch(p) * dt + cs_veg%deadstemc_patch(p) = cs_veg%deadstemc_patch(p) & + - cf_veg%m_deadstemc_to_litter_patch(p) * dt + cs_veg%livecrootc_patch(p) = cs_veg%livecrootc_patch(p) & + - cf_veg%m_livecrootc_to_litter_patch(p) * dt + cs_veg%deadcrootc_patch(p) = cs_veg%deadcrootc_patch(p) & + - cf_veg%m_deadcrootc_to_litter_patch(p) * dt + + ! storage pools + cs_veg%leafc_storage_patch(p) = cs_veg%leafc_storage_patch(p) & + - cf_veg%m_leafc_storage_to_litter_patch(p) * dt + cs_veg%frootc_storage_patch(p) = cs_veg%frootc_storage_patch(p) & + - cf_veg%m_frootc_storage_to_litter_patch(p) * dt + cs_veg%livestemc_storage_patch(p) = cs_veg%livestemc_storage_patch(p) & + - cf_veg%m_livestemc_storage_to_litter_patch(p) * dt + cs_veg%deadstemc_storage_patch(p) = cs_veg%deadstemc_storage_patch(p) & + - cf_veg%m_deadstemc_storage_to_litter_patch(p) * dt + cs_veg%livecrootc_storage_patch(p) = cs_veg%livecrootc_storage_patch(p) & + - cf_veg%m_livecrootc_storage_to_litter_patch(p) * dt + cs_veg%deadcrootc_storage_patch(p) = cs_veg%deadcrootc_storage_patch(p) & + - cf_veg%m_deadcrootc_storage_to_litter_patch(p) * dt + + ! transfer pools + cs_veg%leafc_xfer_patch(p) = cs_veg%leafc_xfer_patch(p) & + - cf_veg%m_leafc_xfer_to_litter_patch(p) * dt + cs_veg%frootc_xfer_patch(p) = cs_veg%frootc_xfer_patch(p) & + - cf_veg%m_frootc_xfer_to_litter_patch(p) * dt + cs_veg%livestemc_xfer_patch(p) = cs_veg%livestemc_xfer_patch(p) & + - cf_veg%m_livestemc_xfer_to_litter_patch(p) * dt + cs_veg%deadstemc_xfer_patch(p) = cs_veg%deadstemc_xfer_patch(p) & + - cf_veg%m_deadstemc_xfer_to_litter_patch(p) * dt + cs_veg%livecrootc_xfer_patch(p) = cs_veg%livecrootc_xfer_patch(p) & + - cf_veg%m_livecrootc_xfer_to_litter_patch(p) * dt + cs_veg%deadcrootc_xfer_patch(p) = cs_veg%deadcrootc_xfer_patch(p) & + - cf_veg%m_deadcrootc_xfer_to_litter_patch(p) * dt + else + ! NOTE: The matrix version of this is in CNGapMortality (EBK 11/25/2019) + end if !not use_matrixcn + end do ! end of patch loop + + end associate + + end subroutine CStateUpdate2 + + !----------------------------------------------------------------------- + subroutine CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst, & + soilbiogeochem_carbonflux_inst) + ! + ! !DESCRIPTION: + ! Update all the prognostic carbon state + ! variables affected by harvest mortality fluxes + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,k,l ! indices + integer :: fp,fc ! lake filter indices + real(r8):: dt ! radiation time step (seconds) + !----------------------------------------------------------------------- + + associate( & + cf_veg => cnveg_carbonflux_inst , & + cs_veg => cnveg_carbonstate_inst , & + cf_soil => soilbiogeochem_carbonflux_inst, & + cs_soil => soilbiogeochem_carbonstate_inst & + ) + + ! set time steps + dt = get_step_size_real() + + ! column level carbon fluxes from harvest mortality + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! column harvest fluxes + if (.not. use_soil_matrixcn)then + cs_soil%decomp_cpools_vr_col(c,j,i_met_lit) = & + cs_soil%decomp_cpools_vr_col(c,j,i_met_lit) + cf_veg%harvest_c_to_litr_met_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_cel_lit) = & + cs_soil%decomp_cpools_vr_col(c,j,i_cel_lit) + cf_veg%harvest_c_to_litr_cel_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_lig_lit) = & + cs_soil%decomp_cpools_vr_col(c,j,i_lig_lit) + cf_veg%harvest_c_to_litr_lig_c_col(c,j) * dt + cs_soil%decomp_cpools_vr_col(c,j,i_cwd) = & + cs_soil%decomp_cpools_vr_col(c,j,i_cwd) + cf_veg%harvest_c_to_cwdc_col(c,j) * dt + else +! cf_soil%matrix_Cinput%V(c,j+(i_met_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_met_lit-1)*nlevdecomp) + cf_veg%harvest_c_to_litr_met_c_col(c,j) * dt +! cf_soil%matrix_Cinput%V(c,j+(i_cel_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_cel_lit-1)*nlevdecomp) + cf_veg%harvest_c_to_litr_cel_c_col(c,j) * dt +! cf_soil%matrix_Cinput%V(c,j+(i_lig_lit-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_lig_lit-1)*nlevdecomp) + cf_veg%harvest_c_to_litr_lig_c_col(c,j) * dt +! cf_soil%matrix_Cinput%V(c,j+(i_cwd-1)*nlevdecomp) = & +! cf_soil%matrix_Cinput%V(c,j+(i_cwd-1)*nlevdecomp) + cf_veg%harvest_c_to_cwdc_col(c,j) * dt + end if + + ! wood to product pools - states updated in CNProducts + end do + end do + + ! patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! xsmrpool + cs_veg%xsmrpool_patch(p) = cs_veg%xsmrpool_patch(p) & + - cf_veg%hrv_xsmrpool_to_atm_patch(p) * dt + + ! patch-level carbon fluxes from harvest mortality + ! storage pools + cs_veg%gresp_storage_patch(p) = cs_veg%gresp_storage_patch(p) & + - cf_veg%hrv_gresp_storage_to_litter_patch(p) * dt + + ! transfer pools + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) & + - cf_veg%hrv_gresp_xfer_to_litter_patch(p) * dt + + + if(.not. use_matrixcn)then + ! displayed pools + cs_veg%leafc_patch(p) = cs_veg%leafc_patch(p) & + - cf_veg%hrv_leafc_to_litter_patch(p) * dt + cs_veg%frootc_patch(p) = cs_veg%frootc_patch(p) & + - cf_veg%hrv_frootc_to_litter_patch(p) * dt + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) & + - cf_veg%hrv_livestemc_to_litter_patch(p) * dt + cs_veg%deadstemc_patch(p) = cs_veg%deadstemc_patch(p) & + - cf_veg%wood_harvestc_patch(p) * dt + cs_veg%livecrootc_patch(p) = cs_veg%livecrootc_patch(p) & + - cf_veg%hrv_livecrootc_to_litter_patch(p) * dt + cs_veg%deadcrootc_patch(p) = cs_veg%deadcrootc_patch(p) & + - cf_veg%hrv_deadcrootc_to_litter_patch(p) * dt + + ! storage pools + cs_veg%leafc_storage_patch(p) = cs_veg%leafc_storage_patch(p) & + - cf_veg%hrv_leafc_storage_to_litter_patch(p) * dt + cs_veg%frootc_storage_patch(p) = cs_veg%frootc_storage_patch(p) & + - cf_veg%hrv_frootc_storage_to_litter_patch(p) * dt + cs_veg%livestemc_storage_patch(p) = cs_veg%livestemc_storage_patch(p) & + - cf_veg%hrv_livestemc_storage_to_litter_patch(p) * dt + cs_veg%deadstemc_storage_patch(p) = cs_veg%deadstemc_storage_patch(p) & + - cf_veg%hrv_deadstemc_storage_to_litter_patch(p) * dt + cs_veg%livecrootc_storage_patch(p) = cs_veg%livecrootc_storage_patch(p) & + - cf_veg%hrv_livecrootc_storage_to_litter_patch(p) * dt + cs_veg%deadcrootc_storage_patch(p) = cs_veg%deadcrootc_storage_patch(p) & + - cf_veg%hrv_deadcrootc_storage_to_litter_patch(p) * dt + + ! transfer pools + cs_veg%leafc_xfer_patch(p) = cs_veg%leafc_xfer_patch(p) & + - cf_veg%hrv_leafc_xfer_to_litter_patch(p) * dt + cs_veg%frootc_xfer_patch(p) = cs_veg%frootc_xfer_patch(p) & + - cf_veg%hrv_frootc_xfer_to_litter_patch(p) * dt + cs_veg%livestemc_xfer_patch(p) = cs_veg%livestemc_xfer_patch(p) & + - cf_veg%hrv_livestemc_xfer_to_litter_patch(p) * dt + cs_veg%deadstemc_xfer_patch(p) = cs_veg%deadstemc_xfer_patch(p) & + - cf_veg%hrv_deadstemc_xfer_to_litter_patch(p) * dt + cs_veg%livecrootc_xfer_patch(p) = cs_veg%livecrootc_xfer_patch(p) & + - cf_veg%hrv_livecrootc_xfer_to_litter_patch(p) * dt + cs_veg%deadcrootc_xfer_patch(p) = cs_veg%deadcrootc_xfer_patch(p) & + - cf_veg%hrv_deadcrootc_xfer_to_litter_patch(p) * dt + else + ! NOTE: The matrix equivalent of the above is in CNHarvest (EBK 11/25/2019) + end if + + end do ! end of patch loop + + end associate + + end subroutine CStateUpdate2h + +end module CNCStateUpdate2Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate3Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate3Mod.F90 new file mode 100755 index 000000000..b9d55b231 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCStateUpdate3Mod.F90 @@ -0,0 +1,211 @@ +module CNCStateUpdate3Mod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for carbon state variable update, mortality fluxes. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use clm_time_manager , only : get_step_size_real + use clm_varpar , only : nlevdecomp, ndecomp_pools, i_cwd, i_met_lit, i_cel_lit, i_lig_lit + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use clm_varctl , only : use_matrixcn,use_soil_matrixcn + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: CStateUpdate3 + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CStateUpdate3( num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst,& + soilbiogeochem_carbonflux_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update all the prognostic carbon state + ! variables affected by fire fluxes + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,l,k ! indices + integer :: fp,fc ! lake filter indices + real(r8):: dt ! radiation time step (seconds) + !----------------------------------------------------------------------- + + associate( & + cf_veg => cnveg_carbonflux_inst , & ! Input + cs_veg => cnveg_carbonstate_inst, & ! Output + cf_soil => soilbiogeochem_carbonflux_inst, & ! Output + cs_soil => soilbiogeochem_carbonstate_inst & ! Output + ) + + ! set time steps + dt = get_step_size_real() + + ! column level carbon fluxes from fire + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + ! patch-level wood to column-level CWD (uncombusted wood) + if (.not. use_soil_matrixcn) then + cs_soil%decomp_cpools_vr_col(c,j,i_cwd) = cs_soil%decomp_cpools_vr_col(c,j,i_cwd) + & + cf_veg%fire_mortality_c_to_cwdc_col(c,j) * dt + + ! patch-level wood to column-level litter (uncombusted wood) + cs_soil%decomp_cpools_vr_col(c,j,i_met_lit) = cs_soil%decomp_cpools_vr_col(c,j,i_met_lit) + & + cf_veg%m_c_to_litr_met_fire_col(c,j)* dt + cs_soil%decomp_cpools_vr_col(c,j,i_cel_lit) = cs_soil%decomp_cpools_vr_col(c,j,i_cel_lit) + & + cf_veg%m_c_to_litr_cel_fire_col(c,j)* dt + cs_soil%decomp_cpools_vr_col(c,j,i_lig_lit) = cs_soil%decomp_cpools_vr_col(c,j,i_lig_lit) + & + cf_veg%m_c_to_litr_lig_fire_col(c,j)* dt + else +! ! patch-level wood to column-level CWD (uncombusted wood) +! cf_soil%matrix_Cinput%V(c,j+(i_cwd-1)*nlevdecomp) = cf_soil%matrix_Cinput%V(c,j+(i_cwd-1)*nlevdecomp) + & +! cf_veg%fire_mortality_c_to_cwdc_col(c,j) * dt +! +! ! patch-level wood to column-level litter (uncombusted wood) +! cf_soil%matrix_Cinput%V(c,j+(i_met_lit-1)*nlevdecomp) = cf_soil%matrix_Cinput%V(c,j+(i_met_lit-1)*nlevdecomp) + & +! cf_veg%m_c_to_litr_met_fire_col(c,j)* dt +! cf_soil%matrix_Cinput%V(c,j+(i_cel_lit-1)*nlevdecomp) = cf_soil%matrix_Cinput%V(c,j+(i_cel_lit-1)*nlevdecomp) + & +! cf_veg%m_c_to_litr_cel_fire_col(c,j)* dt +! cf_soil%matrix_Cinput%V(c,j+(i_lig_lit-1)*nlevdecomp) = cf_soil%matrix_Cinput%V(c,j+(i_lig_lit-1)*nlevdecomp) + & +! cf_veg%m_c_to_litr_lig_fire_col(c,j)* dt + end if + end do + end do + + ! litter and CWD losses to fire + if(.not. use_soil_matrixcn)then + do l = 1, ndecomp_pools + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + cs_soil%decomp_cpools_vr_col(c,j,l) = cs_soil%decomp_cpools_vr_col(c,j,l) - & + cf_veg%m_decomp_cpools_to_fire_vr_col(c,j,l) * dt + end do + end do + end do + end if + + ! patch-level carbon fluxes from fire + do fp = 1,num_soilp + p = filter_soilp(fp) + + cs_veg%gresp_storage_patch(p) = cs_veg%gresp_storage_patch(p) - & + cf_veg%m_gresp_storage_to_fire_patch(p) * dt + cs_veg%gresp_storage_patch(p) = cs_veg%gresp_storage_patch(p) - & + cf_veg%m_gresp_storage_to_litter_fire_patch(p) * dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - & + cf_veg%m_gresp_xfer_to_fire_patch(p) * dt + cs_veg%gresp_xfer_patch(p) = cs_veg%gresp_xfer_patch(p) - & + cf_veg%m_gresp_xfer_to_litter_fire_patch(p) * dt + if(.not. use_matrixcn)then + ! displayed pools + cs_veg%leafc_patch(p) = cs_veg%leafc_patch(p) - & + cf_veg%m_leafc_to_fire_patch(p) * dt + cs_veg%leafc_patch(p) = cs_veg%leafc_patch(p) - & + cf_veg%m_leafc_to_litter_fire_patch(p) * dt + cs_veg%frootc_patch(p) = cs_veg%frootc_patch(p) - & + cf_veg%m_frootc_to_fire_patch(p) * dt + cs_veg%frootc_patch(p) = cs_veg%frootc_patch(p) - & + cf_veg%m_frootc_to_litter_fire_patch(p) * dt + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) - & + cf_veg%m_livestemc_to_fire_patch(p) * dt + cs_veg%livestemc_patch(p) = cs_veg%livestemc_patch(p) - & + cf_veg%m_livestemc_to_litter_fire_patch(p) * dt - & + cf_veg%m_livestemc_to_deadstemc_fire_patch(p) * dt + cs_veg%deadstemc_patch(p) = cs_veg%deadstemc_patch(p) - & + cf_veg%m_deadstemc_to_fire_patch(p) * dt + cs_veg%deadstemc_patch(p) = cs_veg%deadstemc_patch(p) - & + cf_veg%m_deadstemc_to_litter_fire_patch(p) * dt + & + cf_veg%m_livestemc_to_deadstemc_fire_patch(p) * dt + cs_veg%livecrootc_patch(p) = cs_veg%livecrootc_patch(p) - & + cf_veg%m_livecrootc_to_fire_patch(p) * dt + cs_veg%livecrootc_patch(p) = cs_veg%livecrootc_patch(p) - & + cf_veg%m_livecrootc_to_litter_fire_patch(p) * dt - & + cf_veg%m_livecrootc_to_deadcrootc_fire_patch(p) * dt + cs_veg%deadcrootc_patch(p) = cs_veg%deadcrootc_patch(p) - & + cf_veg%m_deadcrootc_to_fire_patch(p) * dt + cs_veg%deadcrootc_patch(p) = cs_veg%deadcrootc_patch(p) - & + cf_veg%m_deadcrootc_to_litter_fire_patch(p)* dt + & + cf_veg%m_livecrootc_to_deadcrootc_fire_patch(p) * dt + + ! storage pools + cs_veg%leafc_storage_patch(p) = cs_veg%leafc_storage_patch(p) - & + cf_veg%m_leafc_storage_to_fire_patch(p) * dt + cs_veg%leafc_storage_patch(p) = cs_veg%leafc_storage_patch(p) - & + cf_veg%m_leafc_storage_to_litter_fire_patch(p) * dt + cs_veg%frootc_storage_patch(p) = cs_veg%frootc_storage_patch(p) - & + cf_veg%m_frootc_storage_to_fire_patch(p) * dt + cs_veg%frootc_storage_patch(p) = cs_veg%frootc_storage_patch(p) - & + cf_veg%m_frootc_storage_to_litter_fire_patch(p) * dt + cs_veg%livestemc_storage_patch(p) = cs_veg%livestemc_storage_patch(p) - & + cf_veg%m_livestemc_storage_to_fire_patch(p) * dt + cs_veg%livestemc_storage_patch(p) = cs_veg%livestemc_storage_patch(p) - & + cf_veg%m_livestemc_storage_to_litter_fire_patch(p) * dt + cs_veg%deadstemc_storage_patch(p) = cs_veg%deadstemc_storage_patch(p) - & + cf_veg%m_deadstemc_storage_to_fire_patch(p) * dt + cs_veg%deadstemc_storage_patch(p) = cs_veg%deadstemc_storage_patch(p) - & + cf_veg%m_deadstemc_storage_to_litter_fire_patch(p) * dt + cs_veg%livecrootc_storage_patch(p) = cs_veg%livecrootc_storage_patch(p) - & + cf_veg%m_livecrootc_storage_to_fire_patch(p) * dt + cs_veg%livecrootc_storage_patch(p) = cs_veg%livecrootc_storage_patch(p) - & + cf_veg%m_livecrootc_storage_to_litter_fire_patch(p)* dt + cs_veg%deadcrootc_storage_patch(p) = cs_veg%deadcrootc_storage_patch(p) - & + cf_veg%m_deadcrootc_storage_to_fire_patch(p) * dt + cs_veg%deadcrootc_storage_patch(p) = cs_veg%deadcrootc_storage_patch(p) - & + cf_veg%m_deadcrootc_storage_to_litter_fire_patch(p)* dt + + ! transfer pools + cs_veg%leafc_xfer_patch(p) = cs_veg%leafc_xfer_patch(p) - & + cf_veg%m_leafc_xfer_to_fire_patch(p) * dt + cs_veg%leafc_xfer_patch(p) = cs_veg%leafc_xfer_patch(p) - & + cf_veg%m_leafc_xfer_to_litter_fire_patch(p) * dt + cs_veg%frootc_xfer_patch(p) = cs_veg%frootc_xfer_patch(p) - & + cf_veg%m_frootc_xfer_to_fire_patch(p) * dt + cs_veg%frootc_xfer_patch(p) = cs_veg%frootc_xfer_patch(p) - & + cf_veg%m_frootc_xfer_to_litter_fire_patch(p) * dt + cs_veg%livestemc_xfer_patch(p) = cs_veg%livestemc_xfer_patch(p) - & + cf_veg%m_livestemc_xfer_to_fire_patch(p) * dt + cs_veg%livestemc_xfer_patch(p) = cs_veg%livestemc_xfer_patch(p) - & + cf_veg%m_livestemc_xfer_to_litter_fire_patch(p) * dt + cs_veg%deadstemc_xfer_patch(p) = cs_veg%deadstemc_xfer_patch(p) - & + cf_veg%m_deadstemc_xfer_to_fire_patch(p) * dt + cs_veg%deadstemc_xfer_patch(p) = cs_veg%deadstemc_xfer_patch(p) - & + cf_veg%m_deadstemc_xfer_to_litter_fire_patch(p) * dt + cs_veg%livecrootc_xfer_patch(p) = cs_veg%livecrootc_xfer_patch(p) - & + cf_veg%m_livecrootc_xfer_to_fire_patch(p) * dt + cs_veg%livecrootc_xfer_patch(p) = cs_veg%livecrootc_xfer_patch(p) - & + cf_veg%m_livecrootc_xfer_to_litter_fire_patch(p)* dt + cs_veg%deadcrootc_xfer_patch(p) = cs_veg%deadcrootc_xfer_patch(p) - & + cf_veg%m_deadcrootc_xfer_to_fire_patch(p) * dt + cs_veg%deadcrootc_xfer_patch(p) = cs_veg%deadcrootc_xfer_patch(p) - & + cf_veg%m_deadcrootc_xfer_to_litter_fire_patch(p)* dt + else + ! NOTE: The equivalent changes for matrix code are in CNFireBase and CNFireLi2014 codes EBK (11/26/2019) + end if !not use_matrixcn + end do ! end of patch loop + + end associate + + end subroutine CStateUpdate3 + +end module CNCStateUpdate3Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNDriverMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNDriverMod.F90 new file mode 100755 index 000000000..8b7f2c43d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNDriverMod.F90 @@ -0,0 +1,1151 @@ +module CNDriverMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Ecosystem dynamics: phenology, vegetation + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varctl , only : use_c13, use_c14, use_fates, use_dynroot + use dynSubgridControlMod , only : get_do_harvest + use decompMod , only : bounds_type + use perf_mod , only : t_startf, t_stopf + use clm_varctl , only : use_century_decomp, use_nitrif_denitrif, use_nguardrail + use clm_varctl , only : use_crop + use clm_varctl , only : use_matrixcn,use_soil_matrixcn + use CNSharedParamsMod , only : use_fun + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use CNProductsMod , only : cn_products_type + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use CNDVType , only : dgvs_type + use CanopyStateType , only : canopystate_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use WaterFluxBulkType , only : waterfluxbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use atm2lndType , only : atm2lnd_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use PhotosynthesisMod , only : photosyns_type + use ch4Mod , only : ch4_type + use EnergyFluxType , only : energyflux_type + use SaturatedExcessRunoffMod , only : saturated_excess_runoff_type + use ActiveLayerMod , only : active_layer_type + ! + ! !PUBLIC TYPES: + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: CNDriverInit ! Ecosystem dynamics: initialization + public :: CNDriverNoLeaching ! Ecosystem dynamics: phenology, vegetation, before doing N leaching + public :: CNDriverLeaching ! Ecosystem dynamics: phenology, vegetation, doing N leaching + public :: CNDriverSummarizeStates + public :: CNDriverSummarizeFluxes + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CNDriverInit(bounds, NLFilename, cnfire_method) + ! + ! !DESCRIPTION: + ! Initialzation of the CN Ecosystem dynamics. + ! + ! !USES: + use CNSharedParamsMod , only : use_fun + use CNPhenologyMod , only : CNPhenologyInit + use FireMethodType , only : fire_method_type + use SoilBiogeochemCompetitionMod, only : SoilBiogeochemCompetitionInit + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + character(len=*) , intent(in) :: NLFilename ! Namelist filename + class(fire_method_type) , intent(inout) :: cnfire_method + !----------------------------------------------------------------------- + call SoilBiogeochemCompetitionInit(bounds) + call CNPhenologyInit(bounds) + call cnfire_method%FireInit(bounds) + + end subroutine CNDriverInit + + !----------------------------------------------------------------------- + subroutine CNDriverNoLeaching(bounds, & + num_soilc, filter_soilc, num_soilp, filter_soilp, num_actfirec, filter_actfirec, & + num_actfirep, filter_actfirep, num_pcropp, filter_pcropp, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, doalb, & + cnveg_state_inst, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, & + c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst, & + c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, & + c_products_inst, c13_products_inst, c14_products_inst, n_products_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_state_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & + active_layer_inst, & + atm2lnd_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, waterfluxbulk_inst, & + wateratm2lndbulk_inst, canopystate_inst, soilstate_inst, temperature_inst, & + crop_inst, ch4_inst, & + dgvs_inst, photosyns_inst, saturated_excess_runoff_inst, energyflux_inst, & + nutrient_competition_method, cnfire_method, dribble_crophrv_xsmrpool_2atm) + ! + ! !DESCRIPTION: + ! The core CN code is executed here. Calculates fluxes for maintenance + ! respiration, decomposition, allocation, phenology, and growth respiration. + ! These routines happen on the radiation time step so that canopy structure + ! stays synchronized with albedo calculations. + ! + ! !USES: + use clm_varpar , only: nlevgrnd, nlevdecomp_full, nvegcpool, nvegnpool + use clm_varpar , only: nlevdecomp, ndecomp_cascade_transitions, ndecomp_pools + use subgridAveMod , only: p2c + use CropType , only: crop_type + use CNNDynamicsMod , only: CNNDeposition,CNNFixation, CNNFert, CNSoyfix,CNFreeLivingFixation + use CNMRespMod , only: CNMResp + use CNFUNMod , only: CNFUNInit !, CNFUN + use CNPhenologyMod , only: CNPhenology + use CNGRespMod , only: CNGResp + use FireMethodType , only: fire_method_type + ! use CNCIsoFluxMod , only: CIsoFlux1, CIsoFlux2, CIsoFlux2h, CIsoFlux3 + ! use CNC14DecayMod , only: C14Decay + use CNCStateUpdate1Mod , only: CStateUpdate1,CStateUpdate0 + use CNCStateUpdate2Mod , only: CStateUpdate2, CStateUpdate2h + use CNCStateUpdate3Mod , only: CStateUpdate3 + use CNNStateUpdate1Mod , only: NStateUpdate1 + use CNNStateUpdate2Mod , only: NStateUpdate2, NStateUpdate2h + use CNGapMortalityMod , only: CNGapMortality + use CNSharedParamsMod , only: use_fun + ! use dynHarvestMod , only: CNHarvest + use SoilBiogeochemDecompCascadeBGCMod , only: decomp_rate_constants_bgc + use SoilBiogeochemDecompCascadeCNMod , only: decomp_rate_constants_cn + use SoilBiogeochemCompetitionMod , only: SoilBiogeochemCompetition + use SoilBiogeochemDecompMod , only: SoilBiogeochemDecomp + use SoilBiogeochemLittVertTranspMod , only: SoilBiogeochemLittVertTransp + use SoilBiogeochemPotentialMod , only: SoilBiogeochemPotential + use SoilBiogeochemVerticalProfileMod , only: SoilBiogeochemVerticalProfile + use SoilBiogeochemNitrifDenitrifMod , only: SoilBiogeochemNitrifDenitrif + use SoilBiogeochemNStateUpdate1Mod , only: SoilBiogeochemNStateUpdate1 + use NutrientCompetitionMethodMod , only: nutrient_competition_method_type + use CNRootDynMod , only: CNRootDyn + use CNPrecisionControlMod , only: CNPrecisionControl + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(out) :: num_actfirep ! number of soil patches on fire in filter + integer , intent(out) :: filter_actfirep(:) ! filter for soil patches on fire + integer , intent(out) :: num_actfirec ! number of soil columns on fire in filter + integer , intent(out) :: filter_actfirec(:) ! filter for soil columns on fire + integer , intent(in) :: num_pcropp ! number of prog. crop patches in filter + integer , intent(in) :: filter_pcropp(:) ! filter for prognostic crop patches + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + logical , intent(in) :: doalb ! true = surface albedo calculation time step + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: c13_cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: c14_cnveg_carbonstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cn_products_type) , intent(inout) :: c_products_inst + type(cn_products_type) , intent(inout) :: c13_products_inst + type(cn_products_type) , intent(inout) :: c14_products_inst + type(cn_products_type) , intent(inout) :: n_products_inst + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(active_layer_type) , intent(in) :: active_layer_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(wateratm2lndbulk_type) , intent(inout) :: wateratm2lndbulk_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(inout) :: temperature_inst + type(crop_type) , intent(inout) :: crop_inst + type(ch4_type) , intent(in) :: ch4_inst + type(dgvs_type) , intent(inout) :: dgvs_inst + type(photosyns_type) , intent(in) :: photosyns_inst + type(saturated_excess_runoff_type) , intent(in) :: saturated_excess_runoff_inst + type(energyflux_type) , intent(in) :: energyflux_inst + class(nutrient_competition_method_type) , intent(inout) :: nutrient_competition_method + class(fire_method_type) , intent(inout) :: cnfire_method + logical , intent(in) :: dribble_crophrv_xsmrpool_2atm + ! + ! !LOCAL VARIABLES: + real(r8):: cn_decomp_pools(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_pools) + real(r8):: p_decomp_cpool_loss(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_cascade_transitions) !potential C loss from one pool to another + real(r8):: pmnf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,1:ndecomp_cascade_transitions) !potential mineral N flux, from one pool to another + real(r8):: arepr(bounds%begp:bounds%endp) ! reproduction allocation coefficient (only used for use_crop) + real(r8):: aroot(bounds%begp:bounds%endp) ! root allocation coefficient (only used for use_crop) + integer :: begp,endp + integer :: begc,endc + + integer :: dummy_to_make_pgi_happy + !----------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + associate( & + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit projected leaf area index + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded projected leaf area index + frac_veg_nosno => canopystate_inst%frac_veg_nosno_patch , & ! Input: [integer (:) ] fraction of vegetation not covered by snow (0 OR 1) [-] + frac_veg_nosno_alb => canopystate_inst%frac_veg_nosno_alb_patch , & ! Output: [integer (:) ] frac of vegetation not covered by snow [-] + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index, no burying by snow + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index, no burying by snow + elai => canopystate_inst%elai_patch , & ! Output: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Output: [real(r8) (:) ] one-sided stem area index with burying by snow + htop => canopystate_inst%htop_patch , & ! Output: [real(r8) (:) ] canopy top (m) + hbot => canopystate_inst%hbot_patch & ! Output: [real(r8) (:) ] canopy bottom (m) + ) + + ! -------------------------------------------------- + ! zero the column-level C and N fluxes + ! -------------------------------------------------- + + call t_startf('CNZero') + + ! COMPILER_BUG(wjs, 2014-11-29, pgi 14.7) Without this, the filter is full of garbage + ! in some situations + call t_startf('CNZero-soilbgc-cflux') + dummy_to_make_pgi_happy = ubound(filter_soilc, 1) + call soilbiogeochem_carbonflux_inst%SetValues( & + num_soilc, filter_soilc, 0._r8) + if ( use_c13 ) then + call c13_soilbiogeochem_carbonflux_inst%SetValues( & + num_soilc, filter_soilc, 0._r8) + end if + if ( use_c14 ) then + call c14_soilbiogeochem_carbonflux_inst%SetValues( & + num_soilc, filter_soilc, 0._r8) + end if + call t_stopf('CNZero-soilbgc-cflux') + + call t_startf('CNZero-vegbgc-cflux') + call cnveg_carbonflux_inst%SetValues( & + nvegcpool,& + num_soilp, filter_soilp, 0._r8, & + num_soilc, filter_soilc, 0._r8) + if ( use_c13 ) then + call c13_cnveg_carbonflux_inst%SetValues( & + nvegcpool,& + num_soilp, filter_soilp, 0._r8, & + num_soilc, filter_soilc, 0._r8) + end if + if ( use_c14 ) then + call c14_cnveg_carbonflux_inst%SetValues( & + nvegcpool,& + num_soilp, filter_soilp, 0._r8, & + num_soilc, filter_soilc, 0._r8) + end if + call t_stopf('CNZero-vegbgc-cflux') + + call t_startf('CNZero-vegbgc-nflux') + call cnveg_nitrogenflux_inst%SetValues( & + nvegnpool, & + num_soilp, filter_soilp, 0._r8, & + num_soilc, filter_soilc, 0._r8) + + call t_stopf('CNZero-vegbgc-nflux') + call t_startf('CNZero-soilbgc-nflux') + call soilbiogeochem_nitrogenflux_inst%SetValues( & + num_soilc, filter_soilc, 0._r8) + + call t_stopf('CNZero-soilbgc-nflux') + call t_stopf('CNZero') + + ! -------------------------------------------------- + ! Nitrogen Deposition, Fixation and Respiration + ! -------------------------------------------------- + + call t_startf('CNDeposition') + call CNNDeposition(bounds, & + atm2lnd_inst, soilbiogeochem_nitrogenflux_inst) + call t_stopf('CNDeposition') + + if(use_fun)then + call t_startf('CNFLivFixation') + call CNFreeLivingFixation( num_soilc, filter_soilc, & + waterfluxbulk_inst, soilbiogeochem_nitrogenflux_inst) + call t_stopf('CNFLivFixation') + else + call t_startf('CNFixation') + call CNNFixation( num_soilc, filter_soilc, & + cnveg_carbonflux_inst, soilbiogeochem_nitrogenflux_inst) + call t_stopf('CNFixation') + end if + + + if (use_crop) then + call CNNFert(bounds, num_soilc,filter_soilc, & + cnveg_nitrogenflux_inst, soilbiogeochem_nitrogenflux_inst) + + if (.not. use_fun) then ! if FUN is active, then soy fixation handled by FUN + call CNSoyfix (bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + waterdiagnosticbulk_inst, crop_inst, cnveg_state_inst, cnveg_nitrogenflux_inst , & + soilbiogeochem_state_inst, soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + end if + end if + + call t_startf('CNMResp') + call CNMResp(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + canopystate_inst, soilstate_inst, temperature_inst, photosyns_inst, & + cnveg_carbonflux_inst, cnveg_nitrogenstate_inst) + call t_stopf('CNMResp') + + !-------------------------------------------- + ! Soil Biogeochemistry + !-------------------------------------------- + + call t_startf('SoilBiogeochem') + if (use_century_decomp) then + call decomp_rate_constants_bgc(bounds, num_soilc, filter_soilc, & + soilstate_inst, temperature_inst, ch4_inst, soilbiogeochem_carbonflux_inst) + else + call decomp_rate_constants_cn(bounds, num_soilc, filter_soilc, & + soilstate_inst, temperature_inst, ch4_inst, soilbiogeochem_carbonflux_inst) + end if + + ! calculate potential decomp rates and total immobilization demand (previously inlined in CNDecompAlloc) + call SoilBiogeochemPotential (bounds, num_soilc, filter_soilc, & + soilbiogeochem_state_inst, soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & + cn_decomp_pools=cn_decomp_pools(begc:endc,1:nlevdecomp,1:ndecomp_pools), & + p_decomp_cpool_loss=p_decomp_cpool_loss(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions), & + pmnf_decomp_cascade=pmnf_decomp_cascade(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions)) + + ! calculate vertical profiles for distributing soil and litter C and N (previously subroutine decomp_vertprofiles called from CNDecompAlloc) + call SoilBiogeochemVerticalProfile(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + active_layer_inst, soilstate_inst,soilbiogeochem_state_inst) + + ! calculate nitrification and denitrification rates (previously subroutine nitrif_denitrif called from CNDecompAlloc) + if (use_nitrif_denitrif) then + call SoilBiogeochemNitrifDenitrif(bounds, num_soilc, filter_soilc, & + soilstate_inst, waterstatebulk_inst, temperature_inst, ch4_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + end if + call t_stopf('SoilBiogeochem') + + !-------------------------------------------- + ! Resolve the competition between plants and soil heterotrophs + ! for available soil mineral N resource + !-------------------------------------------- + + call t_startf('CNDecompAlloc') + + ! Jinyun Tang: at this stage, the plant_nutrient_demand only calculates the plant ntirgeon demand. + ! Assume phosphorus dynamics will be included in the future. Also, I consider plant_nutrient_demand + ! as a generic interface to call actual nutrient calculation from different aboveground plantbgc. + ! Right now it is assumed the plant nutrient demand is summarized into columnwise demand, and the + ! nutrient redistribution after uptake is done by the plant bgc accordingly. + ! When nutrient competition is required to be done at cohort level both plant_nutrient_demand and + ! do_nutrient_competition should be modified, but that modification should not significantly change + ! the current interface. + + !RF: moved ths call to before nutrient_demand, so that croplive didn't change half way through crop N cycle. + if ( use_fun ) then + call t_startf('CNPhenology_phase1') + call CNPhenology (bounds, num_soilc, filter_soilc, num_soilp, & + filter_soilp, num_pcropp, filter_pcropp, & + doalb, waterdiagnosticbulk_inst, wateratm2lndbulk_inst, temperature_inst, atm2lnd_inst, & + crop_inst, canopystate_inst, soilstate_inst, dgvs_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + c13_cnveg_carbonstate_inst, c14_cnveg_carbonstate_inst, & + leaf_prof_patch=soilbiogeochem_state_inst%leaf_prof_patch(begp:endp,1:nlevdecomp_full), & + froot_prof_patch=soilbiogeochem_state_inst%froot_prof_patch(begp:endp,1:nlevdecomp_full), & + phase=1) + call t_stopf('CNPhenology_phase1') + + call t_startf('CNFUNInit') + call CNFUNInit(bounds,cnveg_state_inst,cnveg_carbonstate_inst,cnveg_nitrogenstate_inst) + call t_stopf('CNFUNInit') + + end if + + call t_startf('calc_plant_nutrient_demand') + call nutrient_competition_method%calc_plant_nutrient_demand ( & + bounds, num_soilp, filter_soilp, & + photosyns_inst, crop_inst, canopystate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenstate_inst, & + energyflux_inst, & + aroot=aroot(begp:endp), arepr=arepr(begp:endp)) + + ! get the column-averaged plant_ndemand (needed for following call to SoilBiogeochemCompetition) + + call p2c(bounds, num_soilc, filter_soilc, & + cnveg_nitrogenflux_inst%plant_ndemand_patch(begp:endp), & + soilbiogeochem_state_inst%plant_ndemand_col(begc:endc)) + call t_stopf('calc_plant_nutrient_demand') + + ! resolve plant/heterotroph competition for mineral N + + + call t_startf('soilbiogeochemcompetition') + call SoilBiogeochemCompetition (bounds, num_soilc, filter_soilc,num_soilp, filter_soilp, waterstatebulk_inst, & + waterfluxbulk_inst,temperature_inst,soilstate_inst,cnveg_state_inst, & + cnveg_carbonstate_inst ,& + cnveg_carbonflux_inst,cnveg_nitrogenstate_inst,cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst,& + soilbiogeochem_state_inst,soilbiogeochem_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst,canopystate_inst) + call t_stopf('soilbiogeochemcompetition') + + ! distribute the available N between the competing patches on the basis of + ! relative demand, and allocate C and N to new growth and storage + + call t_startf('calc_plant_nutrient_competition') + call nutrient_competition_method%calc_plant_nutrient_competition ( & + bounds, num_soilp, filter_soilp, & + cnveg_state_inst, crop_inst, canopystate_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_nitrogenstate_inst, & + aroot=aroot(begp:endp), & + arepr=arepr(begp:endp), & + fpg_col=soilbiogeochem_state_inst%fpg_col(begc:endc)) + call t_stopf('calc_plant_nutrient_competition') + + call t_stopf('CNDecompAlloc') + + !-------------------------------------------- + ! Calculate litter and soil decomposition rate + !-------------------------------------------- + + ! Calculation of actual immobilization and decomp rates, following + ! resolution of plant/heterotroph competition for mineral N (previously inlined in CNDecompAllocation in CNDecompMod) + + call t_startf('SoilBiogeochemDecomp') + + call SoilBiogeochemDecomp (bounds, num_soilc, filter_soilc, & + soilbiogeochem_state_inst, soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & + cn_decomp_pools=cn_decomp_pools(begc:endc,1:nlevdecomp,1:ndecomp_pools), & + p_decomp_cpool_loss=p_decomp_cpool_loss(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions), & + pmnf_decomp_cascade=pmnf_decomp_cascade(begc:endc,1:nlevdecomp,1:ndecomp_cascade_transitions)) + + call t_stopf('SoilBiogeochemDecomp') + + !-------------------------------------------- + ! Phenology + !-------------------------------------------- + + ! CNphenology needs to be called after above calls, since it depends on current + ! time-step fluxes to new growth on the lastlitterfall timestep in deciduous systems + + call t_startf('CNPhenology') + + if ( .not. use_fun ) then + call CNPhenology (bounds, num_soilc, filter_soilc, num_soilp, & + filter_soilp, num_pcropp, filter_pcropp, & + doalb, waterdiagnosticbulk_inst, wateratm2lndbulk_inst, temperature_inst, atm2lnd_inst, & + crop_inst, canopystate_inst, soilstate_inst, dgvs_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + c13_cnveg_carbonstate_inst, c14_cnveg_carbonstate_inst, & + leaf_prof_patch=soilbiogeochem_state_inst%leaf_prof_patch(begp:endp,1:nlevdecomp_full), & + froot_prof_patch=soilbiogeochem_state_inst%froot_prof_patch(begp:endp,1:nlevdecomp_full), & + phase=1) + end if + call CNPhenology (bounds, num_soilc, filter_soilc, num_soilp, & + filter_soilp, num_pcropp, filter_pcropp, & + doalb, waterdiagnosticbulk_inst, wateratm2lndbulk_inst, temperature_inst, atm2lnd_inst, & + crop_inst, canopystate_inst, soilstate_inst, dgvs_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + c13_cnveg_carbonstate_inst, c14_cnveg_carbonstate_inst, & + leaf_prof_patch=soilbiogeochem_state_inst%leaf_prof_patch(begp:endp,1:nlevdecomp_full), & + froot_prof_patch=soilbiogeochem_state_inst%froot_prof_patch(begp:endp,1:nlevdecomp_full), & + phase=2) + + call t_stopf('CNPhenology') + + !-------------------------------------------- + ! Growth respiration + !-------------------------------------------- + + call t_startf('CNGResp') + + call CNGResp(num_soilp, filter_soilp,& + cnveg_carbonflux_inst, canopystate_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst) + + call t_stopf('CNGResp') + + !-------------------------------------------- + ! Dynamic Roots + !-------------------------------------------- + + if( use_dynroot ) then + call t_startf('CNRootDyn') + + call CNRootDyn(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, & + cnveg_state_inst, crop_inst, soilstate_inst, soilbiogeochem_nitrogenstate_inst) + + call t_stopf('CNRootDyn') + end if + + !-------------------------------------------- + ! CNUpdate0 + !-------------------------------------------- + + call t_startf('CNUpdate0') + + call CStateUpdate0(num_soilp, filter_soilp, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst) + + if ( use_c13 ) then + call CStateUpdate0(num_soilp, filter_soilp, & + c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst) + end if + + if ( use_c14 ) then + call CStateUpdate0(num_soilp, filter_soilp, & + c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst) + end if + + call t_stopf('CNUpdate0') + + if ( use_nguardrail ) then + call t_startf('CNPrecisionControl') + call CNPrecisionControl(bounds, num_soilp, filter_soilp, & + cnveg_carbonstate_inst, c13_cnveg_carbonstate_inst, & + c14_cnveg_carbonstate_inst, cnveg_nitrogenstate_inst) + call t_stopf('CNPrecisionControl') + end if + !-------------------------------------------- + ! Update1 + !-------------------------------------------- + + call t_startf('CNUpdate1') + + ! Set the carbon isotopic flux variables (except for gap-phase mortality and fire fluxes) + if ( use_c13 ) then + +! call CIsoFlux1(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst, & +! soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & +! cnveg_carbonflux_inst, cnveg_carbonstate_inst, & +! c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & +! c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst, & +! isotope='c13') + end if + if ( use_c14 ) then +! call CIsoFlux1(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst, & +! soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & +! cnveg_carbonflux_inst, cnveg_carbonstate_inst, & +! c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & +! c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst, & +! isotope='c14') + end if + + ! Update all prognostic carbon state variables (except for gap-phase mortality and fire fluxes) + call CStateUpdate1( num_soilc, filter_soilc, num_soilp, filter_soilp, & + crop_inst, cnveg_carbonflux_inst, cnveg_carbonstate_inst, & + soilbiogeochem_carbonflux_inst, dribble_crophrv_xsmrpool_2atm) + if ( use_c13 ) then + call CStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, & + crop_inst, c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst, dribble_crophrv_xsmrpool_2atm) + end if + if ( use_c14 ) then + call CStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, & + crop_inst, c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst, dribble_crophrv_xsmrpool_2atm) + end if + + ! Update all prognostic nitrogen state variables (except for gap-phase mortality and fire fluxes) + call NStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + + call t_stopf('CNUpdate1') + + if ( use_nguardrail ) then + call t_startf('CNPrecisionControl') + call CNPrecisionControl(bounds, num_soilp, filter_soilp, & + cnveg_carbonstate_inst, c13_cnveg_carbonstate_inst, & + c14_cnveg_carbonstate_inst, cnveg_nitrogenstate_inst) + call t_stopf('CNPrecisionControl') + end if + + call t_startf('SoilBiogeochemStateUpdate1') + call SoilBiogeochemNStateUpdate1(num_soilc, filter_soilc, & + soilbiogeochem_state_inst, soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst) + call t_stopf('SoilBiogeochemStateUpdate1') + + + !-------------------------------------------- + ! Calculate vertical mixing of soil and litter pools + !-------------------------------------------- + + call t_startf('SoilBiogeochemLittVertTransp') + + call SoilBiogeochemLittVertTransp(bounds, num_soilc, filter_soilc, & + active_layer_inst, soilbiogeochem_state_inst, & + soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + c13_soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonflux_inst, & + c14_soilbiogeochem_carbonstate_inst, c14_soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + + call t_stopf('SoilBiogeochemLittVertTransp') + + !-------------------------------------------- + ! Calculate the gap mortality carbon and nitrogen fluxes + !-------------------------------------------- + + call t_startf('CNGapMortality') + + call CNGapMortality (bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + dgvs_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & + cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, canopystate_inst, & + !cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, & + leaf_prof_patch=soilbiogeochem_state_inst%leaf_prof_patch(begp:endp, 1:nlevdecomp_full), & + froot_prof_patch=soilbiogeochem_state_inst%froot_prof_patch(begp:endp, 1:nlevdecomp_full), & + croot_prof_patch=soilbiogeochem_state_inst%croot_prof_patch(begp:endp, 1:nlevdecomp_full), & + stem_prof_patch=soilbiogeochem_state_inst%stem_prof_patch(begp:endp, 1:nlevdecomp_full)) + + call t_stopf('CNGapMortality') + + !-------------------------------------------- + ! Update2 (gap mortality) + !-------------------------------------------- + + call t_startf('CNUpdate2') + + ! Set the carbon isotopic fluxes for gap mortality + if ( use_c13 ) then +! call CIsoFlux2(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst, cnveg_carbonflux_inst, cnveg_carbonstate_inst, & +! iso_cnveg_carbonflux_inst=c13_cnveg_carbonflux_inst, & +! iso_cnveg_carbonstate_inst=c13_cnveg_carbonstate_inst, & +! isotope='c13') + end if + if ( use_c14 ) then +! call CIsoFlux2(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst, cnveg_carbonflux_inst, cnveg_carbonstate_inst, & +! iso_cnveg_carbonflux_inst=c14_cnveg_carbonflux_inst, & +! iso_cnveg_carbonstate_inst=c14_cnveg_carbonstate_inst, & +! isotope='c14') + end if + + ! Update all the prognostic carbon state variables affected by gap-phase mortality fluxes + call CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst, & + soilbiogeochem_carbonflux_inst) + if ( use_c13 ) then + call CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, & + c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst) + end if + if ( use_c14 ) then + call CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, & + c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst, c14_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst) + end if + + ! Update all the prognostic nitrogen state variables affected by gap-phase mortality fluxes + call NStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst,soilbiogeochem_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst) + + !-------------------------------------------- + ! Update2h (harvest) + !-------------------------------------------- + + ! Set harvest mortality routine + if (get_do_harvest()) then +! call CNHarvest(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, & +! cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + end if + + if ( use_c13 ) then +! call CIsoFlux2h(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst, & +! cnveg_carbonflux_inst, cnveg_carbonstate_inst, & +! c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst, & +! isotope='c13') + end if + if ( use_c14 ) then +! call CIsoFlux2h(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst, & +! cnveg_carbonflux_inst, cnveg_carbonstate_inst, & +! c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst, & +! isotope='c14') + end if + + call CStateUpdate2h( num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst, & + soilbiogeochem_carbonflux_inst) + if ( use_c13 ) then + call CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, & + c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst) + end if + if ( use_c14 ) then + call CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, & + c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst, c14_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst) + end if + + call NStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst) + call t_stopf('CNUpdate2') + + if ( use_nguardrail ) then + call t_startf('CNPrecisionControl') + call CNPrecisionControl(bounds, num_soilp, filter_soilp, & + cnveg_carbonstate_inst, c13_cnveg_carbonstate_inst, & + c14_cnveg_carbonstate_inst, cnveg_nitrogenstate_inst) + call t_stopf('CNPrecisionControl') + end if + !-------------------------------------------- + ! Calculate loss fluxes from wood products pools + ! and update product pool state variables + !-------------------------------------------- + + call t_startf('CNWoodProducts') + call c_products_inst%UpdateProducts(bounds, & + num_soilp, filter_soilp, & + dwt_wood_product_gain_patch = cnveg_carbonflux_inst%dwt_wood_productc_gain_patch(begp:endp), & + wood_harvest_patch = cnveg_carbonflux_inst%wood_harvestc_patch(begp:endp), & + dwt_crop_product_gain_patch = cnveg_carbonflux_inst%dwt_crop_productc_gain_patch(begp:endp), & + grain_to_cropprod_patch = cnveg_carbonflux_inst%grainc_to_cropprodc_patch(begp:endp)) + call t_stopf('CNWoodProducts') + + if (use_c13) then + call c13_products_inst%UpdateProducts(bounds, & + num_soilp, filter_soilp, & + dwt_wood_product_gain_patch = c13_cnveg_carbonflux_inst%dwt_wood_productc_gain_patch(begp:endp), & + wood_harvest_patch = c13_cnveg_carbonflux_inst%wood_harvestc_patch(begp:endp), & + dwt_crop_product_gain_patch = c13_cnveg_carbonflux_inst%dwt_crop_productc_gain_patch(begp:endp), & + grain_to_cropprod_patch = c13_cnveg_carbonflux_inst%grainc_to_cropprodc_patch(begp:endp)) + end if + + if (use_c14) then + call c14_products_inst%UpdateProducts(bounds, & + num_soilp, filter_soilp, & + dwt_wood_product_gain_patch = c14_cnveg_carbonflux_inst%dwt_wood_productc_gain_patch(begp:endp), & + wood_harvest_patch = c14_cnveg_carbonflux_inst%wood_harvestc_patch(begp:endp), & + dwt_crop_product_gain_patch = c14_cnveg_carbonflux_inst%dwt_crop_productc_gain_patch(begp:endp), & + grain_to_cropprod_patch = c14_cnveg_carbonflux_inst%grainc_to_cropprodc_patch(begp:endp)) + end if + + call n_products_inst%UpdateProducts(bounds, & + num_soilp, filter_soilp, & + dwt_wood_product_gain_patch = cnveg_nitrogenflux_inst%dwt_wood_productn_gain_patch(begp:endp), & + wood_harvest_patch = cnveg_nitrogenflux_inst%wood_harvestn_patch(begp:endp), & + dwt_crop_product_gain_patch = cnveg_nitrogenflux_inst%dwt_crop_productn_gain_patch(begp:endp), & + grain_to_cropprod_patch = cnveg_nitrogenflux_inst%grainn_to_cropprodn_patch(begp:endp)) + + !-------------------------------------------- + ! Calculate fire area and fluxes + !-------------------------------------------- + + call t_startf('CNFire') + call cnfire_method%CNFireArea(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + atm2lnd_inst, energyflux_inst, saturated_excess_runoff_inst, waterdiagnosticbulk_inst, wateratm2lndbulk_inst, & + waterstatebulk_inst, soilstate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, & + totlitc_col=soilbiogeochem_carbonstate_inst%totlitc_col(begc:endc), & + decomp_cpools_vr_col=soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools), & + t_soi17cm_col=temperature_inst%t_soi17cm_col(begc:endc)) + + call cnfire_method%CNFireFluxes(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_actfirec, filter_actfirec, num_actfirep, filter_actfirep, & + dgvs_inst, cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, & + leaf_prof_patch=soilbiogeochem_state_inst%leaf_prof_patch(begp:endp, 1:nlevdecomp_full), & + froot_prof_patch=soilbiogeochem_state_inst%froot_prof_patch(begp:endp, 1:nlevdecomp_full), & + croot_prof_patch=soilbiogeochem_state_inst%croot_prof_patch(begp:endp, 1:nlevdecomp_full), & + stem_prof_patch=soilbiogeochem_state_inst%stem_prof_patch(begp:endp, 1:nlevdecomp_full), & + totsomc_col=soilbiogeochem_carbonstate_inst%totsomc_col(begc:endc), & + decomp_cpools_vr_col=soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools), & + decomp_npools_vr_col=soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools), & + somc_fire_col=soilbiogeochem_carbonflux_inst%somc_fire_col(begc:endc)) + call t_stopf('CNFire') + + + !-------------------------------------------- + ! Update3 + !-------------------------------------------- + + call t_startf('CNUpdate3') + if ( use_c13 ) then +! call CIsoFlux3(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst , soilbiogeochem_carbonstate_inst, & +! cnveg_carbonflux_inst, cnveg_carbonstate_inst, & +! c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst, & +! c13_soilbiogeochem_carbonstate_inst, & +! isotope='c13') + end if + if ( use_c14 ) then +! call CIsoFlux3(num_soilc, filter_soilc, num_soilp, filter_soilp, & +! soilbiogeochem_state_inst , soilbiogeochem_carbonstate_inst, & +! cnveg_carbonflux_inst, cnveg_carbonstate_inst, & +! c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst, & +! c14_soilbiogeochem_carbonstate_inst, & +! isotope='c14') + end if + + call CStateUpdate3( num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonflux_inst, cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst, & + soilbiogeochem_carbonflux_inst) + + if ( use_c13 ) then + call CStateUpdate3( num_soilc, filter_soilc, num_soilp, filter_soilp, & + c13_cnveg_carbonflux_inst, c13_cnveg_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst) + end if + + if ( use_c14 ) then + call CStateUpdate3( num_soilc, filter_soilc, num_soilp, filter_soilp, & + c14_cnveg_carbonflux_inst, c14_cnveg_carbonstate_inst, c14_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst) + + call C14Decay(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + c14_cnveg_carbonstate_inst, c14_soilbiogeochem_carbonstate_inst, & + c14_cnveg_carbonflux_inst, c14_soilbiogeochem_carbonflux_inst) + end if + call t_stopf('CNUpdate3') + + if ( use_nguardrail ) then + call t_startf('CNPrecisionControl') + call CNPrecisionControl(bounds, num_soilp, filter_soilp, & + cnveg_carbonstate_inst, c13_cnveg_carbonstate_inst, & + c14_cnveg_carbonstate_inst, cnveg_nitrogenstate_inst) + call t_stopf('CNPrecisionControl') + end if + + end associate + + end subroutine CNDriverNoLeaching + + !----------------------------------------------------------------------- + subroutine CNDriverLeaching(bounds, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_actfirec, filter_actfirec, num_actfirep, filter_actfirep,& + waterstatebulk_inst, waterfluxbulk_inst, & + soilstate_inst, cnveg_state_inst, & + cnveg_carbonflux_inst,cnveg_carbonstate_inst,soilbiogeochem_carbonstate_inst, & + soilbiogeochem_carbonflux_inst,soilbiogeochem_state_inst, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & + c13_cnveg_carbonstate_inst,c14_cnveg_carbonstate_inst, & + c13_cnveg_carbonflux_inst,c14_cnveg_carbonflux_inst, & + c13_soilbiogeochem_carbonstate_inst,c14_soilbiogeochem_carbonstate_inst,& + c13_soilbiogeochem_carbonflux_inst,c14_soilbiogeochem_carbonflux_inst) + ! + ! !DESCRIPTION: + ! Update the nitrogen leaching rate as a function of soluble mineral N and total soil water outflow. + ! Also update nitrogen state variables + ! + ! !USES: + use SoilBiogeochemNLeachingMod, only: SoilBiogeochemNLeaching + use CNNStateUpdate3Mod , only: NStateUpdate3 + ! use CNVegMatrixMod , only: CNVegMatrix + ! use CNSoilMatrixMod , only: CNSoilMatrix + use clm_time_manager , only : is_beg_curr_year,get_curr_date + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_actfirec ! number of soil columns on fire in filter + integer , intent(in) :: filter_actfirec(:) ! filter for soil columns on fire + integer , intent(in) :: num_actfirep ! number of soil patches on fire in filter + integer , intent(in) :: filter_actfirep(:) ! filter for soil patches on fire + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(cnveg_carbonstate_type) , intent(inout) :: c13_cnveg_carbonstate_inst + type(cnveg_carbonstate_type) , intent(inout) :: c14_cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst + integer p,fp,yr,mon,day,sec + !----------------------------------------------------------------------- + + ! Mineral nitrogen dynamics (deposition, fixation, leaching) + + call t_startf('SoilBiogeochemNLeaching') + call SoilBiogeochemNLeaching(bounds, num_soilc, filter_soilc, & + waterstatebulk_inst, waterfluxbulk_inst, soilbiogeochem_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst) + call t_stopf('SoilBiogeochemNLeaching') + + ! Nitrogen state variable update, mortality fluxes. + + call t_startf('NUpdate3') + + call NStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst) + + call t_stopf('NUpdate3') + if(use_matrixcn)then +! call t_startf('CNVMatrix') +! call CNVegMatrix(bounds,num_soilp,filter_soilp(1:num_soilp),num_actfirep,filter_actfirep,cnveg_carbonstate_inst,cnveg_nitrogenstate_inst,& +! cnveg_carbonflux_inst, cnveg_nitrogenflux_inst,cnveg_state_inst,soilbiogeochem_nitrogenflux_inst,& +! c13_cnveg_carbonstate_inst,c14_cnveg_carbonstate_inst,c13_cnveg_carbonflux_inst,& +! c14_cnveg_carbonflux_inst) +! call t_stopf('CNVMatrix') + end if + + if(use_soil_matrixcn)then +! call t_startf('CNSoilMatrix') +! call CNSoilMatrix(bounds,num_soilc, filter_soilc(1:num_soilc), num_actfirec, filter_actfirec, & +! cnveg_carbonflux_inst,soilbiogeochem_carbonstate_inst, & +! soilbiogeochem_carbonflux_inst,soilbiogeochem_state_inst, & +! cnveg_nitrogenflux_inst, soilbiogeochem_nitrogenflux_inst, & +! soilbiogeochem_nitrogenstate_inst,c13_soilbiogeochem_carbonstate_inst,& +! c13_soilbiogeochem_carbonflux_inst,c14_soilbiogeochem_carbonstate_inst,& +! c14_soilbiogeochem_carbonflux_inst) +! call t_stopf('CNSoilMatrix') + end if + + end subroutine CNDriverLeaching + + !----------------------------------------------------------------------- + subroutine CNDriverSummarizeStates(bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonstate_inst, c13_cnveg_carbonstate_inst, c14_cnveg_carbonstate_inst, & + cnveg_nitrogenstate_inst, & + soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! Call to all CN and SoilBiogeochem summary routines, for state variables + ! + ! !USES: + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all active columns + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonstate_type) , intent(inout) :: c13_cnveg_carbonstate_inst + type(cnveg_carbonstate_type) , intent(inout) :: c14_cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: begc,endc + + character(len=*), parameter :: subname = 'CNDriverSummarizeStates' + !----------------------------------------------------------------------- + + begc = bounds%begc; endc= bounds%endc + + call t_startf('CNsum') + + ! ---------------------------------------------- + ! soilbiogeochem carbon/nitrogen state summary + ! ---------------------------------------------- + + call soilbiogeochem_carbonstate_inst%summary(bounds, num_allc, filter_allc) + if ( use_c13 ) then + call c13_soilbiogeochem_carbonstate_inst%summary(bounds, num_allc, filter_allc) + end if + if ( use_c14 ) then + call c14_soilbiogeochem_carbonstate_inst%summary(bounds, num_allc, filter_allc) + end if + call soilbiogeochem_nitrogenstate_inst%summary(bounds, num_allc, filter_allc) + + ! ---------------------------------------------- + ! cnveg carbon/nitrogen state summary + ! ---------------------------------------------- + + call cnveg_carbonstate_inst%Summary(bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + soilbiogeochem_cwdc_col=soilbiogeochem_carbonstate_inst%cwdc_col(begc:endc), & + soilbiogeochem_totlitc_col=soilbiogeochem_carbonstate_inst%totlitc_col(begc:endc), & + soilbiogeochem_totsomc_col=soilbiogeochem_carbonstate_inst%totsomc_col(begc:endc), & + soilbiogeochem_ctrunc_col=soilbiogeochem_carbonstate_inst%ctrunc_col(begc:endc)) + + if ( use_c13 ) then + call c13_cnveg_carbonstate_inst%Summary(bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + soilbiogeochem_cwdc_col=c13_soilbiogeochem_carbonstate_inst%cwdc_col(begc:endc), & + soilbiogeochem_totlitc_col=c13_soilbiogeochem_carbonstate_inst%totlitc_col(begc:endc), & + soilbiogeochem_totsomc_col=c13_soilbiogeochem_carbonstate_inst%totsomc_col(begc:endc), & + soilbiogeochem_ctrunc_col=c13_soilbiogeochem_carbonstate_inst%ctrunc_col(begc:endc)) + end if + + if ( use_c14 ) then + call c14_cnveg_carbonstate_inst%Summary(bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + soilbiogeochem_cwdc_col=c14_soilbiogeochem_carbonstate_inst%cwdc_col(begc:endc), & + soilbiogeochem_totlitc_col=c14_soilbiogeochem_carbonstate_inst%totlitc_col(begc:endc), & + soilbiogeochem_totsomc_col=c14_soilbiogeochem_carbonstate_inst%totsomc_col(begc:endc), & + soilbiogeochem_ctrunc_col=c14_soilbiogeochem_carbonstate_inst%ctrunc_col(begc:endc)) + end if + + call cnveg_nitrogenstate_inst%Summary(bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + soilbiogeochem_nitrogenstate_inst) + + call t_stopf('CNsum') + + end subroutine CNDriverSummarizeStates + + !----------------------------------------------------------------------- + subroutine CNDriverSummarizeFluxes(bounds, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonflux_inst, c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenflux_inst, & + c_products_inst, c13_products_inst, c14_products_inst, & + soilbiogeochem_carbonflux_inst, & + c13_soilbiogeochem_carbonflux_inst, & + c14_soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! Call to all CN and SoilBiogeochem summary routines, for state variables + ! + ! !USES: + use clm_varpar , only: ndecomp_cascade_transitions + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(cn_products_type) , intent(in) :: c_products_inst + type(cn_products_type) , intent(in) :: c13_products_inst + type(cn_products_type) , intent(in) :: c14_products_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: begc,endc + integer :: begg,endg + + character(len=*), parameter :: subname = 'CNDriverSummarizeFluxes' + !----------------------------------------------------------------------- + + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg = bounds%endg + + call t_startf('CNsum') + + ! ---------------------------------------------- + ! soilbiogeochem carbon/nitrogen flux summary + ! ---------------------------------------------- + + call soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) + if ( use_c13 ) then + call c13_soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) + end if + if ( use_c14 ) then + call c14_soilbiogeochem_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc) + end if + call soilbiogeochem_nitrogenflux_inst%Summary(bounds, num_soilc, filter_soilc) + + ! ---------------------------------------------- + ! cnveg carbon/nitrogen flux summary + ! ---------------------------------------------- + + call cnveg_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + isotope='bulk', & + soilbiogeochem_hr_col=soilbiogeochem_carbonflux_inst%hr_col(begc:endc), & + soilbiogeochem_lithr_col=soilbiogeochem_carbonflux_inst%lithr_col(begc:endc), & + soilbiogeochem_decomp_cascade_ctransfer_col=& + soilbiogeochem_carbonflux_inst%decomp_cascade_ctransfer_col(begc:endc,1:ndecomp_cascade_transitions), & + product_closs_grc=c_products_inst%product_loss_grc(begg:endg)) + + if ( use_c13 ) then + call c13_cnveg_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + isotope='c13', & + soilbiogeochem_hr_col=c13_soilbiogeochem_carbonflux_inst%hr_col(begc:endc), & + soilbiogeochem_lithr_col=c13_soilbiogeochem_carbonflux_inst%lithr_col(begc:endc), & + soilbiogeochem_decomp_cascade_ctransfer_col=& + c13_soilbiogeochem_carbonflux_inst%decomp_cascade_ctransfer_col(begc:endc,1:ndecomp_cascade_transitions), & + product_closs_grc=c13_products_inst%product_loss_grc(begg:endg)) + end if + + if ( use_c14 ) then + call c14_cnveg_carbonflux_inst%Summary(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + isotope='c14', & + soilbiogeochem_hr_col=c14_soilbiogeochem_carbonflux_inst%hr_col(begc:endc), & + soilbiogeochem_lithr_col=c14_soilbiogeochem_carbonflux_inst%lithr_col(begc:endc), & + soilbiogeochem_decomp_cascade_ctransfer_col=& + c14_soilbiogeochem_carbonflux_inst%decomp_cascade_ctransfer_col(begc:endc,1:ndecomp_cascade_transitions), & + product_closs_grc=c14_products_inst%product_loss_grc(begg:endg)) + end if + + call cnveg_nitrogenflux_inst%Summary(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp) + + call t_stopf('CNsum') + + end subroutine CNDriverSummarizeFluxes + +end module CNDriverMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFUNMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFUNMod.F90 new file mode 100755 index 000000000..9c4cce20b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFUNMod.F90 @@ -0,0 +1,1812 @@ +module CNFUNMod +!-------------------------------------------------------------------- + !--- +! ! DESCRIPTION +! ! The FUN model developed by Fisher et al. 2010 and +! ! end Brzostek et al. 2014. Coded by Mingjie Shi 2015. +! ! Coding logic and structure altered by Rosie Fisher. October 2015. +! ! Critically, this removes the 'FUN-resistors' idea of Brzostek et + ! al. 2014 +! ! and replaces it with uptake that is proportional to the N/C + ! exchange rate. +! ! and adjusts the logic so that FUN does not depends upon the + ! CLM4.0 'FPG' downregulation idea +! ! and instead it takes C spent on N uptake away from growth. +! ! The critical output so fthis code are sminn_to_plant_fun and + ! npp_Nuptake, which are the N +! ! available to the plant for grwoth, and the C spent on obtaining + ! it. + +! !USES: + use, intrinsic :: iso_fortran_env, only: INT64 + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog + use PatchType , only : patch + use ColumnType , only : col + use pftconMod , only : pftcon, npcropmin + use decompMod , only : bounds_type + use clm_varctl , only : use_nitrif_denitrif,use_flexiblecn,use_matrixcn + use abortutils , only : endrun + use CNVegstateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegnitrogenstateType , only : cnveg_nitrogenstate_type + use CNVegnitrogenfluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterFluxBulkType , only : waterfluxbulk_type + use TemperatureType , only : temperature_type + use SoilStateType , only : soilstate_type + use CanopyStateType , only : canopystate_type + use perf_mod , only : t_startf, t_stopf + + implicit none + private +! +! !PUBLIC MEMBER FUNCTIONS: + public:: readParams ! Read in parameters needed for FUN + public:: CNFUNInit ! FUN calculation initialization + public:: CNFUN ! Run FUN + + type, private :: params_type + real(r8) :: ndays_on ! number of days to complete leaf onset + real(r8) :: ndays_off ! number of days to complete leaf offset + end type params_type + + ! + type(params_type), private :: params_inst ! params_inst is + ! populated in readParamsMod + ! + ! + ! !PRIVATE DATA MEMBERS: + real(r8) :: dt ! decomp timestep (seconds) + real(r8) :: ndays_on ! number of days to complete onset + real(r8) :: ndays_off ! number of days to complete offset + + integer, private, parameter :: COST_METHOD = 2 !new way of doing the N uptake + ! resistances. see teamwork thread on over-cheap uptake in N + ! resistors. + integer, private, parameter :: nstp = 2 ! Number of + ! calculation part + integer, private, parameter :: ncost6 = 6 ! Number of + ! N transport pathways + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +! +!-------------------------------------------------------------------- + !--- + contains +!-------------------------------------------------------------------- + !--- + subroutine readParams ( ncid ) + ! + ! !USES: + use ncdio_pio , only : file_desc_t,ncd_io + + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNFUNParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in parameter + character(len=100) :: tString ! temp. var for reading +!-------------------------------------------------------------------- + !--- + + ! read in parameters + + tString='ndays_on' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun( msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%ndays_on=tempr + + tString='ndays_off' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun( msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%ndays_off=tempr + + + end subroutine readParams + +!-------------------------------------------------------------------- + !--- + subroutine CNFUNInit (bounds,cnveg_state_inst,cnveg_carbonstate_inst,cnveg_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! + ! !USES: + use clm_varcon , only: secspday, fun_period + use clm_time_manager, only: get_step_size_real,get_nstep,get_curr_date,get_days_per_year + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type), intent(inout) :: cnveg_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: dayspyr ! days per year (days) + real(r8) :: timestep_fun ! Timestep length for + ! FUN (s) + real(r8) :: numofyear ! number of days per + ! year + integer(INT64) :: nstep ! time step number + integer :: nstep_fun ! Number of + ! atmospheric timesteps between calls to FUN + character(len=32) :: subname = 'CNFUNInit' +!-------------------------------------------------------------------- + !--- + +! Set local pointers + associate(ivt => patch%itype , & ! Input: [integer (:) ] p + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + leafcn_offset => cnveg_state_inst%leafcn_offset_patch , & ! Output: + ! [real(r8) (:) ] Leaf C:N used by FUN + leafc_storage_xfer_acc => cnveg_carbonstate_inst%leafc_storage_xfer_acc_patch , & ! Output: [real(r8) (:) + ! ] Accmulated leaf C transfer (gC/m2) + storage_cdemand => cnveg_carbonstate_inst%storage_cdemand_patch , & ! Output: [real(r8) (:) + ! ] C use from the C storage pool + leafn_storage_xfer_acc => cnveg_nitrogenstate_inst%leafn_storage_xfer_acc_patch, & ! Output: [real(r8) (:) + ! ] Accmulated leaf N transfer (gC/m2) + storage_ndemand => cnveg_nitrogenstate_inst%storage_ndemand_patch & ! Output: [real(r8) (:) + ! ] N demand during the offset period + ) + !-------------------------------------------------------------------- + !--- + ! Calculate some timestep-related values. + !-------------------------------------------------------------------- + !--- + ! set time steps + dt = get_step_size_real() + dayspyr = get_days_per_year() + nstep = get_nstep() + timestep_fun = real(secspday * fun_period) + nstep_fun = int(secspday * dayspyr / dt) + + ndays_on = params_inst%ndays_on + ndays_off = params_inst%ndays_off + + !-------------------------------------------------------------------- + !--- + ! Decide if FUN will be called on this timestep. + !-------------------------------------------------------------------- + !--- + numofyear = nstep/nstep_fun + if (mod(nstep,nstep_fun) == 0) then + leafcn_offset(bounds%begp:bounds%endp) = leafcn(ivt(bounds%begp:bounds%endp)) + storage_cdemand(bounds%begp:bounds%endp) = 0._r8 + storage_ndemand(bounds%begp:bounds%endp) = 0._r8 + leafn_storage_xfer_acc(bounds%begp:bounds%endp) = 0._r8 + leafc_storage_xfer_acc(bounds%begp:bounds%endp) = 0._r8 + end if +!-------------------------------------------------------------------- + !--- + end associate + end subroutine CNFUNInit +!-------------------------------------------------------------------- + !--- + + !-------------------------------------------------------------------- + !--- + ! Start the CNFUN subroutine + !-------------------------------------------------------------------- + !--- + subroutine CNFUN(bounds,num_soilc, filter_soilc,num_soilp& + &,filter_soilp,waterstatebulk_inst, & + & waterfluxbulk_inst,temperature_inst,soilstate_inst& + &,cnveg_state_inst,cnveg_carbonstate_inst,& + & cnveg_carbonflux_inst,cnveg_nitrogenstate_inst& + &,cnveg_nitrogenflux_inst ,& + & soilbiogeochem_nitrogenflux_inst& + &,soilbiogeochem_carbonflux_inst,canopystate_inst,& + & soilbiogeochem_nitrogenstate_inst) + +! !USES: + use clm_time_manager, only : get_step_size_real, get_curr_date, get_days_per_year + use clm_varpar , only : nlevdecomp + use clm_varcon , only : secspday, smallValue, fun_period, tfrz, dzsoi_decomp, spval + use clm_varctl , only : use_nitrif_denitrif + use PatchType , only : patch + use subgridAveMod , only : p2c + use pftconMod , only : npcropmin + !use CNVegMatrixMod , only : matrix_update_phn +! +! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + type(temperature_type) , intent(in) :: temperature_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + ! local pointers to implicit in arrays + ! + !-------------------------------------------------------------------- + ! ------------ + ! Integer parameters + !-------------------------------------------------------------------- + !----------- + integer, parameter :: icostFix = 1 ! Process + ! number for fixing. + integer, parameter :: icostRetrans = 2 ! Process + ! number for retranslocation. + integer, parameter :: icostActiveNO3 = 3 ! Process + ! number for mycorrhizal uptake of NO3. + integer, parameter :: icostActiveNH4 = 4 ! Process + ! number for mycorrhizal uptake of NH4 + integer, parameter :: icostnonmyc_no3 = 5 ! Process + ! number for nonmyc uptake of NO3. + integer, parameter :: icostnonmyc_nh4 = 6 ! Process + ! number for nonmyc uptake of NH4. + real(r8), parameter :: big_cost = 1000000000._r8! An arbitrarily large cost + + ! array index when plant is fixing + integer, parameter :: plants_are_fixing = 1 + integer, parameter :: plants_not_fixing = 2 + + ! array index for ECM step versus AM step + integer, parameter :: ecm_step = 1 + integer, parameter :: am_step = 2 + ! arbitrary large cost (gC/gN). + !-------------------------------------------------------------------- + !----------------------------------------------- + ! Local Real variables. + !-------------------------------------------------------------------- + !----------------------------------------------- + real(r8) :: excess ! excess N taken up by transpiration (gN/m2) + real(r8) :: steppday ! model time steps in each day (-) + real(r8) :: rootc_dens_step ! root C for each PFT in each soil layer(gC/m2) + real(r8) :: retrans_limit1 ! a temporary variable for leafn (gN/m2) + real(r8) :: qflx_tran_veg_layer ! transpiration in each soil layer (mm H2O/S) + real(r8) :: dn ! Increment of N (gN/m2) + real(r8) :: dn_retrans ! Increment of N (gN/m2) + real(r8) :: dnpp ! Increment of NPP (gC/m2) + real(r8) :: dnpp_retrans ! Increment of NPP (gC/m2) + real(r8) :: rootc_dens(bounds%begp:bounds%endp,1:nlevdecomp) ! the root carbon density (gC/m2) + real(r8) :: rootC(bounds%begp:bounds%endp) ! root biomass (gC/m2) + real(r8) :: permyc(bounds%begp:bounds%endp,1:nstp) ! the arrary for the ECM and AM ratio (-) + real(r8) :: kc_active(bounds%begp:bounds%endp,1:nstp) ! the kc_active parameter (gC/m2) + real(r8) :: kn_active(bounds%begp:bounds%endp,1:nstp) ! the kn_active parameter (gC/m2) + real(r8) :: availc_pool(bounds%begp:bounds%endp) ! The avaible C pool for allocation (gC/m2) + real(r8) :: plantN(bounds%begp:bounds%endp) ! Plant N (gN/m2) + real(r8) :: plant_ndemand_pool(bounds%begp:bounds%endp) ! The N demand pool (gN/m2) + real(r8) :: plant_ndemand_pool_step(bounds%begp:bounds%endp,1:nstp) ! the N demand pool (gN/m2) + real(r8) :: leafn_step(bounds%begp:bounds%endp,1:nstp) ! N loss based for deciduous trees (gN/m2) + real(r8) :: leafn_retrans_step(bounds%begp:bounds%endp,1:nstp) ! N loss based for deciduous trees (gN/m2) + real(r8) :: litterfall_n(bounds%begp:bounds%endp) ! N loss based on the leafc to litter (gN/m2) + real(r8) :: litterfall_n_step(bounds%begp:bounds%endp,1:nstp) ! N loss based on the leafc to litter (gN/m2) + real(r8) :: litterfall_c_step(bounds%begp:bounds%endp,1:nstp) ! N loss based on the leafc to litter (gN/m2) + real(r8) :: tc_soisno(bounds%begc:bounds%endc,1:nlevdecomp) ! Soil temperature (degrees Celsius) + real(r8) :: npp_remaining(bounds%begp:bounds%endp,1:nstp) ! A temporary variable for npp_remaining(gC/m2) + real(r8) :: n_passive_step(bounds%begp:bounds%endp,1:nstp) ! N taken up by transpiration at substep(gN/m2) + real(r8) :: n_passive_acc(bounds%begp:bounds%endp) ! N acquired by passive uptake (gN/m2) + real(r8) :: cost_retran(bounds%begp:bounds%endp,1:nlevdecomp) ! cost of retran (gC/gN) + real(r8) :: cost_fix(bounds%begp:bounds%endp,1:nlevdecomp) ! cost of fixation (gC/gN) + real(r8) :: cost_resis(bounds%begp:bounds%endp,1:nlevdecomp) ! cost of resis (gC/gN) + real(r8) :: cost_res_resis(bounds%begp:bounds%endp,1:nlevdecomp) ! The cost of resis (gN/gC) + real(r8) :: n_fix_acc(bounds%begp:bounds%endp,1:nstp) ! N acquired by fixation (gN/m2) + real(r8) :: n_fix_acc_total(bounds%begp:bounds%endp) ! N acquired by fixation (gN/m2) + real(r8) :: npp_fix_acc(bounds%begp:bounds%endp,1:nstp) ! Amount of NPP used by fixation (gC/m2) + real(r8) :: npp_fix_acc_total(bounds%begp:bounds%endp) ! Amount of NPP used by fixation (gC/m2) + real(r8) :: n_retrans_acc(bounds%begp:bounds%endp,1:nstp) ! N acquired by retranslocation (gN/m2) + real(r8) :: n_retrans_acc_total(bounds%begp:bounds%endp) ! N acquired by retranslocation (gN/m2) + real(r8) :: free_nretrans_acc(bounds%begp:bounds%endp,1:nstp) ! N acquired by retranslocation (gN/m2) + real(r8) :: npp_retrans_acc(bounds%begp:bounds%endp,1:nstp) ! NPP used for the extraction (gC/m2) + real(r8) :: npp_retrans_acc_total(bounds%begp:bounds%endp) ! NPP used for the extraction (gC/m2) + real(r8) :: nt_uptake(bounds%begp:bounds%endp,1:nstp) ! N uptake from retrans, active, and fix(gN/m2) + real(r8) :: npp_uptake(bounds%begp:bounds%endp,1:nstp) ! NPP used by the uptakes (gC/m2) + + !----------NITRIF_DENITRIF-------------! + + real(r8) :: sminn_no3_diff ! A temporary limit for N uptake (gN/m2) + real(r8) :: sminn_nh4_diff ! A temporary limit for N uptake (gN/m2) + real(r8) :: active_no3_limit1 ! A temporary limit for N uptake (gN/m2) + real(r8) :: active_nh4_limit1 ! A temporary limit for N uptake (gN/m2) + real(r8) :: cost_active_no3(bounds%begp:bounds%endp,1:nlevdecomp) ! cost of mycorrhizal (gC/gN) + real(r8) :: cost_active_nh4(bounds%begp:bounds%endp,1:nlevdecomp) ! cost of mycorrhizal (gC/gN) + real(r8) :: cost_nonmyc_no3(bounds%begp:bounds%endp,1:nlevdecomp) ! cost of nonmyc (gC/gN) + real(r8) :: cost_nonmyc_nh4(bounds%begp:bounds%endp,1:nlevdecomp) ! cost of nonmyc (gC/gN) + + real(r8) :: sminn_no3_conc(bounds%begc:bounds%endc,1:nlevdecomp) ! Concentration of no3 in soil water (gN/gH2O) + real(r8) :: sminn_no3_conc_step(bounds%begp:bounds%endp,1:nlevdecomp,1:nstp) ! A temporary variable for soil mineral N (gN/gH2O) + real(r8) :: sminn_no3_layer(bounds%begc:bounds%endc,1:nlevdecomp) ! Available no3 in each soil layer (gN/m2) + real(r8) :: sminn_no3_layer_step(bounds%begp:bounds%endp,1:nlevdecomp,1:nstp)! A temporary variable for soil no3 (gN/m2) + real(r8) :: sminn_no3_uptake(bounds%begp:bounds%endp,1:nlevdecomp,1:nstp) ! A temporary variable for soil mineral N (gN/m2/s) + real(r8) :: sminn_nh4_conc(bounds%begc:bounds%endc,1:nlevdecomp) ! Concentration of nh4 in soil water (gN/gH2O) + real(r8) :: sminn_nh4_conc_step(bounds%begp:bounds%endp,1:nlevdecomp,1:nstp) ! A temporary variable for soil mineral N (gN/gH2O) + real(r8) :: sminn_nh4_layer(bounds%begc:bounds%endc,1:nlevdecomp) ! Available nh4 in each soil layer (gN/m2) + real(r8) :: sminn_nh4_layer_step(bounds%begp:bounds%endp,1:nlevdecomp,1:nstp)! A temporary variable for soil mineral N (gN/m2) + real(r8) :: sminn_nh4_uptake(bounds%begp:bounds%endp,1:nlevdecomp,1:nstp) ! A temporary variable for soil mineral N (gN/m2/s) + + real(r8) :: active_no3_uptake1(bounds%begp:bounds%endp,1:nlevdecomp) ! no3 mycorrhizal uptake (gN/m2) + real(r8) :: active_nh4_uptake1(bounds%begp:bounds%endp,1:nlevdecomp) ! nh4 mycorrhizal uptake (gN/m2) + real(r8) :: nonmyc_no3_uptake1(bounds%begp:bounds%endp,1:nlevdecomp) ! no3 non-mycorrhizal uptake (gN/m2) + real(r8) :: nonmyc_nh4_uptake1(bounds%begp:bounds%endp,1:nlevdecomp) ! nh4 non-mycorrhizal uptake (gN/m2) + real(r8) :: active_no3_uptake2(bounds%begp:bounds%endp,1:nlevdecomp) ! no3 mycorrhizal uptake (gN/m2) + real(r8) :: active_nh4_uptake2(bounds%begp:bounds%endp,1:nlevdecomp) ! nh4 mycorrhizal uptake (gN/m2) + real(r8) :: nonmyc_no3_uptake2(bounds%begp:bounds%endp,1:nlevdecomp) ! no3 non-mycorrhizal uptake (gN/m2) + real(r8) :: nonmyc_nh4_uptake2(bounds%begp:bounds%endp,1:nlevdecomp) ! nh4 non-mycorrhizal uptake (gN/m2) + real(r8) :: n_am_no3_acc(bounds%begp:bounds%endp) ! AM no3 uptake (gN/m2) + real(r8) :: n_am_nh4_acc(bounds%begp:bounds%endp) ! AM nh4 uptake (gN/m2) + real(r8) :: n_ecm_no3_acc(bounds%begp:bounds%endp) ! ECM no3 uptake (gN/m2) + real(r8) :: n_ecm_nh4_acc(bounds%begp:bounds%endp) ! ECM nh4 uptake (gN/m2) + real(r8) :: n_active_no3_acc(bounds%begp:bounds%endp,1:nstp) ! Mycorrhizal no3 uptake (gN/m2) + real(r8) :: n_active_nh4_acc(bounds%begp:bounds%endp,1:nstp) ! Mycorrhizal nh4 uptake (gN/m2) + real(r8) :: n_nonmyc_no3_acc(bounds%begp:bounds%endp,1:nstp) ! Non-myc no3 uptake (gN/m2) + real(r8) :: n_nonmyc_nh4_acc(bounds%begp:bounds%endp,1:nstp) ! Non-myc nh4 uptake (gN/m2) + real(r8) :: n_active_no3_acc_total(bounds%begp:bounds%endp) ! Mycorrhizal no3 uptake (gN/m2) + real(r8) :: n_active_nh4_acc_total(bounds%begp:bounds%endp) ! Mycorrhizal no3 uptake (gN/m2) + + real(r8) :: n_nonmyc_no3_acc_total(bounds%begp:bounds%endp) ! Non-myc no3 uptake (gN/m2) + real(r8) :: n_nonmyc_nh4_acc_total(bounds%begp:bounds%endp) ! Non-myc no3 uptake (gN/m2) + real(r8) :: npp_active_no3_acc(bounds%begp:bounds%endp,1:nstp) ! Mycorrhizal no3 uptake used C (gC/m2) + real(r8) :: npp_active_nh4_acc(bounds%begp:bounds%endp,1:nstp) ! Mycorrhizal nh4 uptake used C (gC/m2) + real(r8) :: npp_nonmyc_no3_acc(bounds%begp:bounds%endp,1:nstp) ! Non-myc no3 uptake used C (gC/m2) + real(r8) :: npp_nonmyc_nh4_acc(bounds%begp:bounds%endp,1:nstp) ! Non-myc nh4 uptake used C (gC/m2) + real(r8) :: npp_active_no3_acc_total(bounds%begp:bounds%endp) ! Mycorrhizal no3 uptake used C (gC/m2) + real(r8) :: npp_active_nh4_acc_total(bounds%begp:bounds%endp) ! Mycorrhizal nh4 uptake used C (gC/m2) + real(r8) :: npp_nonmyc_no3_acc_total(bounds%begp:bounds%endp) ! Non-myc no3 uptake used C (gC/m2) + real(r8) :: npp_nonmyc_nh4_acc_total(bounds%begp:bounds%endp) ! Non-myc nh4 uptake used C (gC/m2) + real(r8) :: n_am_no3_retrans(bounds%begp:bounds%endp) ! AM no3 uptake for offset (gN/m2) + real(r8) :: n_am_nh4_retrans(bounds%begp:bounds%endp) ! AM nh4 uptake for offset (gN/m2) + real(r8) :: n_ecm_no3_retrans(bounds%begp:bounds%endp) ! ECM no3 uptake for offset (gN/m2) + real(r8) :: n_ecm_nh4_retrans(bounds%begp:bounds%endp) ! ECM nh4 uptake for offset (gN/m2) + real(r8) :: n_active_no3_retrans(bounds%begp:bounds%endp,1:nstp) ! Mycorrhizal no3 for offset (gN/m2) + real(r8) :: n_active_nh4_retrans(bounds%begp:bounds%endp,1:nstp) ! Mycorrhizal nh4 for offset (gN/m2) + real(r8) :: n_nonmyc_no3_retrans(bounds%begp:bounds%endp,1:nstp) ! Non-myc no3 for offset (gN/m2) + real(r8) :: n_nonmyc_nh4_retrans(bounds%begp:bounds%endp,1:nstp) ! Non-myc nh4 for offset (gN/m2) + real(r8) :: n_active_no3_retrans_total(bounds%begp:bounds%endp) ! Mycorrhizal no3 for offset (gN/m2) + real(r8) :: n_active_nh4_retrans_total(bounds%begp:bounds%endp) ! Mycorrhizal nh4 for offset (gN/m2) + real(r8) :: n_nonmyc_no3_retrans_total(bounds%begp:bounds%endp) ! Non-myc no3 for offset (gN/m2) + real(r8) :: n_nonmyc_nh4_retrans_total(bounds%begp:bounds%endp) ! Non-myc nh4 for offset (gN/m2) + real(r8) :: n_passive_no3_vr(bounds%begp:bounds%endp,1:nlevdecomp) ! Layer passive no3 uptake (gN/m2) + real(r8) :: n_passive_nh4_vr(bounds%begp:bounds%endp,1:nlevdecomp) ! Layer passive nh4 uptake (gN/m2) + real(r8) :: n_fix_no3_vr(bounds%begp:bounds%endp,1:nlevdecomp) ! Layer fixation no3 uptake (gN/m2) + real(r8) :: n_fix_nh4_vr(bounds%begp:bounds%endp,1:nlevdecomp) ! Layer fixation nh4 uptake (gN/m2) + real(r8) :: n_active_no3_vr(bounds%begp:bounds%endp,1:nlevdecomp) ! Layer mycorrhizal no3 uptake (gN/m2) + real(r8) :: n_nonmyc_no3_vr(bounds%begp:bounds%endp,1:nlevdecomp) ! Layer non-myc no3 uptake (gN/m2) + real(r8) :: n_active_nh4_vr(bounds%begp:bounds%endp,1:nlevdecomp) ! Layer mycorrhizal nh4 uptake (gN/m2) + real(r8) :: n_nonmyc_nh4_vr(bounds%begp:bounds%endp,1:nlevdecomp) ! Layer non-myc nh4 uptake (gN/m2) + real(r8) :: npp_active_no3_retrans(bounds%begp:bounds%endp,1:nstp) ! Mycorrhizal no3 uptake used C for offset (gN/m2) + real(r8) :: npp_active_nh4_retrans(bounds%begp:bounds%endp,1:nstp) ! Mycorrhizal nh4 uptake used C for offset (gN/m2) + real(r8) :: npp_nonmyc_no3_retrans(bounds%begp:bounds%endp,1:nstp) ! Non-myc no3 uptake used C for offset (gN/m2) + real(r8) :: npp_nonmyc_nh4_retrans(bounds%begp:bounds%endp,1:nstp) ! Non-myc nh4 uptake used C for offset (gN/m2) + real(r8) :: npp_active_no3_retrans_total(bounds%begp:bounds%endp) ! Mycorrhizal no3 uptake used C for offset (gN/m2) + real(r8) :: npp_active_nh4_retrans_total(bounds%begp:bounds%endp) ! Mycorrhizal nh4 uptake used C for offset (gN/m2) + real(r8) :: npp_nonmyc_no3_retrans_total(bounds%begp:bounds%endp) ! Non-myc no3 uptake used C for offset (gN/m2) + real(r8) :: npp_nonmyc_nh4_retrans_total(bounds%begp:bounds%endp) ! Non-myc nh4 uptake used C for offset (gN/m2) + + + real(r8) :: costNit(1:nlevdecomp,ncost6) ! Cost of N via each process (gC/gN) + + ! Uptake fluxes for COST_METHOD=2 + ! actual npp to each layer for each uptake process + real(r8) :: npp_to_fixation(1:nlevdecomp) + real(r8) :: npp_to_retrans(1:nlevdecomp) + real(r8) :: npp_to_active_nh4(1:nlevdecomp) + real(r8) :: npp_to_nonmyc_nh4(1:nlevdecomp) + real(r8) :: npp_to_active_no3(1:nlevdecomp) + real(r8) :: npp_to_nonmyc_no3 (1:nlevdecomp) + + ! fraction of carbon to each uptake process + real(r8) :: npp_frac_to_fixation(1:nlevdecomp) + real(r8) :: npp_frac_to_retrans(1:nlevdecomp) + real(r8) :: npp_frac_to_active_nh4(1:nlevdecomp) + real(r8) :: npp_frac_to_nonmyc_nh4(1:nlevdecomp) + real(r8) :: npp_frac_to_active_no3(1:nlevdecomp) + real(r8) :: npp_frac_to_nonmyc_no3 (1:nlevdecomp) + + ! hypothetical fluxes on N in each layer + real(r8) :: n_exch_fixation(1:nlevdecomp) ! N aquired from one unit of C for fixation (unitless) + real(r8) :: n_exch_retrans(1:nlevdecomp) ! N aquired from one unit of C for retrans (unitless) + real(r8) :: n_exch_active_nh4(1:nlevdecomp) ! N aquired from one unit of C for act nh4(unitless) + real(r8) :: n_exch_nonmyc_nh4(1:nlevdecomp) ! N aquired from one unit of C for nonmy nh4 (unitless) + real(r8) :: n_exch_active_no3(1:nlevdecomp) ! N aquired from one unit of C for act no3 (unitless) + real(r8) :: n_exch_nonmyc_no3(1:nlevdecomp) ! N aquired from one unit of C for nonmyc no3 (unitless) + + !actual fluxes of N in each layer + real(r8) :: n_from_fixation(1:nlevdecomp) ! N aquired in each layer for fixation (gN m-2 s-1) + real(r8) :: n_from_retrans(1:nlevdecomp) ! N aquired in each layer of C for retrans (gN m-2 s-1) + real(r8) :: n_from_active_nh4(1:nlevdecomp) ! N aquired in each layer of C for act nh4 (gN m-2 s-1) + real(r8) :: n_from_nonmyc_nh4(1:nlevdecomp) ! N aquired in each layer of C for nonmy nh4 (gN m-2 s-1) + real(r8) :: n_from_active_no3(1:nlevdecomp) ! N aquired in each layer of C for act no3 (gN m-2 s-1) + real(r8) :: n_from_nonmyc_no3(1:nlevdecomp) ! N aquired in each layer of C for nonmyc no3 (gN m-2 s-1) + + real(r8) :: free_Nretrans(bounds%begp:bounds%endp) ! the total amount of NO3 and NH4 (gN/m3/s) + + ! Uptake fluxes for COST_METHOD=2 + !actual fluxes of N in each layer + real(r8) :: frac_ideal_C_use ! How much less C do we use for 'buying' N than that + ! needed to get to the ideal ratio? fraction. + + real(r8) :: N_acquired + real(r8) :: C_spent + real(r8) :: leaf_narea ! leaf n per unit leaf + ! area in gN/m2 (averaged across canopy, which is OK for the cost + ! calculation) + + + real(r8) :: sum_n_acquired ! Sum N aquired from one unit of C (unitless) + real(r8) :: burned_off_carbon ! carbon wasted by poor allocation algorithm. If + ! this is too big, we need a better iteration. + real(r8) :: temp_n_flux + real(r8) :: delta_cn ! difference between 'ideal' leaf CN ration and + ! actual leaf C:N ratio. C/N + real(r8) :: excess_carbon ! how much carbon goes into the leaf C + ! pool on account of the flexibleCN modifications. + real(r8) :: excess_carbon_acc ! excess accumulated over layers. + ! WITHOUT GROWTH RESP + real(r8) :: fixerfrac ! what fraction of plants can fix? + real(r8) :: npp_to_spend ! how much carbon do we need to get + ! rid of? + real(r8) :: soil_n_extraction ! calculates total N pullled from + ! soil + real(r8) :: total_N_conductance !inverse of C to of N for whole soil + ! -leaf pathway + real(r8) :: total_N_resistance ! C to of N for whole soil -leaf + ! pathway + real(r8) :: free_RT_frac=0.0_r8 !fraction of N retranslocation which is automatic/free. + ! SHould be made into a PFT parameter. + + real(r8) :: paid_for_n_retrans + real(r8) :: free_n_retrans + real(r8) :: total_c_spent_retrans + real(r8) :: total_c_accounted_retrans + + + !------end of not_use_nitrif_denitrif------! + !-------------------------------------------------------------------- + !------------ + ! Local Integer variables + !-------------------------------------------------------------------- + !------------ + integer :: fn ! number of values + ! in pft filter + integer :: fp ! lake filter pft + ! index + integer :: fc ! lake filter column + ! index + integer :: p, c ! pft index + integer :: g, l ! indices + integer :: j, i, k ! soil/snow level + ! index + integer :: istp ! Loop counters/work + integer :: icost ! a local index + integer :: fixer ! 0 = non-fixer, 1 + ! =fixer + logical :: unmetDemand ! True while there + ! is still demand for N + logical :: local_use_flexibleCN ! local version of use_flexCN + integer :: FIX ! for loop. 1 for + ! fixers, 2 for non fixers. This will become redundant with the + ! 'fixer' parameter if it works. + + !-------------------------------------------------------------------- + !--------------------------------- + associate(ivt => patch%itype , & ! Input: [integer (:) ] p + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + lflitcn => pftcon%lflitcn , & ! Input: leaf litter C:N (gC/gN) + season_decid => pftcon%season_decid , & ! Input: binary flag for seasonal + ! -deciduous leaf habit (0 or 1) + stress_decid => pftcon%stress_decid , & ! Input: binary flag for stress + ! -deciduous leaf habit (0 or 1) + a_fix => pftcon%a_fix , & ! Input: A BNF parameter + b_fix => pftcon%b_fix , & ! Input: A BNF parameter + c_fix => pftcon%c_fix , & ! Input: A BNF parameter + s_fix => pftcon%s_fix , & ! Input: A BNF parameter + akc_active => pftcon%akc_active , & ! Input: A mycorrhizal uptake + ! parameter + akn_active => pftcon%akn_active , & ! Input: A mycorrhizal uptake + ! parameter + ekc_active => pftcon%ekc_active , & ! Input: A mycorrhizal uptake + ! parameter + ekn_active => pftcon%ekn_active , & ! Input: A mycorrhizal upatke + ! parameter + kc_nonmyc => pftcon%kc_nonmyc , & ! Input: A non-mycorrhizal uptake + ! parameter + kn_nonmyc => pftcon%kn_nonmyc , & ! Input: A non-mycorrhizal uptake + ! parameter + perecm => pftcon%perecm , & ! Input: The fraction of ECM + ! -associated PFT + grperc => pftcon%grperc , & ! Input: growth percentage + fun_cn_flex_a => pftcon%fun_cn_flex_a , & ! Parameter a of FUN-flexcn link code (def 5) + fun_cn_flex_b => pftcon%fun_cn_flex_b , & ! Parameter b of FUN-flexcn link code (def 200) + fun_cn_flex_c => pftcon%fun_cn_flex_c , & ! Parameter b of FUN-flexcn link code (def 80) + FUN_fracfixers => pftcon%FUN_fracfixers , & ! Fraction of C that can be used for fixation. + leafcn_offset => cnveg_state_inst%leafcn_offset_patch , & ! Output: + ! [real(r8) (:)] Leaf C:N used by FUN + plantCN => cnveg_state_inst%plantCN_patch , & ! Output: [real(r8) (:)] Plant + ! C:N used by FUN + onset_flag => cnveg_state_inst%onset_flag_patch , & ! Output: [real(r8) (:)] onset + ! flag + offset_flag => cnveg_state_inst%offset_flag_patch , & ! Output: [real(r8) (:)] offset + ! flag + availc => cnveg_carbonflux_inst%availc_patch , & ! Iutput: [real(r8) (:)] C flux + ! available for allocation (gC/m2/s) + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:)] (gC/m2) + ! leaf C + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) + ! (:)] (gC/m2) leaf C storage + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) + ! (:)] (gC/m2) fine root C + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) + ! (:)] (gC/m2) fine root C storage + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) + ! (:)] (gC/m2) live stem C + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) + ! (:)] (gC/m2) live coarse root C + leafc_storage_xfer_acc => cnveg_carbonstate_inst%leafc_storage_xfer_acc_patch , & ! uutput: [real(r8) + ! (:)] Accmulated leaf C transfer (gC/m2) + storage_cdemand => cnveg_carbonstate_inst%storage_cdemand_patch , & ! Output: [real(r8) + ! (:)] C use f rom the C storage pool + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one + ! -sided leaf area index + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:)] + ! (gN/m2) leaf N + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:)] + ! (gN/m2) fine root N + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:)] + ! (gN/m2) live stem N + livecrootn => cnveg_nitrogenstate_inst%livecrootn_patch , & ! Input: [real(r8) (:)] + ! (gN/m2) retranslocation N + retransn => cnveg_nitrogenstate_inst%retransn_patch , & ! Input: [real(r8) (:)] + ! (gN/m2) live coarse root N + leafn_storage_xfer_acc => cnveg_nitrogenstate_inst%leafn_storage_xfer_acc_patch, & ! Output: [real(r8) (:)] + ! Accmulated leaf N transfer (gC/m2) + storage_ndemand => cnveg_nitrogenstate_inst%storage_ndemand_patch , & ! Output: [real(r8) (:)] + ! N demand during the offset period + leafc_to_litter => cnveg_carbonflux_inst%leafc_to_litter_patch , & ! Output: [real(r8) + ! (:) ] leaf C litterfall (gC/m2/s) + leafc_to_litter_fun => cnveg_carbonflux_inst%leafc_to_litter_fun_patch , & ! Output: [real(r8) + ! (:) ] leaf C litterfall used by FUN (gC/m2/s) + prev_leafc_to_litter => cnveg_carbonflux_inst%prev_leafc_to_litter_patch , & ! Output: [real(r8) (:) + ! ] previous timestep leaf C litterfall flux (gC/m2/s) + leafc_storage_to_xfer => cnveg_carbonflux_inst%leafc_storage_to_xfer_patch , & ! Output: [real(r8) + ! (:) ] + npp_Nactive => cnveg_carbonflux_inst%npp_Nactive_patch , & ! Output: [real(r8) + ! (:) ] Mycorrhizal N uptake used C (gC/m2/s) + npp_Nnonmyc => cnveg_carbonflux_inst%npp_Nnonmyc_patch , & ! Output: [real(r8) + ! (:) ] Non-mycorrhizal N uptake use C (gC/m2/s) + npp_Nam => cnveg_carbonflux_inst%npp_Nam_patch , & ! Output: [real(r8) + ! (:) ] AM uptake use C (gC/m2/s) + npp_Necm => cnveg_carbonflux_inst%npp_Necm_patch , & ! Output: [real(r8) + ! (:) ] ECM uptake use C (gC/m2/s) + npp_Nactive_no3 => cnveg_carbonflux_inst%npp_Nactive_no3_patch , & ! Output: [real(r8) + ! (:) ] Mycorrhizal N uptake used C (gC/m2/s) + npp_Nnonmyc_no3 => cnveg_carbonflux_inst%npp_Nnonmyc_no3_patch , & ! Output: [real(r8) + ! (:) ] Non-myco uptake use C (gC/m2/s) rrhizal N uptake + ! (gN/m2/s) + npp_Nam_no3 => cnveg_carbonflux_inst%npp_Nam_no3_patch , & ! Output: [real(r8) + ! (:) ] AM uptake use C (gC/m2/s) + npp_Necm_no3 => cnveg_carbonflux_inst%npp_Necm_no3_patch , & ! Output: [real(r8) + ! (:) ] ECM uptake use C (gC/m2/s) + npp_Nactive_nh4 => cnveg_carbonflux_inst%npp_Nactive_nh4_patch , & ! Output: [real(r8) + ! (:) ] Mycorrhizal N uptake used C (gC/m2/s) + npp_Nnonmyc_nh4 => cnveg_carbonflux_inst%npp_Nnonmyc_nh4_patch , & ! Output: [real(r8) + ! (:) ] Non-mycorrhizal N uptake used C (gC/m2/s) + npp_Nam_nh4 => cnveg_carbonflux_inst%npp_Nam_nh4_patch , & ! Output: [real(r8) + ! (:) ] AM uptake used C(gC/m2/s) + npp_Necm_nh4 => cnveg_carbonflux_inst%npp_Necm_nh4_patch , & ! Output: [real(r8) + ! (:) ] ECM uptake used C (gC/m2/s) + npp_Nfix => cnveg_carbonflux_inst%npp_Nfix_patch , & ! Output: [real(r8) + ! (:) ] Symbiotic BNF used C (gC/m2/s) + npp_Nretrans => cnveg_carbonflux_inst%npp_Nretrans_patch , & ! Output: [real(r8) + ! (:) ] Retranslocation N uptake used C (gC/m2/s) + npp_Nuptake => cnveg_carbonflux_inst%npp_Nuptake_patch , & ! Output: [real(r8) + ! (:) ] Total N uptake of FUN used C (gC/m2/s) + npp_growth => cnveg_carbonflux_inst%npp_growth_patch , & ! Output: [real(r8) + ! (:) ] Total N uptake of FUN used C (gC/m2/s) + burnedoff_carbon => cnveg_carbonflux_inst%npp_burnedoff_patch , & ! Output: [real(r8) + ! (:) ] C that cannot be used for N uptake(gC/m2/s) + leafc_change => cnveg_carbonflux_inst%leafc_change_patch , & ! Output: [real(r8) + ! (:) ] Used C from the leaf (gC/m2/s) + leafn_storage_to_xfer => cnveg_nitrogenflux_inst%leafn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + iretransn_to_iout => cnveg_nitrogenflux_inst%iretransn_to_iout_ph , & ! Input: [integer] + plant_ndemand => cnveg_nitrogenflux_inst%plant_ndemand_patch , & ! Iutput: [real(r8) (:) + ! ] N flux required to support initial GPP (gN/m2/s) + plant_ndemand_retrans => cnveg_nitrogenflux_inst%plant_ndemand_retrans_patch , & ! Output: [real(r8) (:) + ! ] N demand generated for FUN (gN/m2/s) + plant_ndemand_season => cnveg_nitrogenflux_inst%plant_ndemand_season_patch , & ! Output: [real(r8) (:) + ! ] N demand for seasonal deciduous forest (gN/m2/s) + plant_ndemand_stress => cnveg_nitrogenflux_inst%plant_ndemand_stress_patch , & ! Output: [real(r8) (:) + ! ] N demand for stress deciduous forest (gN/m2/s) + Nactive => cnveg_nitrogenflux_inst%Nactive_patch , & ! Output: [real(r8) (:) + ! ] Mycorrhizal N uptake (gN/m2/s) + Nnonmyc => cnveg_nitrogenflux_inst%Nnonmyc_patch , & ! Output: [real(r8) (:) + ! ] Non-mycorrhizal N uptake (gN/m2/s) + Nam => cnveg_nitrogenflux_inst%Nam_patch , & ! Output: [real(r8) (:) ] AM + ! uptake (gN/m2/s) + Necm => cnveg_nitrogenflux_inst%Necm_patch , & ! Output: [real(r8) (:) ] ECM + ! uptake (gN/m2/s) + Nactive_no3 => cnveg_nitrogenflux_inst%Nactive_no3_patch , & ! Output: [real(r8) (:) + ! ] Mycorrhizal N uptake (gN/m2/s) + Nnonmyc_no3 => cnveg_nitrogenflux_inst%Nnonmyc_no3_patch , & ! Output: [real(r8) (:) + ! ] Non-mycorrhizal N uptake (gN/m2/s) + Nam_no3 => cnveg_nitrogenflux_inst%Nam_no3_patch , & ! Output: [real(r8) (:) + ! ] AM uptake (gN/m2/s) + Necm_no3 => cnveg_nitrogenflux_inst%Necm_no3_patch , & ! Output: [real(r8) (:) + ! ] ECM uptake (gN/m2/s) + Nactive_nh4 => cnveg_nitrogenflux_inst%Nactive_nh4_patch , & ! Output: [real(r8) (:) + ! ] Mycorrhizal N uptake (gN/m2/s) + Nnonmyc_nh4 => cnveg_nitrogenflux_inst%Nnonmyc_nh4_patch , & ! Output: [real(r8) (:) + ! ] Non-mycorrhizal N uptake (gN/m2/s) + Nam_nh4 => cnveg_nitrogenflux_inst%Nam_nh4_patch , & ! Output: [real(r8) (:) + ! ] AM uptake (gN/m2/s) + Necm_nh4 => cnveg_nitrogenflux_inst%Necm_nh4_patch , & ! Output: [real(r8) (:) + ! ] ECM uptake (gN/m2/s) + Npassive => cnveg_nitrogenflux_inst%Npassive_patch , & ! Output: [real(r8) (:) + ! ] Passive N uptake (gN/m2/s) + Nfix => cnveg_nitrogenflux_inst%Nfix_patch , & ! Output: [real(r8) (:) ] + ! Symbiotic BNF (gN/m2/s) + cost_nfix => cnveg_nitrogenflux_inst%cost_Nfix_patch , & ! Output: [real(r8) (:) + ! ] Cost of fixation gC:gN + cost_nactive => cnveg_nitrogenflux_inst%cost_Nactive_patch , & ! Output: [real(r8) (:) ] + ! Cost of active uptake gC:gN + cost_nretrans => cnveg_nitrogenflux_inst%cost_Nretrans_patch , & ! Output: [real(r8) (:) ] + ! Cost of retranslocation gC:gN + nuptake_npp_fraction_patch => cnveg_nitrogenflux_inst%nuptake_npp_fraction_patch , & ! Output: [real(r8) (:) + ! ] frac of NPP in NUPTAKE + + c_allometry => cnveg_state_inst%c_allometry_patch , & ! Output: [real(r8) (:) ] C + ! allocation index (DIM) + n_allometry => cnveg_state_inst%n_allometry_patch , & ! Output: [real(r8) (:) ] N + ! allocation index (DIM) + leafn_storage => cnveg_nitrogenstate_inst%leafn_storage_patch , & ! Input: [real(r8) (:) + ! ] (gN/m2) leaf N store + nfix_to_sminn => soilbiogeochem_nitrogenflux_inst%nfix_to_sminn_col , & ! Output: [real(r8) (:)] + ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2 + ! /s) + Nretrans => cnveg_nitrogenflux_inst%Nretrans_patch , & ! Output: [real(r8) (:) + ! ] Retranslocation N uptake (gN/m2/s) + Nretrans_season => cnveg_nitrogenflux_inst%Nretrans_season_patch , & ! Output: [real(r8) (:) + ! ] Retranslocation N uptake (gN/m2/s) + Nretrans_stress => cnveg_nitrogenflux_inst%Nretrans_stress_patch , & ! Output: [real(r8) (:) + ! ] Retranslocation N uptake (gN/m2/s) + Nuptake => cnveg_nitrogenflux_inst%Nuptake_patch , & ! Output: [real(r8) (:) + ! ] Total N uptake of FUN (gN/m2/s) + retransn_to_npool => cnveg_nitrogenflux_inst%retransn_to_npool_patch , & ! Output: [real(r8) + ! (:) ] deployment of retranslocated N (gN/m2/s) + free_retransn_to_npool => cnveg_nitrogenflux_inst%free_retransn_to_npool_patch , & ! Output: [real(r8) + ! uptake of free N from leaves (needed to allow RT during the night with no NPP + sminn_to_plant_fun => cnveg_nitrogenflux_inst%sminn_to_plant_fun_patch , & ! Output: + ! [real(r8) (:) ] Total soil N uptake of FUN (gN/m2/s) + sminn_to_plant_fun_vr => cnveg_nitrogenflux_inst%sminn_to_plant_fun_vr_patch , & ! Output: + ! [real(r8) (:) ] Total layer soil N uptake of FUN (gN/m2 + ! /s) + sminn_to_plant_fun_no3_vr => cnveg_nitrogenflux_inst%sminn_to_plant_fun_no3_vr_patch , & ! Output: [real(r8) + ! (:) ] Total layer no3 uptake of FUN (gN/m2/s) + sminn_to_plant_fun_nh4_vr => cnveg_nitrogenflux_inst%sminn_to_plant_fun_nh4_vr_patch , & ! Output: [real(r8) + ! (:) ] Total layer nh4 uptake of FUN (gN/m2/s) + sminn_to_plant_vr => soilbiogeochem_nitrogenflux_inst%sminn_to_plant_vr_col , & ! Output: [real(r8) (: + ! ,:) ] + smin_no3_to_plant_vr => soilbiogeochem_nitrogenflux_inst%smin_no3_to_plant_vr_col , & ! Output: [real(r8) (: + ! ,:) ] + smin_nh4_to_plant_vr => soilbiogeochem_nitrogenflux_inst%smin_nh4_to_plant_vr_col , & ! Output: [real(r8) (: + ! ,:) ] + smin_vr_nh4 => soilbiogeochem_nitrogenstate_inst%smin_nh4_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral + ! NH4 + smin_vr_no3 => soilbiogeochem_nitrogenstate_inst%smin_no3_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral + ! NO3 + soilc_change => cnveg_carbonflux_inst%soilc_change_patch , & ! Output: [real(r8) + ! (:) ] Used C from the soil (gC/m2/s) + h2osoi_liq => waterstatebulk_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:)] + ! liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:)] + ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + crootfr => soilstate_inst%crootfr_patch & ! Input: [real(r8) (:,:)] + ! fraction of roots for carbon in each soil layer (nlevgrnd) + ) + !-------------------------------------------------------------------- + !----------- + ! Initialize output fluxes, which were also initialized in CNFUNMod. + !-------------------------------------------------------------------- + !----------- + local_use_flexibleCN = use_flexibleCN + steppday = 48._r8 + qflx_tran_veg_layer = 0._r8 + rootc_dens_step = 0._r8 + plant_ndemand_pool = 0._r8 + + call t_startf('CNFUNzeroarrays') + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + availc_pool(p) = 0._r8 + rootC(p) = 0._r8 + litterfall_n(p) = 0._r8 + burnedoff_carbon(p) = 0._r8 + end do + + + do j = 1, nlevdecomp + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + c = patch%column(p) + rootc_dens(p,j) = 0._r8 + cost_retran(p,j) = 0._r8 + cost_fix(p,j) = 0._r8 + cost_resis(p,j) = 0._r8 + cost_res_resis(p,j) = 0._r8 + cost_active_no3(p,j) = 0._r8 + cost_active_nh4(p,j) = 0._r8 + cost_nonmyc_no3(p,j) = 0._r8 + cost_nonmyc_nh4(p,j) = 0._r8 + + sminn_no3_conc(c,j) = 0._r8 + sminn_no3_layer(c,j) = 0._r8 + sminn_nh4_conc(c,j) = 0._r8 + sminn_nh4_layer(c,j) = 0._r8 + end do + end do + + do istp = 1, nstp + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + npp_remaining(p,istp) = 0._r8 + permyc(p,istp) = 0._r8 + plant_ndemand_pool_step(p,istp) = 0._r8 + nt_uptake(p,istp) = 0._r8 + npp_uptake(p,istp) = 0._r8 + leafn_step(p,istp) = 0._r8 + leafn_retrans_step(p,istp) = 0._r8 + litterfall_n_step(p,istp) = 0._r8 + litterfall_c_step(p,istp) = 0._r8 + end do + do j = 1, nlevdecomp + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + sminn_no3_conc_step(p,j,istp) = 0._r8 + sminn_no3_layer_step(p,j,istp) = 0._r8 + sminn_no3_uptake(p,j,istp) = 0._r8 + sminn_nh4_conc_step(p,j,istp) = 0._r8 + sminn_nh4_layer_step(p,j,istp) = 0._r8 + sminn_nh4_uptake(p,j,istp) = 0._r8 + end do + end do + end do + + do icost = 1, ncost6 + do j = 1, nlevdecomp + costNit(j,icost) = big_cost + end do + end do + + ! Time step of FUN + dt = get_step_size_real() + call t_stopf('CNFUNzeroarrays') + !-------------------------------------------------------------------- + !---------------------------- + ! Calculation starts + !-------------------------------------------------------------------- + call t_startf('CNFUNcalcs1') + !---------------------------- + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + + litterfall_n(p) = (leafc_to_litter_fun(p) / leafcn_offset(p)) * dt + rootC(p) = frootc(p) + + plantN(p) = leafn(p) + frootn(p) + livestemn(p) + livecrootn(p) + if (n_allometry(p).gt.0._r8) then + plantCN(p) = c_allometry(p)/n_allometry(p) !changed RF. + ! above code gives CN ratio too low. + else + plantCN(p) = 0._r8 + end if + end do ! PFT ends + do istp = 1, nstp + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + + if (istp.eq.ecm_step) then + permyc(p,istp) = perecm(ivt(p)) + kc_active(p,istp) = ekc_active(ivt(p)) + kn_active(p,istp) = ekn_active(ivt(p)) + else + permyc(p,istp) = 1._r8 - perecm(ivt(p)) + kc_active(p,istp) = akc_active(ivt(p)) + kn_active(p,istp) = akn_active(ivt(p)) + end if + + if(leafc(p)>0.0_r8)then + ! N available in leaf which fell off in this timestep. Same fraction loss as C. + litterfall_c_step(p,istp) = dt * permyc(p,istp) * leafc_to_litter_fun(p) + litterfall_n_step(p,istp) = dt * permyc(p,istp) * leafn(p) * leafc_to_litter_fun(p)/leafc(p) + endif + + if (season_decid(ivt(p)) == 1._r8.or.stress_decid(ivt(p)) == 1._r8) then + if (offset_flag(p) .ne. 1._r8) then + litterfall_n_step(p,istp) = 0.0_r8 + litterfall_c_step(p,istp) = 0.0_r8 + endif + endif + + end do + end do + + do j = 1, nlevdecomp + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + c = patch%column(p) + sminn_no3_layer(c,j)= smin_no3_to_plant_vr(c,j) * dzsoi_decomp(j) * dt + sminn_nh4_layer(c,j)= smin_nh4_to_plant_vr(c,j) * dzsoi_decomp(j) * dt + if (h2osoi_liq(c,j) < smallValue) then + sminn_no3_layer(c,j) = 0._r8 + sminn_nh4_layer(c,j) = 0._r8 + end if + sminn_no3_layer(c,j) = max(sminn_no3_layer(c,j),0._r8) + sminn_nh4_layer(c,j) = max(sminn_nh4_layer(c,j),0._r8) + if (h2osoi_liq(c,j) > smallValue) then + sminn_no3_conc(c,j) = sminn_no3_layer(c,j) / (h2osoi_liq(c,j) * 1000._r8) ! (gN/m2)/(gH2O/m2) (coverted from + ! kg2g) + sminn_nh4_conc(c,j) = sminn_nh4_layer(c,j) / (h2osoi_liq(c,j) * 1000._r8) ! (gN/m2)/(gH2O/m2) (coverted from + ! kg2g) + else + sminn_no3_conc(c,j) = 0._r8 + sminn_nh4_conc(c,j) = 0._r8 + end if + end do + end do + + do istp = 1, nstp + do j = 1, nlevdecomp + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + c = patch%column(p) + + sminn_no3_layer_step(p,j,istp) = sminn_no3_layer(c,j) * permyc(p,istp) + sminn_nh4_layer_step(p,j,istp) = sminn_nh4_layer(c,j) * permyc(p,istp) + sminn_no3_conc_step(p,j,istp) = sminn_no3_conc(c,j) * permyc(p,istp) + sminn_nh4_conc_step(p,j,istp) = sminn_nh4_conc(c,j) * permyc(p,istp) + end do + end do + end do + call t_stopf('CNFUNcalcs1') + + call t_startf('CNFUNzeroarrays2') + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + n_passive_acc(p) = 0._r8 + n_fix_acc_total(p) = 0._r8 + n_retrans_acc_total(p) = 0._r8 + npp_fix_acc_total(p) = 0._r8 + n_nonmyc_no3_retrans_total(p) = 0._r8 + n_nonmyc_nh4_retrans_total(p) = 0._r8 + npp_retrans_acc_total(p) = 0._r8 + n_am_no3_acc(p) = 0._r8 + n_am_nh4_acc(p) = 0._r8 + n_am_no3_retrans(p) = 0._r8 + n_am_nh4_retrans(p) = 0._r8 + n_ecm_no3_acc(p) = 0._r8 + n_ecm_nh4_acc(p) = 0._r8 + n_ecm_no3_retrans(p) = 0._r8 + n_ecm_nh4_retrans(p) = 0._r8 + n_active_no3_acc_total(p) = 0._r8 + n_active_nh4_acc_total(p) = 0._r8 + n_active_no3_retrans_total(p) = 0._r8 + n_active_nh4_retrans_total(p) = 0._r8 + n_nonmyc_no3_acc_total(p) = 0._r8 + n_nonmyc_nh4_acc_total(p) = 0._r8 + npp_active_no3_acc_total(p) = 0._r8 + npp_active_nh4_acc_total(p) = 0._r8 + npp_active_no3_retrans_total(p) = 0._r8 + npp_active_nh4_retrans_total(p) = 0._r8 + npp_nonmyc_no3_acc_total(p) = 0._r8 + npp_nonmyc_nh4_acc_total(p) = 0._r8 + npp_nonmyc_no3_retrans_total(p) = 0._r8 + npp_nonmyc_nh4_retrans_total(p) = 0._r8 + free_Nretrans(p) = 0._r8 + end do + + do j = 1, nlevdecomp + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + n_passive_no3_vr(p,j) = 0._r8 + n_passive_nh4_vr(p,j) = 0._r8 + n_active_no3_vr(p,j) = 0._r8 + n_nonmyc_no3_vr(p,j) = 0._r8 + n_active_nh4_vr(p,j) = 0._r8 + n_nonmyc_nh4_vr(p,j) = 0._r8 + end do + end do + do istp = 1, nstp + do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + n_passive_step(p,istp) = 0._r8 + n_fix_acc(p,istp) = 0._r8 + n_retrans_acc(p,istp) = 0._r8 + npp_fix_acc(p,istp) = 0._r8 + npp_retrans_acc(p,istp) = 0._r8 + n_active_no3_acc(p,istp) = 0._r8 + n_active_nh4_acc(p,istp) = 0._r8 + n_active_no3_retrans(p,istp) = 0._r8 + n_active_nh4_retrans(p,istp) = 0._r8 + n_nonmyc_no3_acc(p,istp) = 0._r8 + n_nonmyc_nh4_acc(p,istp) = 0._r8 + n_nonmyc_no3_retrans(p,istp) = 0._r8 + n_nonmyc_nh4_retrans(p,istp) = 0._r8 + npp_active_no3_acc(p,istp) = 0._r8 + npp_active_nh4_acc(p,istp) = 0._r8 + npp_active_no3_retrans(p,istp) = 0._r8 + npp_active_nh4_retrans(p,istp) = 0._r8 + npp_nonmyc_no3_acc(p,istp) = 0._r8 + npp_nonmyc_nh4_acc(p,istp) = 0._r8 + npp_nonmyc_no3_retrans(p,istp) = 0._r8 + npp_nonmyc_nh4_retrans(p,istp) = 0._r8 + end do + end do + + burned_off_carbon = 0._r8 + call t_stopf('CNFUNzeroarrays2') + + + call t_startf('CNFUNcalcs') +pft:do fp = 1,num_soilp ! PFT Starts + p = filter_soilp(fp) + c = patch%column(p) + excess_carbon_acc = 0.0_r8 + burned_off_carbon = 0.0_r8 + + sminn_to_plant_fun_nh4_vr(p,:) = 0._r8 + sminn_to_plant_fun_no3_vr(p,:) = 0._r8 + + ! I have turned off this r etranslocation functionality for now. To + ! be rolled back in to a new version later on once the rest of + ! th + ! mode is working OK. RF + + if (season_decid(ivt(p)) == 1._r8.or.stress_decid(ivt(p)) == 1._r8) then + if (onset_flag(p) == 1._r8) then + leafc_storage_xfer_acc(p) = leafc_storage_xfer_acc(p) + leafc_storage_to_xfer(p) * dt + leafn_storage_xfer_acc(p) = leafn_storage_xfer_acc(p) + leafn_storage_to_xfer(p) * dt + end if + if (offset_flag(p) == 1._r8) then + storage_cdemand(p) = leafc_storage(p) / (ndays_off * steppday) + storage_ndemand(p) = leafn_storage_xfer_acc(p) / (ndays_off * steppday) + storage_ndemand(p) = max(storage_ndemand(p),0._r8) + else + storage_cdemand(p) = 0._r8 + storage_ndemand(p) = 0._r8 + end if + else + storage_cdemand(p) = 0._r8 + storage_ndemand(p) = 0._r8 + end if ! end for deciduous + + !---------How much carbon is provided, to be used for either growth + ! or Nitrogen uptake?------------------- + availc_pool(p) = availc(p) * dt + + if (availc_pool(p) > 0._r8) then + do j = 1, nlevdecomp + rootc_dens(p,j) = crootfr(p,j) * rootC(p) + end do + end if + + plant_ndemand_pool(p) = plant_ndemand(p) * dt + plant_ndemand_pool(p) = max(plant_ndemand_pool(p),0._r8) + plant_ndemand_retrans(p) = storage_ndemand(p) + + !-------------------------------------------------------------------- + !---------- +stp: do istp = ecm_step, am_step ! TWO STEPS + retrans_limit1 = 0._r8 + dn = 0._r8 + dnpp = 0._r8 + + ! zero out all of the fluxes that get accumulated accross ISTP + sminn_no3_diff = 0._r8 + sminn_nh4_diff = 0._r8 + active_no3_limit1 = 0._r8 + active_nh4_limit1 = 0._r8 + + + n_from_active_no3(:) = 0.0_r8 + n_from_active_nh4(:) = 0.0_r8 + n_from_nonmyc_no3(:) = 0.0_r8 + n_from_nonmyc_nh4(:) = 0.0_r8 + n_from_fixation(:) = 0.0_r8 + n_from_retrans(:) = 0.0_r8 + + n_active_no3_acc(p,istp) = 0.0_r8 + n_active_nh4_acc(p,istp) = 0.0_r8 + n_nonmyc_no3_acc(p,istp) = 0.0_r8 + n_nonmyc_nh4_acc(p,istp) = 0.0_r8 + n_fix_acc(p,istp) = 0.0_r8 + n_retrans_acc(p,istp) = 0.0_r8 + free_nretrans_acc(p,istp) = 0.0_r8 + + npp_active_no3_acc(p,istp) = 0.0_r8 + npp_active_nh4_acc(p,istp) = 0.0_r8 + npp_nonmyc_no3_acc(p,istp) = 0.0_r8 + npp_nonmyc_no3_acc(p,istp) = 0.0_r8 + npp_fix_acc(p,istp) = 0.0_r8 + npp_retrans_acc(p,istp) = 0.0_r8 + + npp_to_active_no3(:) = 0.0_r8 + npp_to_active_nh4(:) = 0.0_r8 + npp_to_nonmyc_no3(:) = 0.0_r8 + npp_to_nonmyc_nh4(:) = 0.0_r8 + npp_to_fixation(:) = 0.0_r8 + npp_to_retrans(:) = 0.0_r8 + + + + unmetDemand = .TRUE. + plant_ndemand_pool_step(p,istp) = plant_ndemand_pool(p) * permyc(p,istp) + npp_remaining(p,istp) = availc_pool(p) * permyc(p,istp) + + + ! if (plant_ndemand_pool_step(p,istp) .gt. 0._r8) then ! + ! plant_ndemand_pool_step > 0.0 + + do j = 1, nlevdecomp + tc_soisno(c,j) = t_soisno(c,j) - tfrz + if(pftcon%c3psn(patch%itype(p)).eq.1)then + fixer=1 + else + fixer=0 + endif + costNit(j,icostFix) = fun_cost_fix(fixer,a_fix(ivt(p)),b_fix(ivt(p))& + ,c_fix(ivt(p)) ,big_cost,crootfr(p,j),s_fix(ivt(p)),tc_soisno(c,j)) + end do + cost_fix(p,1:nlevdecomp) = costNit(:,icostFix) + + + !-------------------------------------------------------------------- + !------------ + ! If passive uptake is insufficient, consider fixation, + ! mycorrhizal + ! non-mycorrhizal, storage, and retranslocation. + !-------------------------------------------------------------------- + !------------ + !-------------------------------------------------------------------- + !------------ + ! Costs of active uptake. + !-------------------------------------------------------------------- + !------------ + !------Mycorrhizal Uptake Cost-----------------! + do j = 1,nlevdecomp + rootc_dens_step = rootc_dens(p,j) * permyc(p,istp) + costNit(j,icostActiveNO3) = fun_cost_active(sminn_no3_layer_step(p,j,istp) & + ,big_cost,kc_active(p,istp),kn_active(p,istp) ,rootc_dens_step,crootfr(p,j),smallValue) + costNit(j,icostActiveNH4) = fun_cost_active(sminn_nh4_layer_step(p,j,istp) & + ,big_cost,kc_active(p,istp),kn_active(p,istp) ,rootc_dens_step,crootfr(p,j),smallValue) + end do + cost_active_no3(p,1:nlevdecomp) = costNit(:,icostActiveNO3) + cost_active_nh4(p,1:nlevdecomp) = costNit(:,icostActiveNH4) + + + !------Non-mycorrhizal Uptake Cost-------------! + do j = 1,nlevdecomp + rootc_dens_step = rootc_dens(p,j) * permyc(p,istp) + costNit(j,icostnonmyc_no3) = fun_cost_nonmyc(sminn_no3_layer_step(p,j,istp) & + ,big_cost,kc_nonmyc(ivt(p)),kn_nonmyc(ivt(p)) ,rootc_dens_step,crootfr(p,j),smallValue) + costNit(j,icostnonmyc_nh4) = fun_cost_nonmyc(sminn_nh4_layer_step(p,j,istp) & + ,big_cost,kc_nonmyc(ivt(p)),kn_nonmyc(ivt(p)) ,rootc_dens_step,crootfr(p,j),smallValue) + end do + cost_nonmyc_no3(p,1:nlevdecomp) = costNit(:,icostnonmyc_no3) + cost_nonmyc_nh4(p,1:nlevdecomp) = costNit(:,icostnonmyc_nh4) + + + ! Remove C required to pair with N from passive uptake + ! from the available pool. + npp_remaining(p,istp) = npp_remaining(p,istp) - n_passive_step(p,istp)*plantCN(p) + +fix_loop: do FIX =plants_are_fixing, plants_not_fixing !loop around percentages of fixers and non + ! fixers, with differnt costs. + if(FIX==plants_are_fixing)then ! How much of the carbon in this PFT can in principle be used for fixation? + ! This is analagous to fixing the % of fixers for a given PFT - may not be realistic in the long run + ! but prevents wholesale switching to fixer dominance during e.g. CO2 fertilization. + fixerfrac = FUN_fracfixers(ivt(p)) + else + fixerfrac = 1.0_r8 - FUN_fracfixers(ivt(p)) + endif + npp_to_spend = npp_remaining(p,istp) * fixerfrac !put parameter here. + + + + n_from_active_no3(1:nlevdecomp) = 0._r8 + n_from_active_nh4(1:nlevdecomp) = 0._r8 + n_from_nonmyc_no3(1:nlevdecomp) = 0._r8 + n_from_nonmyc_nh4(1:nlevdecomp) = 0._r8 + !-------------------------------------------------------------------- + !----------- + ! Calculate Integrated Resistance OF WHOLE SOIL COLUMN + !-------------------------------------------------------------------- + !----------- + + sum_n_acquired = 0.0_r8 + total_N_conductance = 0.0_r8 + do j = 1, nlevdecomp + !----------! + ! Method changed from FUN-resistors method to a method which + ! allocates fluxs based on conductance. rosief + !----------! + + ! Sum the conductances + total_N_conductance = total_N_conductance + 1._r8/ & + cost_active_no3(p,j) + 1._r8/cost_active_nh4(p,j) & + + 1._r8/cost_nonmyc_no3(p,j) & + + 1._r8/cost_nonmyc_nh4(p,j) + if(FIX==plants_are_fixing)then + total_N_conductance = total_N_conductance + 1.0_r8 * 1._r8/cost_fix(p,j) + end if + + end do + + do j = 1, nlevdecomp + ! Calculate npp allocation to pathways proportional to their exchange rate (N/C) + + npp_frac_to_active_nh4(j) = (1._r8/cost_active_nh4(p,j)) / total_N_conductance + npp_frac_to_nonmyc_nh4(j) = (1._r8/cost_nonmyc_nh4(p,j)) / total_N_conductance + npp_frac_to_active_no3(j) = (1._r8/cost_active_no3(p,j)) / total_N_conductance + npp_frac_to_nonmyc_no3(j) = (1._r8/cost_nonmyc_no3(p,j)) / total_N_conductance + if(FIX==plants_are_fixing)then + npp_frac_to_fixation(j) = (1.0_r8 * 1._r8/cost_fix(p,j)) / total_N_conductance + else + npp_frac_to_fixation(j) = 0.0_r8 + end if + + ! Calculate hypothetical N uptake from each source + if(FIX==plants_are_fixing)then + n_exch_fixation(j) = npp_frac_to_fixation(j) / cost_fix(p,j) + else + n_exch_fixation(j) = 0.0_r8 + end if + + n_exch_active_nh4(j) = npp_frac_to_active_nh4(j) / cost_active_nh4(p,j) + n_exch_nonmyc_nh4(j) = npp_frac_to_nonmyc_nh4(j) / cost_nonmyc_nh4(p,j) + n_exch_active_no3(j) = npp_frac_to_active_no3(j) / cost_active_no3(p,j) + n_exch_nonmyc_no3(j) = npp_frac_to_nonmyc_no3(j) / cost_nonmyc_no3(p,j) + + ! Total N aquired from one unit of carbon (N/C) + sum_n_acquired = sum_n_acquired + n_exch_active_nh4(j) +& + n_exch_nonmyc_nh4(j)+ n_exch_active_no3(j) + n_exch_nonmyc_no3(j) + + if(FIX==plants_are_fixing)then + sum_n_acquired= sum_n_acquired + n_exch_fixation(j) + end if + + end do !nlevdecomp + + total_N_resistance = 1.0_r8/sum_n_acquired + + !------------------------------------------------------------------------------- + ! Calculate appropriate degree of retranslocation + !------------------------------------------------------------------------------- + + if(leafc(p).gt.0.0_r8.and.litterfall_n_step(p,istp)* fixerfrac>0.0_r8.and.ivt(p) 0._r8 + end do stp ! NSTEP + + + !------------------------------------------------------------------------------- + ! Turn step level quantities back into fluxes per second. + !------------------------------------------------------------------------------- + + !---------------------------N fluxes--------------------! + Npassive(p) = n_passive_acc(p)/dt + Nfix(p) = n_fix_acc_total(p)/dt + retransn_to_npool(p) = n_retrans_acc_total(p)/dt + if(.not. use_matrixcn)then + free_retransn_to_npool(p) = free_nretrans(p)/dt + else +! if(retransn(p) .gt. 0)then +! free_retransn_to_npool(p) = retransn(p) * matrix_update_phn(p,iretransn_to_iout,free_nretrans(p)/dt/retransn(p),dt,cnveg_nitrogenflux_inst,.true.,.true.) +! else +! free_retransn_to_npool(p) = 0._r8 +! end if + end if + ! this is the N that comes off leaves. + Nretrans(p) = retransn_to_npool(p) + free_retransn_to_npool(p) + + + + + !Extract active uptake N from soil pools. + do j = 1, nlevdecomp + !RF change. The N fixed doesn't actually come out of the soil mineral pools, it is 'new'... + sminn_to_plant_fun_no3_vr(p,j) = (n_passive_no3_vr(p,j) + n_active_no3_vr(p,j) & + + n_nonmyc_no3_vr(p,j))/(dzsoi_decomp(j)*dt) + sminn_to_plant_fun_nh4_vr(p,j) = (n_passive_nh4_vr(p,j) + n_active_nh4_vr(p,j) & + + n_nonmyc_nh4_vr(p,j))/(dzsoi_decomp(j)*dt) + + end do + + + + Nactive_no3(p) = n_active_no3_acc_total(p)/dt + n_active_no3_retrans_total(p)/dt + Nactive_nh4(p) = n_active_nh4_acc_total(p)/dt + n_active_nh4_retrans_total(p)/dt + + + + Necm_no3(p) = n_ecm_no3_acc(p)/dt + n_ecm_no3_retrans(p)/dt + Necm_nh4(p) = n_ecm_nh4_acc(p)/dt + n_ecm_nh4_retrans(p)/dt + Necm(p) = Necm_no3(p) + Necm_nh4(p) + Nam_no3(p) = n_am_no3_acc(p)/dt + n_am_no3_retrans(p)/dt + Nam_nh4(p) = n_am_nh4_acc(p)/dt + n_am_nh4_retrans(p)/dt + Nam(p) = Nam_no3(p) + Nam_nh4(p) + Nnonmyc_no3(p) = n_nonmyc_no3_acc_total(p)/dt + n_nonmyc_no3_retrans_total(p)/dt + Nnonmyc_nh4(p) = n_nonmyc_nh4_acc_total(p)/dt + n_nonmyc_nh4_retrans_total(p)/dt + Nnonmyc(p) = Nnonmyc_no3(p) + Nnonmyc_nh4(p) + plant_ndemand_retrans(p) = plant_ndemand_retrans(p)/dt + Nuptake(p) = Nactive_no3(p) + Nactive_nh4(p) + Nnonmyc_no3(p) & + + Nnonmyc_nh4(p) + Nfix(p) + Npassive(p) + & + retransn_to_npool(p)+free_retransn_to_npool(p) + Nactive(p) = Nactive_no3(p) + Nactive_nh4(p) + Nnonmyc_no3(p) + Nnonmyc_nh4(p) + + ! free N goes straight to the npool, not throught Nuptake... + sminn_to_plant_fun(p) = Nactive_no3(p) + Nactive_nh4(p) + Nnonmyc_no3(p) + Nnonmyc_nh4(p) + Nfix(p) + Npassive(p) + + + soil_n_extraction = ( sum(n_active_no3_vr(p,1: nlevdecomp))+sum(n_nonmyc_no3_vr(p,1: nlevdecomp))+& + sum(n_active_nh4_vr(p,1: nlevdecomp)) + sum(n_nonmyc_nh4_vr(p,1: nlevdecomp))) + + !---------------------------C fluxes--------------------! + + npp_Nactive_no3(p) = npp_active_no3_acc_total(p)/dt + npp_active_no3_retrans_total(p)/dt + npp_Nactive_nh4(p) = npp_active_nh4_acc_total(p)/dt + npp_active_nh4_retrans_total(p)/dt + + npp_Nnonmyc_no3(p) = npp_nonmyc_no3_acc_total(p)/dt + npp_nonmyc_no3_retrans_total(p)/dt + npp_Nnonmyc_nh4(p) = npp_nonmyc_nh4_acc_total(p)/dt + npp_nonmyc_nh4_retrans_total(p)/dt + npp_Nactive(p) = npp_Nactive_no3(p) + npp_Nactive_nh4(p) + npp_Nnonmyc_no3(p) + npp_Nnonmyc_nh4(p) + npp_Nnonmyc(p) = npp_Nnonmyc_no3(p) + npp_Nnonmyc_nh4(p) + npp_Nfix(p) = npp_fix_acc_total(p)/dt + npp_Nretrans(p) = npp_retrans_acc_total(p)/dt + + !---------------------------Extra Respiration Fluxes--------------------! + soilc_change(p) = (npp_active_no3_acc_total(p) + npp_active_nh4_acc_total(p) & + + npp_nonmyc_no3_acc_total(p) & + + npp_nonmyc_nh4_acc_total(p) + npp_fix_acc_total(p))/dt & + + npp_Nretrans(p) + soilc_change(p) = soilc_change(p) + burned_off_carbon / dt + burnedoff_carbon(p) = burned_off_carbon/dt + npp_Nuptake(p) = soilc_change(p) + ! how much carbon goes to growth of tissues? + npp_growth(p) = (Nuptake(p)- free_retransn_to_npool(p))*plantCN(p)+(excess_carbon_acc/dt) !does not include gresp, since this is calculated from growth + + + + !-----------------------Diagnostic Fluxes------------------------------! + if(availc(p).gt.0.0_r8)then !what happens in the night? + nuptake_npp_fraction_patch(p) = npp_Nuptake(p)/availc(p) + else + nuptake_npp_fraction_patch(p) = spval + endif + if(npp_Nfix(p).gt.0.0_r8)then + cost_nfix(p) = Nfix(p)/npp_Nfix(p) + else + cost_nfix(p) = spval + endif + if(npp_Nactive(p).gt.0.0_r8)then + cost_nactive(p) = Nactive(p)/npp_Nactive(p) + else + cost_nactive(p) = spval + endif + if(npp_Nretrans(p).gt.0.0_r8)then + cost_nretrans(p) = Nretrans(p)/npp_Nretrans(p) + else + cost_nretrans(p) = spval + endif + + + end do pft ! PFT Ends + + call t_stopf('CNFUNcalcs') + + call p2c(bounds, num_soilc, filter_soilc, & + cnveg_carbonflux_inst%soilc_change_patch(bounds%begp:bounds%endp), & + soilbiogeochem_carbonflux_inst%soilc_change_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + cnveg_nitrogenflux_inst%Nfix_patch(bounds%begp:bounds%endp), & + soilbiogeochem_nitrogenflux_inst%nfix_to_sminn_col(bounds%begc:bounds%endc)) + + end associate + end subroutine CNFUN +!========================================================================================= + real(r8) function fun_cost_fix(fixer,a_fix,b_fix,c_fix,big_cost,crootfr,s_fix, tc_soisno) + +! Description: +! Calculate the cost of fixing N by nodules. +! Code Description: +! This code is written to CLM4CN by Mingjie Shi on 06/27/2013 + + implicit none +!-------------------------------------------------------------------------- +! Function result. +!-------------------------------------------------------------------------- +! real(r8) , intent(out) :: cost_of_n !!! cost of fixing N (kgC/kgN) +!-------------------------------------------------------------------------- +! Scalar arguments with intent(in). +!-------------------------------------------------------------------------- + integer, intent(in) :: fixer ! flag indicating if plant is a fixer + ! 1=yes, otherwise no. + real(r8), intent(in) :: a_fix ! As in Houlton et al. (Nature) 2008 + real(r8), intent(in) :: b_fix ! As in Houlton et al. (Nature) 2008 + real(r8), intent(in) :: c_fix ! As in Houlton et al. (Nature) 2008 + real(r8), intent(in) :: big_cost ! an arbitrary large cost (gC/gN) + real(r8), intent(in) :: crootfr ! fraction of roots for carbon that are in this layer + real(r8), intent(in) :: s_fix ! Inverts Houlton et al. 2008 and constrains between 7.5 and 12.5 + real(r8), intent(in) :: tc_soisno ! soil temperature (degrees Celsius) + + if (fixer == 1 .and. crootfr > 1.e-6_r8) then + fun_cost_fix = s_fix * (exp(a_fix + b_fix * tc_soisno * (1._r8 - 0.5_r8 * tc_soisno / c_fix)) - 2._r8) + + + ! New term to directly account for Ben Houlton's temperature response function. + ! Assumes s_fix is -6. (RF, Jan 2015) + ! 1.25 converts from the Houlton temp response function to a 0-1 limitation factor. + ! The cost of N should probably be 6 gC/gN (or 9, including maintenance costs of nodules) + ! for 'optimal' temperatures. This cost should increase in a way that mirrors + ! Houlton et al's observations of temperautre limitations on the mirboial fixation rates. + ! We don't actually simulate the rate of fixation (and assume that N uptake is instantaneous) + ! here, so instead the limitation term is here rolled into the cost function. + + ! Here we invert the 'cost' to give the optimal N:C ratio (1/6 gN/gC) The amount of N + ! you get for a given C goes down as it gets colder, so this can be multiplied by + ! the temperature function to give a temperature-limited N:C of f/6. This number + ! can then be inverted to give a temperature limited C:N, as 1/(f/6). Which is the + ! same as 6/f, given here" + fun_cost_fix = (-1*s_fix) * 1.0_r8 / (1.25_r8* (exp(a_fix + b_fix * tc_soisno * (1._r8 - 0.5_r8 * tc_soisno / c_fix)) )) + else + fun_cost_fix = big_cost + end if ! ends up with the fixer or non-fixer decision + + end function fun_cost_fix +!========================================================================================= + real(r8) function fun_cost_active(sminn_layer,big_cost,kc_active,kn_active,rootc_dens,crootfr,smallValue) + +! Description: +! Calculate the cost of active uptake of N frm the soil. +! Code Description: +! This code is written to CLM4 by Mingjie Shi. + + implicit none +!-------------------------------------------------------------------------- +! Function result. +!-------------------------------------------------------------------------- + real(r8), intent(in) :: sminn_layer ! Amount of N (as NH4 or NO3) in the soil that is available to plants (gN/m2). + real(r8), intent(in) :: big_cost ! An arbitrary large cost (gC/gN). + real(r8), intent(in) :: kc_active ! Constant for cost of active uptake (gC/m2). + real(r8), intent(in) :: kn_active ! Constant for cost of active uptake (gC/m2). + real(r8), intent(in) :: rootc_dens ! Root carbon density in layer (gC/m3). + real(r8), intent(in) :: crootfr ! Fraction of roots that are in this layer. + real(r8), intent(in) :: smallValue ! A small number. + + if (rootc_dens > 1.e-6_r8.and.sminn_layer > smallValue) then + fun_cost_active = kn_active/sminn_layer + kc_active/rootc_dens + else +! There are very few roots in this layer. Set a high cost. + fun_cost_active = big_cost + end if + + end function fun_cost_active +!========================================================================================= + real(r8) function fun_cost_nonmyc(sminn_layer,big_cost,kc_nonmyc,kn_nonmyc,rootc_dens,crootfr,smallValue) + +! Description: +! Calculate the cost of nonmyc uptake of N frm the soil. +! Code Description: +! This code is written to CLM4 by Mingjie Shi. + + implicit none +!-------------------------------------------------------------------------- +! Function result. +!-------------------------------------------------------------------------- + real(r8), intent(in) :: sminn_layer ! Amount of N (as NH4 or NO3) in the soil that is available to plants (gN/m2). + real(r8), intent(in) :: big_cost ! An arbitrary large cost (gC/gN). + real(r8), intent(in) :: kc_nonmyc ! Constant for cost of nonmyc uptake (gC/m2). + real(r8), intent(in) :: kn_nonmyc ! Constant for cost of nonmyc uptake (gC/m2). + real(r8), intent(in) :: rootc_dens ! Root carbon density in layer (gC/m3). + real(r8), intent(in) :: crootfr ! Fraction of roots that are in this layer. + real(r8), intent(in) :: smallValue ! A small number. + + if (rootc_dens > 1.e-6_r8.and.sminn_layer > smallValue) then + fun_cost_nonmyc = kn_nonmyc / sminn_layer + kc_nonmyc / rootc_dens + else +! There are very few roots in this layer. Set a high cost. + fun_cost_nonmyc = big_cost + end if + + end function fun_cost_nonmyc + +!========================================================================== + + subroutine fun_retranslocation(p,dt,npp_to_spend,total_falling_leaf_c, & + total_falling_leaf_n, total_n_resistance, total_c_spent_retrans, & + total_c_accounted_retrans, free_n_retrans, paid_for_n_retrans, & + target_leafcn, grperc, plantCN) +! +! Description: +! This subroutine (should it be a function?) calculates the amount of N absorbed and C spent +! during retranslocation. +! Rosie Fisher. April 2016. +! !USES: + implicit none + +! !ARGUMENTS: + real(r8), intent(IN) :: total_falling_leaf_c ! INPUT gC/m2/timestep + real(r8), intent(IN) :: total_falling_leaf_n ! INPUT gC/m2/timestep + real(r8), intent(IN) :: total_n_resistance ! INPUT gC/gN + real(r8), intent(IN) :: npp_to_spend ! INPUT gN/m2/timestep + real(r8), intent(IN) :: target_leafcn ! INPUT gC/gN + real(r8), intent(IN) :: dt ! INPUT seconds + real(r8), intent(IN) :: grperc ! INPUT growth respiration fraction + real(r8), intent(IN) :: plantCN ! INPUT plant CN ratio + integer, intent(IN) :: p ! INPUT patch index + + real(r8), intent(OUT) :: total_c_spent_retrans ! OUTPUT gC/m2/timestep + real(r8), intent(OUT) :: total_c_accounted_retrans ! OUTPUT gC/m2/timestep + real(r8), intent(OUT) :: paid_for_n_retrans ! OUTPUT gN/m2/timestep + real(r8), intent(OUT) :: free_n_retrans ! OUTPUT gN/m2/timestep + + ! + ! !LOCAL VARIABLES: + real(r8) :: kresorb ! INTERNAL used factor + real(r8) :: falling_leaf_c ! INTERNAL gC/m2/timestep + real(r8) :: falling_leaf_n ! INTERNAL gN/m2/timestep + real(r8) :: falling_leaf_cn ! INTERNAL gC/gN + real(r8) :: cost_retrans_temp ! INTERNAL gC/gN + real(r8) :: leaf_n_ext ! INTERNAL gN/m2/timestep + real(r8) :: c_spent_retrans ! INTERNAL gC/m2/timestep + real(r8) :: c_accounted_retrans ! INTERNAL gC/m2/timestep + real(r8) :: npp_to_spend_temp ! INTERNAL gC/m2/timestep + real(r8) :: max_falling_leaf_cn ! INTERNAL gC/gN + real(r8) :: min_falling_leaf_cn ! INTERNAL gC/gN + real(r8) :: cost_escalation ! INTERNAL cost function parameter + integer :: iter ! INTERNAL + integer :: exitloop ! INTERNAL + ! ------------------------------------------------------------------------------- + + + ! ------------------ Initialize total fluxes. ------------------! + total_c_spent_retrans = 0.0_r8 + total_c_accounted_retrans = 0.0_r8 + c_accounted_retrans = 0.0_r8 + paid_for_n_retrans = 0.0_r8 + npp_to_spend_temp = npp_to_spend + + ! ------------------ Initial C and N pools in falling leaves. ------------------! + falling_leaf_c = total_falling_leaf_c + falling_leaf_n = total_falling_leaf_n + + ! ------------------ PARAMETERS ------------------ + max_falling_leaf_cn = target_leafcn * 3.0_r8 + min_falling_leaf_cn = target_leafcn * 1.5_r8 + cost_escalation = 1.3_r8 + + ! ------------------ Free uptake ------------------ + free_n_retrans = max(falling_leaf_n - (falling_leaf_c/min_falling_leaf_cn),0.0_r8) + falling_leaf_n = falling_leaf_n - free_n_retrans + + ! ------------------ Initial CN ratio and costs ------------------! + falling_leaf_cn = falling_leaf_c/falling_leaf_n + kresorb = (1.0_r8/target_leafcn) + cost_retrans_temp = kresorb / ((1.0_r8/falling_leaf_cn )**1.3_r8) + + ! ------------------ Iteration loops to figure out extraction limit ------------! + iter = 0 + exitloop = 0 + do while(exitloop==0.and.cost_retrans_temp .lt. total_n_resistance.and. & + falling_leaf_n.ge.0.0_r8.and.npp_to_spend.gt.0.0_r8) + ! ------------------ Spend some C on removing N ------------! + ! spend enough C to increase leaf C/N by 1 unit. + c_spent_retrans = cost_retrans_temp * (falling_leaf_n - falling_leaf_c / & + (falling_leaf_cn + 1.0_r8)) + ! don't spend more C than you have + c_spent_retrans = min(npp_to_spend_temp, c_spent_retrans) + ! N extracted, per this amount of C expenditure + leaf_n_ext = c_spent_retrans / cost_retrans_temp + ! Do not empty N pool + leaf_n_ext = min(falling_leaf_n, leaf_n_ext) + !How much C do you need to account for the N that got taken up? + c_accounted_retrans = leaf_n_ext * plantCN * (1.0_r8 + grperc) + + ! ------------------ Update leafCN, recalculate costs ------------! + falling_leaf_n = falling_leaf_n - leaf_n_ext ! remove N from falling leaves pool + if(falling_leaf_n.gt.0.0_r8)then + falling_leaf_cn = falling_leaf_c/falling_leaf_n ! C/N ratio + cost_retrans_temp = kresorb /((1.0_r8/falling_leaf_cn)**1.3_r8) ! cost function. PARAMETER + else + exitloop=1 + endif + + ! ------------------ Accumulate total fluxes ------------! + total_c_spent_retrans = total_c_spent_retrans + c_spent_retrans + total_c_accounted_retrans = total_c_accounted_retrans + c_accounted_retrans + paid_for_n_retrans = paid_for_n_retrans + leaf_n_ext + npp_to_spend_temp = npp_to_spend_temp - c_spent_retrans - c_accounted_retrans + iter = iter+1 + + ! run out of C or N + if(npp_to_spend_temp.le.0.0_r8)then + exitloop=1 + ! if we made a solving error on this (expenditure and n uptake should + ! really be solved simultaneously) + ! then remove the error from the expenditure. This changes the notional cost, + ! but only by a bit and prevents cpool errors. + + total_c_spent_retrans = total_c_spent_retrans + npp_to_spend_temp + endif + ! leaf CN is too high + if(falling_leaf_cn.ge.max_falling_leaf_cn)then + exitloop=1 + endif + ! safety check to prevent hanging code + if(iter.ge.150)then + exitloop=1 + endif + end do + + end subroutine fun_retranslocation + +!========================================================================== + +end module CNFUNMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireEmissionsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireEmissionsMod.F90 new file mode 100755 index 000000000..12420e975 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireEmissionsMod.F90 @@ -0,0 +1,288 @@ +module CNFireEmissionsMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Gathers carbon emissions from fire sources to be sent to CAM-Chem via + ! the coupler .... + ! Created by F. Vitt, and revised by F. Li + ! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use abortutils, only : endrun + use PatchType, only : patch + use decompMod, only : bounds_type + use shr_fire_emis_mod, only : shr_fire_emis_comps_n, shr_fire_emis_comp_t, shr_fire_emis_linkedlist + use shr_fire_emis_mod, only : shr_fire_emis_mechcomps_n, shr_fire_emis_mechcomps + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: CNFireEmisUpdate + public :: init_fireemis_type + ! + ! !PRIVATE TYPES: + type, private :: emis_t + real(r8), pointer :: emis(:) + end type emis_t + ! + ! !PUBLIC TYPES: + type, public :: fireemis_type + real(r8), pointer, public :: fireflx_patch(:,:) ! carbon flux from fire sources (kg/m2/sec) + real(r8), pointer, public :: ztop_patch(:) ! height of the smoke plume (meters) + type(emis_t), pointer, private :: comp(:) ! fire emissions component (corresponds to emis factors table input file) + type(emis_t), pointer, private :: mech(:) ! cam-chem mechism species emissions + type(emis_t), private :: totfire ! sum of all species emissions + + end type fireemis_type + + !------------------------------------------------------------------------ +contains + + + !----------------------------------------------------------------------- + subroutine init_fireemis_type(bounds, this) + ! + ! Allocate memory for module datatypes + use nanMod , only : nan + use clm_varcon , only : spval + + ! !ARGUMENTS: + type(fireemis_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: beg, end, i + !--------------------------------------------------------------------- + + beg = bounds%begp + end = bounds%endp + + allocate(this%totfire%emis(beg:end)) + this%totfire%emis(beg:end) = nan + + if (shr_fire_emis_mechcomps_n>0) then + allocate(this%ztop_patch(beg:end)) + this%ztop_patch(beg:end) = spval + + allocate(this%fireflx_patch(beg:end,shr_fire_emis_mechcomps_n)) + this%fireflx_patch(beg:end,:) = spval + + allocate(this%mech(shr_fire_emis_mechcomps_n)) + do i = 1, shr_fire_emis_mechcomps_n + allocate(this%mech(i)%emis(beg:end)) + this%mech(i)%emis(beg:end) = nan + enddo + endif + + if (shr_fire_emis_comps_n>0) then + allocate(this%comp(shr_fire_emis_comps_n)) + do i = 1, shr_fire_emis_comps_n + allocate(this%comp(i)%emis(beg:end)) + this%comp(i)%emis(beg:end) = nan + enddo + endif + + end subroutine init_fireemis_type + + !----------------------------------------------------------------------- + subroutine CNFireEmisUpdate(bounds, num_soilp, filter_soilp, cnveg_cf_inst, cnveg_cs_inst, fireemis_inst ) + + use CNVegcarbonfluxType, only : cnveg_carbonflux_type + use CNVegCarbonStateType, only : cnveg_carbonstate_type + use clm_varpar, only : ndecomp_pools, nlevdecomp + use clm_varcon, only : dzsoi_decomp + + !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: num_soilp ! number of soil pfts in filter + integer, intent(in) :: filter_soilp(:) ! filter for soil pfts + type(cnveg_carbonflux_type), intent(in) :: cnveg_cf_inst + type(cnveg_carbonstate_type),intent(in) :: cnveg_cs_inst + type(fireemis_type), intent(inout) :: fireemis_inst + + !LOCAL VARIABLES: + real(r8) :: fire_flux + real(r8) :: fire_flux_lf + real(r8) :: fire_flux_lf1 + type(shr_fire_emis_comp_t), pointer :: emis_cmp + real(r8) :: emis_flux(shr_fire_emis_comps_n) + integer :: fp,p,g,c ! indices + real(r8) :: epsilon ! emission factor [ug m-2 h-1] + integer :: i, ii, icomp, imech, n_emis_comps, l, j + + if ( shr_fire_emis_mechcomps_n < 1) return + + associate( & + fire_emis => fireemis_inst%fireflx_patch, & + totfire => fireemis_inst%totfire, & + mech => fireemis_inst%mech, & + comp => fireemis_inst%comp, & + ztop => fireemis_inst%ztop_patch & + ) + + ! initialize to zero ... + fire_emis(bounds%begp:bounds%endp,:) = 0._r8 + totfire%emis(bounds%begp:bounds%endp) = 0._r8 + ztop(bounds%begp:bounds%endp) = 0._r8 + + do i = 1, shr_fire_emis_mechcomps_n + mech(i)%emis(bounds%begp:bounds%endp) = 0._r8 + enddo + + do i = 1, shr_fire_emis_comps_n + comp(i)%emis(bounds%begp:bounds%endp) = 0._r8 + enddo + + ! Begin loop over points + !_______________________________________________________________________________ + do fp = 1,num_soilp + p = filter_soilp(fp) + g = patch%gridcell(p) + c = patch%column(p) + + ! initialize EF + epsilon=0._r8 + emis_flux(:) = 0._r8 + + ! calculate fire emissions for non-bare ground PFTs + if (patch%itype(p) > 0)then + if(cnveg_cs_inst%totvegc_col(c) > 0._r8)then + fire_flux_lf1=0._r8 + do l = 1, ndecomp_pools + do j = 1, nlevdecomp + fire_flux_lf1 = fire_flux_lf1 + & + cnveg_cf_inst%m_decomp_cpools_to_fire_vr_col(c,j,l)*dzsoi_decomp(j) + enddo + end do + fire_flux_lf = fire_flux_lf1*cnveg_cs_inst%totvegc_patch(p)/cnveg_cs_inst%totvegc_col(c) + else + fire_flux_lf=0._r8 + end if + fire_flux = fire_flux_lf & + + cnveg_cf_inst%m_leafc_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from leafc + + cnveg_cf_inst%m_leafc_storage_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from leafc_storage + + cnveg_cf_inst%m_leafc_xfer_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from leafc_xfer + + cnveg_cf_inst%m_livestemc_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from livestemc + + cnveg_cf_inst%m_livestemc_storage_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from livestemc_storage + + cnveg_cf_inst%m_livestemc_xfer_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from livestemc_xfer + + cnveg_cf_inst%m_deadstemc_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from deadstemc_xfer + + cnveg_cf_inst%m_deadstemc_storage_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from deadstemc_storage + + cnveg_cf_inst%m_deadstemc_xfer_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from deadstemc_xfer + + cnveg_cf_inst%m_frootc_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from frootc + + cnveg_cf_inst%m_frootc_storage_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from frootc_storage + + cnveg_cf_inst%m_frootc_xfer_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from frootc_xfer + + cnveg_cf_inst%m_livecrootc_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from livecrootc + + cnveg_cf_inst%m_livecrootc_storage_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from livecrootc_storage + + cnveg_cf_inst%m_livecrootc_xfer_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from livecrootc_xfer + + cnveg_cf_inst%m_deadcrootc_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from deadcrootc + + cnveg_cf_inst%m_deadcrootc_storage_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from deadcrootc_storage + + cnveg_cf_inst%m_deadcrootc_xfer_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from deadcrootc_xfer + + cnveg_cf_inst%m_gresp_storage_to_fire_patch (p) & ! (gC/m2/s) fire C emissions from gresp_storage + + cnveg_cf_inst%m_gresp_xfer_to_fire_patch (p) ! (gC/m2/s) fire C emissions from gresp_xfer + ! for diagnostics + totfire%emis(p) = fire_flux ! gC/m2/sec + + ! loop over fire components + emis_cmp => shr_fire_emis_linkedlist + emis_cmp_loop: do while(associated(emis_cmp)) + + icomp = emis_cmp%index + epsilon = emis_cmp%emis_factors(patch%itype(p)) + + comp(icomp)%emis(p) = epsilon * fire_flux* 1.e-3_r8/0.5_r8 ! (to convert gC/m2/sec to kg species/m2/sec) + emis_flux(icomp) = emis_cmp%coeff*comp(icomp)%emis(p) + + emis_cmp => emis_cmp%next_emiscomp + + enddo emis_cmp_loop + + ! sum up the emissions compontent fluxes for the fluxes of chem mechanism compounds + do imech = 1,shr_fire_emis_mechcomps_n + n_emis_comps = shr_fire_emis_mechcomps(imech)%n_emis_comps + do icomp = 1,n_emis_comps ! loop over number of emission components that make up the nth mechanism compoud + ii = shr_fire_emis_mechcomps(imech)%emis_comps(icomp)%ptr%index + fire_emis(p,imech) = fire_emis(p,imech) + emis_flux(ii) + mech(imech)%emis(p) = fire_emis(p,imech) + enddo + enddo + + ztop(p) = vert_dist_top( patch%itype(p) ) + + end if ! ivt(1:15 only) + + enddo ! fp + end associate + + end subroutine CNFireEmisUpdate + +! Private methods +!----------------------------------------------------------------------- +!ztop compiled from Val Martin et al ACP 2010, Tosca et al. JGR 2011 and Jian et al., ACP 2013 +!st ztop updated based on Val Martin pers. communication Jan2015 +!----------------------------------------------------------------------- +! not_vegetated 500 m +!PFT1: needleleaf_evergreen_temperate_tree 4000 m +!2: needleleaf_evergreen_boreal_tree 4000 m +!3: needleleaf_deciduous_boreal_tree 3000 m +!4: broadleaf_evergreen_tropical_tree 2500 m +!5: broadleaf_evergreen_temperate_tree 3000 m +!6: broadleaf_deciduous_tropical_tree 2500 m +!7: broadleaf_deciduous_temperate_tree 3000 m +!8: broadleaf_deciduous_boreal_tree 3000 m +!9: broadleaf_evergreen_shrub 2000 m +!10: broadleaf_deciduous_temperate_shrub 2000 m +!11: broadleaf_deciduous_boreal_shrub 2000 m +!12: c3_arctic_grass 1000 m +!13: c3_non-arctic_grass 1000 m +!14: c4_grass 1000 m +!15: c3_crop 1000 m +!(and all new crops: 1000m) + + function vert_dist_top( veg_type ) result(ztop) + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use pftconMod , only : noveg, ndllf_evr_tmp_tree, ndllf_evr_brl_tree + use pftconMod , only : ndllf_dcd_brl_tree, nbrdlf_evr_tmp_tree + use pftconMod , only : nbrdlf_dcd_tmp_tree, nbrdlf_dcd_brl_tree + use pftconMod , only : nbrdlf_evr_trp_tree, nbrdlf_dcd_trp_tree + use pftconMod , only : nbrdlf_evr_shrub, nbrdlf_dcd_brl_shrub + use pftconMod , only : nc3_arctic_grass, nc3_nonarctic_grass + use pftconMod , only : nc3crop, nc3irrig + use pftconMod , only : npcropmin, npcropmax + implicit none + integer, intent(in) :: veg_type + + real(r8) :: ztop + + ! Bare soil, won't be used + if ( veg_type == noveg ) then + ztop = nan + ! temperate and boreal evergreen needleleaf trees + else if ( veg_type == ndllf_evr_tmp_tree .or. veg_type == ndllf_evr_brl_tree ) then + ztop = 4.e3_r8 ! m + ! temperate and boreal trees + else if ( veg_type == ndllf_dcd_brl_tree .or. veg_type == nbrdlf_evr_tmp_tree .or. & + veg_type == nbrdlf_dcd_tmp_tree .or. veg_type == nbrdlf_dcd_brl_tree ) then + ztop = 3.e3_r8 ! m + ! tropical broadleaf trees (evergreen and decidious) + else if ( veg_type == nbrdlf_evr_trp_tree .or. veg_type == nbrdlf_dcd_trp_tree ) then + ztop = 2.5e3_r8 ! m + ! shrubs + else if ( veg_type >= nbrdlf_evr_shrub .and. veg_type <= nbrdlf_dcd_brl_shrub ) then + ztop = 2.e3_r8 ! m + ! grasses + else if ( veg_type >= nc3_arctic_grass .and. veg_type <= nc3_nonarctic_grass ) then + ztop = 1.e3_r8 ! m + ! generic unmanaged crops + else if ( veg_type == nc3crop .or. veg_type <= nc3irrig ) then + ztop = 1.e3_r8 ! m + ! Prognostic crops + else if ( veg_type >= npcropmin .and. veg_type <= npcropmax ) then + ztop = 1.e3_r8 ! m + else + call endrun('ERROR:: undefined veg_type' ) + end if + + end function vert_dist_top + +end module CNFireEmissionsMod + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireFactoryMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireFactoryMod.F90 new file mode 100755 index 000000000..dbd9b70d1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireFactoryMod.F90 @@ -0,0 +1,129 @@ +module CNFireFactoryMod + + !--------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Factory to create an instance of fire_method_type. This module figures + ! out the particular type to return. + ! + ! !USES: + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog + + implicit none + save + private + ! + ! !PUBLIC ROUTINES: + public :: CNFireReadNML ! read the fire namelist + public :: create_cnfire_method ! create an object of class fire_method_type + + ! !PRIVATE DATA MEMBERS: + character(len=80), private :: fire_method = "li2014qianfrc" + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + subroutine CNFireReadNML( NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for cnfire + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'CNFireReadNML' + character(len=*), parameter :: nmlname = 'cnfire_inparm' + !----------------------------------------------------------------------- + + namelist /cnfire_inparm/ fire_method + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=cnfire_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR finding "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (fire_method, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=cnfire_inparm) + write(iulog,*) ' ' + end if + end subroutine CNFireReadNML + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine create_cnfire_method( NLFilename, cnfire_method ) + ! + ! !DESCRIPTION: + ! Create and return an object of fire_method_type. The particular type + ! is determined based on a namelist parameter. + ! + ! !USES: + use shr_kind_mod , only : SHR_KIND_CL + use FireMethodType , only : fire_method_type + use CNFireNoFireMod , only : cnfire_nofire_type + use CNFireLi2014Mod , only : cnfire_li2014_type + use CNFireLi2016Mod , only : cnfire_li2016_type + use CNFireLi2021Mod , only : cnfire_li2021_type + use decompMod , only : bounds_type + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + class(fire_method_type), allocatable, intent(inout) :: cnfire_method + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'create_cnfire_method' + !----------------------------------------------------------------------- + + select case (trim(fire_method)) + + case ("nofire") + allocate(cnfire_nofire_type :: cnfire_method) + case ("li2014qianfrc") + allocate(cnfire_li2014_type :: cnfire_method) + case ("li2016crufrc") + allocate(cnfire_li2016_type :: cnfire_method) + case ("li2021gswpfrc") + allocate(cnfire_li2021_type :: cnfire_method) + + case default + write(iulog,*) subname//' ERROR: unknown method: ', fire_method + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + call cnfire_method%FireReadNML( NLFilename ) + + end subroutine create_cnfire_method + !----------------------------------------------------------------------- + +end module CNFireFactoryMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2014Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2014Mod.F90 new file mode 100755 index 000000000..62185163b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2014Mod.F90 @@ -0,0 +1,1505 @@ +module CNFireLi2014Mod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! module for fire dynamics + ! created in Nov, 2012 and revised in Apr, 2013 by F. Li and S. Levis + ! based on Li et al. (2012a,b; 2013) + ! revised in Apr, 2014 according Li et al.(2014) + ! Fire-related parameters were calibrated or tuned in Apr, 2013 based on the + ! 20th Century transient simulations at f19_g16 with (newfire05_clm45sci15_clm4_0_58) + ! a CLM4.5 version, Qian et al. (2006) atmospheric forcing, and + ! climatological lightning data. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8, CL => shr_kind_CL + use shr_const_mod , only : SHR_CONST_PI,SHR_CONST_TKFRZ + use shr_infnan_mod , only : shr_infnan_isnan + use clm_varctl , only : iulog, use_matrixcn, use_soil_matrixcn + use clm_varpar , only : nlevdecomp, ndecomp_pools, nlevdecomp_full + use clm_varcon , only : dzsoi_decomp + use pftconMod , only : noveg, pftcon + use abortutils , only : endrun + use decompMod , only : bounds_type + use subgridAveMod , only : p2c + use atm2lndType , only : atm2lnd_type + use CNDVType , only : dgvs_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type, spinup_factor_deadwood + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use EnergyFluxType , only : energyflux_type + use SaturatedExcessRunoffMod , only : saturated_excess_runoff_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use SoilStateType , only : soilstate_type +! use SoilWaterRetentionCurveMod , only : soil_water_retention_curve_type + use GridcellType , only : grc + use ColumnType , only : col + use PatchType , only : patch + use FireMethodType , only : fire_method_type + use CNFireBaseMod , only : cnfire_base_type, cnfire_const, cnfire_params + use CN2CLMType + ! use CNVegMatrixMod , only : matrix_update_fic, matrix_update_fin + ! + implicit none + private + ! + ! !PUBLIC TYPES: + public :: cnfire_li2014_type + ! + type, extends(cnfire_base_type) :: cnfire_li2014_type + private + contains + ! + ! !PUBLIC MEMBER FUNCTIONS: + procedure, public :: need_lightning_and_popdens + procedure, public :: CNFireArea ! Calculate fire area + procedure, public :: CNFireFluxes + end type cnfire_li2014_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + function need_lightning_and_popdens(this) + ! !ARGUMENTS: + class(cnfire_li2014_type), intent(in) :: this + logical :: need_lightning_and_popdens ! function result + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'need_lightning_and_popdens' + !----------------------------------------------------------------------- + + need_lightning_and_popdens = .true. + end function need_lightning_and_popdens + + !----------------------------------------------------------------------- + subroutine CNFireArea (this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + atm2lnd_inst, energyflux_inst, saturated_excess_runoff_inst, waterdiagnosticbulk_inst, & + wateratm2lndbulk_inst, waterstatebulk_inst, soilstate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, totlitc_col, decomp_cpools_vr_col, t_soi17cm_col) + ! + ! !DESCRIPTION: + ! Computes column-level burned area + ! + ! !USES: + use clm_time_manager , only: get_step_size_real, get_days_per_year, get_curr_date, get_nstep + use clm_varcon , only: secspday, secsphr + use pftconMod , only: nc4_grass, nc3crop, ndllf_evr_tmp_tree + use pftconMod , only: nbrdlf_evr_trp_tree, nbrdlf_dcd_trp_tree, nbrdlf_evr_shrub + use dynSubgridControlMod , only: run_has_transient_landcover + ! + ! !ARGUMENTS: + class(cnfire_li2014_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(energyflux_type) , intent(in) :: energyflux_inst + type(saturated_excess_runoff_type) , intent(in) :: saturated_excess_runoff_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(wateratm2lndbulk_type) , intent(in) :: wateratm2lndbulk_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + !class(soil_water_retention_curve_type), intent(in) :: soil_water_retention_curve + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + real(r8) , intent(in) :: totlitc_col(bounds%begc:) + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,1:,1:) + real(r8) , intent(in) :: t_soi17cm_col(bounds%begc:) + ! + ! !LOCAL VARIABLES: + integer :: g,l,c,p,pi,j,fc,fp,kyr, kmo, kda, mcsec ! index variables + real(r8) :: dt ! time step variable (s) + real(r8) :: m ! top-layer soil moisture (proportion) + real(r8) :: dayspyr ! days per year + real(r8) :: cli ! effect of climate on deforestation fires (0-1) + real(r8) :: cri ! thresholds used for cli, (mm/d), see Eq.(7) in Li et al.(2013) + real(r8) :: fb ! availability of fuel for regs A and C + real(r8) :: fhd ! impact of hd on agricultural fire + real(r8) :: fgdp ! impact of gdp on agricultural fire + real(r8) :: fire_m ! combustability of fuel for fire occurrence + real(r8) :: spread_m ! combustability of fuel for fire spread + real(r8) :: Lb_lf ! length-to-breadth ratio added by Lifang + integer :: i_cwd ! cwd pool + real(r8) :: lh ! anthro. ignitions (count/km2/hr) + real(r8) :: fs ! hd-dependent fires suppression (0-1) + real(r8) :: ig ! total ignitions (count/km2/hr) + real(r8) :: hdmlf ! human density + real(r8) :: btran_col(bounds%begc:bounds%endc) + logical :: transient_landcover ! whether this run has any prescribed transient landcover + real(r8), target :: prec60_col_target(bounds%begc:bounds%endc) + real(r8), target :: prec10_col_target(bounds%begc:bounds%endc) + real(r8), pointer :: prec60_col(:) + real(r8), pointer :: prec10_col(:) + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(totlitc_col) == (/bounds%endc/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_cpools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(t_soi17cm_col) == (/bounds%endc/)) , sourcefile, __LINE__) + + associate( & + totlitc => totlitc_col , & ! Input: [real(r8) (:) ] (gC/m2) total lit C (column-level mean) + decomp_cpools_vr => decomp_cpools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) VR decomp. (litter, cwd, soil) + tsoi17 => t_soi17cm_col , & ! Input: [real(r8) (:) ] (K) soil T for top 0.17 m + lfuel => cnfire_const%lfuel , & ! Input: [real(r8) ] (gC/m2) Lower threshold of fuel mass + ufuel => cnfire_const%ufuel , & ! Input: [real(r8) ] (gC/m2) Upper threshold of fuel mass + rh_hgh => cnfire_const%rh_hgh , & ! Input: [real(r8) ] (%) High relative humidity + rh_low => cnfire_const%rh_low , & ! Input: [real(r8) ] (%) Low relative humidity + bt_min => cnfire_const%bt_min , & ! Input: [real(r8) ] (0-1) Minimum btran + bt_max => cnfire_const%bt_max , & ! Input: [real(r8) ] (0-1) Maximum btran + cli_scale => cnfire_const%cli_scale , & ! Input: [real(r8) ] (/d) global constant for deforestation fires + cropfire_a1 => cnfire_const%cropfire_a1 , & ! Input: [real(r8) ] (/hr) a1 parameter for cropland fire + non_boreal_peatfire_c => cnfire_const%non_boreal_peatfire_c , & ! Input: [real(r8) ] (/hr) c parameter for non-boreal peatland fire + pot_hmn_ign_counts_alpha => cnfire_const%pot_hmn_ign_counts_alpha , & ! Input: [real(r8) ] (/person/month) Potential human ignition counts + boreal_peatfire_c => cnfire_const%boreal_peatfire_c , & ! Input: [real(r8) ] (/hr) c parameter for boreal peatland fire + + fsr_pft => pftcon%fsr_pft , & ! Input: + fd_pft => pftcon%fd_pft , & ! Input: + + btran2 => this%cnfire_base_type%btran2_patch , & ! Input: [real(r8) (:) ] root zone soil wetness + fsat => saturated_excess_runoff_inst%fsat_col , & ! Input: [real(r8) (:) ] fractional area with water table at surface + wf => waterdiagnosticbulk_inst%wf_col , & ! Input: [real(r8) (:) ] soil water as frac. of whc for top 0.05 m + wf2 => waterdiagnosticbulk_inst%wf2_col , & ! Input: [real(r8) (:) ] soil water as frac. of whc for top 0.17 m + + is_cwd => decomp_cascade_con%is_cwd , & ! Input: [logical (:) ] TRUE => pool is a cwd pool + + forc_rh => wateratm2lndbulk_inst%forc_rh_grc , & ! Input: [real(r8) (:) ] relative humidity + forc_wind => atm2lnd_inst%forc_wind_grc , & ! Input: [real(r8) (:) ] atmospheric wind speed (m/s) + forc_t => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:) ] downscaled atmospheric temperature (Kelvin) + forc_rain => wateratm2lndbulk_inst%forc_rain_downscaled_col , & ! Input: [real(r8) (:) ] downscaled rain + forc_snow => wateratm2lndbulk_inst%forc_snow_downscaled_col , & ! Input: [real(r8) (:) ] downscaled snow + prec60 => wateratm2lndbulk_inst%prec60_patch , & ! Input: [real(r8) (:) ] 60-day running mean of tot. precipitation + prec10 => wateratm2lndbulk_inst%prec10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of tot. precipitation + + dwt_smoothed => cnveg_state_inst%dwt_smoothed_patch , & ! Input: [real(r8) (:) ] change in patch weight (-1 to 1) on the gridcell, smoothed over the year + cropf_col => cnveg_state_inst%cropf_col , & ! Input: [real(r8) (:) ] cropland fraction in veg column + gdp_lf => cnveg_state_inst%gdp_lf_col , & ! Input: [real(r8) (:) ] gdp data + peatf_lf => cnveg_state_inst%peatf_lf_col , & ! Input: [real(r8) (:) ] peatland fraction data + abm_lf => cnveg_state_inst%abm_lf_col , & ! Input: [integer (:) ] prescribed crop fire time + baf_crop => cnveg_state_inst%baf_crop_col , & ! Output: [real(r8) (:) ] burned area fraction for cropland (/sec) + baf_peatf => cnveg_state_inst%baf_peatf_col , & ! Output: [real(r8) (:) ] burned area fraction for peatland (/sec) + burndate => cnveg_state_inst%burndate_patch , & ! Output: [integer (:) ] burn date for crop + fbac => cnveg_state_inst%fbac_col , & ! Output: [real(r8) (:) ] total burned area out of conversion (/sec) + fbac1 => cnveg_state_inst%fbac1_col , & ! Output: [real(r8) (:) ] burned area out of conversion region due to land use fire + farea_burned => cnveg_state_inst%farea_burned_col , & ! Output: [real(r8) (:) ] total fractional area burned (/sec) + nfire => cnveg_state_inst%nfire_col , & ! Output: [real(r8) (:) ] fire counts (count/km2/sec), valid only in Reg. C + fsr_col => cnveg_state_inst%fsr_col , & ! Output: [real(r8) (:) ] fire spread rate at column level + fd_col => cnveg_state_inst%fd_col , & ! Output: [real(r8) (:) ] fire duration rate at column level + lgdp_col => cnveg_state_inst%lgdp_col , & ! Output: [real(r8) (:) ] gdp limitation factor for nfire + lgdp1_col => cnveg_state_inst%lgdp1_col , & ! Output: [real(r8) (:) ] gdp limitation factor for baf per fire + lpop_col => cnveg_state_inst%lpop_col , & ! Output: [real(r8) (:) ] pop limitation factor for baf per fire + lfwt => cnveg_state_inst%lfwt_col , & ! Output: [real(r8) (:) ] fractional coverage of non-crop and non-bare-soil Patches + trotr1_col => cnveg_state_inst%trotr1_col , & ! Output: [real(r8) (:) ] patch weight of BET on the column (0-1) + trotr2_col => cnveg_state_inst%trotr2_col , & ! Output: [real(r8) (:) ] patch weight of BDT on the column (0-1) + dtrotr_col => cnveg_state_inst%dtrotr_col , & ! Output: [real(r8) (:) ] decreased frac. coverage of BET+BDT on grid for dt + lfc => cnveg_state_inst%lfc_col , & ! Output: [real(r8) (:) ] conversion area frac. of BET+BDT that haven't burned before + wtlf => cnveg_state_inst%wtlf_col , & ! Output: [real(r8) (:) ] fractional coverage of non-crop Patches + + totvegc => cnveg_carbonstate_inst%totvegc_col , & ! Input: [real(r8) (:) ] totvegc at column level + deadcrootc => cnveg_carbonstate_inst%deadcrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C + deadcrootc_storage => cnveg_carbonstate_inst%deadcrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C storage + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C storage + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C transfer + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C storage + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C transfer + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C storage + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C transfer + rootc_col => cnveg_carbonstate_inst%rootc_col , & ! Output: [real(r8) (:) ] root carbon + leafc_col => cnveg_carbonstate_inst%leafc_col , & ! Output: [real(r8) (:) ] leaf carbon at column level + fuelc => cnveg_carbonstate_inst%fuelc_col , & ! Output: [real(r8) (:) ] fuel avalability factor for Reg.C + fuelc_crop => cnveg_carbonstate_inst%fuelc_crop_col & ! Output: [real(r8) (:) ] fuel avalability factor for Reg.A + ) + + ! jkolassa Mar 2023: insert Catch values in CLM types + + this%forc_hdm = cn2clm_inst%forc_hdm_cn2clm + this%forc_lnfm = cn2clm_inst%forc_lnfm_cn2clm + + transient_landcover = run_has_transient_landcover() + + !pft to column average + prec10_col =>prec10_col_target + call p2c(bounds, num_soilc, filter_soilc, & + prec10(bounds%begp:bounds%endp), & + prec10_col(bounds%begc:bounds%endc)) + + prec60_col =>prec60_col_target + call p2c(bounds, num_soilc, filter_soilc, & + prec60(bounds%begp:bounds%endp), & + prec60_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + leafc(bounds%begp:bounds%endp), & + leafc_col(bounds%begc:bounds%endc)) + + call get_curr_date (kyr, kmo, kda, mcsec) + dayspyr = get_days_per_year() + ! Get model step size + dt = get_step_size_real() + ! + ! On first time-step, just set area burned to zero and exit + ! + if ( get_nstep() == 0 )then + do fc = 1,num_soilc + c = filter_soilc(fc) + farea_burned(c) = 0._r8 + baf_crop(c) = 0._r8 + baf_peatf(c) = 0._r8 + fbac(c) = 0._r8 + fbac1(c) = 0._r8 + cropf_col(c) = 0._r8 + end do + return + end if + ! + ! Calculate fraction of crop (cropf_col) and non-crop and non-bare-soil + ! vegetation (lfwt) in vegetated column + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + cropf_col(c) = 0._r8 + lfwt(c) = 0._r8 + end do + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + ! For crop veg types + if( patch%itype(p) > nc4_grass )then + cropf_col(c) = cropf_col(c) + patch%wtcol(p) + end if + ! For natural vegetation (non-crop and non-bare-soil) + if( patch%itype(p) >= ndllf_evr_tmp_tree .and. patch%itype(p) <= nc4_grass )then + lfwt(c) = lfwt(c) + patch%wtcol(p) + end if + end do + ! + ! Calculate crop fuel + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + fuelc_crop(c)=0._r8 + end do + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + ! For crop PFTs, fuel load includes leaf and litter; only + ! column-level litter carbon + ! is available, so we use leaf carbon to estimate the + ! litter carbon for crop PFTs + if( patch%itype(p) > nc4_grass .and. patch%wtcol(p) > 0._r8 .and. leafc_col(c) > 0._r8 )then + fuelc_crop(c)=fuelc_crop(c) + (leafc(p) + leafc_storage(p) + & + leafc_xfer(p))*patch%wtcol(p)/cropf_col(c) + & + totlitc(c)*leafc(p)/leafc_col(c)*patch%wtcol(p)/cropf_col(c) + end if + end do + ! + ! Calculate noncrop column variables + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + fsr_col(c) = 0._r8 + fd_col(c) = 0._r8 + rootc_col(c) = 0._r8 + lgdp_col(c) = 0._r8 + lgdp1_col(c) = 0._r8 + lpop_col(c) = 0._r8 + btran_col(c) = 0._r8 + wtlf(c) = 0._r8 + trotr1_col(c)= 0._r8 + trotr2_col(c)= 0._r8 + if (transient_landcover) then + dtrotr_col(c)=0._r8 + end if + end do + + ! This subroutine calculates btran2 + ! call this%CNFire_calc_fire_root_wetness_Li2014(bounds, & + ! num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + ! waterstatebulk_inst, soilstate_inst, soil_water_retention_curve) + + ! jkolassa Mar 2023: insert Catchment btran2 + + btran2 = cn2clm_inst%btran2_patch_cn2clm + + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + c = patch%column(p) + ! For non-crop -- natural vegetation and bare-soil + if( patch%itype(p) < nc3crop .and. cropf_col(c) < 1.0_r8 )then + btran_col(c) = btran_col(c)+btran2(p)*patch%wtcol(p) + wtlf(c) = wtlf(c)+patch%wtcol(p) + end if + end do + + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = col%gridcell(c) + + ! For non-crop -- natural vegetation and bare-soil + if( patch%itype(p) < nc3crop .and. cropf_col(c) < 1.0_r8 )then + + ! NOTE(wjs, 2016-12-15) These calculations of the fraction of evergreen + ! and deciduous tropical trees (used to determine if a column is + ! tropical closed forest) use the current fractions. However, I think + ! they are used in code that applies to land cover change. Note that + ! land cover change is currently generated on the first time step of the + ! year (even though the fire code sees the annually-smoothed dwt). Thus, + ! I think that, for this to be totally consistent, this code should + ! consider the fractional coverage of each PFT prior to the relevant + ! land cover change event. (These fractions could be computed in the + ! code that handles land cover change, so that the fire code remains + ! agnostic to exactly how and when land cover change happens.) + ! + ! For example, if a year started with fractional coverages of + ! nbrdlf_evr_trp_tree = 0.35 and nbrdlf_dcd_trp_tree = 0.35, but then + ! the start-of-year land cover change reduced both of these to 0.2: The + ! current code would consider the column to NOT be tropical closed + ! forest (because nbrdlf_evr_trp_tree+nbrdlf_dcd_trp_tree < 0.6), + ! whereas in fact the land cover change occurred when the column *was* + ! tropical closed forest. + if( patch%itype(p) == nbrdlf_evr_trp_tree .and. patch%wtcol(p) > 0._r8 )then + trotr1_col(c)=trotr1_col(c)+patch%wtcol(p) + end if + if( patch%itype(p) == nbrdlf_dcd_trp_tree .and. patch%wtcol(p) > 0._r8 )then + trotr2_col(c)=trotr2_col(c)+patch%wtcol(p) + end if + + if (transient_landcover) then + if( patch%itype(p) == nbrdlf_evr_trp_tree .or. patch%itype(p) == nbrdlf_dcd_trp_tree )then + if(dwt_smoothed(p) < 0._r8)then + ! Land cover change in CLM happens all at once on the first time + ! step of the year. However, the fire code needs deforestation + ! rates throughout the year, in order to combine these + ! deforestation rates with the current season's climate. So we + ! use a smoothed version of dwt. + ! + ! This isn't ideal, because the carbon stocks that the fire code + ! is operating on will have decreased by the full annual amount + ! before the fire code does anything. But the biggest effect of + ! these deforestation fires is as a trigger for other fires, and + ! the C fluxes are merely diagnostic so don't need to be + ! conservative, so this isn't a big issue. + ! + ! (Actually, it would be even better if the fire code had a + ! realistic breakdown of annual deforestation into the + ! different seasons. But having deforestation spread evenly + ! throughout the year is much better than having it all + ! concentrated on January 1.) + dtrotr_col(c)=dtrotr_col(c)-dwt_smoothed(p) + end if + end if + end if + rootc_col(c) = rootc_col(c) + (frootc(p) + frootc_storage(p) + & + frootc_xfer(p) + deadcrootc(p) + & + deadcrootc_storage(p) + deadcrootc_xfer(p) + & + livecrootc(p)+livecrootc_storage(p) + & + livecrootc_xfer(p))*patch%wtcol(p) + + fsr_col(c) = fsr_col(c) + fsr_pft(patch%itype(p))*patch%wtcol(p)/(1.0_r8-cropf_col(c)) + + if( lfwt(c) /= 0.0_r8 )then + hdmlf=this%forc_hdm(g) + + ! all these constants are in Li et al. BG (2012a,b;2013) + + if( hdmlf > 0.1_r8 )then + ! For NOT bare-soil + if( patch%itype(p) /= noveg )then + ! For shrub and grass (crop already excluded above) + if( patch%itype(p) >= nbrdlf_evr_shrub )then !for shurb and grass + lgdp_col(c) = lgdp_col(c) + (0.1_r8 + 0.9_r8* & + exp(-1._r8*SHR_CONST_PI* & + (gdp_lf(c)/8._r8)**0.5_r8))*patch%wtcol(p) & + /(1.0_r8 - cropf_col(c)) + lgdp1_col(c) = lgdp1_col(c) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*SHR_CONST_PI* & + (gdp_lf(c)/7._r8)))*patch%wtcol(p)/lfwt(c) + lpop_col(c) = lpop_col(c) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*SHR_CONST_PI* & + (hdmlf/450._r8)**0.5_r8))*patch%wtcol(p)/lfwt(c) + else ! for trees + if( gdp_lf(c) > 20._r8 )then + lgdp_col(c) =lgdp_col(c)+cnfire_const%occur_hi_gdp_tree*patch%wtcol(p)/(1.0_r8 - cropf_col(c)) + else + lgdp_col(c) = lgdp_col(c)+patch%wtcol(p)/(1.0_r8 - cropf_col(c)) + end if + if( gdp_lf(c) > 20._r8 )then + lgdp1_col(c) = lgdp1_col(c)+0.62_r8*patch%wtcol(p)/lfwt(c) + else + if( gdp_lf(c) > 8._r8 ) then + lgdp1_col(c)=lgdp1_col(c)+0.83_r8*patch%wtcol(p)/lfwt(c) + else + lgdp1_col(c)=lgdp1_col(c)+patch%wtcol(p)/lfwt(c) + end if + end if + lpop_col(c) = lpop_col(c) + (0.4_r8 + 0.6_r8* & + exp(-1._r8*SHR_CONST_PI* & + (hdmlf/125._r8)))*patch%wtcol(p)/lfwt(c) + end if + end if + else + lgdp_col(c) = lgdp_col(c)+patch%wtcol(p)/(1.0_r8 - cropf_col(c)) + lgdp1_col(c) = lgdp1_col(c)+patch%wtcol(p)/lfwt(c) + lpop_col(c) = lpop_col(c)+patch%wtcol(p)/lfwt(c) + end if + end if + + fd_col(c) = fd_col(c) + fd_pft(patch%itype(p)) * patch%wtcol(p) * secsphr / (1.0_r8-cropf_col(c)) + end if + end do + + ! estimate annual decreased fractional coverage of BET+BDT + ! land cover conversion in CLM4.5 is the same for each timestep except for the beginning + + if (transient_landcover) then + do fc = 1,num_soilc + c = filter_soilc(fc) + if( dtrotr_col(c) > 0._r8 )then + if( kmo == 1 .and. kda == 1 .and. mcsec == 0)then + lfc(c) = 0._r8 + end if + if( kmo == 1 .and. kda == 1 .and. mcsec == dt)then + lfc(c) = dtrotr_col(c)*dayspyr*secspday/dt + end if + else + lfc(c)=0._r8 + end if + end do + end if + ! + ! calculate burned area fraction in cropland + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + baf_crop(c)=0._r8 + end do + + do fp = 1,num_soilp + p = filter_soilp(fp) + if( kmo == 1 .and. kda == 1 .and. mcsec == 0 )then + burndate(p) = 10000 ! init. value; actual range [0 365] + end if + end do + + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = col%gridcell(c) + ! For crop + if( forc_t(c) >= SHR_CONST_TKFRZ .and. patch%itype(p) > nc4_grass .and. & + kmo == abm_lf(c) .and. forc_rain(c)+forc_snow(c) == 0._r8 .and. & + burndate(p) >= 999 .and. patch%wtcol(p) > 0._r8 )then ! catch crop burn time + + hdmlf = this%forc_hdm(g) + + ! calculate human density impact on ag. fire + fhd = 0.04_r8+0.96_r8*exp(-1._r8*SHR_CONST_PI*(hdmlf/350._r8)**0.5_r8) + + ! calculate impact of GDP on ag. fire + fgdp = 0.01_r8+0.99_r8*exp(-1._r8*SHR_CONST_PI*(gdp_lf(c)/10._r8)) + + ! calculate burned area + fb = max(0.0_r8,min(1.0_r8,(fuelc_crop(c)-lfuel)/(ufuel-lfuel))) + + ! crop fire only for generic crop types at this time + ! managed crops are treated as grasses if crop model is turned on + baf_crop(c) = baf_crop(c) + cropfire_a1/secsphr*fb*fhd*fgdp*patch%wtcol(p) + if( fb*fhd*fgdp*patch%wtcol(p) > 0._r8)then + burndate(p)=kda + end if + end if + end do + ! + ! calculate peatland fire + ! + do fc = 1, num_soilc + c = filter_soilc(fc) + g= col%gridcell(c) + if(grc%latdeg(g) < cnfire_const%borealat )then + baf_peatf(c) = non_boreal_peatfire_c/secsphr*max(0._r8, & + min(1._r8,(4.0_r8-prec60_col(c)*secspday)/ & + 4.0_r8))**2*peatf_lf(c)*(1._r8-fsat(c)) + else + baf_peatf(c) = boreal_peatfire_c/secsphr*exp(-SHR_CONST_PI*(max(wf2(c),0._r8)/0.3_r8))* & + max(0._r8,min(1._r8,(tsoi17(c)-SHR_CONST_TKFRZ)/10._r8))*peatf_lf(c)* & + (1._r8-fsat(c)) + end if + end do + ! + ! calculate other fires + ! + + ! Set the number of timesteps for e-folding. + ! When the simulation has run fewer than this number of steps, + ! re-scale the e-folding time to get a stable early estimate. + + ! find which pool is the cwd pool + i_cwd = 0 + do l = 1, ndecomp_pools + if ( is_cwd(l) ) then + i_cwd = l + endif + end do + + ! + ! begin column loop to calculate fractional area affected by fire + ! + do fc = 1, num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + hdmlf=this%forc_hdm(g) + + nfire(c) = 0._r8 + if( cropf_col(c) < 1.0 )then + if (trotr1_col(c)+trotr2_col(c)>0.6_r8) then + farea_burned(c)=min(1.0_r8,baf_crop(c)+baf_peatf(c)) + else + fuelc(c) = totlitc(c)+totvegc(c)-rootc_col(c)-fuelc_crop(c)*cropf_col(c) + do j = 1, nlevdecomp + fuelc(c) = fuelc(c)+decomp_cpools_vr(c,j,i_cwd) * dzsoi_decomp(j) + end do + fuelc(c) = fuelc(c)/(1._r8-cropf_col(c)) + fb = max(0.0_r8,min(1.0_r8,(fuelc(c)-lfuel)/(ufuel-lfuel))) + m = max(0._r8,wf(c)) + fire_m = exp(-SHR_CONST_PI *(m/0.69_r8)**2)*(1.0_r8 - max(0._r8, & + min(1._r8,(forc_rh(g)-rh_low)/(rh_hgh-rh_low))))* & + min(1._r8,exp(SHR_CONST_PI*(forc_t(c)-SHR_CONST_TKFRZ)/10._r8)) + lh = pot_hmn_ign_counts_alpha*6.8_r8*hdmlf**(0.43_r8)/30._r8/24._r8 + fs = 1._r8-(0.01_r8+0.98_r8*exp(-0.025_r8*hdmlf)) + ig = (lh+this%forc_lnfm(g)/(5.16_r8+2.16_r8*cos(3._r8*grc%lat(g)))* & + cnfire_params%ignition_efficiency)*(1._r8-fs)*(1._r8-cropf_col(c)) + nfire(c) = ig/secsphr*fb*fire_m*lgdp_col(c) !fire counts/km2/sec + Lb_lf = 1._r8+10.0_r8*(1._r8-EXP(-0.06_r8*forc_wind(g))) + if ( wtlf(c) > 0.0_r8 )then + spread_m = (1.0_r8 - max(0._r8,min(1._r8,(btran_col(c)/wtlf(c)-bt_min)/ & + (bt_max-bt_min))))*(1.0_r8-max(0._r8, & + min(1._r8,(forc_rh(g)-rh_low)/(rh_hgh-rh_low)))) + else + spread_m = 0.0_r8 + end if + farea_burned(c) = min(1._r8,(cnfire_const%g0*spread_m*fsr_col(c)* & + fd_col(c)/1000._r8)**2*lgdp1_col(c)* & + lpop_col(c)*nfire(c)*SHR_CONST_PI*Lb_lf+ & + baf_crop(c)+baf_peatf(c)) ! fraction (0-1) per sec + end if + ! + ! if landuse change data is used, calculate deforestation fires and + ! add it in the total of burned area fraction + ! + if (transient_landcover) then + if( trotr1_col(c)+trotr2_col(c) > 0.6_r8 )then + if(( kmo == 1 .and. kda == 1 .and. mcsec == 0) .or. & + dtrotr_col(c) <=0._r8 )then + fbac1(c) = 0._r8 + farea_burned(c) = baf_crop(c)+baf_peatf(c) + else + cri = (4.0_r8*trotr1_col(c)+1.8_r8*trotr2_col(c))/(trotr1_col(c)+trotr2_col(c)) + cli = (max(0._r8,min(1._r8,(cri-prec60_col(c)*secspday)/cri))**0.5)* & + (max(0._r8,min(1._r8,(cri-prec10_col(c)*secspday)/cri))**0.5)* & + max(0.0005_r8,min(1._r8,19._r8*dtrotr_col(c)*dayspyr*secspday/dt-0.001_r8))* & + max(0._r8,min(1._r8,(0.25_r8-(forc_rain(c)+forc_snow(c))*secsphr)/0.25_r8)) + farea_burned(c) = cli*(cli_scale/secspday)+baf_crop(c)+baf_peatf(c) + ! burned area out of conversion region due to land use fire + fbac1(c) = max(0._r8,cli*(cli_scale/secspday) - 2.0_r8*lfc(c)/dt) + end if + ! total burned area out of conversion + fbac(c) = fbac1(c)+baf_crop(c)+baf_peatf(c) + else + fbac(c) = farea_burned(c) + end if + end if + + else + farea_burned(c) = min(1._r8,baf_crop(c)+baf_peatf(c)) + end if + + end do ! end of column loop + + end associate + + end subroutine CNFireArea + + !----------------------------------------------------------------------- + subroutine CNFireFluxes (this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_actfirec, filter_actfirec, num_actfirep, filter_actfirep, dgvs_inst, cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, leaf_prof_patch, froot_prof_patch, croot_prof_patch, stem_prof_patch, & + totsomc_col, decomp_cpools_vr_col, decomp_npools_vr_col, somc_fire_col) + ! + ! !DESCRIPTION: + ! Fire effects routine for coupled carbon-nitrogen code (CN). + ! Relies primarily on estimate of fractional area burned, from CNFireArea(). + ! + ! Total fire carbon emissions (g C/m2 land area/yr) + ! =avg(COL_FIRE_CLOSS)*seconds_per_year + avg(SOMC_FIRE)*seconds_per_year + + ! avg(LF_CONV_CFLUX)*seconds_per_year*min(1.0,avg(LFC2)*seconds_per_year)*0.8 + ! where avg means the temporal average in a year + ! seconds_per_year is the number of seconds in a year. + ! + ! !USES: + use clm_time_manager , only: get_step_size_real,get_days_per_year,get_curr_date + use clm_varctl , only: use_cndv + use clm_varcon , only: secspday + use pftconMod , only: nc3crop + use dynSubgridControlMod , only: run_has_transient_landcover + use clm_varpar , only: ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,iretransn,ioutc,ioutn + ! + ! !ARGUMENTS: + class(cnfire_li2014_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(out) :: num_actfirep ! number of active patches on fire in filter + integer , intent(out) :: filter_actfirep(:) ! filter for soil patches + integer , intent(out) :: num_actfirec ! number of active columns on fire in filter + integer , intent(out) :: filter_actfirec(:) ! filter for soil columns + type(dgvs_type) , intent(inout) :: dgvs_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + real(r8) , intent(in) :: leaf_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: froot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: croot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: stem_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: totsomc_col(bounds%begc:) ! (gC/m2) total soil organic matter C + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,1:,1:) ! (gC/m3) VR decomp. (litter, cwd, soil) + real(r8) , intent(in) :: decomp_npools_vr_col(bounds%begc:,1:,1:) ! (gC/m3) VR decomp. (litter, cwd, soil) + real(r8) , intent(out) :: somc_fire_col(bounds%begc:) ! (gC/m2/s) fire C emissions due to peat burning + ! + ! !LOCAL VARIABLES: + integer :: g,c,p,j,l,pi,kyr, kmo, kda, mcsec ! indices + integer :: fp,fc ! filter indices + real(r8):: f ! rate for fire effects (1/s) + real(r8):: m ! acceleration factor for fuel carbon + real(r8):: dt ! time step variable (s) + real(r8):: dayspyr ! days per year + logical :: transient_landcover ! whether this run has any prescribed transient landcover + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(leaf_prof_patch) == (/bounds%endp,nlevdecomp_full/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(froot_prof_patch) == (/bounds%endp,nlevdecomp_full/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(croot_prof_patch) == (/bounds%endp,nlevdecomp_full/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(stem_prof_patch) == (/bounds%endp,nlevdecomp_full/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(totsomc_col) == (/bounds%endc/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_cpools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_npools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(somc_fire_col) == (/bounds%endc/)) , sourcefile, __LINE__) + + ! NOTE: VR = Vertically Resolved + ! conv. = conversion + ! frac. = fraction + ! BAF = Burned Area Fraction + ! ann. = annual + ! GC = gridcell + ! dt = timestep + ! C = Carbon + ! N = Nitrogen + ! emis. = emissions + ! decomp. = decomposing + + associate( & + croot_prof => croot_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of coarse roots + stem_prof => stem_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of stems + froot_prof => froot_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of fine roots + leaf_prof => leaf_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of leaves + totsomc => totsomc_col , & ! Input: [real(r8) (:) ] (gC/m2) total soil organic matter C + decomp_cpools_vr => decomp_cpools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) VR decomp. (litter, cwd, soil) + decomp_npools_vr => decomp_npools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) VR decomp. (litter, cwd, soil) + somc_fire => somc_fire_col , & ! Output: [real(r8) (:) ] (gC/m2/s) fire C emissions due to peat burning + + is_cwd => decomp_cascade_con%is_cwd , & ! Input: [logical (:) ] TRUE => pool is a cwd pool + is_litter => decomp_cascade_con%is_litter , & ! Input: [logical (:) ] TRUE => pool is a litter pool + + woody => pftcon%woody , & ! Input: woody lifeform (1=woody, 0=not woody) + cc_leaf => pftcon%cc_leaf , & ! Input: + cc_lstem => pftcon%cc_lstem , & ! Input: + cc_dstem => pftcon%cc_dstem , & ! Input: + cc_other => pftcon%cc_other , & ! Input: + fm_leaf => pftcon%fm_leaf , & ! Input: + fm_lstem => pftcon%fm_lstem , & ! Input: + fm_other => pftcon%fm_other , & ! Input: + fm_root => pftcon%fm_root , & ! Input: + fm_lroot => pftcon%fm_lroot , & ! Input: + fm_droot => pftcon%fm_droot , & ! Input: + lf_flab => pftcon%lf_flab , & ! Input: + lf_fcel => pftcon%lf_fcel , & ! Input: + lf_flig => pftcon%lf_flig , & ! Input: + fr_flab => pftcon%fr_flab , & ! Input: + fr_fcel => pftcon%fr_fcel , & ! Input: + fr_flig => pftcon%fr_flig , & ! Input: + + nind => dgvs_inst%nind_patch , & ! Input: [real(r8) (:) ] number of individuals (#/m2) + + cropf_col => cnveg_state_inst%cropf_col , & ! Input: [real(r8) (:) ] cropland fraction in veg column + farea_burned => cnveg_state_inst%farea_burned_col , & ! Input: [real(r8) (:) ] fractional area burned (/sec) + fbac1 => cnveg_state_inst%fbac1_col , & ! Input: [real(r8) (:) ] burned area out of conv. region due to LU fire + fbac => cnveg_state_inst%fbac_col , & ! Input: [real(r8) (:) ] total burned area out of conversion (/sec) + baf_crop => cnveg_state_inst%baf_crop_col , & ! Input: [real(r8) (:) ] BAF for cropland + baf_peatf => cnveg_state_inst%baf_peatf_col , & ! Input: [real(r8) (:) ] BAF for peatlabd + trotr1_col => cnveg_state_inst%trotr1_col , & ! Input: [real(r8) (:) ] patch weight of BET on the column (0-1) + trotr2_col => cnveg_state_inst%trotr2_col , & ! Input: [real(r8) (:) ] patch weight of BDT on the column (0-1) + dtrotr_col => cnveg_state_inst%dtrotr_col , & ! Input: [real(r8) (:) ] ann. decreased frac. coverage of BET+BDT (0-1) on GC + lfc => cnveg_state_inst%lfc_col , & ! Input: [real(r8) (:) ] conv. area frac. of BET+BDT that haven't burned before + lfc2 => cnveg_state_inst%lfc2_col , & ! Output: [real(r8) (:) ] conv. area frac. of BET+BDT burned this dt (/sec) + + leafcmax => cnveg_carbonstate_inst%leafcmax_patch , & ! Output: [real(r8) (:) ] (gC/m2) ann max leaf C + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C storage + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C transfer + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C + livestemc_storage => cnveg_carbonstate_inst%livestemc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C storage + livestemc_xfer => cnveg_carbonstate_inst%livestemc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C transfer + deadstemc => cnveg_carbonstate_inst%deadstemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C + deadstemc_storage => cnveg_carbonstate_inst%deadstemc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C storage + deadstemc_xfer => cnveg_carbonstate_inst%deadstemc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C transfer + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C storage + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C transfer + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C storage + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C transfer + deadcrootc => cnveg_carbonstate_inst%deadcrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C + deadcrootc_storage => cnveg_carbonstate_inst%deadcrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C storage + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + gresp_storage => cnveg_carbonstate_inst%gresp_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) growth respiration storage + gresp_xfer => cnveg_carbonstate_inst%gresp_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) growth respiration transfer + + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N + leafn_storage => cnveg_nitrogenstate_inst%leafn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N storage + leafn_xfer => cnveg_nitrogenstate_inst%leafn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N transfer + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N + livestemn_storage => cnveg_nitrogenstate_inst%livestemn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N storage + livestemn_xfer => cnveg_nitrogenstate_inst%livestemn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N transfer + deadstemn => cnveg_nitrogenstate_inst%deadstemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N + deadstemn_storage => cnveg_nitrogenstate_inst%deadstemn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N storage + deadstemn_xfer => cnveg_nitrogenstate_inst%deadstemn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N transfer + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N + frootn_storage => cnveg_nitrogenstate_inst%frootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N storage + frootn_xfer => cnveg_nitrogenstate_inst%frootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N transfer + livecrootn => cnveg_nitrogenstate_inst%livecrootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N + livecrootn_storage => cnveg_nitrogenstate_inst%livecrootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N storage + livecrootn_xfer => cnveg_nitrogenstate_inst%livecrootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N transfer + deadcrootn => cnveg_nitrogenstate_inst%deadcrootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N + deadcrootn_storage => cnveg_nitrogenstate_inst%deadcrootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N storage + deadcrootn_xfer => cnveg_nitrogenstate_inst%deadcrootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N transfer + retransn => cnveg_nitrogenstate_inst%retransn_patch , & ! Input: [real(r8) (:) ] (gN/m2) plant pool of retranslocated N + + fire_mortality_c_to_cwdc => cnveg_carbonflux_inst%fire_mortality_c_to_cwdc_col , & ! Input: [real(r8) (:,:) ] C flux fire mortality to CWD (gC/m3/s) + m_leafc_to_fire => cnveg_carbonflux_inst%m_leafc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) fire C emis. from leafc + m_leafc_storage_to_fire => cnveg_carbonflux_inst%m_leafc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) fire C emis. from leafc_storage + m_leafc_xfer_to_fire => cnveg_carbonflux_inst%m_leafc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) fire C emis. from leafc_xfer + m_livestemc_to_fire => cnveg_carbonflux_inst%m_livestemc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) fire C emis. from livestemc + m_livestemc_storage_to_fire => cnveg_carbonflux_inst%m_livestemc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livestemc_storage + m_livestemc_xfer_to_fire => cnveg_carbonflux_inst%m_livestemc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livestemc_xfer + m_deadstemc_to_fire => cnveg_carbonflux_inst%m_deadstemc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadstemc_xfer + m_deadstemc_storage_to_fire => cnveg_carbonflux_inst%m_deadstemc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadstemc_storage + m_deadstemc_xfer_to_fire => cnveg_carbonflux_inst%m_deadstemc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadstemc_xfer + m_frootc_to_fire => cnveg_carbonflux_inst%m_frootc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. frootc + m_frootc_storage_to_fire => cnveg_carbonflux_inst%m_frootc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. frootc_storage + m_frootc_xfer_to_fire => cnveg_carbonflux_inst%m_frootc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. frootc_xfer + m_livecrootc_to_fire => cnveg_carbonflux_inst%m_livecrootc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livecrootc + m_livecrootc_storage_to_fire => cnveg_carbonflux_inst%m_livecrootc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livecrootc_storage + m_livecrootc_xfer_to_fire => cnveg_carbonflux_inst%m_livecrootc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. livecrootc_xfer + m_deadcrootc_to_fire => cnveg_carbonflux_inst%m_deadcrootc_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadcrootc + m_deadcrootc_storage_to_fire => cnveg_carbonflux_inst%m_deadcrootc_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadcrootc_storage + m_deadcrootc_xfer_to_fire => cnveg_carbonflux_inst%m_deadcrootc_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. deadcrootc_xfer + m_gresp_storage_to_fire => cnveg_carbonflux_inst%m_gresp_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. gresp_storage + m_gresp_xfer_to_fire => cnveg_carbonflux_inst%m_gresp_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) C emis. gresp_xfer + m_leafc_to_litter_fire => cnveg_carbonflux_inst%m_leafc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_leafc_storage_to_litter_fire => cnveg_carbonflux_inst%m_leafc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_leafc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_leafc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemc_to_litter_fire => cnveg_carbonflux_inst%m_livestemc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemc_storage_to_litter_fire => cnveg_carbonflux_inst%m_livestemc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_livestemc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemc_to_deadstemc_fire => cnveg_carbonflux_inst%m_livestemc_to_deadstemc_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemc_to_litter_fire => cnveg_carbonflux_inst%m_deadstemc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemc_storage_to_litter_fire => cnveg_carbonflux_inst%m_deadstemc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_deadstemc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootc_to_litter_fire => cnveg_carbonflux_inst%m_frootc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootc_storage_to_litter_fire => cnveg_carbonflux_inst%m_frootc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_frootc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootc_to_litter_fire => cnveg_carbonflux_inst%m_livecrootc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootc_storage_to_litter_fire => cnveg_carbonflux_inst%m_livecrootc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_livecrootc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootc_to_deadcrootc_fire => cnveg_carbonflux_inst%m_livecrootc_to_deadcrootc_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootc_to_litter_fire => cnveg_carbonflux_inst%m_deadcrootc_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootc_storage_to_litter_fire => cnveg_carbonflux_inst%m_deadcrootc_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootc_xfer_to_litter_fire => cnveg_carbonflux_inst%m_deadcrootc_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_gresp_storage_to_litter_fire => cnveg_carbonflux_inst%m_gresp_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_gresp_xfer_to_litter_fire => cnveg_carbonflux_inst%m_gresp_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_decomp_cpools_to_fire_vr => cnveg_carbonflux_inst%m_decomp_cpools_to_fire_vr_col , & ! Output: [real(r8) (:,:,:) ] (gC/m3/s) VR decomp. C fire loss + m_c_to_litr_met_fire => cnveg_carbonflux_inst%m_c_to_litr_met_fire_col , & ! Output: [real(r8) (:,:) ] + m_c_to_litr_cel_fire => cnveg_carbonflux_inst%m_c_to_litr_cel_fire_col , & ! Output: [real(r8) (:,:) ] + m_c_to_litr_lig_fire => cnveg_carbonflux_inst%m_c_to_litr_lig_fire_col , & ! Output: [real(r8) (:,:) ] + + fire_mortality_n_to_cwdn => cnveg_nitrogenflux_inst%fire_mortality_n_to_cwdn_col , & ! Input: [real(r8) (:,:) ] N flux fire mortality to CWD (gN/m3/s) + m_leafn_to_fire => cnveg_nitrogenflux_inst%m_leafn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. leafn + m_leafn_storage_to_fire => cnveg_nitrogenflux_inst%m_leafn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. leafn_storage + m_leafn_xfer_to_fire => cnveg_nitrogenflux_inst%m_leafn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. leafn_xfer + m_livestemn_to_fire => cnveg_nitrogenflux_inst%m_livestemn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livestemn + m_livestemn_storage_to_fire => cnveg_nitrogenflux_inst%m_livestemn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livestemn_s + m_livestemn_xfer_to_fire => cnveg_nitrogenflux_inst%m_livestemn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livestemn_xfer + m_deadstemn_to_fire => cnveg_nitrogenflux_inst%m_deadstemn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadstemn + m_deadstemn_storage_to_fire => cnveg_nitrogenflux_inst%m_deadstemn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadstemn_storage + m_deadstemn_xfer_to_fire => cnveg_nitrogenflux_inst%m_deadstemn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadstemn_xfer + m_frootn_to_fire => cnveg_nitrogenflux_inst%m_frootn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. frootn + m_frootn_storage_to_fire => cnveg_nitrogenflux_inst%m_frootn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. frootn_storage + m_frootn_xfer_to_fire => cnveg_nitrogenflux_inst%m_frootn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. frootn_xfer + m_livecrootn_to_fire => cnveg_nitrogenflux_inst%m_livecrootn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. m_livecrootn_to_fire + m_livecrootn_storage_to_fire => cnveg_nitrogenflux_inst%m_livecrootn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livecrootn_storage + m_livecrootn_xfer_to_fire => cnveg_nitrogenflux_inst%m_livecrootn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. livecrootn_xfer + m_deadcrootn_to_fire => cnveg_nitrogenflux_inst%m_deadcrootn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadcrootn + m_deadcrootn_storage_to_fire => cnveg_nitrogenflux_inst%m_deadcrootn_storage_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadcrootn_storage + m_deadcrootn_xfer_to_fire => cnveg_nitrogenflux_inst%m_deadcrootn_xfer_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. deadcrootn_xfer + m_retransn_to_fire => cnveg_nitrogenflux_inst%m_retransn_to_fire_patch , & ! Input: [real(r8) (:) ] (gN/m2/s) N emis. retransn + m_leafn_to_litter_fire => cnveg_nitrogenflux_inst%m_leafn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_leafn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_leafn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_leafn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_leafn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemn_to_litter_fire => cnveg_nitrogenflux_inst%m_livestemn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_livestemn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_livestemn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livestemn_to_deadstemn_fire => cnveg_nitrogenflux_inst%m_livestemn_to_deadstemn_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemn_to_litter_fire => cnveg_nitrogenflux_inst%m_deadstemn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_deadstemn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadstemn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_deadstemn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootn_to_litter_fire => cnveg_nitrogenflux_inst%m_frootn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_frootn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_frootn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_frootn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootn_to_litter_fire => cnveg_nitrogenflux_inst%m_livecrootn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_livecrootn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_livecrootn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_livecrootn_to_deadcrootn_fire => cnveg_nitrogenflux_inst%m_livecrootn_to_deadcrootn_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootn_to_litter_fire => cnveg_nitrogenflux_inst%m_deadcrootn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootn_storage_to_litter_fire => cnveg_nitrogenflux_inst%m_deadcrootn_storage_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_deadcrootn_xfer_to_litter_fire => cnveg_nitrogenflux_inst%m_deadcrootn_xfer_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_retransn_to_litter_fire => cnveg_nitrogenflux_inst%m_retransn_to_litter_fire_patch , & ! Output: [real(r8) (:) ] + m_decomp_npools_to_fire_vr => cnveg_nitrogenflux_inst%m_decomp_npools_to_fire_vr_col , & ! Output: [real(r8) (:,:,:) ] VR decomp. N fire loss (gN/m3/s) + m_n_to_litr_met_fire => cnveg_nitrogenflux_inst%m_n_to_litr_met_fire_col , & ! Output: [real(r8) (:,:) ] + m_n_to_litr_cel_fire => cnveg_nitrogenflux_inst%m_n_to_litr_cel_fire_col , & ! Output: [real(r8) (:,:) ] + m_n_to_litr_lig_fire => cnveg_nitrogenflux_inst%m_n_to_litr_lig_fire_col , & ! Output: [real(r8) (:,:) ] + ileaf_to_iout_fic => cnveg_carbonflux_inst%ileaf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from leaf pool to outside of vegetation pools + ileafst_to_iout_fic => cnveg_carbonflux_inst%ileafst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from leaf storage pool to outside of vegetation pools + ileafxf_to_iout_fic => cnveg_carbonflux_inst%ileafxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from leaf transfer pool to outside of vegetation pools + ifroot_to_iout_fic => cnveg_carbonflux_inst%ifroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from fine root pool to outside of vegetation pools + ifrootst_to_iout_fic => cnveg_carbonflux_inst%ifrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from fine root storage pool to outside of vegetation pools + ifrootxf_to_iout_fic => cnveg_carbonflux_inst%ifrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from fine root transfer pool to outside of vegetation pools + ilivestem_to_iout_fic => cnveg_carbonflux_inst%ilivestem_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live stem pool to outside of vegetation pools + ilivestemst_to_iout_fic => cnveg_carbonflux_inst%ilivestemst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live stem storage pool to outside of vegetation pools + ilivestemxf_to_iout_fic => cnveg_carbonflux_inst%ilivestemxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live stem transfer pool to outside of vegetation pools + ideadstem_to_iout_fic => cnveg_carbonflux_inst%ideadstem_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead stem pool to outside of vegetation pools + ideadstemst_to_iout_fic => cnveg_carbonflux_inst%ideadstemst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead stem storage pool to outside of vegetation pools + ideadstemxf_to_iout_fic => cnveg_carbonflux_inst%ideadstemxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead stem transfer pool to outside of vegetation pools + ilivecroot_to_iout_fic => cnveg_carbonflux_inst%ilivecroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live coarse root pool to outside of vegetation pools + ilivecrootst_to_iout_fic => cnveg_carbonflux_inst%ilivecrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live coarse root storage pool to outside of vegetation pools + ilivecrootxf_to_iout_fic => cnveg_carbonflux_inst%ilivecrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from live coarse root transfer pool to outside of vegetation pools + ideadcroot_to_iout_fic => cnveg_carbonflux_inst%ideadcroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead coarse root pool to outside of vegetation pools + ideadcrootst_to_iout_fic => cnveg_carbonflux_inst%ideadcrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead coarse root storage pool to outside of vegetation pools + ideadcrootxf_to_iout_fic => cnveg_carbonflux_inst%ideadcrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related C transfer from dead coarse root transfer pool to outside of vegetation pools + ilivestem_to_ideadstem_fic => cnveg_carbonflux_inst%ilivestem_to_ideadstem_fi , & ! Input: [integer (:)] Index of fire related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_fic => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_fi , & ! Input: [integer (:)] Index of fire related C transfer from live coarse root pool to dead coarse root pool + ileaf_to_iout_fin => cnveg_nitrogenflux_inst%ileaf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from leaf pool to outside of vegetation pools + ileafst_to_iout_fin => cnveg_nitrogenflux_inst%ileafst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from leaf storage pool to outside of vegetation pools + ileafxf_to_iout_fin => cnveg_nitrogenflux_inst%ileafxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from leaf transfer pool to outside of vegetation pools + ifroot_to_iout_fin => cnveg_nitrogenflux_inst%ifroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from fine root pool to outside of vegetation pools + ifrootst_to_iout_fin => cnveg_nitrogenflux_inst%ifrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from fine root storage pool to outside of vegetation pools + ifrootxf_to_iout_fin => cnveg_nitrogenflux_inst%ifrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from fine transfer pool to outside of vegetation pools + ilivestem_to_iout_fin => cnveg_nitrogenflux_inst%ilivestem_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live stem pool to outside of vegetation pools + ilivestemst_to_iout_fin => cnveg_nitrogenflux_inst%ilivestemst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live stem storage pool to outside of vegetation pool + ilivestemxf_to_iout_fin => cnveg_nitrogenflux_inst%ilivestemxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live stem transfer pool to outside of vegetation pools + ideadstem_to_iout_fin => cnveg_nitrogenflux_inst%ideadstem_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead stem pool to outside of vegetation pools + ideadstemst_to_iout_fin => cnveg_nitrogenflux_inst%ideadstemst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead stem storage pool to outside of vegetation pools + ideadstemxf_to_iout_fin => cnveg_nitrogenflux_inst%ideadstemxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead stem transfer pool to outside of vegetation pools + ilivecroot_to_iout_fin => cnveg_nitrogenflux_inst%ilivecroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live coarse root pool to outside of vegetation pools + ilivecrootst_to_iout_fin => cnveg_nitrogenflux_inst%ilivecrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live coarse root storage pool to outside of vegetation pools + ilivecrootxf_to_iout_fin => cnveg_nitrogenflux_inst%ilivecrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from live coarse root transfer pool to outside of vegetation pools + ideadcroot_to_iout_fin => cnveg_nitrogenflux_inst%ideadcroot_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead coarse root pool to outside of vegetation pools + ideadcrootst_to_iout_fin => cnveg_nitrogenflux_inst%ideadcrootst_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead coarse root storage pool to outside of vegetation pools + ideadcrootxf_to_iout_fin => cnveg_nitrogenflux_inst%ideadcrootxf_to_iout_fi , & ! Input: [integer (:)] Index of fire related N transfer from dead coarse root transfer pool to outside of vegetation pools + ilivestem_to_ideadstem_fin => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_fi , & ! Input: [integer (:)] Index of fire related N transfer from live stem to dead stem pool + ilivecroot_to_ideadcroot_fin => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_fi , & ! Input: [integer (:)] Index of fire related N transfer from live coarse root pool to dead coarse root pool + iretransn_to_iout_fin => cnveg_nitrogenflux_inst%iretransn_to_iout_fi & ! Input: [integer (:)] Index of fire related N transfer from retranslocated N pool to outside of vegetation pools + ) + + transient_landcover = run_has_transient_landcover() + + ! Get model step size + ! calculate burned area fraction per sec + dt = get_step_size_real() + + dayspyr = get_days_per_year() + ! + ! patch loop + ! + num_actfirep = 0 + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + if( patch%itype(p) < nc3crop .and. cropf_col(c) < 1.0_r8)then + ! For non-crop (bare-soil and natural vegetation) + if (transient_landcover) then + f = (fbac(c)-baf_crop(c))/(1.0_r8-cropf_col(c)) + else + f = (farea_burned(c)-baf_crop(c))/(1.0_r8-cropf_col(c)) + end if + else + ! For crops + if(cropf_col(c) > 0._r8)then + f = baf_crop(c) /cropf_col(c) + else + f = 0._r8 + end if + end if + + ! apply this rate to the patch state variables to get flux rates + ! biomass burning + ! carbon fluxes + m = spinup_factor_deadwood + + if(f /= 0)then + num_actfirep = num_actfirep + 1 + filter_actfirep(num_actfirep) = p + end if + + m_gresp_storage_to_fire(p) = gresp_storage(p) * f * cc_other(patch%itype(p)) + m_gresp_xfer_to_fire(p) = gresp_xfer(p) * f * cc_other(patch%itype(p)) + if ( .not. use_matrixcn )then + ! NOTE: The non matrix version of this is in CNCStateUpdate3::CStateUpdate3 EBK (11/26/2019) + ! and CNNStateUpdate3::NStateUpdate3 + m_leafc_to_fire(p) = leafc(p) * f * cc_leaf(patch%itype(p)) + m_leafc_storage_to_fire(p) = leafc_storage(p) * f * cc_other(patch%itype(p)) + m_leafc_xfer_to_fire(p) = leafc_xfer(p) * f * cc_other(patch%itype(p)) + m_livestemc_to_fire(p) = livestemc(p) * f * cc_lstem(patch%itype(p)) + m_livestemc_storage_to_fire(p) = livestemc_storage(p) * f * cc_other(patch%itype(p)) + m_livestemc_xfer_to_fire(p) = livestemc_xfer(p) * f * cc_other(patch%itype(p)) + m_deadstemc_to_fire(p) = deadstemc(p) * f * cc_dstem(patch%itype(p)) * m + m_deadstemc_storage_to_fire(p) = deadstemc_storage(p) * f * cc_other(patch%itype(p)) + m_deadstemc_xfer_to_fire(p) = deadstemc_xfer(p) * f * cc_other(patch%itype(p)) + m_frootc_to_fire(p) = frootc(p) * f * 0._r8 + m_frootc_storage_to_fire(p) = frootc_storage(p) * f * cc_other(patch%itype(p)) + m_frootc_xfer_to_fire(p) = frootc_xfer(p) * f * cc_other(patch%itype(p)) + m_livecrootc_to_fire(p) = livecrootc(p) * f * 0._r8 + m_livecrootc_storage_to_fire(p) = livecrootc_storage(p) * f * cc_other(patch%itype(p)) + m_livecrootc_xfer_to_fire(p) = livecrootc_xfer(p) * f * cc_other(patch%itype(p)) + m_deadcrootc_to_fire(p) = deadcrootc(p) * f * 0._r8 + m_deadcrootc_storage_to_fire(p) = deadcrootc_storage(p) * f* cc_other(patch%itype(p)) + m_deadcrootc_xfer_to_fire(p) = deadcrootc_xfer(p) * f * cc_other(patch%itype(p)) + + + ! nitrogen fluxes + m_leafn_to_fire(p) = leafn(p) * f * cc_leaf(patch%itype(p)) + m_leafn_storage_to_fire(p) = leafn_storage(p) * f * cc_other(patch%itype(p)) + m_leafn_xfer_to_fire(p) = leafn_xfer(p) * f * cc_other(patch%itype(p)) + m_livestemn_to_fire(p) = livestemn(p) * f * cc_lstem(patch%itype(p)) + m_livestemn_storage_to_fire(p) = livestemn_storage(p) * f * cc_other(patch%itype(p)) + m_livestemn_xfer_to_fire(p) = livestemn_xfer(p) * f * cc_other(patch%itype(p)) + m_deadstemn_to_fire(p) = deadstemn(p) * f * cc_dstem(patch%itype(p)) * m + m_deadstemn_storage_to_fire(p) = deadstemn_storage(p) * f * cc_other(patch%itype(p)) + m_deadstemn_xfer_to_fire(p) = deadstemn_xfer(p) * f * cc_other(patch%itype(p)) + m_frootn_to_fire(p) = frootn(p) * f * 0._r8 + m_frootn_storage_to_fire(p) = frootn_storage(p) * f * cc_other(patch%itype(p)) + m_frootn_xfer_to_fire(p) = frootn_xfer(p) * f * cc_other(patch%itype(p)) + m_livecrootn_to_fire(p) = livecrootn(p) * f * 0._r8 + m_livecrootn_storage_to_fire(p) = livecrootn_storage(p) * f * cc_other(patch%itype(p)) + m_livecrootn_xfer_to_fire(p) = livecrootn_xfer(p) * f * cc_other(patch%itype(p)) + m_deadcrootn_to_fire(p) = deadcrootn(p) * f * 0._r8 + m_deadcrootn_xfer_to_fire(p) = deadcrootn_xfer(p) * f * cc_other(patch%itype(p)) + m_deadcrootn_storage_to_fire(p) = deadcrootn_storage(p) * f * cc_other(patch%itype(p)) + m_retransn_to_fire(p) = retransn(p) * f * cc_other(patch%itype(p)) + + else +! m_leafc_to_fire(p) = leafc(p) * matrix_update_fic(p,ileaf_to_iout_fic ,f * cc_leaf(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_leafc_storage_to_fire(p) = leafc_storage(p) * matrix_update_fic(p,ileafst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_leafc_xfer_to_fire(p) = leafc_xfer(p) * matrix_update_fic(p,ileafxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_to_fire(p) = livestemc(p) * matrix_update_fic(p,ilivestem_to_iout_fic ,f * cc_lstem(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_storage_to_fire(p) = livestemc_storage(p) * matrix_update_fic(p,ilivestemst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_xfer_to_fire(p) = livestemc_xfer(p) * matrix_update_fic(p,ilivestemxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_to_fire(p) = deadstemc(p) * matrix_update_fic(p,ideadstem_to_iout_fic ,f * cc_dstem(patch%itype(p))*m,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_storage_to_fire(p) = deadstemc_storage(p) * matrix_update_fic(p,ideadstemst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_xfer_to_fire(p) = deadstemc_xfer(p) * matrix_update_fic(p,ideadstemxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_to_fire(p) = frootc(p) * matrix_update_fic(p,ifroot_to_iout_fic ,f * 0._r8 ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_storage_to_fire(p) = frootc_storage(p) * matrix_update_fic(p,ifrootst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_xfer_to_fire(p) = frootc_xfer(p) * matrix_update_fic(p,ifrootxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_to_fire(p) = livecrootc(p) * matrix_update_fic(p,ilivecroot_to_iout_fic ,f * 0._r8 ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_storage_to_fire(p) = livecrootc_storage(p) * matrix_update_fic(p,ilivecrootst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_xfer_to_fire(p) = livecrootc_xfer(p) * matrix_update_fic(p,ilivecrootxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_to_fire(p) = deadcrootc(p) * matrix_update_fic(p,ideadcroot_to_iout_fic ,f * 0._r8 ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_storage_to_fire(p) = deadcrootc_storage(p) * matrix_update_fic(p,ideadcrootst_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_xfer_to_fire(p) = deadcrootc_xfer(p) * matrix_update_fic(p,ideadcrootxf_to_iout_fic ,f * cc_other(patch%itype(p)) ,dt,cnveg_carbonflux_inst,.True.,.True.) +! +! m_leafn_to_fire(p) = leafn(p) * matrix_update_fin(p,ileaf_to_iout_fin ,f * cc_leaf(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_leafn_storage_to_fire(p) = leafn_storage(p) * matrix_update_fin(p,ileafst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_leafn_xfer_to_fire(p) = leafn_xfer(p) * matrix_update_fin(p,ileafxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_to_fire(p) = livestemn(p) * matrix_update_fin(p,ilivestem_to_iout_fin ,f * cc_lstem(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_storage_to_fire(p) = livestemn_storage(p) * matrix_update_fin(p,ilivestemst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_xfer_to_fire(p) = livestemn_xfer(p) * matrix_update_fin(p,ilivestemxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_to_fire(p) = deadstemn(p) * matrix_update_fin(p,ideadstem_to_iout_fin ,f * cc_dstem(patch%itype(p))*m,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_storage_to_fire(p) = deadstemn_storage(p) * matrix_update_fin(p,ideadstemst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_xfer_to_fire(p) = deadstemn_xfer(p) * matrix_update_fin(p,ideadstemxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_to_fire(p) = frootn(p) * matrix_update_fin(p,ifroot_to_iout_fin ,f * 0._r8 ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_storage_to_fire(p) = frootn_storage(p) * matrix_update_fin(p,ifrootst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_xfer_to_fire(p) = frootn_xfer(p) * matrix_update_fin(p,ifrootxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_to_fire(p) = livecrootn(p) * matrix_update_fin(p,ilivecroot_to_iout_fin ,f * 0._r8 ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_storage_to_fire(p) = livecrootn_storage(p) * matrix_update_fin(p,ilivecrootst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_xfer_to_fire(p) = livecrootn_xfer(p) * matrix_update_fin(p,ilivecrootxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_to_fire(p) = deadcrootn(p) * matrix_update_fin(p,ideadcroot_to_iout_fin ,f * 0._r8 ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_storage_to_fire(p) = deadcrootn_storage(p) * matrix_update_fin(p,ideadcrootst_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_xfer_to_fire(p) = deadcrootn_xfer(p) * matrix_update_fin(p,ideadcrootxf_to_iout_fin ,f * cc_other(patch%itype(p)) ,dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_retransn_to_fire(p) = retransn(p) * matrix_update_fin(p,iretransn_to_iout_fin ,f * 0._r8 ,dt,cnveg_nitrogenflux_inst,.True.,.True.) + end if + ! mortality due to fire + ! carbon pools + if ( .not. use_matrixcn )then + ! NOTE: The non matrix version of this is in CNCStateUpdate3::CStateUpdate3 EBK (11/26/2019) + ! and CNNStateUpdate3::NStateUpdate3 + m_leafc_to_litter_fire(p) = leafc(p) * f * & + (1._r8 - cc_leaf(patch%itype(p))) * & + fm_leaf(patch%itype(p)) + m_leafc_storage_to_litter_fire(p) = leafc_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_leafc_xfer_to_litter_fire(p) = leafc_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from livestem/livecroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_livestemc_to_litter_fire(p) = livestemc(p) * f * & + (1._r8 - cc_lstem(patch%itype(p))) * & + fm_droot(patch%itype(p)) + m_livestemc_storage_to_litter_fire(p) = livestemc_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livestemc_xfer_to_litter_fire(p) = livestemc_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent the fraction of plant-tissue mortality for deadstem/deadcroot + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 + m_livestemc_to_deadstemc_fire(p) = livestemc(p) * f * & + (1._r8 - cc_lstem(patch%itype(p))) * & + (fm_lstem(patch%itype(p))-fm_droot(patch%itype(p))) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from deadstem/deadcroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_deadstemc_to_litter_fire(p) = deadstemc(p) * f * m * & + (1._r8 - cc_dstem(patch%itype(p))) * & + fm_droot(patch%itype(p)) + m_deadstemc_storage_to_litter_fire(p) = deadstemc_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_deadstemc_xfer_to_litter_fire(p) = deadstemc_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_frootc_to_litter_fire(p) = frootc(p) * f * & + fm_root(patch%itype(p)) + m_frootc_storage_to_litter_fire(p) = frootc_storage(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_frootc_xfer_to_litter_fire(p) = frootc_xfer(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from livestem/livecroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_livecrootc_to_litter_fire(p) = livecrootc(p) * f * & + fm_droot(patch%itype(p)) + m_livecrootc_storage_to_litter_fire(p) = livecrootc_storage(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livecrootc_xfer_to_litter_fire(p) = livecrootc_xfer(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livecrootc_to_deadcrootc_fire(p) = livecrootc(p) * f * & + (fm_lroot(patch%itype(p))-fm_droot(patch%itype(p))) + m_deadcrootc_to_litter_fire(p) = deadcrootc(p) * f * m * & + fm_droot(patch%itype(p)) + m_deadcrootc_storage_to_litter_fire(p) = deadcrootc_storage(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_deadcrootc_xfer_to_litter_fire(p) = deadcrootc_xfer(p) * f * & + (1._r8- cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_gresp_storage_to_litter_fire(p) = gresp_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_gresp_xfer_to_litter_fire(p) = gresp_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + + + ! nitrogen pools + m_leafn_to_litter_fire(p) = leafn(p) * f * & + (1._r8 - cc_leaf(patch%itype(p))) * & + fm_leaf(patch%itype(p)) + m_leafn_storage_to_litter_fire(p) = leafn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_leafn_xfer_to_litter_fire(p) = leafn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from livestem/livecroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_livestemn_to_litter_fire(p) = livestemn(p) * f * & + (1._r8 - cc_lstem(patch%itype(p))) * & + fm_droot(patch%itype(p)) + m_livestemn_storage_to_litter_fire(p) = livestemn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livestemn_xfer_to_litter_fire(p) = livestemn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent the fraction of plant-tissue mortality for deadstem/deadcroot + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 + m_livestemn_to_deadstemn_fire(p) = livestemn(p) * f * & + (1._r8 - cc_lstem(patch%itype(p))) * & + (fm_lstem(patch%itype(p))-fm_droot(patch%itype(p))) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from deadstem/deadcroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_deadstemn_to_litter_fire(p) = deadstemn(p) * f * m * & + (1._r8 - cc_dstem(patch%itype(p))) * & + fm_droot(patch%itype(p)) + m_deadstemn_storage_to_litter_fire(p) = deadstemn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_deadstemn_xfer_to_litter_fire(p) = deadstemn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_frootn_to_litter_fire(p) = frootn(p) * f * & + fm_root(patch%itype(p)) + m_frootn_storage_to_litter_fire(p) = frootn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_frootn_xfer_to_litter_fire(p) = frootn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + ! NOTE: It looks incorrect to use fm_droot here, but it's used to represent fraction of transport from livestem/livecroot to litter + ! EBK Oct/06/2017 see bug 2516 http://bugs.cgd.ucar.edu/show_bug.cgi?id=2516 (stem and root live or dead assumed to have the same transport) + m_livecrootn_to_litter_fire(p) = livecrootn(p) * f * & + fm_droot(patch%itype(p)) + m_livecrootn_storage_to_litter_fire(p) = livecrootn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livecrootn_xfer_to_litter_fire(p) = livecrootn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_livecrootn_to_deadcrootn_fire(p) = livecrootn(p) * f * & + (fm_lroot(patch%itype(p))-fm_droot(patch%itype(p))) + m_deadcrootn_to_litter_fire(p) = deadcrootn(p) * f * m * & + fm_droot(patch%itype(p)) + m_deadcrootn_storage_to_litter_fire(p) = deadcrootn_storage(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_deadcrootn_xfer_to_litter_fire(p) = deadcrootn_xfer(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + m_retransn_to_litter_fire(p) = retransn(p) * f * & + (1._r8 - cc_other(patch%itype(p))) * & + fm_other(patch%itype(p)) + + else +! m_leafc_to_litter_fire(p) = leafc(p) * matrix_update_fic(p,ileaf_to_iout_fic, & +! f * (1._r8 - cc_leaf(patch%itype(p))) * fm_leaf(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_leafc_storage_to_litter_fire(p) = leafc_storage(p) * matrix_update_fic(p,ileafst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_leafc_xfer_to_litter_fire(p) = leafc_xfer(p) * matrix_update_fic(p,ileafxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_to_litter_fire(p) = livestemc(p) * matrix_update_fic(p,ilivestem_to_iout_fic, & +! f * (1._r8 - cc_lstem(patch%itype(p))) * fm_droot(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_storage_to_litter_fire(p) = livestemc_storage(p) * matrix_update_fic(p,ilivestemst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_xfer_to_litter_fire(p) = livestemc_xfer(p) * matrix_update_fic(p,ilivestemxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livestemc_to_deadstemc_fire(p) = livestemc(p) * matrix_update_fic(p,ilivestem_to_ideadstem_fic,& +! f * (1._r8 - cc_lstem(patch%itype(p))) * (fm_lstem(patch%itype(p))-fm_droot(patch%itype(p))),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_to_litter_fire(p) = deadstemc(p) * matrix_update_fic(p,ideadstem_to_iout_fic, & +! f * (1._r8 - cc_dstem(patch%itype(p))) * fm_droot(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_storage_to_litter_fire(p) = deadstemc_storage(p) * matrix_update_fic(p,ideadstemst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadstemc_xfer_to_litter_fire(p) = deadstemc_xfer(p) * matrix_update_fic(p,ideadstemxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_to_litter_fire(p) = frootc(p) * matrix_update_fic(p,ifroot_to_iout_fic, & +! f * fm_root(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_storage_to_litter_fire(p) = frootc_storage(p) * matrix_update_fic(p,ifrootst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_frootc_xfer_to_litter_fire(p) = frootc_xfer(p) * matrix_update_fic(p,ifrootxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_to_litter_fire(p) = livecrootc(p) * matrix_update_fic(p,ilivecroot_to_iout_fic, & +! f * fm_droot(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_storage_to_litter_fire(p) = livecrootc_storage(p) * matrix_update_fic(p,ilivecrootst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_xfer_to_litter_fire(p) = livecrootc_xfer(p) * matrix_update_fic(p,ilivecrootxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_livecrootc_to_deadcrootc_fire(p) = livecrootc(p) * matrix_update_fic(p,ilivecroot_to_ideadcroot_fic,& +! f * (fm_lroot(patch%itype(p))-fm_droot(patch%itype(p))),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_to_litter_fire(p) = deadcrootc(p) * matrix_update_fic(p,ideadcroot_to_iout_fic, & +! f * m * fm_droot(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_storage_to_litter_fire(p) = deadcrootc_storage(p) * matrix_update_fic(p,ideadcrootst_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! m_deadcrootc_xfer_to_litter_fire(p) = deadcrootc_xfer(p) * matrix_update_fic(p,ideadcrootxf_to_iout_fic, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_carbonflux_inst,.True.,.True.) +! +! m_leafn_to_litter_fire(p) = leafn(p) * matrix_update_fin(p,ileaf_to_iout_fin, & +! f * (1._r8 - cc_leaf(patch%itype(p))) * fm_leaf(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_leafn_storage_to_litter_fire(p) = leafn_storage(p) * matrix_update_fin(p,ileafst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_leafn_xfer_to_litter_fire(p) = leafn_xfer(p) * matrix_update_fin(p,ileafxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_to_litter_fire(p) = livestemn(p) * matrix_update_fin(p,ilivestem_to_iout_fin, & +! f * (1._r8 - cc_lstem(patch%itype(p))) * fm_droot(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_storage_to_litter_fire(p) = livestemn_storage(p) * matrix_update_fin(p,ilivestemst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_xfer_to_litter_fire(p) = livestemn_xfer(p) * matrix_update_fin(p,ilivestemxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livestemn_to_deadstemn_fire(p) = livestemn(p) * matrix_update_fin(p,ilivestem_to_ideadstem_fin,& +! f * (1._r8 - cc_lstem(patch%itype(p))) * (fm_lstem(patch%itype(p))-fm_droot(patch%itype(p))),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_to_litter_fire(p) = deadstemn(p) * matrix_update_fin(p,ideadstem_to_iout_fin, & +! f * (1._r8 - cc_dstem(patch%itype(p))) * fm_droot(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_storage_to_litter_fire(p) = deadstemn_storage(p) * matrix_update_fin(p,ideadstemst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadstemn_xfer_to_litter_fire(p) = deadstemn_xfer(p) * matrix_update_fin(p,ideadstemxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_to_litter_fire(p) = frootn(p) * matrix_update_fin(p,ifroot_to_iout_fin, & +! f * fm_root(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_storage_to_litter_fire(p) = frootn_storage(p) * matrix_update_fin(p,ifrootst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_frootn_xfer_to_litter_fire(p) = frootn_xfer(p) * matrix_update_fin(p,ifrootxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_to_litter_fire(p) = livecrootn(p) * matrix_update_fin(p,ilivecroot_to_iout_fin, & +! f * fm_droot(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_storage_to_litter_fire(p) = livecrootn_storage(p) * matrix_update_fin(p,ilivecrootst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_xfer_to_litter_fire(p) = livecrootn_xfer(p) * matrix_update_fin(p,ilivecrootxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_livecrootn_to_deadcrootn_fire(p) = livecrootn(p) * matrix_update_fin(p,ilivecroot_to_ideadcroot_fin,& +! f * (fm_lroot(patch%itype(p))-fm_droot(patch%itype(p))),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_to_litter_fire(p) = deadcrootn(p) * matrix_update_fin(p,ideadcroot_to_iout_fin, & +! f * m * fm_droot(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_storage_to_litter_fire(p) = deadcrootn_storage(p) * matrix_update_fin(p,ideadcrootst_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +! m_deadcrootn_xfer_to_litter_fire(p) = deadcrootn_xfer(p) * matrix_update_fin(p,ideadcrootxf_to_iout_fin, & +! f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +!KO + ! This term is not currently in the matrix code version of CNFireBaseMod, but there are non-matrix terms for this + ! in CNFireLi2014Mod and in CNFireBaseMod in ctsm5.1.dev012. I'm not adding it here because tests are passing without it. +!KO m_retransn_to_litter_fire(p) = retransn(p) * matrix_update_fin(p,iretransn_to_iout_fin, & +!KO f * (1._r8 - cc_other(patch%itype(p))) * fm_other(patch%itype(p)),dt,cnveg_nitrogenflux_inst,.True.,.True.) +!KO + end if + + if (use_cndv) then + if ( woody(patch%itype(p)) == 1._r8 )then + if ( livestemc(p)+deadstemc(p) > 0._r8 )then + nind(p) = nind(p)*(1._r8-1._r8*fm_droot(patch%itype(p))*f) + else + nind(p) = 0._r8 + end if + end if + leafcmax(p) = max(leafc(p)-m_leafc_to_fire(p)*dt, leafcmax(p)) + if (patch%itype(p) == noveg) leafcmax(p) = 0._r8 + end if + + end do ! end of patches loop + + ! fire-induced transfer of carbon and nitrogen pools to litter and cwd + + do j = 1,nlevdecomp + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & + m_deadstemc_to_litter_fire(p) * patch%wtcol(p) * stem_prof(p,j) + fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & + m_deadcrootc_to_litter_fire(p) * patch%wtcol(p) * croot_prof(p,j) + fire_mortality_n_to_cwdn(c,j) = fire_mortality_n_to_cwdn(c,j) + & + m_deadstemn_to_litter_fire(p) * patch%wtcol(p) * stem_prof(p,j) + fire_mortality_n_to_cwdn(c,j) = fire_mortality_n_to_cwdn(c,j) + & + m_deadcrootn_to_litter_fire(p) * patch%wtcol(p) * croot_prof(p,j) + + + fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & + m_livestemc_to_litter_fire(p) * patch%wtcol(p) * stem_prof(p,j) + fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & + m_livecrootc_to_litter_fire(p) * patch%wtcol(p) * croot_prof(p,j) + fire_mortality_n_to_cwdn(c,j) = fire_mortality_n_to_cwdn(c,j) + & + m_livestemn_to_litter_fire(p) * patch%wtcol(p) * stem_prof(p,j) + fire_mortality_n_to_cwdn(c,j) = fire_mortality_n_to_cwdn(c,j) + & + m_livecrootn_to_litter_fire(p) * patch%wtcol(p) * croot_prof(p,j) + + + m_c_to_litr_met_fire(c,j)=m_c_to_litr_met_fire(c,j) + & + ((m_leafc_to_litter_fire(p)*lf_flab(patch%itype(p)) & + +m_leafc_storage_to_litter_fire(p) + & + m_leafc_xfer_to_litter_fire(p) + & + m_gresp_storage_to_litter_fire(p) & + +m_gresp_xfer_to_litter_fire(p))*leaf_prof(p,j) + & + (m_frootc_to_litter_fire(p)*fr_flab(patch%itype(p)) & + +m_frootc_storage_to_litter_fire(p) + & + m_frootc_xfer_to_litter_fire(p))*froot_prof(p,j) & + +(m_livestemc_storage_to_litter_fire(p) + & + m_livestemc_xfer_to_litter_fire(p) & + +m_deadstemc_storage_to_litter_fire(p) + & + m_deadstemc_xfer_to_litter_fire(p))* stem_prof(p,j)& + +(m_livecrootc_storage_to_litter_fire(p) + & + m_livecrootc_xfer_to_litter_fire(p) & + +m_deadcrootc_storage_to_litter_fire(p) + & + m_deadcrootc_xfer_to_litter_fire(p))* croot_prof(p,j))* patch%wtcol(p) + m_c_to_litr_cel_fire(c,j)=m_c_to_litr_cel_fire(c,j) + & + (m_leafc_to_litter_fire(p)*lf_fcel(patch%itype(p))*leaf_prof(p,j) + & + m_frootc_to_litter_fire(p)*fr_fcel(patch%itype(p))*froot_prof(p,j))* patch%wtcol(p) + m_c_to_litr_lig_fire(c,j)=m_c_to_litr_lig_fire(c,j) + & + (m_leafc_to_litter_fire(p)*lf_flig(patch%itype(p))*leaf_prof(p,j) + & + m_frootc_to_litter_fire(p)*fr_flig(patch%itype(p))*froot_prof(p,j))* patch%wtcol(p) + + m_n_to_litr_met_fire(c,j)=m_n_to_litr_met_fire(c,j) + & + ((m_leafn_to_litter_fire(p)*lf_flab(patch%itype(p)) & + +m_leafn_storage_to_litter_fire(p) + & + m_leafn_xfer_to_litter_fire(p)+m_retransn_to_litter_fire(p)) & + *leaf_prof(p,j) +(m_frootn_to_litter_fire(p)*fr_flab(patch%itype(p)) & + +m_frootn_storage_to_litter_fire(p) + & + m_frootn_xfer_to_litter_fire(p))*froot_prof(p,j) & + +(m_livestemn_storage_to_litter_fire(p) + & + m_livestemn_xfer_to_litter_fire(p) & + +m_deadstemn_storage_to_litter_fire(p) + & + m_deadstemn_xfer_to_litter_fire(p))* stem_prof(p,j)& + +(m_livecrootn_storage_to_litter_fire(p) + & + m_livecrootn_xfer_to_litter_fire(p) & + +m_deadcrootn_storage_to_litter_fire(p) + & + m_deadcrootn_xfer_to_litter_fire(p))* croot_prof(p,j))* patch%wtcol(p) + m_n_to_litr_cel_fire(c,j)=m_n_to_litr_cel_fire(c,j) + & + (m_leafn_to_litter_fire(p)*lf_fcel(patch%itype(p))*leaf_prof(p,j) + & + m_frootn_to_litter_fire(p)*fr_fcel(patch%itype(p))*froot_prof(p,j))* patch%wtcol(p) + m_n_to_litr_lig_fire(c,j)=m_n_to_litr_lig_fire(c,j) + & + (m_leafn_to_litter_fire(p)*lf_flig(patch%itype(p))*leaf_prof(p,j) + & + m_frootn_to_litter_fire(p)*fr_flig(patch%itype(p))*froot_prof(p,j))* patch%wtcol(p) + end do + end do + ! + ! vertically-resolved decomposing C/N fire loss + ! column loop + ! + num_actfirec = 0 + do fc = 1,num_soilc + c = filter_soilc(fc) + + f = farea_burned(c) + + if(f .ne. 0 .or. f .ne. baf_crop(c))then + num_actfirec = num_actfirec + 1 + filter_actfirec(num_actfirec) = c + end if + + ! change CC for litter from 0.4_r8 to 0.5_r8 and CC for CWD from 0.2_r8 + ! to 0.25_r8 according to Li et al.(2014) + do j = 1, nlevdecomp + ! carbon fluxes + do l = 1, ndecomp_pools + if ( is_litter(l) ) then + m_decomp_cpools_to_fire_vr(c,j,l) = decomp_cpools_vr(c,j,l) * f * 0.5_r8 + if(use_soil_matrixcn)then +! associate( & +! matrix_decomp_fire_k => soilbiogeochem_carbonflux_inst%matrix_decomp_fire_k_col & ! Output: [real(r8) (:,:) ] +! ) +! matrix_decomp_fire_k(c,j+nlevdecomp*(l-1)) = matrix_decomp_fire_k(c,j+nlevdecomp*(l-1)) - f * 0.5_r8 * dt +! end associate + end if + end if + if ( is_cwd(l) ) then + m_decomp_cpools_to_fire_vr(c,j,l) = decomp_cpools_vr(c,j,l) * & + (f-baf_crop(c)) * 0.25_r8 + if(use_soil_matrixcn)then +! associate( & +! matrix_decomp_fire_k => soilbiogeochem_carbonflux_inst%matrix_decomp_fire_k_col & ! Output: [real(r8) (:,:) ] +! ) +! matrix_decomp_fire_k(c,j+nlevdecomp*(l-1)) = matrix_decomp_fire_k(c,j+nlevdecomp*(l-1)) - (f-baf_crop(c)) * 0.25_r8 * dt +! end associate + end if + end if + end do + + ! nitrogen fluxes + do l = 1, ndecomp_pools + if ( is_litter(l) ) then + m_decomp_npools_to_fire_vr(c,j,l) = decomp_npools_vr(c,j,l) * f * 0.5_r8 + end if + if ( is_cwd(l) ) then + m_decomp_npools_to_fire_vr(c,j,l) = decomp_npools_vr(c,j,l) * & + (f-baf_crop(c)) * 0.25_r8 + end if + end do + + end do + end do ! end of column loop + + ! carbon loss due to deforestation fires + + if (transient_landcover) then + call get_curr_date (kyr, kmo, kda, mcsec) + do fc = 1,num_soilc + c = filter_soilc(fc) + lfc2(c)=0._r8 + if( .not. (kmo == 1 .and. kda == 1 .and. mcsec == 0) )then + if( trotr1_col(c)+trotr2_col(c) > 0.6_r8 .and. dtrotr_col(c) > 0._r8 .and. & + lfc(c) > 0._r8 .and. fbac1(c) == 0._r8) then + lfc2(c) = max(0._r8, min(lfc(c), (farea_burned(c)-baf_crop(c) - & + baf_peatf(c))/2.0*dt))/(dtrotr_col(c)*dayspyr*secspday/dt)/dt + lfc(c) = lfc(c) - max(0._r8, min(lfc(c), (farea_burned(c)-baf_crop(c) - & + baf_peatf(c))*dt/2.0_r8)) + end if + end if + end do + end if + ! + ! Carbon loss due to peat fires + ! + ! somc_fire is not connected to clm45 soil carbon pool, ie does not decrease + ! soil carbon b/c clm45 soil carbon was very low in several peatland grids + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + if( grc%latdeg(g) < cnfire_const%borealat)then + somc_fire(c)= totsomc(c)*baf_peatf(c)*6.0_r8/33.9_r8 + else + somc_fire(c)= baf_peatf(c)*2.2e3_r8 + end if + end do + + ! Fang Li has not added aerosol and trace gas emissions due to fire, yet + ! They will be added here in proportion to the carbon emission + ! Emission factors differ for various fire types + + end associate + + end subroutine CNFireFluxes + +end module CNFireLi2014Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2016Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2016Mod.F90 new file mode 100755 index 000000000..2fd6b4c58 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2016Mod.F90 @@ -0,0 +1,664 @@ +module CNFireLi2016Mod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! module for fire dynamics + ! created in Nov, 2012 and revised in Apr, 2013 by F. Li and S. Levis + ! based on Li et al. (2012a,b; 2013) + ! revised in Apr, 2014 according to Li et al.(2014) + ! revised in May, 2015, according to Li et al. (2015, in prep.) + ! Fire-related parameters were calibrated or tuned in May, 2015 based on the + ! 20th Century transient simulations at f19_g16 with a CLM4.5 version + ! (clm50fire), CRUNCEPv5, and climatological lightning data. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8, CL => shr_kind_CL + use shr_const_mod , only : SHR_CONST_PI,SHR_CONST_TKFRZ + use shr_infnan_mod , only : shr_infnan_isnan + use clm_varctl , only : iulog + use clm_varpar , only : nlevdecomp, ndecomp_pools, nlevdecomp_full + use clm_varcon , only : dzsoi_decomp + use pftconMod , only : noveg, pftcon + use abortutils , only : endrun + use decompMod , only : bounds_type + use subgridAveMod , only : p2c + use atm2lndType , only : atm2lnd_type + use CNDVType , only : dgvs_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type, spinup_factor_deadwood + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use EnergyFluxType , only : energyflux_type + use SaturatedExcessRunoffMod , only : saturated_excess_runoff_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use SoilStateType , only : soilstate_type + ! use SoilWaterRetentionCurveMod , only : soil_water_retention_curve_type + use GridcellType , only : grc + use ColumnType , only : col + use PatchType , only : patch + use SoilBiogeochemStateType , only : get_spinup_latitude_term + use FireMethodType , only : fire_method_type + use CNFireBaseMod , only : cnfire_base_type, cnfire_const, cnfire_params + use CN2CLMType + ! + implicit none + private + ! + ! !PUBLIC TYPES: + public :: cnfire_li2016_type + ! + type, extends(cnfire_base_type) :: cnfire_li2016_type + private + contains + ! + ! !PUBLIC MEMBER FUNCTIONS: + procedure, public :: need_lightning_and_popdens + procedure, public :: CNFireArea ! Calculate fire area + end type cnfire_li2016_type + ! + ! !PRIVATE MEMBER DATA: + !----------------------------------------------------------------------- + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + function need_lightning_and_popdens(this) + ! !ARGUMENTS: + class(cnfire_li2016_type), intent(in) :: this + logical :: need_lightning_and_popdens ! function result + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'need_lightning_and_popdens' + !----------------------------------------------------------------------- + + need_lightning_and_popdens = .true. + end function need_lightning_and_popdens + + !----------------------------------------------------------------------- + subroutine CNFireArea (this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + atm2lnd_inst, energyflux_inst, saturated_excess_runoff_inst, waterdiagnosticbulk_inst, & + wateratm2lndbulk_inst, waterstatebulk_inst, soilstate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, totlitc_col, decomp_cpools_vr_col, t_soi17cm_col) + ! + ! !DESCRIPTION: + ! Computes column-level burned area + ! + ! !USES: + use clm_time_manager , only: get_step_size_real, get_days_per_year, get_curr_date, get_nstep + use clm_varcon , only: secspday, secsphr + use clm_varctl , only: spinup_state + use pftconMod , only: nc4_grass, nc3crop, ndllf_evr_tmp_tree + use pftconMod , only: nbrdlf_evr_trp_tree, nbrdlf_dcd_trp_tree, nbrdlf_evr_shrub + use dynSubgridControlMod , only : run_has_transient_landcover + ! + ! !ARGUMENTS: + class(cnfire_li2016_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(energyflux_type) , intent(in) :: energyflux_inst + type(saturated_excess_runoff_type) , intent(in) :: saturated_excess_runoff_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(wateratm2lndbulk_type) , intent(in) :: wateratm2lndbulk_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + !class(soil_water_retention_curve_type), intent(in) :: soil_water_retention_curve + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + real(r8) , intent(in) :: totlitc_col(bounds%begc:) + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,1:,1:) + real(r8) , intent(in) :: t_soi17cm_col(bounds%begc:) + ! + ! !LOCAL VARIABLES: + ! + integer :: g,l,c,p,pi,j,fc,fp,kyr, kmo, kda, mcsec ! index variables + real(r8) :: dt ! time step variable (s) + real(r8) :: dayspyr ! days per year + real(r8) :: cli ! effect of climate on deforestation fires (0-1) + real(r8) :: cri ! thresholds used for cli, (mm/d), see Eq.(7) in Li et al.(2013) + real(r8) :: fb ! availability of fuel for regs A and C + real(r8) :: fhd ! impact of hd on agricultural fire + real(r8) :: fgdp ! impact of gdp on agricultural fire + real(r8) :: fire_m ! combustability of fuel for fire occurrence + real(r8) :: spread_m ! combustability of fuel for fire spread + real(r8) :: Lb_lf ! length-to-breadth ratio added by Lifang + integer :: i_cwd ! cwd pool + real(r8) :: lh ! anthro. ignitions (count/km2/hr) + real(r8) :: fs ! hd-dependent fires suppression (0-1) + real(r8) :: ig ! total ignitions (count/km2/hr) + real(r8) :: hdmlf ! human density + real(r8) :: arh, arh30 !combustability of fuel related to RH and RH30 + real(r8) :: afuel !weight for arh and arh30 + real(r8) :: btran_col(bounds%begc:bounds%endc) + logical :: transient_landcover ! whether this run has any prescribed transient landcover + real(r8), target :: prec60_col_target(bounds%begc:bounds%endc) + real(r8), target :: prec10_col_target(bounds%begc:bounds%endc) + real(r8), target :: rh30_col_target(bounds%begc:bounds%endc) + real(r8), pointer :: prec60_col(:) + real(r8), pointer :: prec10_col(:) + real(r8), pointer :: rh30_col(:) + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(totlitc_col) == (/bounds%endc/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_cpools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(t_soi17cm_col) == (/bounds%endc/)) , sourcefile, __LINE__) + + associate( & + totlitc => totlitc_col , & ! Input: [real(r8) (:) ] (gC/m2) total lit C (column-level mean) + decomp_cpools_vr => decomp_cpools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) VR decomp. (litter, cwd, soil) + tsoi17 => t_soi17cm_col , & ! Input: [real(r8) (:) ] (K) soil T for top 0.17 m + + lfuel => cnfire_const%lfuel , & ! Input: [real(r8) ] (gC/m2) Lower threshold of fuel mass + ufuel => cnfire_const%ufuel , & ! Input: [real(r8) ] (gC/m2) Upper threshold of fuel mass + rh_hgh => cnfire_const%rh_hgh , & ! Input: [real(r8) ] (%) High relative humidity + rh_low => cnfire_const%rh_low , & ! Input: [real(r8) ] (%) Low relative humidity + bt_min => cnfire_const%bt_min , & ! Input: [real(r8) ] (0-1) Minimum btran + bt_max => cnfire_const%bt_max , & ! Input: [real(r8) ] (0-1) Maximum btran + cli_scale => cnfire_const%cli_scale , & ! Input: [real(r8) ] (/d) global constant for deforestation fires + cropfire_a1 => cnfire_const%cropfire_a1 , & ! Input: [real(r8) ] (/hr) a1 parameter for cropland fire + non_boreal_peatfire_c => cnfire_const%non_boreal_peatfire_c , & ! Input: [real(r8) ] (/hr) c parameter for non-boreal peatland fire + pot_hmn_ign_counts_alpha => cnfire_const%pot_hmn_ign_counts_alpha , & ! Input: [real(r8) ] (/person/month) Potential human ignition counts + boreal_peatfire_c => cnfire_const%boreal_peatfire_c , & ! Input: [real(r8) ] (/hr) c parameter for boreal peatland fire + + fsr_pft => pftcon%fsr_pft , & ! Input: + fd_pft => pftcon%fd_pft , & ! Input: + + btran2 => this%cnfire_base_type%btran2_patch , & ! Input: [real(r8) (:) ] root zone soil wetness + fsat => saturated_excess_runoff_inst%fsat_col , & ! Input: [real(r8) (:) ] fractional area with water table at surface + wf2 => waterdiagnosticbulk_inst%wf2_col , & ! Input: [real(r8) (:) ] soil water as frac. of whc for top 0.17 m + + is_cwd => decomp_cascade_con%is_cwd , & ! Input: [logical (:) ] TRUE => pool is a cwd pool + spinup_factor => decomp_cascade_con%spinup_factor , & ! Input: [real(r8) (:) ] factor for AD spinup associated with each pool + + forc_rh => wateratm2lndbulk_inst%forc_rh_grc , & ! Input: [real(r8) (:) ] relative humidity + forc_wind => atm2lnd_inst%forc_wind_grc , & ! Input: [real(r8) (:) ] atmospheric wind speed (m/s) + forc_t => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:) ] downscaled atmospheric temperature (Kelvin) + forc_rain => wateratm2lndbulk_inst%forc_rain_downscaled_col , & ! Input: [real(r8) (:) ] downscaled rain + forc_snow => wateratm2lndbulk_inst%forc_snow_downscaled_col , & ! Input: [real(r8) (:) ] downscaled snow + prec60 => wateratm2lndbulk_inst%prec60_patch , & ! Input: [real(r8) (:) ] 60-day running mean of tot. precipitation + prec10 => wateratm2lndbulk_inst%prec10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of tot. precipitation + rh30 => wateratm2lndbulk_inst%rh30_patch , & ! Input: [real(r8) (:) ] 10-day running mean of tot. precipitation + dwt_smoothed => cnveg_state_inst%dwt_smoothed_patch , & ! Input: [real(r8) (:) ] change in patch weight (-1 to 1) on the gridcell, smoothed over the year + cropf_col => cnveg_state_inst%cropf_col , & ! Input: [real(r8) (:) ] cropland fraction in veg column + gdp_lf => cnveg_state_inst%gdp_lf_col , & ! Input: [real(r8) (:) ] gdp data + peatf_lf => cnveg_state_inst%peatf_lf_col , & ! Input: [real(r8) (:) ] peatland fraction data + abm_lf => cnveg_state_inst%abm_lf_col , & ! Input: [integer (:) ] prescribed crop fire time + baf_crop => cnveg_state_inst%baf_crop_col , & ! Output: [real(r8) (:) ] burned area fraction for cropland (/sec) + baf_peatf => cnveg_state_inst%baf_peatf_col , & ! Output: [real(r8) (:) ] burned area fraction for peatland (/sec) + burndate => cnveg_state_inst%burndate_patch , & ! Output: [integer (:) ] burn date for crop + fbac => cnveg_state_inst%fbac_col , & ! Output: [real(r8) (:) ] total burned area out of conversion (/sec) + fbac1 => cnveg_state_inst%fbac1_col , & ! Output: [real(r8) (:) ] burned area out of conversion region due to land use fire + farea_burned => cnveg_state_inst%farea_burned_col , & ! Output: [real(r8) (:) ] total fractional area burned (/sec) + nfire => cnveg_state_inst%nfire_col , & ! Output: [real(r8) (:) ] fire counts (count/km2/sec), valid only in Reg. C + fsr_col => cnveg_state_inst%fsr_col , & ! Output: [real(r8) (:) ] fire spread rate at column level + fd_col => cnveg_state_inst%fd_col , & ! Output: [real(r8) (:) ] fire duration rate at column level + lgdp_col => cnveg_state_inst%lgdp_col , & ! Output: [real(r8) (:) ] gdp limitation factor for nfire + lgdp1_col => cnveg_state_inst%lgdp1_col , & ! Output: [real(r8) (:) ] gdp limitation factor for baf per fire + lpop_col => cnveg_state_inst%lpop_col , & ! Output: [real(r8) (:) ] pop limitation factor for baf per fire + lfwt => cnveg_state_inst%lfwt_col , & ! Output: [real(r8) (:) ] fractional coverage of non-crop and non-bare-soil Patches + trotr1_col => cnveg_state_inst%trotr1_col , & ! Output: [real(r8) (:) ] patch weight of BET on the column (0-1) + trotr2_col => cnveg_state_inst%trotr2_col , & ! Output: [real(r8) (:) ] patch weight of BDT on the column (0-1) + dtrotr_col => cnveg_state_inst%dtrotr_col , & ! Output: [real(r8) (:) ] decreased frac. coverage of BET+BDT on grid for dt + lfc => cnveg_state_inst%lfc_col , & ! Output: [real(r8) (:) ] conversion area frac. of BET+BDT that haven't burned before + wtlf => cnveg_state_inst%wtlf_col , & ! Output: [real(r8) (:) ] fractional coverage of non-crop Patches + + totvegc => cnveg_carbonstate_inst%totvegc_col , & ! Input: [real(r8) (:) ] totvegc at column level + deadcrootc => cnveg_carbonstate_inst%deadcrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C + deadcrootc_storage => cnveg_carbonstate_inst%deadcrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C storage + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + deadstemc => cnveg_carbonstate_inst%deadstemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem root C + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C storage + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C transfer + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C storage + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C transfer + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C storage + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C transfer + rootc_col => cnveg_carbonstate_inst%rootc_col , & ! Output: [real(r8) (:) ] root carbon + leafc_col => cnveg_carbonstate_inst%leafc_col , & ! Output: [real(r8) (:) ] leaf carbon at column level + deadstemc_col => cnveg_carbonstate_inst%deadstemc_col , & ! Output: [real(r8) (:) ] deadstem carbon at column level + fuelc => cnveg_carbonstate_inst%fuelc_col , & ! Output: [real(r8) (:) ] fuel load coutside cropland + fuelc_crop => cnveg_carbonstate_inst%fuelc_crop_col & ! Output: [real(r8) (:) ] fuel load for cropland + ) + + ! jkolassa Mar 2023: insert Catch values in CLM types + this%forc_hdm = cn2clm_inst%forc_hdm_cn2clm + this%forc_lnfm = cn2clm_inst%forc_lnfm_cn2clm + + transient_landcover = run_has_transient_landcover() + + !pft to column average + prec10_col =>prec10_col_target + call p2c(bounds, num_soilc, filter_soilc, & + prec10(bounds%begp:bounds%endp), & + prec10_col(bounds%begc:bounds%endc)) + + prec60_col =>prec60_col_target + call p2c(bounds, num_soilc, filter_soilc, & + prec60(bounds%begp:bounds%endp), & + prec60_col(bounds%begc:bounds%endc)) + + rh30_col =>rh30_col_target + call p2c(bounds, num_soilc, filter_soilc, & + rh30(bounds%begp:bounds%endp), & + rh30_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + leafc(bounds%begp:bounds%endp), & + leafc_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + deadstemc(bounds%begp:bounds%endp), & + deadstemc_col(bounds%begc:bounds%endc)) + + call get_curr_date (kyr, kmo, kda, mcsec) + dayspyr = get_days_per_year() + ! Get model step size + dt = get_step_size_real() + ! + ! On first time-step, just set area burned to zero and exit + ! + if ( get_nstep() == 0 )then + do fc = 1,num_soilc + c = filter_soilc(fc) + farea_burned(c) = 0._r8 + baf_crop(c) = 0._r8 + baf_peatf(c) = 0._r8 + fbac(c) = 0._r8 + fbac1(c) = 0._r8 + cropf_col(c) = 0._r8 + end do + return + end if + ! + ! Calculate fraction of crop (cropf_col) and non-crop and non-bare-soil + ! vegetation (lfwt) in vegetated column + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + cropf_col(c) = 0._r8 + lfwt(c) = 0._r8 + end do + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + ! For crop veg types + if( patch%itype(p) > nc4_grass )then + cropf_col(c) = cropf_col(c) + patch%wtcol(p) + end if + ! For natural vegetation (non-crop and non-bare-soil) + if( patch%itype(p) >= ndllf_evr_tmp_tree .and. patch%itype(p) <= nc4_grass )then + lfwt(c) = lfwt(c) + patch%wtcol(p) + end if + end do + ! + ! Calculate crop fuel + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + fuelc_crop(c)=0._r8 + end do + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + ! For crop PFTs, fuel load includes leaf and litter; only + ! column-level litter carbon + ! is available, so we use leaf carbon to estimate the + ! litter carbon for crop PFTs + if( patch%itype(p) > nc4_grass .and. patch%wtcol(p) > 0._r8 .and. leafc_col(c) > 0._r8 )then + fuelc_crop(c)=fuelc_crop(c) + (leafc(p) + leafc_storage(p) + & + leafc_xfer(p))*patch%wtcol(p)/cropf_col(c) + & + totlitc(c)*leafc(p)/leafc_col(c)*patch%wtcol(p)/cropf_col(c) + end if + end do + ! + ! Calculate noncrop column variables + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + fsr_col(c) = 0._r8 + fd_col(c) = 0._r8 + rootc_col(c) = 0._r8 + lgdp_col(c) = 0._r8 + lgdp1_col(c) = 0._r8 + lpop_col(c) = 0._r8 + btran_col(c) = 0._r8 + wtlf(c) = 0._r8 + trotr1_col(c)= 0._r8 + trotr2_col(c)= 0._r8 + if (transient_landcover) then + dtrotr_col(c)=0._r8 + end if + end do + + ! This subroutine calculates btran2 + ! call this%CNFire_calc_fire_root_wetness_Li2014(bounds, & + ! num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + ! waterstatebulk_inst, soilstate_inst, soil_water_retention_curve) + + ! jkolassa Mar 2023: insert Catchment btran2 + btran2 = cn2clm_inst%btran2_patch_cn2clm + + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + c = patch%column(p) + ! For non-crop -- natural vegetation and bare-soil + if( patch%itype(p) < nc3crop .and. cropf_col(c) < 1.0_r8 )then + btran_col(c) = btran_col(c)+btran2(p)*patch%wtcol(p) + wtlf(c) = wtlf(c)+patch%wtcol(p) + end if + end do + + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = col%gridcell(c) + + ! For non-crop -- natural vegetation and bare-soil + if( patch%itype(p) < nc3crop .and. cropf_col(c) < 1.0_r8 )then + + ! NOTE(wjs, 2016-12-15) These calculations of the fraction of evergreen + ! and deciduous tropical trees (used to determine if a column is + ! tropical closed forest) use the current fractions. However, I think + ! they are used in code that applies to land cover change. Note that + ! land cover change is currently generated on the first time step of the + ! year (even though the fire code sees the annually-smoothed dwt). Thus, + ! I think that, for this to be totally consistent, this code should + ! consider the fractional coverage of each PFT prior to the relevant + ! land cover change event. (These fractions could be computed in the + ! code that handles land cover change, so that the fire code remains + ! agnostic to exactly how and when land cover change happens.) + ! + ! For example, if a year started with fractional coverages of + ! nbrdlf_evr_trp_tree = 0.35 and nbrdlf_dcd_trp_tree = 0.35, but then + ! the start-of-year land cover change reduced both of these to 0.2: The + ! current code would consider the column to NOT be tropical closed + ! forest (because nbrdlf_evr_trp_tree+nbrdlf_dcd_trp_tree < 0.6), + ! whereas in fact the land cover change occurred when the column *was* + ! tropical closed forest. + if( patch%itype(p) == nbrdlf_evr_trp_tree .and. patch%wtcol(p) > 0._r8 )then + trotr1_col(c)=trotr1_col(c)+patch%wtcol(p) + end if + if( patch%itype(p) == nbrdlf_dcd_trp_tree .and. patch%wtcol(p) > 0._r8 )then + trotr2_col(c)=trotr2_col(c)+patch%wtcol(p) + end if + + if (transient_landcover) then + if( patch%itype(p) == nbrdlf_evr_trp_tree .or. patch%itype(p) == nbrdlf_dcd_trp_tree )then + if(dwt_smoothed(p) < 0._r8)then + ! Land cover change in CLM happens all at once on the first time + ! step of the year. However, the fire code needs deforestation + ! rates throughout the year, in order to combine these + ! deforestation rates with the current season's climate. So we + ! use a smoothed version of dwt. + ! + ! This isn't ideal, because the carbon stocks that the fire code + ! is operating on will have decreased by the full annual amount + ! before the fire code does anything. But the biggest effect of + ! these deforestation fires is as a trigger for other fires, and + ! the C fluxes are merely diagnostic so don't need to be + ! conservative, so this isn't a big issue. + ! + ! (Actually, it would be even better if the fire code had a + ! realistic breakdown of annual deforestation into the + ! different seasons. But having deforestation spread evenly + ! throughout the year is much better than having it all + ! concentrated on January 1.) + dtrotr_col(c)=dtrotr_col(c)-dwt_smoothed(p) + end if + end if + end if + rootc_col(c) = rootc_col(c) + (frootc(p) + frootc_storage(p) + & + frootc_xfer(p) + deadcrootc(p) * spinup_factor_deadwood + & + deadcrootc_storage(p) + deadcrootc_xfer(p) + & + livecrootc(p)+livecrootc_storage(p) + & + livecrootc_xfer(p))*patch%wtcol(p) + + fsr_col(c) = fsr_col(c) + fsr_pft(patch%itype(p))*patch%wtcol(p)/(1.0_r8-cropf_col(c)) + + hdmlf=this%forc_hdm(g) + + ! all these constants are in Li et al. BG (2012a,b;2013) + + if( hdmlf > 0.1_r8 )then + ! For NOT bare-soil + if( patch%itype(p) /= noveg )then + ! For shrub and grass (crop already excluded above) + if( patch%itype(p) >= nbrdlf_evr_shrub )then !for shurb and grass + lgdp_col(c) = lgdp_col(c) + (0.1_r8 + 0.9_r8* & + exp(-1._r8*SHR_CONST_PI* & + (gdp_lf(c)/8._r8)**0.5_r8))*patch%wtcol(p) & + /(1.0_r8 - cropf_col(c)) + lgdp1_col(c) = lgdp1_col(c) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*SHR_CONST_PI* & + (gdp_lf(c)/7._r8)))*patch%wtcol(p)/(1._r8 - cropf_col(c)) + lpop_col(c) = lpop_col(c) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*SHR_CONST_PI* & + (hdmlf/450._r8)**0.5_r8))*patch%wtcol(p)/(1._r8 - cropf_col(c)) + else ! for trees + if( gdp_lf(c) > 20._r8 )then + lgdp_col(c) =lgdp_col(c)+cnfire_const%occur_hi_gdp_tree*patch%wtcol(p)/(1._r8 - cropf_col(c)) + lgdp1_col(c) =lgdp1_col(c)+0.62_r8*patch%wtcol(p)/(1._r8 - cropf_col(c)) + else + if( gdp_lf(c) > 8._r8 )then + lgdp_col(c)=lgdp_col(c)+0.79_r8*patch%wtcol(p)/(1._r8 - cropf_col(c)) + lgdp1_col(c)=lgdp1_col(c)+0.83_r8*patch%wtcol(p)/(1._r8 - cropf_col(c)) + else + lgdp_col(c) = lgdp_col(c)+patch%wtcol(p)/(1._r8 - cropf_col(c)) + lgdp1_col(c)=lgdp1_col(c)+patch%wtcol(p)/(1._r8 - cropf_col(c)) + end if + end if + lpop_col(c) = lpop_col(c) + (0.4_r8 + 0.6_r8* & + exp(-1._r8*SHR_CONST_PI* & + (hdmlf/125._r8)))*patch%wtcol(p)/(1._r8 -cropf_col(c)) + end if + end if + else + lgdp_col(c) = lgdp_col(c)+patch%wtcol(p)/(1.0_r8 - cropf_col(c)) + lgdp1_col(c) = lgdp1_col(c)+patch%wtcol(p)/(1.0_r8 -cropf_col(c)) + lpop_col(c) = lpop_col(c)+patch%wtcol(p)/(1.0_r8 -cropf_col(c)) + end if + + fd_col(c) = fd_col(c) + fd_pft(patch%itype(p)) * patch%wtcol(p) * secsphr / (1.0_r8-cropf_col(c)) + end if + end do + + ! estimate annual decreased fractional coverage of BET+BDT + ! land cover conversion in CLM4.5 is the same for each timestep except for the beginning + + if (transient_landcover) then + do fc = 1,num_soilc + c = filter_soilc(fc) + if( dtrotr_col(c) > 0._r8 )then + if( kmo == 1 .and. kda == 1 .and. mcsec == 0)then + lfc(c) = 0._r8 + end if + if( kmo == 1 .and. kda == 1 .and. mcsec == dt)then + lfc(c) = dtrotr_col(c)*dayspyr*secspday/dt + end if + else + lfc(c)=0._r8 + end if + end do + end if + ! + ! calculate burned area fraction in cropland + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + baf_crop(c)=0._r8 + end do + + do fp = 1,num_soilp + p = filter_soilp(fp) + if( kmo == 1 .and. kda == 1 .and. mcsec == 0 )then + burndate(p) = 10000 ! init. value; actual range [0 365] + end if + end do + + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = col%gridcell(c) + + ! For crop + if( forc_t(c) >= SHR_CONST_TKFRZ .and. patch%itype(p) > nc4_grass .and. & + kmo == abm_lf(c) .and. & + burndate(p) >= 999 .and. patch%wtcol(p) > 0._r8 )then ! catch crop burn time + + hdmlf = this%forc_hdm(g) + + ! calculate human density impact on ag. fire + fhd = 0.04_r8+0.96_r8*exp(-1._r8*SHR_CONST_PI*(hdmlf/350._r8)**0.5_r8) + + ! calculate impact of GDP on ag. fire + fgdp = 0.01_r8+0.99_r8*exp(-1._r8*SHR_CONST_PI*(gdp_lf(c)/10._r8)) + + ! calculate burned area + fb = max(0.0_r8,min(1.0_r8,(fuelc_crop(c)-lfuel)/(ufuel-lfuel))) + + ! crop fire only for generic crop types at this time + ! managed crops are treated as grasses if crop model is turned on + baf_crop(c) = baf_crop(c) + cropfire_a1/secsphr*fhd*fgdp*patch%wtcol(p) + if( fb*fhd*fgdp*patch%wtcol(p) > 0._r8)then + burndate(p)=kda + end if + end if + end do + ! + ! calculate peatland fire + ! + do fc = 1, num_soilc + c = filter_soilc(fc) + g= col%gridcell(c) + if(grc%latdeg(g) < cnfire_const%borealat )then + baf_peatf(c) = non_boreal_peatfire_c/secsphr*max(0._r8, & + min(1._r8,(4.0_r8-prec60_col(c)*secspday)/ & + 4.0_r8))**2*peatf_lf(c)*(1._r8-fsat(c)) + else + baf_peatf(c) = boreal_peatfire_c/secsphr*exp(-SHR_CONST_PI*(max(wf2(c),0._r8)/0.3_r8))* & + max(0._r8,min(1._r8,(tsoi17(c)-SHR_CONST_TKFRZ)/10._r8))*peatf_lf(c)* & + (1._r8-fsat(c)) + end if + end do + ! + ! calculate other fires + ! + + ! Set the number of timesteps for e-folding. + ! When the simulation has run fewer than this number of steps, + ! re-scale the e-folding time to get a stable early estimate. + + ! find which pool is the cwd pool + i_cwd = 0 + do l = 1, ndecomp_pools + if ( is_cwd(l) ) then + i_cwd = l + endif + end do + + ! + ! begin column loop to calculate fractional area affected by fire + ! + do fc = 1, num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + hdmlf=this%forc_hdm(g) + nfire(c) = 0._r8 + if( cropf_col(c) < 1._r8 )then + fuelc(c) = totlitc(c)+totvegc(c)-rootc_col(c)-fuelc_crop(c)*cropf_col(c) + if (spinup_state == 2) then + fuelc(c) = fuelc(c) + ((spinup_factor_deadwood - 1._r8)*deadstemc_col(c)) + do j = 1, nlevdecomp + fuelc(c) = fuelc(c)+decomp_cpools_vr(c,j,i_cwd) * dzsoi_decomp(j) * spinup_factor(i_cwd) & + * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + end do + else + do j = 1, nlevdecomp + fuelc(c) = fuelc(c)+decomp_cpools_vr(c,j,i_cwd) * dzsoi_decomp(j) + end do + end if + fuelc(c) = fuelc(c)/(1._r8-cropf_col(c)) + fb = max(0.0_r8,min(1.0_r8,(fuelc(c)-lfuel)/(ufuel-lfuel))) + if (trotr1_col(c)+trotr2_col(c)<=0.6_r8) then + afuel =min(1._r8,max(0._r8,(fuelc(c)-2500._r8)/(5000._r8-2500._r8))) + arh=1._r8-max(0._r8, min(1._r8,(forc_rh(g)-rh_low)/(rh_hgh-rh_low))) + arh30=1._r8-max(cnfire_params%prh30, min(1._r8,rh30_col(c)/90._r8)) + if (forc_rh(g) < rh_hgh.and. wtlf(c) > 0._r8 .and. tsoi17(c)> SHR_CONST_TKFRZ)then + fire_m = ((afuel*arh30+(1._r8-afuel)*arh)**1.5_r8)*((1._r8 -max(0._r8,& + min(1._r8,(btran_col(c)/wtlf(c)-bt_min)/(bt_max-bt_min))))**0.5_r8) + else + fire_m = 0._r8 + end if + lh = pot_hmn_ign_counts_alpha*6.8_r8*hdmlf**(0.43_r8)/30._r8/24._r8 + fs = 1._r8-(0.01_r8+0.98_r8*exp(-0.025_r8*hdmlf)) + ig = (lh+this%forc_lnfm(g)/(5.16_r8+2.16_r8*cos(SHR_CONST_PI/180._r8*3*min(60._r8,abs(grc%latdeg(g)))))* & + cnfire_params%ignition_efficiency)*(1._r8-fs)*(1._r8-cropf_col(c)) + nfire(c) = ig/secsphr*fb*fire_m*lgdp_col(c) !fire counts/km2/sec + Lb_lf = 1._r8+10._r8*(1._r8-EXP(-0.06_r8*forc_wind(g))) + spread_m = fire_m**0.5_r8 + farea_burned(c) = min(1._r8,(cnfire_const%g0*spread_m*fsr_col(c)* & + fd_col(c)/1000._r8)**2*lgdp1_col(c)* & + lpop_col(c)*nfire(c)*SHR_CONST_PI*Lb_lf+ & + baf_crop(c)+baf_peatf(c)) ! fraction (0-1) per sec + else + farea_burned(c)=min(1._r8,baf_crop(c)+baf_peatf(c)) + end if + ! + ! if landuse change data is used, calculate deforestation fires and + ! add it in the total of burned area fraction + ! + if (transient_landcover) then + if( trotr1_col(c)+trotr2_col(c) > 0.6_r8 )then + if(( kmo == 1 .and. kda == 1 .and. mcsec == 0) .or. & + dtrotr_col(c) <=0._r8 )then + fbac1(c) = 0._r8 + farea_burned(c) = baf_crop(c)+baf_peatf(c) + else + cri = (4.0_r8*trotr1_col(c)+1.8_r8*trotr2_col(c))/(trotr1_col(c)+trotr2_col(c)) + cli = (max(0._r8,min(1._r8,(cri-prec60_col(c)*secspday)/cri))**0.5)* & + (max(0._r8,min(1._r8,(cri-prec10_col(c)*secspday)/cri))**0.5)* & + max(0.0005_r8,min(1._r8,19._r8*dtrotr_col(c)*dayspyr*secspday/dt-0.001_r8))* & + max(0._r8,min(1._r8,(0.25_r8-(forc_rain(c)+forc_snow(c))*secsphr)/0.25_r8)) + farea_burned(c) = cli*(cli_scale/secspday)+baf_crop(c)+baf_peatf(c) + ! burned area out of conversion region due to land use fire + fbac1(c) = max(0._r8,fb*cli*(cli_scale/secspday) - 2.0_r8*lfc(c)/dt) + end if + ! total burned area out of conversion + fbac(c) = fbac1(c)+baf_crop(c)+baf_peatf(c) + else + fbac(c) = farea_burned(c) + end if + end if + + else + farea_burned(c) = min(1._r8,baf_crop(c)+baf_peatf(c)) + end if + + end do ! end of column loop + + end associate + + end subroutine CNFireArea + +end module CNFireLi2016Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2021Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2021Mod.F90 new file mode 100755 index 000000000..21c87b792 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireLi2021Mod.F90 @@ -0,0 +1,667 @@ +module CNFireLi2021Mod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! module for fire dynamics + ! created in Nov, 2012 and revised in Apr, 2013 by F. Li and S. Levis + ! based on Li et al. (2012a,b; 2013) + ! revised in Apr, 2014 according to Li et al.(2014) + ! revised in May, 2015, according to Li et al. (2015, in prep.) + ! Fire-related parameters were calibrated or tuned in May, 2015 based on the + ! 20th Century transient simulations at f19_g16 with a CLM4.5 version + ! (clm50fire), CRUNCEPv5, and climatological lightning data. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8, CL => shr_kind_CL + use shr_const_mod , only : SHR_CONST_PI,SHR_CONST_TKFRZ + use shr_infnan_mod , only : shr_infnan_isnan + use clm_varctl , only : iulog + use clm_varpar , only : nlevdecomp, ndecomp_pools, nlevdecomp_full, nlevgrnd + use clm_varcon , only : dzsoi_decomp + use pftconMod , only : noveg, pftcon + use abortutils , only : endrun + use decompMod , only : bounds_type + use subgridAveMod , only : p2c + use atm2lndType , only : atm2lnd_type + use CNDVType , only : dgvs_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type, spinup_factor_deadwood + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use EnergyFluxType , only : energyflux_type + use SaturatedExcessRunoffMod , only : saturated_excess_runoff_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use SoilStateType , only : soilstate_type + ! use SoilWaterRetentionCurveMod , only : soil_water_retention_curve_type + use GridcellType , only : grc + use ColumnType , only : col + use PatchType , only : patch + use SoilBiogeochemStateType , only : get_spinup_latitude_term + use FireMethodType , only : fire_method_type + use CNFireBaseMod , only : cnfire_base_type, cnfire_const, cnfire_params + use CN2CLMType + ! + implicit none + private + ! + ! !PUBLIC TYPES: + public :: cnfire_li2021_type + ! + type, extends(cnfire_base_type) :: cnfire_li2021_type + private + contains + ! + ! !PUBLIC MEMBER FUNCTIONS: + procedure, public :: need_lightning_and_popdens + procedure, public :: CNFireArea ! Calculate fire area + end type cnfire_li2021_type + + ! + ! !PRIVATE MEMBER DATA: + !----------------------------------------------------------------------- + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + function need_lightning_and_popdens(this) + ! !ARGUMENTS: + class(cnfire_li2021_type), intent(in) :: this + logical :: need_lightning_and_popdens ! function result + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'need_lightning_and_popdens' + !----------------------------------------------------------------------- + + need_lightning_and_popdens = .true. + end function need_lightning_and_popdens + + !----------------------------------------------------------------------- + subroutine CNFireArea (this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + atm2lnd_inst, energyflux_inst, saturated_excess_runoff_inst, waterdiagnosticbulk_inst, & + wateratm2lndbulk_inst, waterstatebulk_inst, soilstate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, totlitc_col, decomp_cpools_vr_col, t_soi17cm_col) + ! + ! !DESCRIPTION: + ! Computes column-level burned area + ! + ! !USES: + use clm_time_manager , only: get_step_size_real, get_days_per_year, get_curr_date, get_nstep + use clm_varcon , only: secspday, secsphr + use clm_varctl , only: spinup_state + use pftconMod , only: nc4_grass, nc3crop, ndllf_evr_tmp_tree + use pftconMod , only: nbrdlf_evr_trp_tree, nbrdlf_dcd_trp_tree, nbrdlf_evr_shrub + use dynSubgridControlMod , only : run_has_transient_landcover + ! + ! !ARGUMENTS: + class(cnfire_li2021_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(energyflux_type) , intent(in) :: energyflux_inst + type(saturated_excess_runoff_type) , intent(in) :: saturated_excess_runoff_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(wateratm2lndbulk_type) , intent(in) :: wateratm2lndbulk_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + !class(soil_water_retention_curve_type), intent(in) :: soil_water_retention_curve + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + real(r8) , intent(in) :: totlitc_col(bounds%begc:) + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,1:,1:) + real(r8) , intent(in) :: t_soi17cm_col(bounds%begc:) + ! + ! !LOCAL VARIABLES: + ! + integer :: g,l,c,p,pi,j,fc,fp,kyr, kmo, kda, mcsec ! index variables + real(r8) :: dt ! time step variable (s) + real(r8) :: dayspyr ! days per year + real(r8) :: cli ! effect of climate on deforestation fires (0-1) + real(r8) :: cri ! thresholds used for cli, (mm/d), see Eq.(7) in Li et al.(2013) + real(r8) :: fb ! availability of fuel for regs A and C + real(r8) :: fhd ! impact of hd on agricultural fire + real(r8) :: fgdp ! impact of gdp on agricultural fire + real(r8) :: fire_m ! combustability of fuel for fire occurrence + real(r8) :: spread_m ! combustability of fuel for fire spread + real(r8) :: Lb_lf ! length-to-breadth ratio added by Lifang + integer :: i_cwd ! cwd pool + real(r8) :: lh ! anthro. ignitions (count/km2/hr) + real(r8) :: fs ! hd-dependent fires suppression (0-1) + real(r8) :: ig ! total ignitions (count/km2/hr) + real(r8) :: hdmlf ! human density + real(r8) :: arh, arh30 !combustability of fuel related to RH and RH30 + real(r8) :: afuel !weight for arh and arh30 + real(r8) :: btran_col(bounds%begc:bounds%endc) + logical :: transient_landcover ! whether this run has any prescribed transient landcover + real(r8), target :: prec60_col_target(bounds%begc:bounds%endc) + real(r8), target :: prec10_col_target(bounds%begc:bounds%endc) + real(r8), target :: rh30_col_target(bounds%begc:bounds%endc) + real(r8), pointer :: prec60_col(:) + real(r8), pointer :: prec10_col(:) + real(r8), pointer :: rh30_col(:) + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(totlitc_col) == (/bounds%endc/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_cpools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(t_soi17cm_col) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + totlitc => totlitc_col , & ! Input: [real(r8) (:) ] (gC/m2) total lit C (column-level mean) + decomp_cpools_vr => decomp_cpools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) VR decomp. (litter, cwd, soil) + tsoi17 => t_soi17cm_col , & ! Input: [real(r8) (:) ] (K) soil T for top 0.17 m + + lfuel => cnfire_const%lfuel , & ! Input: [real(r8) ] (gC/m2) Lower threshold of fuel mass + ufuel => cnfire_const%ufuel , & ! Input: [real(r8) ] (gC/m2) Upper threshold of fuel mass + rh_hgh => cnfire_const%rh_hgh , & ! Input: [real(r8) ] (%) High relative humidity + rh_low => cnfire_const%rh_low , & ! Input: [real(r8) ] (%) Low relative humidity + cli_scale => cnfire_const%cli_scale , & ! Input: [real(r8) ] (/d) global constant for deforestation fires + cropfire_a1 => cnfire_const%cropfire_a1 , & ! Input: [real(r8) ] (/hr) a1 parameter for cropland fire + non_boreal_peatfire_c => cnfire_const%non_boreal_peatfire_c , & ! Input: [real(r8) ] (/hr) c parameter for non-boreal peatland fire + pot_hmn_ign_counts_alpha => cnfire_const%pot_hmn_ign_counts_alpha , & ! Input: [real(r8) ] (/person/month) Potential human ignition counts + boreal_peatfire_c => cnfire_const%boreal_peatfire_c , & ! Input: [real(r8) ] (/hr) c parameter for boreal peatland fire + + fsr_pft => pftcon%fsr_pft , & ! Input: + fd_pft => pftcon%fd_pft , & ! Input: + rswf_min => pftcon%rswf_min , & ! Input: + rswf_max => pftcon%rswf_max , & ! Input: + btran2 => this%cnfire_base_type%btran2_patch , & ! Input: [real(r8) (:) ] root zone soil wetness + fsat => saturated_excess_runoff_inst%fsat_col , & ! Input: [real(r8) (:) ] fractional area with water table at surface + wf2 => waterdiagnosticbulk_inst%wf2_col , & ! Input: [real(r8) (:) ] soil water as frac. of whc for top 0.17 m + + is_cwd => decomp_cascade_con%is_cwd , & ! Input: [logical (:) ] TRUE => pool is a cwd pool + spinup_factor => decomp_cascade_con%spinup_factor , & ! Input: [real(r8) (:) ] factor for AD spinup associated with each pool + + forc_rh => wateratm2lndbulk_inst%forc_rh_grc , & ! Input: [real(r8) (:) ] relative humidity + forc_wind => atm2lnd_inst%forc_wind_grc , & ! Input: [real(r8) (:) ] atmospheric wind speed (m/s) + forc_t => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:) ] downscaled atmospheric temperature (Kelvin) + forc_rain => wateratm2lndbulk_inst%forc_rain_downscaled_col , & ! Input: [real(r8) (:) ] downscaled rain + forc_snow => wateratm2lndbulk_inst%forc_snow_downscaled_col , & ! Input: [real(r8) (:) ] downscaled snow + prec60 => wateratm2lndbulk_inst%prec60_patch , & ! Input: [real(r8) (:) ] 60-day running mean of tot. precipitation + prec10 => wateratm2lndbulk_inst%prec10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of tot. precipitation + rh30 => wateratm2lndbulk_inst%rh30_patch , & ! Input: [real(r8) (:) ] 10-day running mean of tot. precipitation + dwt_smoothed => cnveg_state_inst%dwt_smoothed_patch , & ! Input: [real(r8) (:) ] change in patch weight (-1 to 1) on the gridcell, smoothed over the year + cropf_col => cnveg_state_inst%cropf_col , & ! Input: [real(r8) (:) ] cropland fraction in veg column + gdp_lf => cnveg_state_inst%gdp_lf_col , & ! Input: [real(r8) (:) ] gdp data + peatf_lf => cnveg_state_inst%peatf_lf_col , & ! Input: [real(r8) (:) ] peatland fraction data + abm_lf => cnveg_state_inst%abm_lf_col , & ! Input: [integer (:) ] prescribed crop fire time + baf_crop => cnveg_state_inst%baf_crop_col , & ! Output: [real(r8) (:) ] burned area fraction for cropland (/sec) + baf_peatf => cnveg_state_inst%baf_peatf_col , & ! Output: [real(r8) (:) ] burned area fraction for peatland (/sec) + burndate => cnveg_state_inst%burndate_patch , & ! Output: [integer (:) ] burn date for crop + fbac => cnveg_state_inst%fbac_col , & ! Output: [real(r8) (:) ] total burned area out of conversion (/sec) + fbac1 => cnveg_state_inst%fbac1_col , & ! Output: [real(r8) (:) ] burned area out of conversion region due to land use fire + farea_burned => cnveg_state_inst%farea_burned_col , & ! Output: [real(r8) (:) ] total fractional area burned (/sec) + nfire => cnveg_state_inst%nfire_col , & ! Output: [real(r8) (:) ] fire counts (count/km2/sec), valid only in Reg. C + fsr_col => cnveg_state_inst%fsr_col , & ! Output: [real(r8) (:) ] fire spread rate at column level + fd_col => cnveg_state_inst%fd_col , & ! Output: [real(r8) (:) ] fire duration rate at column level + lgdp_col => cnveg_state_inst%lgdp_col , & ! Output: [real(r8) (:) ] gdp limitation factor for nfire + lgdp1_col => cnveg_state_inst%lgdp1_col , & ! Output: [real(r8) (:) ] gdp limitation factor for baf per fire + lpop_col => cnveg_state_inst%lpop_col , & ! Output: [real(r8) (:) ] pop limitation factor for baf per fire + lfwt => cnveg_state_inst%lfwt_col , & ! Output: [real(r8) (:) ] fractional coverage of non-crop and non-bare-soil Patches + trotr1_col => cnveg_state_inst%trotr1_col , & ! Output: [real(r8) (:) ] patch weight of BET on the column (0-1) + trotr2_col => cnveg_state_inst%trotr2_col , & ! Output: [real(r8) (:) ] patch weight of BDT on the column (0-1) + dtrotr_col => cnveg_state_inst%dtrotr_col , & ! Output: [real(r8) (:) ] decreased frac. coverage of BET+BDT on grid for dt + lfc => cnveg_state_inst%lfc_col , & ! Output: [real(r8) (:) ] conversion area frac. of BET+BDT that haven't burned before + wtlf => cnveg_state_inst%wtlf_col , & ! Output: [real(r8) (:) ] fractional coverage of non-crop Patches + + totvegc => cnveg_carbonstate_inst%totvegc_col , & ! Input: [real(r8) (:) ] totvegc at column level + deadcrootc => cnveg_carbonstate_inst%deadcrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C + deadcrootc_storage => cnveg_carbonstate_inst%deadcrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C storage + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + deadstemc => cnveg_carbonstate_inst%deadstemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem root C + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C storage + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C transfer + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C storage + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C transfer + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C storage + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C transfer + rootc_col => cnveg_carbonstate_inst%rootc_col , & ! Output: [real(r8) (:) ] root carbon + leafc_col => cnveg_carbonstate_inst%leafc_col , & ! Output: [real(r8) (:) ] leaf carbon at column level + deadstemc_col => cnveg_carbonstate_inst%deadstemc_col , & ! Output: [real(r8) (:) ] deadstem carbon at column level + fuelc => cnveg_carbonstate_inst%fuelc_col , & ! Output: [real(r8) (:) ] fuel load coutside cropland + fuelc_crop => cnveg_carbonstate_inst%fuelc_crop_col & ! Output: [real(r8) (:) ] fuel load for cropland + ) + + ! jkolassa Mar 2023: insert Catch values in CLM types + this%forc_hdm = cn2clm_inst%forc_hdm_cn2clm + this%forc_lnfm = cn2clm_inst%forc_lnfm_cn2clm + + transient_landcover = run_has_transient_landcover() + + !pft to column average + prec10_col =>prec10_col_target + call p2c(bounds, num_soilc, filter_soilc, & + prec10(bounds%begp:bounds%endp), & + prec10_col(bounds%begc:bounds%endc)) + + prec60_col =>prec60_col_target + call p2c(bounds, num_soilc, filter_soilc, & + prec60(bounds%begp:bounds%endp), & + prec60_col(bounds%begc:bounds%endc)) + + rh30_col =>rh30_col_target + call p2c(bounds, num_soilc, filter_soilc, & + rh30(bounds%begp:bounds%endp), & + rh30_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + leafc(bounds%begp:bounds%endp), & + leafc_col(bounds%begc:bounds%endc)) + + call p2c(bounds, num_soilc, filter_soilc, & + deadstemc(bounds%begp:bounds%endp), & + deadstemc_col(bounds%begc:bounds%endc)) + + call get_curr_date (kyr, kmo, kda, mcsec) + dayspyr = get_days_per_year() + ! Get model step size + dt = get_step_size_real() + ! + ! On first time-step, just set area burned to zero and exit + ! + if ( get_nstep() == 0 )then + do fc = 1,num_soilc + c = filter_soilc(fc) + farea_burned(c) = 0._r8 + baf_crop(c) = 0._r8 + baf_peatf(c) = 0._r8 + fbac(c) = 0._r8 + fbac1(c) = 0._r8 + cropf_col(c) = 0._r8 + end do + return + end if + ! + ! Calculate fraction of crop (cropf_col) and non-crop and non-bare-soil + ! vegetation (lfwt) in vegetated column + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + cropf_col(c) = 0._r8 + lfwt(c) = 0._r8 + end do + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + ! For crop veg types + if( patch%itype(p) > nc4_grass )then + cropf_col(c) = cropf_col(c) + patch%wtcol(p) + end if + ! For natural vegetation (non-crop and non-bare-soil) + if( patch%itype(p) >= ndllf_evr_tmp_tree .and. patch%itype(p) <= nc4_grass )then + lfwt(c) = lfwt(c) + patch%wtcol(p) + end if + end do + ! + ! Calculate crop fuel + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + fuelc_crop(c)=0._r8 + end do + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + ! For crop PFTs, fuel load includes leaf and litter; only + ! column-level litter carbon + ! is available, so we use leaf carbon to estimate the + ! litter carbon for crop PFTs + if( patch%itype(p) > nc4_grass .and. patch%wtcol(p) > 0._r8 .and. leafc_col(c) > 0._r8 )then + fuelc_crop(c)=fuelc_crop(c) + (leafc(p) + leafc_storage(p) + & + leafc_xfer(p))*patch%wtcol(p)/cropf_col(c) + & + totlitc(c)*leafc(p)/leafc_col(c)*patch%wtcol(p)/cropf_col(c) + end if + end do + ! + ! Calculate noncrop column variables + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + fsr_col(c) = 0._r8 + fd_col(c) = 0._r8 + rootc_col(c) = 0._r8 + lgdp_col(c) = 0._r8 + lgdp1_col(c) = 0._r8 + lpop_col(c) = 0._r8 + btran_col(c) = 0._r8 + wtlf(c) = 0._r8 + trotr1_col(c)= 0._r8 + trotr2_col(c)= 0._r8 + if (transient_landcover) then + dtrotr_col(c)=0._r8 + end if + end do + + ! This subroutine calculates btran2 + ! call this%CNFire_calc_fire_root_wetness_Li2021(bounds, & + ! num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + ! waterstatebulk_inst, soilstate_inst, soil_water_retention_curve) + + ! jkolassa Mar 2023: insert Catchment btran2 + btran2 = cn2clm_inst%btran2_patch_cn2clm + + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + c = patch%column(p) + ! For non-crop -- natural vegetation and bare-soil + if( patch%itype(p) < nc3crop .and. cropf_col(c) < 1.0_r8 )then + btran_col(c) = btran_col(c)+max(0._r8, min(1._r8, & + (btran2(p)-rswf_min(patch%itype(p)))/(rswf_max(patch%itype(p)) & + -rswf_min(patch%itype(p)))))*patch%wtcol(p) + wtlf(c) = wtlf(c)+patch%wtcol(p) + end if + end do + + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = col%gridcell(c) + + ! For non-crop -- natural vegetation and bare-soil + if( patch%itype(p) < nc3crop .and. cropf_col(c) < 1.0_r8 )then + + ! NOTE(wjs, 2016-12-15) These calculations of the fraction of evergreen + ! and deciduous tropical trees (used to determine if a column is + ! tropical closed forest) use the current fractions. However, I think + ! they are used in code that applies to land cover change. Note that + ! land cover change is currently generated on the first time step of the + ! year (even though the fire code sees the annually-smoothed dwt). Thus, + ! I think that, for this to be totally consistent, this code should + ! consider the fractional coverage of each PFT prior to the relevant + ! land cover change event. (These fractions could be computed in the + ! code that handles land cover change, so that the fire code remains + ! agnostic to exactly how and when land cover change happens.) + ! + ! For example, if a year started with fractional coverages of + ! nbrdlf_evr_trp_tree = 0.35 and nbrdlf_dcd_trp_tree = 0.35, but then + ! the start-of-year land cover change reduced both of these to 0.2: The + ! current code would consider the column to NOT be tropical closed + ! forest (because nbrdlf_evr_trp_tree+nbrdlf_dcd_trp_tree < 0.6), + ! whereas in fact the land cover change occurred when the column *was* + ! tropical closed forest. + if( patch%itype(p) == nbrdlf_evr_trp_tree .and. patch%wtcol(p) > 0._r8 )then + trotr1_col(c)=trotr1_col(c)+patch%wtcol(p) + end if + if( patch%itype(p) == nbrdlf_dcd_trp_tree .and. patch%wtcol(p) > 0._r8 )then + trotr2_col(c)=trotr2_col(c)+patch%wtcol(p) + end if + + if (transient_landcover) then + if( patch%itype(p) == nbrdlf_evr_trp_tree .or. patch%itype(p) == nbrdlf_dcd_trp_tree )then + if(dwt_smoothed(p) < 0._r8)then + ! Land cover change in CLM happens all at once on the first time + ! step of the year. However, the fire code needs deforestation + ! rates throughout the year, in order to combine these + ! deforestation rates with the current season's climate. So we + ! use a smoothed version of dwt. + ! + ! This isn't ideal, because the carbon stocks that the fire code + ! is operating on will have decreased by the full annual amount + ! before the fire code does anything. But the biggest effect of + ! these deforestation fires is as a trigger for other fires, and + ! the C fluxes are merely diagnostic so don't need to be + ! conservative, so this isn't a big issue. + ! + ! (Actually, it would be even better if the fire code had a + ! realistic breakdown of annual deforestation into the + ! different seasons. But having deforestation spread evenly + ! throughout the year is much better than having it all + ! concentrated on January 1.) + dtrotr_col(c)=dtrotr_col(c)-dwt_smoothed(p) + end if + end if + end if + rootc_col(c) = rootc_col(c) + (frootc(p) + frootc_storage(p) + & + frootc_xfer(p) + deadcrootc(p) * spinup_factor_deadwood + & + deadcrootc_storage(p) + deadcrootc_xfer(p) + & + livecrootc(p)+livecrootc_storage(p) + & + livecrootc_xfer(p))*patch%wtcol(p) + + fsr_col(c) = fsr_col(c) + fsr_pft(patch%itype(p))*patch%wtcol(p)/(1.0_r8-cropf_col(c)) + + hdmlf=this%forc_hdm(g) + + ! all these constants are in Li et al. BG (2012a,b;2013) + + if( hdmlf > 0.1_r8 )then + ! For NOT bare-soil + if( patch%itype(p) /= noveg )then + ! For shrub and grass (crop already excluded above) + if( patch%itype(p) >= nbrdlf_evr_shrub )then !for shurb and grass + lgdp_col(c) = lgdp_col(c) + (0.1_r8 + 0.9_r8* & + exp(-1._r8*SHR_CONST_PI* & + (gdp_lf(c)/8._r8)**0.5_r8))*patch%wtcol(p) & + /(1.0_r8 - cropf_col(c)) + lgdp1_col(c) = lgdp1_col(c) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*SHR_CONST_PI* & + (gdp_lf(c)/7._r8)))*patch%wtcol(p)/(1._r8 - cropf_col(c)) + lpop_col(c) = lpop_col(c) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*SHR_CONST_PI* & + (hdmlf/450._r8)**0.5_r8))*patch%wtcol(p)/(1._r8 - cropf_col(c)) + else ! for trees + if( gdp_lf(c) > 20._r8 )then + lgdp_col(c) =lgdp_col(c)+cnfire_const%occur_hi_gdp_tree*patch%wtcol(p)/(1._r8 - cropf_col(c)) + lgdp1_col(c) =lgdp1_col(c)+0.62_r8*patch%wtcol(p)/(1._r8 - cropf_col(c)) + else + if( gdp_lf(c) > 8._r8 )then + lgdp_col(c)=lgdp_col(c)+0.79_r8*patch%wtcol(p)/(1._r8 - cropf_col(c)) + lgdp1_col(c)=lgdp1_col(c)+0.83_r8*patch%wtcol(p)/(1._r8 - cropf_col(c)) + else + lgdp_col(c) = lgdp_col(c)+patch%wtcol(p)/(1._r8 - cropf_col(c)) + lgdp1_col(c)=lgdp1_col(c)+patch%wtcol(p)/(1._r8 - cropf_col(c)) + end if + end if + lpop_col(c) = lpop_col(c) + (0.4_r8 + 0.6_r8* & + exp(-1._r8*SHR_CONST_PI* & + (hdmlf/125._r8)))*patch%wtcol(p)/(1._r8 -cropf_col(c)) + end if + end if + else + lgdp_col(c) = lgdp_col(c)+patch%wtcol(p)/(1.0_r8 - cropf_col(c)) + lgdp1_col(c) = lgdp1_col(c)+patch%wtcol(p)/(1.0_r8 -cropf_col(c)) + lpop_col(c) = lpop_col(c)+patch%wtcol(p)/(1.0_r8 -cropf_col(c)) + end if + + fd_col(c) = fd_col(c) + fd_pft(patch%itype(p)) * patch%wtcol(p) * secsphr / (1.0_r8-cropf_col(c)) + end if + end do + + ! estimate annual decreased fractional coverage of BET+BDT + ! land cover conversion in CLM4.5 is the same for each timestep except for the beginning + + if (transient_landcover) then + do fc = 1,num_soilc + c = filter_soilc(fc) + if( dtrotr_col(c) > 0._r8 )then + if( kmo == 1 .and. kda == 1 .and. mcsec == 0)then + lfc(c) = 0._r8 + end if + if( kmo == 1 .and. kda == 1 .and. mcsec == dt)then + lfc(c) = dtrotr_col(c)*dayspyr*secspday/dt + end if + else + lfc(c)=0._r8 + end if + end do + end if + ! + ! calculate burned area fraction in cropland + ! + do fc = 1,num_soilc + c = filter_soilc(fc) + baf_crop(c)=0._r8 + end do + + do fp = 1,num_soilp + p = filter_soilp(fp) + if( kmo == 1 .and. kda == 1 .and. mcsec == 0 )then + burndate(p) = 10000 ! init. value; actual range [0 365] + end if + end do + + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = col%gridcell(c) + + ! For crop + if( forc_t(c) >= SHR_CONST_TKFRZ .and. patch%itype(p) > nc4_grass .and. & + kmo == abm_lf(c) .and. & + burndate(p) >= 999 .and. patch%wtcol(p) > 0._r8 )then ! catch crop burn time + + hdmlf = this%forc_hdm(g) + + ! calculate human density impact on ag. fire + fhd = 0.04_r8+0.96_r8*exp(-1._r8*SHR_CONST_PI*(hdmlf/350._r8)**0.5_r8) + + ! calculate impact of GDP on ag. fire + fgdp = 0.01_r8+0.99_r8*exp(-1._r8*SHR_CONST_PI*(gdp_lf(c)/10._r8)) + + ! calculate burned area + fb = max(0.0_r8,min(1.0_r8,(fuelc_crop(c)-lfuel)/(ufuel-lfuel))) + + ! crop fire only for generic crop types at this time + ! managed crops are treated as grasses if crop model is turned on + baf_crop(c) = baf_crop(c) + cropfire_a1/secsphr*fhd*fgdp*patch%wtcol(p) + if( fb*fhd*fgdp*patch%wtcol(p) > 0._r8)then + burndate(p)=kda + end if + end if + end do + ! + ! calculate peatland fire + ! + do fc = 1, num_soilc + c = filter_soilc(fc) + g= col%gridcell(c) + if(grc%latdeg(g) < cnfire_const%borealat )then + baf_peatf(c) = non_boreal_peatfire_c/secsphr*max(0._r8, & + min(1._r8,(4.0_r8-prec60_col(c)*secspday)/ & + 4.0_r8))**2*peatf_lf(c)*(1._r8-fsat(c)) + else + baf_peatf(c) = boreal_peatfire_c/secsphr*exp(-SHR_CONST_PI*(max(wf2(c),0._r8)/0.3_r8))* & + max(0._r8,min(1._r8,(tsoi17(c)-SHR_CONST_TKFRZ)/10._r8))*peatf_lf(c)* & + (1._r8-fsat(c)) + end if + end do + ! + ! calculate other fires + ! + + ! Set the number of timesteps for e-folding. + ! When the simulation has run fewer than this number of steps, + ! re-scale the e-folding time to get a stable early estimate. + + ! find which pool is the cwd pool + i_cwd = 0 + do l = 1, ndecomp_pools + if ( is_cwd(l) ) then + i_cwd = l + endif + end do + + ! + ! begin column loop to calculate fractional area affected by fire + ! + do fc = 1, num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + hdmlf=this%forc_hdm(g) + nfire(c) = 0._r8 + if( cropf_col(c) < 1._r8 )then + fuelc(c) = totlitc(c)+totvegc(c)-rootc_col(c)-fuelc_crop(c)*cropf_col(c) + if (spinup_state == 2) then + fuelc(c) = fuelc(c) + ((spinup_factor_deadwood - 1._r8)*deadstemc_col(c)) + do j = 1, nlevdecomp + fuelc(c) = fuelc(c)+decomp_cpools_vr(c,j,i_cwd) * dzsoi_decomp(j) * spinup_factor(i_cwd) & + * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + end do + else + do j = 1, nlevdecomp + fuelc(c) = fuelc(c)+decomp_cpools_vr(c,j,i_cwd) * dzsoi_decomp(j) + end do + end if + fuelc(c) = fuelc(c)/(1._r8-cropf_col(c)) + fb = max(0.0_r8,min(1.0_r8,(fuelc(c)-lfuel)/(ufuel-lfuel))) + if (trotr1_col(c)+trotr2_col(c)<=0.6_r8) then + afuel =min(1._r8,max(0._r8,(fuelc(c)-2500._r8)/(5000._r8-2500._r8))) + arh=1._r8-max(0._r8, min(1._r8,(forc_rh(g)-rh_low)/(rh_hgh-rh_low))) + arh30=1._r8-max(cnfire_params%prh30, min(1._r8,rh30_col(c)/90._r8)) + if (forc_rh(g) < rh_hgh.and. wtlf(c) > 0._r8 .and. tsoi17(c)> SHR_CONST_TKFRZ)then + fire_m = ((afuel*arh30+(1._r8-afuel)*arh)**1.5_r8) & + *((1._r8-btran_col(c)/wtlf(c))**0.5_r8) + else + fire_m = 0._r8 + end if + lh = pot_hmn_ign_counts_alpha*6.8_r8*hdmlf**(0.43_r8)/30._r8/24._r8 + fs = 1._r8-(0.01_r8+0.98_r8*exp(-0.025_r8*hdmlf)) + ig = (lh+this%forc_lnfm(g)/(5.16_r8+2.16_r8* & + cos(SHR_CONST_PI/180._r8*3*min(60._r8,abs(grc%latdeg(g)))))* & + cnfire_params%ignition_efficiency)*(1._r8-fs)*(1._r8-cropf_col(c)) + nfire(c) = ig/secsphr*fb*fire_m*lgdp_col(c) !fire counts/km2/sec + Lb_lf = 1._r8+10._r8*(1._r8-EXP(-0.06_r8*forc_wind(g))) + spread_m = fire_m**0.5_r8 + farea_burned(c) = min(1._r8,(cnfire_const%g0*spread_m*fsr_col(c)* & + fd_col(c)/1000._r8)**2*lgdp1_col(c)* & + lpop_col(c)*nfire(c)*SHR_CONST_PI*Lb_lf+ & + baf_crop(c)+baf_peatf(c)) ! fraction (0-1) per sec + else + farea_burned(c)=min(1._r8,baf_crop(c)+baf_peatf(c)) + end if + ! + ! if landuse change data is used, calculate deforestation fires and + ! add it in the total of burned area fraction + ! + if (transient_landcover) then + if( trotr1_col(c)+trotr2_col(c) > 0.6_r8 )then + if(( kmo == 1 .and. kda == 1 .and. mcsec == 0) .or. & + dtrotr_col(c) <=0._r8 )then + fbac1(c) = 0._r8 + farea_burned(c) = baf_crop(c)+baf_peatf(c) + else + cri = (4.0_r8*trotr1_col(c)+1.8_r8*trotr2_col(c))/(trotr1_col(c)+trotr2_col(c)) + cli = (max(0._r8,min(1._r8,(cri-prec60_col(c)*secspday)/cri))**0.5)* & + (max(0._r8,min(1._r8,(cri-prec10_col(c)*secspday)/cri))**0.5)* & + (15._r8*min(0.0016_r8,dtrotr_col(c)/dt*dayspyr*secspday)+0.009_r8)* & + max(0._r8,min(1._r8,(0.25_r8-(forc_rain(c)+forc_snow(c))*secsphr)/0.25_r8)) + farea_burned(c) = fb*cli*(cli_scale/secspday)+baf_crop(c)+baf_peatf(c) + ! burned area out of conversion region due to land use fire + fbac1(c) = max(0._r8,fb*cli*(cli_scale/secspday) - 2.0_r8*lfc(c)/dt) + end if + ! total burned area out of conversion + fbac(c) = fbac1(c)+baf_crop(c)+baf_peatf(c) + else + fbac(c) = farea_burned(c) + end if + end if + + else + farea_burned(c) = min(1._r8,baf_crop(c)+baf_peatf(c)) + end if + + end do ! end of column loop + + end associate + + end subroutine CNFireArea + +end module CNFireLi2021Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireNoFireMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireNoFireMod.F90 new file mode 100755 index 000000000..5c1472bcb --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireNoFireMod.F90 @@ -0,0 +1,139 @@ +module CNFireNoFireMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! module for fire dynamics with fire explicitly turned off + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8, CL => shr_kind_CL + use decompMod , only : bounds_type + use atm2lndType , only : atm2lnd_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use EnergyFluxType , only : energyflux_type + use SaturatedExcessRunoffMod , only : saturated_excess_runoff_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use SoilStateType , only : soilstate_type + use FireMethodType , only : fire_method_type + use CNFireBaseMod , only : cnfire_base_type + ! + implicit none + private + ! + ! !PUBLIC TYPES: + public :: cnfire_nofire_type + ! + type, extends(cnfire_base_type) :: cnfire_nofire_type + private + contains + ! + ! !PUBLIC MEMBER FUNCTIONS: + procedure, public :: need_lightning_and_popdens + procedure, public :: CNFireArea ! Calculate fire area + end type cnfire_nofire_type + +contains + + !----------------------------------------------------------------------- + function need_lightning_and_popdens(this) + ! !ARGUMENTS: + class(cnfire_nofire_type), intent(in) :: this + logical :: need_lightning_and_popdens ! function result + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'need_lightning_and_popdens' + !----------------------------------------------------------------------- + + need_lightning_and_popdens = .false. + end function need_lightning_and_popdens + + !----------------------------------------------------------------------- + subroutine CNFireArea (this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + atm2lnd_inst, energyflux_inst, saturated_excess_runoff_inst, & + waterdiagnosticbulk_inst, wateratm2lndbulk_inst, & + waterstatebulk_inst, soilstate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, totlitc_col, decomp_cpools_vr_col, t_soi17cm_col) + ! + ! !DESCRIPTION: + ! Computes column-level burned area + ! + ! !USES: + use subgridAveMod , only : p2c + ! + ! !ARGUMENTS: + class(cnfire_nofire_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(energyflux_type) , intent(in) :: energyflux_inst + type(saturated_excess_runoff_type) , intent(in) :: saturated_excess_runoff_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(wateratm2lndbulk_type) , intent(in) :: wateratm2lndbulk_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + real(r8) , intent(in) :: totlitc_col(bounds%begc:) + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,1:,1:) + real(r8) , intent(in) :: t_soi17cm_col(bounds%begc:) + ! + ! !LOCAL VARIABLES: + integer :: c,fc ! index variables + !----------------------------------------------------------------------- + + associate( & + cropf_col => cnveg_state_inst%cropf_col , & ! Input: [real(r8) (:) ] cropland fraction in veg column + baf_crop => cnveg_state_inst%baf_crop_col , & ! Output: [real(r8) (:) ] burned area fraction for cropland (/sec) + baf_peatf => cnveg_state_inst%baf_peatf_col , & ! Output: [real(r8) (:) ] burned area fraction for peatland (/sec) + fbac => cnveg_state_inst%fbac_col , & ! Output: [real(r8) (:) ] total burned area out of conversion (/sec) + fbac1 => cnveg_state_inst%fbac1_col , & ! Output: [real(r8) (:) ] burned area out of conversion region due to land use fire + lfc => cnveg_state_inst%lfc_col , & ! Output: [real(r8) (:) ] conversion area frac. of BET+BDT that haven't burned before + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + leafc_col => cnveg_carbonstate_inst%leafc_col , & ! Output: [real(r8) (:) ] leaf carbon at column level + farea_burned => cnveg_state_inst%farea_burned_col & ! Output: [real(r8) (:) ] total fractional area burned (/sec) + ) + + !pft to column average + call p2c(bounds, num_soilc, filter_soilc, & + leafc(bounds%begp:bounds%endp), & + leafc_col(bounds%begc:bounds%endc)) + ! + ! begin column loop to calculate fractional area affected by fire + ! + do fc = 1, num_soilc + c = filter_soilc(fc) + + ! zero out the fire area + + farea_burned(c) = 0._r8 + baf_crop(c) = 0._r8 + baf_peatf(c) = 0._r8 + fbac(c) = 0._r8 + fbac1(c) = 0._r8 + cropf_col(c) = 0._r8 + lfc(c) = 0._r8 + ! with NOFIRE, tree carbon is still removed in landuse change regions by the + ! landuse code + end do ! end of column loop + + end associate + + end subroutine CNFireArea + +end module CNFireNoFireMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNGRespMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNGRespMod.F90 new file mode 100755 index 000000000..d95761e61 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNGRespMod.F90 @@ -0,0 +1,214 @@ +module CNGRespMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for growth respiration fluxes, + ! for coupled carbon-nitrogen code. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use pftconMod , only : npcropmin, pftcon + use CNVegcarbonfluxType , only : cnveg_carbonflux_type + use PatchType , only : patch + use CanopyStateType , only : canopystate_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: CNGResp + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + ! subroutine CNGResp(num_soilp, filter_soilp, cnveg_carbonflux_inst) + subroutine CNGResp(num_soilp, filter_soilp, cnveg_carbonflux_inst, canopystate_inst, cnveg_carbonstate_inst, & + cnveg_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update all the prognostic carbon state + ! variables + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: p ! indices + integer :: fp ! lake filter patch index + real(r8):: respfact_leaf + real(r8):: respfact_froot + real(r8):: respfact_livecroot + real(r8):: respfact_livestem + real(r8):: respfact_leaf_storage + real(r8):: respfact_froot_storage + real(r8):: respfact_livecroot_storage + real(r8):: respfact_livestem_storage + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:)] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + grperc => pftcon%grperc , & ! Input: growth respiration parameter + grpnow => pftcon%grpnow , & ! Input: growth respiration parameter + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: fine root C:N (gC/gN) + livewdcn => pftcon%livewdcn , & ! Input: live wood (phloem and ray parenchyma) C:N (gC/gN) + + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:)] sunlit projected leaf area index + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:)] shaded projected leaf area index + + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:)] + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:)] + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) (:)] + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) (:)] + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) leaf C storage + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) fine root C storage + livestemc_storage => cnveg_carbonstate_inst%livestemc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) live stem C storage + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) live coarse root C storage + + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:)] (gN/m2) leaf N + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:)] (gN/m2) fine root N + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:)] (gN/m2) live stem N + livecrootn => cnveg_nitrogenstate_inst%livecrootn_patch , & ! Input: [real(r8) (:)] (gN/m2) live coarse root N + leafn_storage => cnveg_nitrogenstate_inst%leafn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) leaf N storage + frootn_storage => cnveg_nitrogenstate_inst%frootn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) fine root N storage + livestemn_storage => cnveg_nitrogenstate_inst%livestemn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) live stem N storage + livecrootn_storage => cnveg_nitrogenstate_inst%livecrootn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) live coarse root N storage + + cpool_to_leafc => cnveg_carbonflux_inst%cpool_to_leafc_patch , & ! Input: [real(r8) (:)] + cpool_to_leafc_storage => cnveg_carbonflux_inst%cpool_to_leafc_storage_patch , & ! Input: [real(r8) (:)] + cpool_to_frootc => cnveg_carbonflux_inst%cpool_to_frootc_patch , & ! Input: [real(r8) (:)] + cpool_to_frootc_storage => cnveg_carbonflux_inst%cpool_to_frootc_storage_patch , & ! Input: [real(r8) (:)] + cpool_to_livestemc => cnveg_carbonflux_inst%cpool_to_livestemc_patch , & ! Input: [real(r8) (:)] + cpool_to_livestemc_storage => cnveg_carbonflux_inst%cpool_to_livestemc_storage_patch , & ! Input: [real(r8) (:)] + cpool_to_deadstemc => cnveg_carbonflux_inst%cpool_to_deadstemc_patch , & ! Input: [real(r8) (:)] + cpool_to_deadstemc_storage => cnveg_carbonflux_inst%cpool_to_deadstemc_storage_patch , & ! Input: [real(r8) (:)] + cpool_to_livecrootc => cnveg_carbonflux_inst%cpool_to_livecrootc_patch , & ! Input: [real(r8) (:)] + cpool_to_livecrootc_storage => cnveg_carbonflux_inst%cpool_to_livecrootc_storage_patch , & ! Input: [real(r8) (:)] + cpool_to_deadcrootc => cnveg_carbonflux_inst%cpool_to_deadcrootc_patch , & ! Input: [real(r8) (:)] allocation to dead coarse root C (gC/m2/s) + cpool_to_deadcrootc_storage => cnveg_carbonflux_inst%cpool_to_deadcrootc_storage_patch , & ! Input: [real(r8) (:)] allocation to dead coarse root C storage (gC/m2/s) + cpool_to_grainc => cnveg_carbonflux_inst%cpool_to_grainc_patch , & ! Input: [real(r8) (:)] allocation to grain C (gC/m2/s) + cpool_to_grainc_storage => cnveg_carbonflux_inst%cpool_to_grainc_storage_patch , & ! Input: [real(r8) (:)] allocation to grain C storage (gC/m2/s) + grainc_xfer_to_grainc => cnveg_carbonflux_inst%grainc_xfer_to_grainc_patch , & ! Input: [real(r8) (:)] grain C growth from storage (gC/m2/s) + leafc_xfer_to_leafc => cnveg_carbonflux_inst%leafc_xfer_to_leafc_patch , & ! Input: [real(r8) (:)] leaf C growth from storage (gC/m2/s) + frootc_xfer_to_frootc => cnveg_carbonflux_inst%frootc_xfer_to_frootc_patch , & ! Input: [real(r8) (:)] fine root C growth from storage (gC/m2/s) + livestemc_xfer_to_livestemc => cnveg_carbonflux_inst%livestemc_xfer_to_livestemc_patch , & ! Input: [real(r8) (:)] live stem C growth from storage (gC/m2/s) + deadstemc_xfer_to_deadstemc => cnveg_carbonflux_inst%deadstemc_xfer_to_deadstemc_patch , & ! Input: [real(r8) (:)] dead stem C growth from storage (gC/m2/s) + livecrootc_xfer_to_livecrootc => cnveg_carbonflux_inst%livecrootc_xfer_to_livecrootc_patch , & ! Input: [real(r8) (:)] live coarse root C growth from storage (gC/m2/s) + deadcrootc_xfer_to_deadcrootc => cnveg_carbonflux_inst%deadcrootc_xfer_to_deadcrootc_patch , & ! Input: [real(r8) (:)] dead coarse root C growth from storage (gC/m2/s) + cpool_grain_gr => cnveg_carbonflux_inst%cpool_grain_gr_patch , & ! Output: [real(r8) (:)] + cpool_grain_storage_gr => cnveg_carbonflux_inst%cpool_grain_storage_gr_patch , & ! Output: [real(r8) (:)] + transfer_grain_gr => cnveg_carbonflux_inst%transfer_grain_gr_patch , & ! Output: [real(r8) (:)] + cpool_leaf_gr => cnveg_carbonflux_inst%cpool_leaf_gr_patch , & ! Output: [real(r8) (:)] + cpool_leaf_storage_gr => cnveg_carbonflux_inst%cpool_leaf_storage_gr_patch , & ! Output: [real(r8) (:)] + transfer_leaf_gr => cnveg_carbonflux_inst%transfer_leaf_gr_patch , & ! Output: [real(r8) (:)] + cpool_froot_gr => cnveg_carbonflux_inst%cpool_froot_gr_patch , & ! Output: [real(r8) (:)] + cpool_froot_storage_gr => cnveg_carbonflux_inst%cpool_froot_storage_gr_patch , & ! Output: [real(r8) (:)] + transfer_froot_gr => cnveg_carbonflux_inst%transfer_froot_gr_patch , & ! Output: [real(r8) (:)] + cpool_livestem_gr => cnveg_carbonflux_inst%cpool_livestem_gr_patch , & ! Output: [real(r8) (:)] + cpool_livestem_storage_gr => cnveg_carbonflux_inst%cpool_livestem_storage_gr_patch , & ! Output: [real(r8) (:)] + transfer_livestem_gr => cnveg_carbonflux_inst%transfer_livestem_gr_patch , & ! Output: [real(r8) (:)] + cpool_deadstem_gr => cnveg_carbonflux_inst%cpool_deadstem_gr_patch , & ! Output: [real(r8) (:)] + cpool_deadstem_storage_gr => cnveg_carbonflux_inst%cpool_deadstem_storage_gr_patch , & ! Output: [real(r8) (:)] + transfer_deadstem_gr => cnveg_carbonflux_inst%transfer_deadstem_gr_patch , & ! Output: [real(r8) (:)] + cpool_livecroot_gr => cnveg_carbonflux_inst%cpool_livecroot_gr_patch , & ! Output: [real(r8) (:)] + cpool_livecroot_storage_gr => cnveg_carbonflux_inst%cpool_livecroot_storage_gr_patch , & ! Output: [real(r8) (:)] + transfer_livecroot_gr => cnveg_carbonflux_inst%transfer_livecroot_gr_patch , & ! Output: [real(r8) (:)] + cpool_deadcroot_gr => cnveg_carbonflux_inst%cpool_deadcroot_gr_patch , & ! Output: [real(r8) (:)] + cpool_deadcroot_storage_gr => cnveg_carbonflux_inst%cpool_deadcroot_storage_gr_patch , & ! Output: [real(r8) (:)] + transfer_deadcroot_gr => cnveg_carbonflux_inst%transfer_deadcroot_gr_patch & ! Output: [real(r8) (:)] + ) + + ! Loop through patches + ! start patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + + respfact_leaf = 1.0_r8 + respfact_froot = 1.0_r8 + respfact_livecroot = 1.0_r8 + respfact_livestem = 1.0_r8 + respfact_livecroot = 1.0_r8 + respfact_livestem = 1.0_r8 + respfact_leaf_storage = 1.0_r8 + respfact_froot_storage = 1.0_r8 + respfact_livecroot_storage = 1.0_r8 + respfact_livestem_storage = 1.0_r8 + respfact_livecroot_storage = 1.0_r8 + respfact_livestem_storage = 1.0_r8 + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cpool_livestem_gr(p) = cpool_to_livestemc(p) * grperc(ivt(p)) * respfact_livestem + + cpool_livestem_storage_gr(p) = cpool_to_livestemc_storage(p) * grperc(ivt(p)) * grpnow(ivt(p)) * & + respfact_livestem_storage + + transfer_livestem_gr(p) = livestemc_xfer_to_livestemc(p) * grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) * & + respfact_livestem_storage + + cpool_grain_gr(p) = cpool_to_grainc(p) * grperc(ivt(p)) + + cpool_grain_storage_gr(p) = cpool_to_grainc_storage(p) * grperc(ivt(p)) * grpnow(ivt(p)) + + transfer_grain_gr(p) = grainc_xfer_to_grainc(p) * grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) + end if + + ! leaf and fine root growth respiration + cpool_leaf_gr(p) = cpool_to_leafc(p) * grperc(ivt(p)) * respfact_leaf + + cpool_leaf_storage_gr(p) = cpool_to_leafc_storage(p) * grperc(ivt(p)) * grpnow(ivt(p)) * respfact_leaf_storage + + transfer_leaf_gr(p) = leafc_xfer_to_leafc(p) * grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) * respfact_leaf_storage + + cpool_froot_gr(p) = cpool_to_frootc(p) * grperc(ivt(p)) * respfact_froot * respfact_froot + + cpool_froot_storage_gr(p) = cpool_to_frootc_storage(p) * grperc(ivt(p)) * grpnow(ivt(p)) * respfact_froot_storage + + transfer_froot_gr(p) = frootc_xfer_to_frootc(p) * grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) * respfact_froot_storage + + if (woody(ivt(p)) == 1._r8) then + cpool_livestem_gr(p) = cpool_to_livestemc(p) * grperc(ivt(p)) * respfact_livestem + + cpool_livestem_storage_gr(p) = cpool_to_livestemc_storage(p) * grperc(ivt(p)) * grpnow(ivt(p)) * & +respfact_livestem_storage + + transfer_livestem_gr(p) = livestemc_xfer_to_livestemc(p) * grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) * & +respfact_livestem_storage + + cpool_deadstem_gr(p) = cpool_to_deadstemc(p) * grperc(ivt(p)) + + cpool_deadstem_storage_gr(p) = cpool_to_deadstemc_storage(p) * grperc(ivt(p)) * grpnow(ivt(p)) + + transfer_deadstem_gr(p) = deadstemc_xfer_to_deadstemc(p) * grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) + + cpool_livecroot_gr(p) = cpool_to_livecrootc(p) * grperc(ivt(p)) * respfact_livecroot + + cpool_livecroot_storage_gr(p) = cpool_to_livecrootc_storage(p) * grperc(ivt(p)) * grpnow(ivt(p)) * & +respfact_livecroot_storage + + transfer_livecroot_gr(p) = livecrootc_xfer_to_livecrootc(p) * grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) * & +respfact_livecroot_storage + + cpool_deadcroot_gr(p) = cpool_to_deadcrootc(p) * grperc(ivt(p)) + + cpool_deadcroot_storage_gr(p) = cpool_to_deadcrootc_storage(p) * grperc(ivt(p)) * grpnow(ivt(p)) + + transfer_deadcroot_gr(p) = deadcrootc_xfer_to_deadcrootc(p) * grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) + end if + + end do + + end associate + + end subroutine CNGResp + +end module CNGRespMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNGapMortalityMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNGapMortalityMod.F90 new file mode 100755 index 000000000..bca42c2fc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNGapMortalityMod.F90 @@ -0,0 +1,613 @@ +module CNGapMortalityMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module holding routines used in gap mortality for coupled carbon + ! nitrogen code. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use pftconMod , only : pftcon + use CNDVType , only : dgvs_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type, spinup_factor_deadwood + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use CanopyStateType , only : canopystate_type + use ColumnType , only : col + use PatchType , only : patch + use GridcellType , only : grc + use clm_varctl , only : use_matrixcn + use clm_varpar , only : ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,iretransn,ioutc,ioutn + ! use CNVegMatrixMod , only : matrix_update_gmc, matrix_update_gmn + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: readParams + public :: CNGapMortality + + type, private :: params_type + real(r8):: am ! mortality rate based on annual rate, fractional mortality (1/yr) + real(r8):: k_mort ! coeff. of growth efficiency in mortality equation + end type params_type + ! + type(params_type), private :: params_inst + ! + ! !PRIVATE MEMBER FUNCTIONS: + private :: CNGap_PatchToColumn + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !DESCRIPTION: + ! Read in parameters + ! + ! !USES: + use ncdio_pio , only : file_desc_t,ncd_io + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNGapMortParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + tString='r_mort' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%am=tempr + + tString='k_mort' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_mort=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine CNGapMortality (bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + dgvs_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst,& + cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, canopystate_inst, & + leaf_prof_patch, froot_prof_patch, croot_prof_patch, stem_prof_patch) + ! + ! !DESCRIPTION: + ! Gap-phase mortality routine for coupled carbon-nitrogen code (CN) + ! + ! !USES: + use clm_time_manager , only: get_days_per_year, get_step_size_real, get_step_size + use clm_varpar , only: nlevdecomp_full + use clm_varcon , only: secspday + use clm_varctl , only: use_cndv, spinup_state + use pftconMod , only: npcropmin + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! column filter for soil points + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! patch filter for soil points + type(dgvs_type) , intent(inout) :: dgvs_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + real(r8) , intent(in) :: leaf_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: froot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: croot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: stem_prof_patch(bounds%begp:,1:) + ! + ! !LOCAL VARIABLES: + integer :: p ! patch index + integer :: fp ! patch filter index + real(r8):: am ! rate for fractional mortality (1/yr) + real(r8):: m ! rate for fractional mortality (1/s) + real(r8):: mort_max ! asymptotic max mortality rate (/yr) + real(r8):: k_mort = 0.3 ! coeff of growth efficiency in mortality equation + real(r8):: dt + logical,parameter :: matrixcheck_gm = .False. + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(leaf_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(froot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(croot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(stem_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform + + greffic => dgvs_inst%greffic_patch , & ! Input: [real(r8) (:) ] + heatstress => dgvs_inst%heatstress_patch , & ! Input: [real(r8) (:) ] + + leafcn => pftcon%leafcn , & ! Input: [real(r8) (:)] leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: [real(r8) (:)] fine root C:N (gC/gN) + livewdcn => pftcon%livewdcn , & ! Input: [real(r8) (:)] live wood (phloem and ray parenchyma) C:N (gC/gN) + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit projected leaf area index + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded projected leaf area index + + nind => dgvs_inst%nind_patch , & ! Output:[real(r8)(:)] number of individuals (#/m2) added by F. Li and S. Levis + ileaf_to_iout_gmc => cnveg_carbonflux_inst%ileaf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from leaf pool to outside of vegetation pools + ileafst_to_iout_gmc => cnveg_carbonflux_inst%ileafst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from leaf storage pool to outside of vegetation pools + ileafxf_to_iout_gmc => cnveg_carbonflux_inst%ileafxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from leaf transfer pool to outside of vegetation pools + ifroot_to_iout_gmc => cnveg_carbonflux_inst%ifroot_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from fine root pool to outside of vegetation pools + ifrootst_to_iout_gmc => cnveg_carbonflux_inst%ifrootst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from fine root storage pool to outside of vegetation pools + ifrootxf_to_iout_gmc => cnveg_carbonflux_inst%ifrootxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from fine root transfer pool to outside of vegetation pools + ilivestem_to_iout_gmc => cnveg_carbonflux_inst%ilivestem_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from live stem pool to outside of vegetation pools + ilivestemst_to_iout_gmc => cnveg_carbonflux_inst%ilivestemst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from live stem storage pool to outside of vegetation pools + ilivestemxf_to_iout_gmc => cnveg_carbonflux_inst%ilivestemxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from live stem transfer pool to outside of vegetation pools + ideadstem_to_iout_gmc => cnveg_carbonflux_inst%ideadstem_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from dead stem pool to outside of vegetation pools + ideadstemst_to_iout_gmc => cnveg_carbonflux_inst%ideadstemst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from dead stem storage pool to outside of vegetation pools + ideadstemxf_to_iout_gmc => cnveg_carbonflux_inst%ideadstemxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from dead stem transfer pool to outside of vegetation pools + ilivecroot_to_iout_gmc => cnveg_carbonflux_inst%ilivecroot_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from live coarse root pool to outside of vegetation pools + ilivecrootst_to_iout_gmc => cnveg_carbonflux_inst%ilivecrootst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from live coarse root storage pool to outside of vegetation pools + ilivecrootxf_to_iout_gmc => cnveg_carbonflux_inst%ilivecrootxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from live coarse root transfer pool to outside of vegetation pools + ideadcroot_to_iout_gmc => cnveg_carbonflux_inst%ideadcroot_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from dead coarse root pool to outside of vegetation pools + ideadcrootst_to_iout_gmc => cnveg_carbonflux_inst%ideadcrootst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from dead coarse root storage pool to outside of vegetation pools + ideadcrootxf_to_iout_gmc => cnveg_carbonflux_inst%ideadcrootxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from dead coarse root transfer pool to outside of vegetation pools + ileaf_to_iout_gmn => cnveg_nitrogenflux_inst%ileaf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from leaf pool to outside of vegetation pools + ileafst_to_iout_gmn => cnveg_nitrogenflux_inst%ileafst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from leaf storage pool to outside of vegetation pools + ileafxf_to_iout_gmn => cnveg_nitrogenflux_inst%ileafxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from leaf transfer pool to outside of vegetation pools + ifroot_to_iout_gmn => cnveg_nitrogenflux_inst%ifroot_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from fine root pool to outside of vegetation pools + ifrootst_to_iout_gmn => cnveg_nitrogenflux_inst%ifrootst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from fine root storage pool to outside of vegetation pools + ifrootxf_to_iout_gmn => cnveg_nitrogenflux_inst%ifrootxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from fine root transfer pool to outside of vegetation pools + ilivestem_to_iout_gmn => cnveg_nitrogenflux_inst%ilivestem_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from live stem pool to outside of vegetation pools + ilivestemst_to_iout_gmn => cnveg_nitrogenflux_inst%ilivestemst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from live stem storage pool to outside of vegetation pools + ilivestemxf_to_iout_gmn => cnveg_nitrogenflux_inst%ilivestemxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from live stem transfer pool to outside of vegetation pools + ideadstem_to_iout_gmn => cnveg_nitrogenflux_inst%ideadstem_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from dead stem pool to outside of vegetation pools + ideadstemst_to_iout_gmn => cnveg_nitrogenflux_inst%ideadstemst_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from dead stem storage pool to outside of vegetation pools + ideadstemxf_to_iout_gmn => cnveg_nitrogenflux_inst%ideadstemxf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from dead stem transfer pool to outside of vegetation pools + ilivecroot_to_iout_gmn => cnveg_nitrogenflux_inst%ilivecroot_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from live coarse root pool to outside of vegetation pools + ilivecrootst_to_iout_gmn => cnveg_nitrogenflux_inst%ilivecrootst_to_iout_gm, & ! Input: [integer (:)] Index of gap mortality related N transfer from live coarse root storage pool to outside of vegetation pools + ilivecrootxf_to_iout_gmn => cnveg_nitrogenflux_inst%ilivecrootxf_to_iout_gm, & ! Input: [integer (:)] Index of gap mortality related N transfer from live coarse root transfer pool to outside of vegetation pools + ideadcroot_to_iout_gmn => cnveg_nitrogenflux_inst%ideadcroot_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from dead coarse root pool to outside of vegetation pools + ideadcrootst_to_iout_gmn => cnveg_nitrogenflux_inst%ideadcrootst_to_iout_gm, & ! Input: [integer (:)] Index of gap mortality related N transfer from dead coarse root storage pool to outside of vegetation pools + ideadcrootxf_to_iout_gmn => cnveg_nitrogenflux_inst%ideadcrootxf_to_iout_gm, & ! Input: [integer (:)] Index of gap mortality related N transfer from dead coarse root transfer pool to outside of vegetation pools + iretransn_to_iout_gmn => cnveg_nitrogenflux_inst%iretransn_to_iout_gm & ! Input: [integer (:)] Index of gap mortality related N transfer from retranslocation pool to outside of vegetation pools + ) + + dt = real( get_step_size(), r8 ) + ! set the mortality rate based on annual rate + am = params_inst%am + ! set coeff of growth efficiency in mortality equation + k_mort = params_inst%k_mort + + ! patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + + if (use_cndv) then + ! Stress mortality from lpj's subr Mortality. + + if (woody(ivt(p)) == 1._r8) then + + if (ivt(p) == 8) then + mort_max = 0.03_r8 ! BDT boreal + else + mort_max = 0.01_r8 ! original value for all patches + end if + + ! heatstress and greffic calculated in Establishment once/yr + + ! Mortality rate inversely related to growth efficiency + ! (Prentice et al 1993) + am = mort_max / (1._r8 + k_mort * greffic(p)) + + ! Mortality rate inversely related to growth efficiency + ! (Prentice et al 1993) + am = mort_max / (1._r8 + k_mort * greffic(p)) + + am = min(1._r8, am + heatstress(p)) + else ! lpj didn't set this for grasses; cn does + ! set the mortality rate based on annual rate + am = params_inst%am + end if + + end if + + m = am/(get_days_per_year() * secspday) + + !------------------------------------------------------ + ! patch-level gap mortality carbon fluxes + !------------------------------------------------------ + + ! displayed pools + if(.not. use_matrixcn)then + cnveg_carbonflux_inst%m_leafc_to_litter_patch(p) = cnveg_carbonstate_inst%leafc_patch(p) * m + cnveg_carbonflux_inst%m_frootc_to_litter_patch(p) = cnveg_carbonstate_inst%frootc_patch(p) * m + cnveg_carbonflux_inst%m_livestemc_to_litter_patch(p) = cnveg_carbonstate_inst%livestemc_patch(p) * m + cnveg_carbonflux_inst%m_livecrootc_to_litter_patch(p) = cnveg_carbonstate_inst%livecrootc_patch(p) * m + else +! cnveg_carbonflux_inst%m_leafc_to_litter_patch(p) = cnveg_carbonstate_inst%leafc_patch(p) * matrix_update_gmc(p,ileaf_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_frootc_to_litter_patch(p) = cnveg_carbonstate_inst%frootc_patch(p) * matrix_update_gmc(p,ifroot_to_iout_gmc,m,dt,cnveg_carbonflux_inst,.true.,.True.) +! cnveg_carbonflux_inst%m_livestemc_to_litter_patch(p) = cnveg_carbonstate_inst%livestemc_patch(p) * matrix_update_gmc(p,ilivestem_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_livecrootc_to_litter_patch(p) = cnveg_carbonstate_inst%livecrootc_patch(p) * matrix_update_gmc(p,ilivecroot_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) + end if + if(.not. use_matrixcn)then + cnveg_carbonflux_inst%m_deadstemc_to_litter_patch(p) = cnveg_carbonstate_inst%deadstemc_patch(p) * m * spinup_factor_deadwood + cnveg_carbonflux_inst%m_deadcrootc_to_litter_patch(p) = cnveg_carbonstate_inst%deadcrootc_patch(p) * m * spinup_factor_deadwood + else +! cnveg_carbonflux_inst%m_deadstemc_to_litter_patch(p) = cnveg_carbonstate_inst%deadstemc_patch(p) * matrix_update_gmc(p,ideadstem_to_iout_gmc, & +! m*spinup_factor_deadwood,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_deadcrootc_to_litter_patch(p) = cnveg_carbonstate_inst%deadcrootc_patch(p) * matrix_update_gmc(p,ideadcroot_to_iout_gmc, & + ! m*spinup_factor_deadwood,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) + end if !use_matrixcn + + ! storage pools + if(.not. use_matrixcn)then + cnveg_carbonflux_inst%m_leafc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%leafc_storage_patch(p) * m + cnveg_carbonflux_inst%m_frootc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%frootc_storage_patch(p) * m + cnveg_carbonflux_inst%m_livestemc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%livestemc_storage_patch(p) * m + cnveg_carbonflux_inst%m_deadstemc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%deadstemc_storage_patch(p) * m + cnveg_carbonflux_inst%m_livecrootc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%livecrootc_storage_patch(p) * m + cnveg_carbonflux_inst%m_deadcrootc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%deadcrootc_storage_patch(p) * m + cnveg_carbonflux_inst%m_gresp_storage_to_litter_patch(p) = cnveg_carbonstate_inst%gresp_storage_patch(p) * m + + ! transfer pools + cnveg_carbonflux_inst%m_leafc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%leafc_xfer_patch(p) * m + cnveg_carbonflux_inst%m_frootc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%frootc_xfer_patch(p) * m + cnveg_carbonflux_inst%m_livestemc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%livestemc_xfer_patch(p) * m + cnveg_carbonflux_inst%m_deadstemc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%deadstemc_xfer_patch(p) * m + cnveg_carbonflux_inst%m_livecrootc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%livecrootc_xfer_patch(p) * m + cnveg_carbonflux_inst%m_deadcrootc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%deadcrootc_xfer_patch(p) * m + cnveg_carbonflux_inst%m_gresp_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%gresp_xfer_patch(p) * m + else +! ! NOTE: The non-matrix version of this is in CNCStateUpdate2Mod CStateUpdate2 (EBK 11/25/2019) +! +! ! storage pools +! cnveg_carbonflux_inst%m_leafc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%leafc_storage_patch(p) * matrix_update_gmc(p,ileafst_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_frootc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%frootc_storage_patch(p) * matrix_update_gmc(p,ifrootst_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_livestemc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%livestemc_storage_patch(p) * matrix_update_gmc(p,ilivestemst_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_deadstemc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%deadstemc_storage_patch(p) * matrix_update_gmc(p,ideadstemst_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_livecrootc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%livecrootc_storage_patch(p) * matrix_update_gmc(p,ilivecrootst_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_deadcrootc_storage_to_litter_patch(p) = cnveg_carbonstate_inst%deadcrootc_storage_patch(p) * matrix_update_gmc(p,ideadcrootst_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! +! ! transfer pools +! cnveg_carbonflux_inst%m_leafc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%leafc_xfer_patch(p) * matrix_update_gmc(p,ileafxf_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_frootc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%frootc_xfer_patch(p) * matrix_update_gmc(p,ifrootxf_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_livestemc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%livestemc_xfer_patch(p) * matrix_update_gmc(p,ilivestemxf_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_deadstemc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%deadstemc_xfer_patch(p) * matrix_update_gmc(p,ideadstemxf_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_livecrootc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%livecrootc_xfer_patch(p) * matrix_update_gmc(p,ilivecrootxf_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) +! cnveg_carbonflux_inst%m_deadcrootc_xfer_to_litter_patch(p) = cnveg_carbonstate_inst%deadcrootc_xfer_patch(p) * matrix_update_gmc(p,ideadcrootxf_to_iout_gmc,m,dt,cnveg_carbonflux_inst,matrixcheck_gm,.True.) + end if !use_matrixcn + + !------------------------------------------------------ + ! patch-level gap mortality nitrogen fluxes + !------------------------------------------------------ + + ! displayed pools + if(.not. use_matrixcn)then + cnveg_nitrogenflux_inst%m_leafn_to_litter_patch(p) = cnveg_nitrogenstate_inst%leafn_patch(p) * m + cnveg_nitrogenflux_inst%m_frootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%frootn_patch(p) * m + cnveg_nitrogenflux_inst%m_livestemn_to_litter_patch(p) = cnveg_nitrogenstate_inst%livestemn_patch(p) * m + cnveg_nitrogenflux_inst%m_livecrootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%livecrootn_patch(p) * m + else +! cnveg_nitrogenflux_inst%m_leafn_to_litter_patch(p) = cnveg_nitrogenstate_inst%leafn_patch(p) * matrix_update_gmn(p,ileaf_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_frootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%frootn_patch(p) * matrix_update_gmn(p,ifroot_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,.true.,.True.) +! cnveg_nitrogenflux_inst%m_livestemn_to_litter_patch(p) = cnveg_nitrogenstate_inst%livestemn_patch(p) * matrix_update_gmn(p,ilivestem_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_livecrootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%livecrootn_patch(p) * matrix_update_gmn(p,ilivecroot_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) + end if + + if (spinup_state == 2 .and. .not. use_cndv) then !accelerate mortality of dead woody pools + if(.not. use_matrixcn)then + cnveg_nitrogenflux_inst%m_deadstemn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_patch(p) * m * spinup_factor_deadwood + cnveg_nitrogenflux_inst%m_deadcrootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_patch(p) * m * spinup_factor_deadwood + else +! cnveg_nitrogenflux_inst%m_deadstemn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_patch(p) * matrix_update_gmn(p,ideadstem_to_iout_gmn , & +! m*spinup_factor_deadwood,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_deadcrootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_patch(p) * matrix_update_gmn(p,ideadcroot_to_iout_gmn, & + !m*spinup_factor_deadwood,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) + end if !.not. use_matrixcn + else + if (.not. use_matrixcn) then + cnveg_nitrogenflux_inst%m_deadstemn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_patch(p) * m + cnveg_nitrogenflux_inst%m_deadcrootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_patch(p) * m + else +! cnveg_nitrogenflux_inst%m_deadstemn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_patch(p) * matrix_update_gmn(p,ideadstem_to_iout_gmn ,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_deadcrootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_patch(p) * matrix_update_gmn(p,ideadcroot_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) + end if !use_matrixcn + end if + + if (ivt(p) < npcropmin) then + if(.not. use_matrixcn)then + cnveg_nitrogenflux_inst%m_retransn_to_litter_patch(p) = cnveg_nitrogenstate_inst%retransn_patch(p) * m + else + !cnveg_nitrogenflux_inst%m_retransn_to_litter_patch(p) = cnveg_nitrogenstate_inst%retransn_patch(p) * matrix_update_gmn(p,iretransn_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) + end if + end if + + if(.not. use_matrixcn)then + ! storage pools + cnveg_nitrogenflux_inst%m_leafn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%leafn_storage_patch(p) * m + cnveg_nitrogenflux_inst%m_frootn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%frootn_storage_patch(p) * m + cnveg_nitrogenflux_inst%m_livestemn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%livestemn_storage_patch(p) * m + cnveg_nitrogenflux_inst%m_deadstemn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_storage_patch(p) * m + cnveg_nitrogenflux_inst%m_livecrootn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%livecrootn_storage_patch(p) * m + cnveg_nitrogenflux_inst%m_deadcrootn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_storage_patch(p) * m + + ! transfer pools + cnveg_nitrogenflux_inst%m_leafn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%leafn_xfer_patch(p) * m + cnveg_nitrogenflux_inst%m_frootn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%frootn_xfer_patch(p) * m + cnveg_nitrogenflux_inst%m_livestemn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%livestemn_xfer_patch(p) * m + cnveg_nitrogenflux_inst%m_deadstemn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_xfer_patch(p) * m + cnveg_nitrogenflux_inst%m_livecrootn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%livecrootn_xfer_patch(p) * m + cnveg_nitrogenflux_inst%m_deadcrootn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_xfer_patch(p) * m + else +! ! storage pools +! cnveg_nitrogenflux_inst%m_leafn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%leafn_storage_patch(p) * matrix_update_gmn(p,ileafst_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_frootn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%frootn_storage_patch(p) * matrix_update_gmn(p,ifrootst_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_livestemn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%livestemn_storage_patch(p) * matrix_update_gmn(p,ilivestemst_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_deadstemn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_storage_patch(p) * matrix_update_gmn(p,ideadstemst_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_livecrootn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%livecrootn_storage_patch(p) * matrix_update_gmn(p,ilivecrootst_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_deadcrootn_storage_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_storage_patch(p) * matrix_update_gmn(p,ideadcrootst_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! +! ! transfer pools +! cnveg_nitrogenflux_inst%m_leafn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%leafn_xfer_patch(p) * matrix_update_gmn(p,ileafxf_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_frootn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%frootn_xfer_patch(p) * matrix_update_gmn(p,ifrootxf_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_livestemn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%livestemn_xfer_patch(p) * matrix_update_gmn(p,ilivestemxf_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_deadstemn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_xfer_patch(p) * matrix_update_gmn(p,ideadstemxf_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_livecrootn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%livecrootn_xfer_patch(p) * matrix_update_gmn(p,ilivecrootxf_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) +! cnveg_nitrogenflux_inst%m_deadcrootn_xfer_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_xfer_patch(p) * matrix_update_gmn(p,ideadcrootxf_to_iout_gmn,m,dt,cnveg_nitrogenflux_inst,matrixcheck_gm,.True.) + end if !use_matrixcn + + ! added by F. Li and S. Levis + if (use_cndv) then + if (woody(ivt(p)) == 1._r8)then + if (cnveg_carbonstate_inst%livestemc_patch(p) + cnveg_carbonstate_inst%deadstemc_patch(p)> 0._r8)then + nind(p)=nind(p)*(1._r8-m) + else + nind(p) = 0._r8 + end if + end if + end if + + end do ! end of patch loop + + ! gather all patch-level litterfall fluxes to the column + ! for litter C and N inputs + + call CNGap_PatchToColumn(bounds, num_soilc, filter_soilc, & + cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, & + leaf_prof_patch(bounds%begp:bounds%endp, 1:nlevdecomp_full), & + froot_prof_patch(bounds%begp:bounds%endp, 1:nlevdecomp_full), & + croot_prof_patch(bounds%begp:bounds%endp, 1:nlevdecomp_full), & + stem_prof_patch(bounds%begp:bounds%endp, 1:nlevdecomp_full)) + + end associate + + end subroutine CNGapMortality + + !----------------------------------------------------------------------- + subroutine CNGap_PatchToColumn (bounds, num_soilc, filter_soilc, & + cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, & + leaf_prof_patch, froot_prof_patch, croot_prof_patch, stem_prof_patch) + ! + ! !DESCRIPTION: + ! gathers all patch-level gap mortality fluxes to the column level and + ! assigns them to the three litter pools + ! + ! !USES: + use clm_varpar , only : maxsoil_patches, nlevdecomp, nlevdecomp_full + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! soil column filter + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + real(r8) , intent(in) :: leaf_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: froot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: croot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: stem_prof_patch(bounds%begp:,1:) + ! + ! !LOCAL VARIABLES: + integer :: fc,c,pi,p,j ! indices + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(leaf_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(froot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(croot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(stem_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + + associate( & + leaf_prof => leaf_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of leaves + froot_prof => froot_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of fine roots + croot_prof => croot_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of coarse roots + stem_prof => stem_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of stems + + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + wtcol => patch%wtcol , & ! Input: [real(r8) (:) ] patch weight relative to column (0-1) + + lf_flab => pftcon%lf_flab , & ! Input: [real(r8) (:) ] leaf litter labile fraction + lf_fcel => pftcon%lf_fcel , & ! Input: [real(r8) (:) ] leaf litter cellulose fraction + lf_flig => pftcon%lf_flig , & ! Input: [real(r8) (:) ] leaf litter lignin fraction + fr_flab => pftcon%fr_flab , & ! Input: [real(r8) (:) ] fine root litter labile fraction + fr_fcel => pftcon%fr_fcel , & ! Input: [real(r8) (:) ] fine root litter cellulose fraction + fr_flig => pftcon%fr_flig , & ! Input: [real(r8) (:) ] fine root litter lignin fraction + + m_leafc_to_litter => cnveg_carbonflux_inst%m_leafc_to_litter_patch , & ! Input: [real(r8) (:) ] + m_frootc_to_litter => cnveg_carbonflux_inst%m_frootc_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livestemc_to_litter => cnveg_carbonflux_inst%m_livestemc_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadstemc_to_litter => cnveg_carbonflux_inst%m_deadstemc_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livecrootc_to_litter => cnveg_carbonflux_inst%m_livecrootc_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadcrootc_to_litter => cnveg_carbonflux_inst%m_deadcrootc_to_litter_patch , & ! Input: [real(r8) (:) ] + m_leafc_storage_to_litter => cnveg_carbonflux_inst%m_leafc_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_frootc_storage_to_litter => cnveg_carbonflux_inst%m_frootc_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livestemc_storage_to_litter => cnveg_carbonflux_inst%m_livestemc_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadstemc_storage_to_litter => cnveg_carbonflux_inst%m_deadstemc_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livecrootc_storage_to_litter => cnveg_carbonflux_inst%m_livecrootc_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadcrootc_storage_to_litter => cnveg_carbonflux_inst%m_deadcrootc_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_gresp_storage_to_litter => cnveg_carbonflux_inst%m_gresp_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_leafc_xfer_to_litter => cnveg_carbonflux_inst%m_leafc_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_frootc_xfer_to_litter => cnveg_carbonflux_inst%m_frootc_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livestemc_xfer_to_litter => cnveg_carbonflux_inst%m_livestemc_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadstemc_xfer_to_litter => cnveg_carbonflux_inst%m_deadstemc_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livecrootc_xfer_to_litter => cnveg_carbonflux_inst%m_livecrootc_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadcrootc_xfer_to_litter => cnveg_carbonflux_inst%m_deadcrootc_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_gresp_xfer_to_litter => cnveg_carbonflux_inst%m_gresp_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + gap_mortality_c_to_litr_met_c => cnveg_carbonflux_inst%gap_mortality_c_to_litr_met_c_col , & ! Output: [real(r8) (:,:) ] C fluxes associated with gap mortality to litter metabolic pool (gC/m3/s) + gap_mortality_c_to_litr_cel_c => cnveg_carbonflux_inst%gap_mortality_c_to_litr_cel_c_col , & ! Output: [real(r8) (:,:) ] C fluxes associated with gap mortality to litter cellulose pool (gC/m3/s) + gap_mortality_c_to_litr_lig_c => cnveg_carbonflux_inst%gap_mortality_c_to_litr_lig_c_col , & ! Output: [real(r8) (:,:) ] C fluxes associated with gap mortality to litter lignin pool (gC/m3/s) + gap_mortality_c_to_cwdc => cnveg_carbonflux_inst%gap_mortality_c_to_cwdc_col , & ! Output: [real(r8) (:,:) ] C fluxes associated with gap mortality to CWD pool (gC/m3/s) + + m_leafn_to_litter => cnveg_nitrogenflux_inst%m_leafn_to_litter_patch , & ! Input: [real(r8) (:) ] + m_frootn_to_litter => cnveg_nitrogenflux_inst%m_frootn_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livestemn_to_litter => cnveg_nitrogenflux_inst%m_livestemn_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadstemn_to_litter => cnveg_nitrogenflux_inst%m_deadstemn_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livecrootn_to_litter => cnveg_nitrogenflux_inst%m_livecrootn_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadcrootn_to_litter => cnveg_nitrogenflux_inst%m_deadcrootn_to_litter_patch , & ! Input: [real(r8) (:) ] + m_retransn_to_litter => cnveg_nitrogenflux_inst%m_retransn_to_litter_patch , & ! Input: [real(r8) (:) ] + m_leafn_storage_to_litter => cnveg_nitrogenflux_inst%m_leafn_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_frootn_storage_to_litter => cnveg_nitrogenflux_inst%m_frootn_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livestemn_storage_to_litter => cnveg_nitrogenflux_inst%m_livestemn_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadstemn_storage_to_litter => cnveg_nitrogenflux_inst%m_deadstemn_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livecrootn_storage_to_litter => cnveg_nitrogenflux_inst%m_livecrootn_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadcrootn_storage_to_litter => cnveg_nitrogenflux_inst%m_deadcrootn_storage_to_litter_patch , & ! Input: [real(r8) (:) ] + m_leafn_xfer_to_litter => cnveg_nitrogenflux_inst%m_leafn_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_frootn_xfer_to_litter => cnveg_nitrogenflux_inst%m_frootn_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livestemn_xfer_to_litter => cnveg_nitrogenflux_inst%m_livestemn_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadstemn_xfer_to_litter => cnveg_nitrogenflux_inst%m_deadstemn_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_livecrootn_xfer_to_litter => cnveg_nitrogenflux_inst%m_livecrootn_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + m_deadcrootn_xfer_to_litter => cnveg_nitrogenflux_inst%m_deadcrootn_xfer_to_litter_patch , & ! Input: [real(r8) (:) ] + gap_mortality_n_to_litr_met_n => cnveg_nitrogenflux_inst%gap_mortality_n_to_litr_met_n_col , & ! Output: [real(r8) (:,:) ] N fluxes associated with gap mortality to litter metabolic pool (gN/m3/s) + gap_mortality_n_to_litr_cel_n => cnveg_nitrogenflux_inst%gap_mortality_n_to_litr_cel_n_col , & ! Output: [real(r8) (:,:) ] N fluxes associated with gap mortality to litter cellulose pool (gN/m3/s) + gap_mortality_n_to_litr_lig_n => cnveg_nitrogenflux_inst%gap_mortality_n_to_litr_lig_n_col , & ! Output: [real(r8) (:,:) ] N fluxes associated with gap mortality to litter lignin pool (gN/m3/s) + gap_mortality_n_to_cwdn => cnveg_nitrogenflux_inst%gap_mortality_n_to_cwdn_col & ! Output: [real(r8) (:,:) ] N fluxes associated with gap mortality to CWD pool (gN/m3/s) + ) + + do j = 1,nlevdecomp + do pi = 1,maxsoil_patches + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (pi <= col%npatches(c)) then + p = col%patchi(c) + pi - 1 + + if (patch%active(p)) then + + ! leaf gap mortality carbon fluxes + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + m_leafc_to_litter(p) * lf_flab(ivt(p)) * wtcol(p) * leaf_prof(p,j) + gap_mortality_c_to_litr_cel_c(c,j) = gap_mortality_c_to_litr_cel_c(c,j) + & + m_leafc_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p) * leaf_prof(p,j) + gap_mortality_c_to_litr_lig_c(c,j) = gap_mortality_c_to_litr_lig_c(c,j) + & + m_leafc_to_litter(p) * lf_flig(ivt(p)) * wtcol(p) * leaf_prof(p,j) + + ! fine root gap mortality carbon fluxes + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + m_frootc_to_litter(p) * fr_flab(ivt(p)) * wtcol(p) * froot_prof(p,j) + gap_mortality_c_to_litr_cel_c(c,j) = gap_mortality_c_to_litr_cel_c(c,j) + & + m_frootc_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p) * froot_prof(p,j) + gap_mortality_c_to_litr_lig_c(c,j) = gap_mortality_c_to_litr_lig_c(c,j) + & + m_frootc_to_litter(p) * fr_flig(ivt(p)) * wtcol(p) * froot_prof(p,j) + + ! wood gap mortality carbon fluxes + gap_mortality_c_to_cwdc(c,j) = gap_mortality_c_to_cwdc(c,j) + & + (m_livestemc_to_litter(p) + m_deadstemc_to_litter(p)) * wtcol(p) * stem_prof(p,j) + gap_mortality_c_to_cwdc(c,j) = gap_mortality_c_to_cwdc(c,j) + & + (m_livecrootc_to_litter(p) + m_deadcrootc_to_litter(p)) * wtcol(p) * croot_prof(p,j) + + ! storage gap mortality carbon fluxes + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + (m_leafc_storage_to_litter(p) + m_gresp_storage_to_litter(p)) * wtcol(p) * leaf_prof(p,j) + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + m_frootc_storage_to_litter(p) * wtcol(p) * froot_prof(p,j) + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + (m_livestemc_storage_to_litter(p) + m_deadstemc_storage_to_litter(p)) * wtcol(p) * stem_prof(p,j) + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + (m_livecrootc_storage_to_litter(p) + m_deadcrootc_storage_to_litter(p)) * wtcol(p) * croot_prof(p,j) + + ! transfer gap mortality carbon fluxes + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + (m_leafc_xfer_to_litter(p) + m_gresp_xfer_to_litter(p)) * wtcol(p) * leaf_prof(p,j) + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + m_frootc_xfer_to_litter(p) * wtcol(p) * froot_prof(p,j) + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + (m_livestemc_xfer_to_litter(p) + m_deadstemc_xfer_to_litter(p)) * wtcol(p) * stem_prof(p,j) + gap_mortality_c_to_litr_met_c(c,j) = gap_mortality_c_to_litr_met_c(c,j) + & + (m_livecrootc_xfer_to_litter(p) + m_deadcrootc_xfer_to_litter(p)) * wtcol(p) * croot_prof(p,j) + + ! leaf gap mortality nitrogen fluxes + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + m_leafn_to_litter(p) * lf_flab(ivt(p)) * wtcol(p) * leaf_prof(p,j) + gap_mortality_n_to_litr_cel_n(c,j) = gap_mortality_n_to_litr_cel_n(c,j) + & + m_leafn_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p) * leaf_prof(p,j) + gap_mortality_n_to_litr_lig_n(c,j) = gap_mortality_n_to_litr_lig_n(c,j) + & + m_leafn_to_litter(p) * lf_flig(ivt(p)) * wtcol(p) * leaf_prof(p,j) + + ! fine root litter nitrogen fluxes + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + m_frootn_to_litter(p) * fr_flab(ivt(p)) * wtcol(p) * froot_prof(p,j) + gap_mortality_n_to_litr_cel_n(c,j) = gap_mortality_n_to_litr_cel_n(c,j) + & + m_frootn_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p) * froot_prof(p,j) + gap_mortality_n_to_litr_lig_n(c,j) = gap_mortality_n_to_litr_lig_n(c,j) + & + m_frootn_to_litter(p) * fr_flig(ivt(p)) * wtcol(p) * froot_prof(p,j) + + ! wood gap mortality nitrogen fluxes + gap_mortality_n_to_cwdn(c,j) = gap_mortality_n_to_cwdn(c,j) + & + (m_livestemn_to_litter(p) + m_deadstemn_to_litter(p)) * wtcol(p) * stem_prof(p,j) + gap_mortality_n_to_cwdn(c,j) = gap_mortality_n_to_cwdn(c,j) + & + (m_livecrootn_to_litter(p) + m_deadcrootn_to_litter(p)) * wtcol(p) * croot_prof(p,j) + + ! retranslocated N pool gap mortality fluxes + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + m_retransn_to_litter(p) * wtcol(p) * leaf_prof(p,j) + + ! storage gap mortality nitrogen fluxes + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + m_leafn_storage_to_litter(p) * wtcol(p) * leaf_prof(p,j) + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + m_frootn_storage_to_litter(p) * wtcol(p) * froot_prof(p,j) + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + (m_livestemn_storage_to_litter(p) + m_deadstemn_storage_to_litter(p)) * wtcol(p) * stem_prof(p,j) + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + (m_livecrootn_storage_to_litter(p) + m_deadcrootn_storage_to_litter(p)) * wtcol(p) * croot_prof(p,j) + + ! transfer gap mortality nitrogen fluxes + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + m_leafn_xfer_to_litter(p) * wtcol(p) * leaf_prof(p,j) + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + m_frootn_xfer_to_litter(p) * wtcol(p) * froot_prof(p,j) + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + (m_livestemn_xfer_to_litter(p) + m_deadstemn_xfer_to_litter(p)) * wtcol(p) * stem_prof(p,j) + gap_mortality_n_to_litr_met_n(c,j) = gap_mortality_n_to_litr_met_n(c,j) + & + (m_livecrootn_xfer_to_litter(p) + m_deadcrootn_xfer_to_litter(p)) * wtcol(p) * croot_prof(p,j) + + + end if + end if + + end do + end do + end do + + end associate + + end subroutine CNGap_PatchToColumn + +end module CNGapMortalityMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNMRespMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNMRespMod.F90 new file mode 100755 index 000000000..35c9357a0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNMRespMod.F90 @@ -0,0 +1,300 @@ +module CNMRespMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module holding maintenance respiration routines for coupled carbon + ! nitrogen code. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_TKFRZ + use clm_varpar , only : nlevgrnd + use clm_varcon , only : spval + use decompMod , only : bounds_type + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use pftconMod , only : npcropmin, pftcon + use SoilStateType , only : soilstate_type + use CanopyStateType , only : canopystate_type + use TemperatureType , only : temperature_type + use PhotosynthesisMod , only : photosyns_type + use CNVegcarbonfluxType , only : cnveg_carbonflux_type + use CNVegnitrogenstateType , only : cnveg_nitrogenstate_type + use CNSharedParamsMod , only : CNParamsShareInst + use PatchType , only : patch + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: CNMRespReadNML ! Read in namelist (CALL FIRST!) + public :: readParams ! Read in parameters from file + public :: CNMResp ! Apply maintenance respiration + + type, private :: params_type + real(r8) :: br = spval ! base rate for maintenance respiration (gC/gN/s) + real(r8) :: br_root = spval ! base rate for maintenance respiration for roots (gC/gN/s) + end type params_type + + type(params_type), private :: params_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CNMRespReadNML( NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for CNMResp (MUST BE CALLED BEFORE readParams!!!) + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'CNMRespReadNML' + character(len=*), parameter :: nmlname = 'cnmresp_inparm' + real(r8) :: br_root = spval ! base rate for maintenance respiration for roots (gC/gN/s) + !----------------------------------------------------------------------- + + namelist /cnmresp_inparm/ br_root + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=cnmresp_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR finding "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (br_root, mpicom) + + params_inst%br_root = br_root + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=cnmresp_inparm) + write(iulog,*) ' ' + end if + + end subroutine CNMRespReadNML + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !DESCRIPTION: + ! Read parameters (call AFTER CNMRespReadNML!) + ! + ! !USES: + use ncdio_pio , only : file_desc_t,ncd_io + use netcdf + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNMRespParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + integer :: ierr, clm_varid + !----------------------------------------------------------------------- + + tString='br_mr' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%br=tempr + + if ( params_inst%br_root == spval ) then + params_inst%br_root = params_inst%br + end if + + end subroutine readParams + + !----------------------------------------------------------------------- + ! FIX(SPM,032414) this shouldn't even be called with fates on. + ! + subroutine CNMResp(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + canopystate_inst, soilstate_inst, temperature_inst, photosyns_inst, & + cnveg_carbonflux_inst, cnveg_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! + ! !ARGUMENTS: + use clm_varcon , only : tfrz + + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil points in column filter + integer , intent(in) :: filter_soilc(:) ! column filter for soil points + integer , intent(in) :: num_soilp ! number of soil points in patch filter + integer , intent(in) :: filter_soilp(:) ! patch filter for soil points + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(photosyns_type) , intent(in) :: photosyns_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j ! indices + integer :: fp ! soil filter patch index + integer :: fc ! soil filter column index + real(r8):: br ! base rate (gC/gN/s) + real(r8):: br_root ! root base rate (gC/gN/s) + real(r8):: q10 ! temperature dependence + + real(r8):: tc ! temperature correction, 2m air temp (unitless) + real(r8):: tcsoi(bounds%begc:bounds%endc,nlevgrnd) ! temperature correction by soil layer (unitless) + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + + frac_veg_nosno => canopystate_inst%frac_veg_nosno_patch , & ! Input: [integer (:) ] fraction of vegetation not covered by snow (0 OR 1) [-] + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit projected leaf area index + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded projected leaf area index + + crootfr => soilstate_inst%crootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots for carbon in each soil layer (nlevgrnd) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + t_ref2m => temperature_inst%t_ref2m_patch , & ! Input: [real(r8) (:) ] 2 m height surface air temperature (Kelvin) + + t10 => temperature_inst%t_a10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of the 2 m temperature (K) + + lmrsun => photosyns_inst%lmrsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf maintenance respiration rate (umol CO2/m**2/s) + lmrsha => photosyns_inst%lmrsha_patch , & ! Input: [real(r8) (:) ] shaded leaf maintenance respiration rate (umol CO2/m**2/s) + rootstem_acc => photosyns_inst%rootstem_acc , & ! Input: [logical ] root and stem acclimation switch + + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N + livecrootn => cnveg_nitrogenstate_inst%livecrootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N + grainn => cnveg_nitrogenstate_inst%grainn_patch , & ! Input: [real(r8) (:) ] (kgN/m2) grain N + + leaf_mr => cnveg_carbonflux_inst%leaf_mr_patch , & ! Output: [real(r8) (:) ] + froot_mr => cnveg_carbonflux_inst%froot_mr_patch , & ! Output: [real(r8) (:) ] + livestem_mr => cnveg_carbonflux_inst%livestem_mr_patch , & ! Output: [real(r8) (:) ] + livecroot_mr => cnveg_carbonflux_inst%livecroot_mr_patch , & ! Output: [real(r8) (:) ] + grain_mr => cnveg_carbonflux_inst%grain_mr_patch & ! Output: [real(r8) (:) ] + + ) + + ! base rate for maintenance respiration is from: + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! set constants + br = params_inst%br + br_root = params_inst%br_root + + ! 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 = CNParamsShareInst%Q10 + + ! column loop to calculate temperature factors in each soil layer + do j=1,nlevgrnd + do fc = 1, num_soilc + c = filter_soilc(fc) + + ! calculate temperature corrections for each soil layer, for use in + ! estimating fine root maintenance respiration with depth + tcsoi(c,j) = Q10**((t_soisno(c,j)-SHR_CONST_TKFRZ - 20.0_r8)/10.0_r8) + end do + end do + + ! patch loop for leaves and live wood + do fp = 1, num_soilp + p = filter_soilp(fp) + + ! calculate maintenance respiration fluxes in + ! gC/m2/s for each of the live plant tissues. + ! Leaf and live wood MR + + tc = Q10**((t_ref2m(p)-SHR_CONST_TKFRZ - 20.0_r8)/10.0_r8) + + !RF: acclimation of root and stem respiration fluxes + ! n.b. we do not yet know if this is defensible scientifically (awaiting data analysis) + ! turning this on will increase R and decrease productivity in boreal forests, A LOT. :) + + if(rootstem_acc)then + br = br * 10._r8**(-0.00794_r8*((t10(p)-tfrz)-25._r8)) + br_root = br_root * 10._r8**(-0.00794_r8*((t10(p)-tfrz)-25._r8)) + end if + + if (frac_veg_nosno(p) == 1) then + + leaf_mr(p) = lmrsun(p) * laisun(p) * 12.011e-6_r8 + & + lmrsha(p) * laisha(p) * 12.011e-6_r8 + + else !nosno + + leaf_mr(p) = 0._r8 + + end if + + if (woody(ivt(p)) == 1) then + livestem_mr(p) = livestemn(p)*br*tc + livecroot_mr(p) = livecrootn(p)*br_root*tc + else if (ivt(p) >= npcropmin) then + livestem_mr(p) = livestemn(p)*br*tc + grain_mr(p) = grainn(p)*br*tc + end if + end do + + ! soil and patch loop for fine root + + do j = 1,nlevgrnd + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + ! Fine root MR + ! crootfr(j) sums to 1.0 over all soil layers, and + ! describes the fraction of root mass for carbon that is in each + ! layer. This is used with the layer temperature correction + ! to estimate the total fine root maintenance respiration as a + ! function of temperature and N content. + if(rootstem_acc)then + br_root = br_root * 10._r8**(-0.00794_r8*((t10(p)-tfrz)-25._r8)) + end if + froot_mr(p) = froot_mr(p) + frootn(p)*br_root*tcsoi(c,j)*crootfr(p,j) + + end do + end do + + end associate + + end subroutine CNMResp + +end module CNMRespMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNDynamicsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNDynamicsMod.F90 new file mode 100755 index 000000000..1cf21deaa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNDynamicsMod.F90 @@ -0,0 +1,441 @@ +module CNNDynamicsMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for mineral nitrogen dynamics (deposition, fixation, leaching) + ! for coupled carbon-nitrogen code. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use clm_varcon , only : dzsoi_decomp, zisoi + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, nfix_timeconst + use subgridAveMod , only : p2c + use atm2lndType , only : atm2lnd_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use WaterFluxBulkType , only : waterfluxbulk_type + use CropType , only : crop_type + use ColumnType , only : col + use PatchType , only : patch + use perf_mod , only : t_startf, t_stopf + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: CNNDynamicsReadNML ! Read in namelist for Mineral Nitrogen Dynamics + public :: CNNDeposition ! Update N deposition rate from atm forcing + public :: CNNFixation ! Update N Fixation rate + public :: CNNFert ! Update N fertilizer for crops + public :: CNSoyfix ! N Fixation for soybeans + public :: CNFreeLivingFixation ! N free living fixation + + ! + ! !PRIVATE DATA MEMBERS: + type, private :: params_type + real(r8) :: freelivfix_intercept ! intercept of line of free living fixation with annual ET + real(r8) :: freelivfix_slope_wET ! slope of line of free living fixation with annual ET + end type params_type + type(params_type) :: params_inst + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CNNDynamicsReadNML( NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for Mineral Nitrogen Dynamics + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'CNNDynamicsReadNML' + character(len=*), parameter :: nmlname = 'mineral_nitrogen_dynamics' + !----------------------------------------------------------------------- + real(r8) :: freelivfix_intercept ! intercept of line of free living fixation with annual ET + real(r8) :: freelivfix_slope_wET ! slope of line of free living fixation with annual ET + namelist /mineral_nitrogen_dynamics/ freelivfix_slope_wET, freelivfix_intercept + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + + freelivfix_intercept = 0.0117_r8 + freelivfix_slope_wET = 0.0006_r8 + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=mineral_nitrogen_dynamics, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(__FILE__, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(__FILE__, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (freelivfix_intercept, mpicom) + call shr_mpi_bcast (freelivfix_slope_wET, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=mineral_nitrogen_dynamics) + write(iulog,*) ' ' + end if + params_inst%freelivfix_intercept = freelivfix_intercept + params_inst%freelivfix_slope_wET = freelivfix_slope_wET + + end subroutine CNNDynamicsReadNML + + !----------------------------------------------------------------------- + subroutine CNNDeposition( bounds, & + atm2lnd_inst, soilbiogeochem_nitrogenflux_inst ) + ! + ! !DESCRIPTION: + ! On the radiation time step, update the nitrogen deposition rate + ! from atmospheric forcing. For now it is assumed that all the atmospheric + ! N deposition goes to the soil mineral N pool. + ! This could be updated later to divide the inputs between mineral N absorbed + ! directly into the canopy and mineral N entering the soil pool. + ! + ! !USES: + use CNSharedParamsMod , only: use_fun + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: g,c ! indices + !----------------------------------------------------------------------- + + associate( & + forc_ndep => atm2lnd_inst%forc_ndep_grc , & ! Input: [real(r8) (:)] nitrogen deposition rate (gN/m2/s) + ndep_to_sminn => soilbiogeochem_nitrogenflux_inst%ndep_to_sminn_col & ! Output: [real(r8) (:)] atmospheric N deposition to soil mineral N (gN/m2/s) + ) + + ! Loop through columns + do c = bounds%begc, bounds%endc + g = col%gridcell(c) + ndep_to_sminn(c) = forc_ndep(g) + + end do + + end associate + + end subroutine CNNDeposition + + !----------------------------------------------------------------------- + subroutine CNFreeLivingFixation(num_soilc, filter_soilc, & + waterfluxbulk_inst, soilbiogeochem_nitrogenflux_inst) + + + use clm_time_manager , only : get_days_per_year + ! use shr_sys_mod , only : shr_sys_flush + use clm_varcon , only : secspday, spval + + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + ! + ! !LOCAL VARIABLES: + integer :: c,fc !indices + real(r8) :: dayspyr !days per year + real(r8) :: secs_per_year !seconds per year + + associate( & + AnnET => waterfluxbulk_inst%AnnET, & ! Input: [real(:) ] : Annual average ET flux mmH20/s + freelivfix_slope => params_inst%freelivfix_slope_wET, & ! Input: [real ] : slope of fixation with ET + freelivfix_inter => params_inst%freelivfix_intercept, & ! Input: [real ] : intercept of fixation with ET + ffix_to_sminn => soilbiogeochem_nitrogenflux_inst%ffix_to_sminn_col & ! Output: [real(:) ] : free living N fixation to soil mineral N (gN/m2/s) + ) + + dayspyr = get_days_per_year() + secs_per_year = dayspyr*24_r8*3600_r8 + + do fc = 1,num_soilc + c = filter_soilc(fc) + ffix_to_sminn(c) = (freelivfix_slope*(max(0._r8,AnnET(c))*secs_per_year) + freelivfix_inter )/secs_per_year !(units g N m-2 s-1) + + end do + + end associate + end subroutine CNFreeLivingFixation + + !----------------------------------------------------------------------- + subroutine CNNFixation(num_soilc, filter_soilc, & + cnveg_carbonflux_inst, soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update the nitrogen fixation rate + ! as a function of annual total NPP. This rate gets updated once per year. + ! All N fixation goes to the soil mineral N pool. + ! + ! !USES: + use clm_time_manager , only : get_days_per_year + ! use shr_sys_mod , only : shr_sys_flush + use clm_varcon , only : secspday, spval + use CNSharedParamsMod , only: use_fun + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: c,fc ! indices + real(r8) :: t ! temporary + real(r8) :: dayspyr ! days per year + !----------------------------------------------------------------------- + + associate( & + cannsum_npp => cnveg_carbonflux_inst%annsum_npp_col , & ! Input: [real(r8) (:)] nitrogen deposition rate (gN/m2/s) + col_lag_npp => cnveg_carbonflux_inst%lag_npp_col , & ! Input: [real(r8) (:)] (gC/m2/s) lagged net primary production + + nfix_to_sminn => soilbiogeochem_nitrogenflux_inst%nfix_to_sminn_col & ! Output: [real(r8) (:)] symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) + ) + + dayspyr = get_days_per_year() + + if ( nfix_timeconst > 0._r8 .and. nfix_timeconst < 500._r8 ) then + ! use exponential relaxation with time constant nfix_timeconst for NPP - NFIX relation + ! Loop through columns + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (col_lag_npp(c) /= spval) then + ! need to put npp in units of gC/m^2/year here first + t = (1.8_r8 * (1._r8 - exp(-0.003_r8 * col_lag_npp(c)*(secspday * dayspyr))))/(secspday * dayspyr) + nfix_to_sminn(c) = max(0._r8,t) + else + nfix_to_sminn(c) = 0._r8 + endif + end do + else + ! use annual-mean values for NPP-NFIX relation + do fc = 1,num_soilc + c = filter_soilc(fc) + + t = (1.8_r8 * (1._r8 - exp(-0.003_r8 * cannsum_npp(c))))/(secspday * dayspyr) + nfix_to_sminn(c) = max(0._r8,t) + end do + endif + if(use_fun)then + nfix_to_sminn(c) = 0.0_r8 + end if + + end associate + + end subroutine CNNFixation + + !----------------------------------------------------------------------- + subroutine CNNFert(bounds, num_soilc, filter_soilc, & + cnveg_nitrogenflux_inst, soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update the nitrogen fertilizer for crops + ! All fertilizer goes into the soil mineral N pool. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(cnveg_nitrogenflux_type) , intent(in) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: c,fc ! indices + !----------------------------------------------------------------------- + + associate( & + fert => cnveg_nitrogenflux_inst%fert_patch , & ! Input: [real(r8) (:)] nitrogen fertilizer rate (gN/m2/s) + fert_to_sminn => soilbiogeochem_nitrogenflux_inst%fert_to_sminn_col & ! Output: [real(r8) (:)] + ) + + call p2c(bounds, num_soilc, filter_soilc, & + fert(bounds%begp:bounds%endp), & + fert_to_sminn(bounds%begc:bounds%endc)) + + end associate + + end subroutine CNNFert + + !----------------------------------------------------------------------- + subroutine CNSoyfix (bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + waterdiagnosticbulk_inst, crop_inst, cnveg_state_inst, cnveg_nitrogenflux_inst , & + soilbiogeochem_state_inst, soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! This routine handles the fixation of nitrogen for soybeans based on + ! the EPICPHASE model M. Cabelguenne et al., Agricultural systems 60: 175-196, 1999 + ! N-fixation is based on soil moisture, plant growth phase, and availibility of + ! nitrogen in the soil root zone. + ! + ! !USES: + use pftconMod, only : ntmp_soybean, nirrig_tmp_soybean + use pftconMod, only : ntrp_soybean, nirrig_trp_soybean + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(crop_type) , intent(in) :: crop_inst + type(cnveg_state_type) , intent(in) :: cnveg_state_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_state_type) , intent(in) :: soilbiogeochem_state_inst + type(soilbiogeochem_nitrogenstate_type) , intent(in) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: fp,p,c + real(r8):: fxw,fxn,fxg,fxr ! soil water factor, nitrogen factor, growth stage factor + real(r8):: soy_ndemand ! difference between nitrogen supply and demand + real(r8):: GDDfrac + real(r8):: sminnthreshold1, sminnthreshold2 + real(r8):: GDDfracthreshold1, GDDfracthreshold2 + real(r8):: GDDfracthreshold3, GDDfracthreshold4 + !----------------------------------------------------------------------- + + associate( & + wf => waterdiagnosticbulk_inst%wf_col , & ! Input: [real(r8) (:) ] soil water as frac. of whc for top 0.5 m + + hui => crop_inst%gddplant_patch , & ! Input: [real(r8) (:) ] gdd since planting (gddplant) + croplive => crop_inst%croplive_patch , & ! Input: [logical (:) ] true if planted and not harvested + + gddmaturity => cnveg_state_inst%gddmaturity_patch , & ! Input: [real(r8) (:) ] gdd needed to harvest + + plant_ndemand => cnveg_nitrogenflux_inst%plant_ndemand_patch , & ! Input: [real(r8) (:) ] N flux required to support initial GPP (gN/m2/s) + soyfixn => cnveg_nitrogenflux_inst%soyfixn_patch , & ! Output: [real(r8) (:) ] nitrogen fixed to each soybean crop + + fpg => soilbiogeochem_state_inst%fpg_col , & ! Input: [real(r8) (:) ] fraction of potential gpp (no units) + + sminn => soilbiogeochem_nitrogenstate_inst%sminn_col , & ! Input: [real(r8) (:) ] (kgN/m2) soil mineral N + soyfixn_to_sminn => soilbiogeochem_nitrogenflux_inst%soyfixn_to_sminn_col & ! Output: [real(r8) (:) ] + ) + + sminnthreshold1 = 30._r8 + sminnthreshold2 = 10._r8 + GDDfracthreshold1 = 0.15_r8 + GDDfracthreshold2 = 0.30_r8 + GDDfracthreshold3 = 0.55_r8 + GDDfracthreshold4 = 0.75_r8 + + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + ! if soybean currently growing then calculate fixation + + if (croplive(p) .and. & + (patch%itype(p) == ntmp_soybean .or. & + patch%itype(p) == nirrig_tmp_soybean .or. & + patch%itype(p) == ntrp_soybean .or. & + patch%itype(p) == nirrig_trp_soybean) ) then + + ! difference between supply and demand + + if (fpg(c) < 1._r8) then + soy_ndemand = 0._r8 + soy_ndemand = plant_ndemand(p) - plant_ndemand(p)*fpg(c) + + ! fixation depends on nitrogen, soil water, and growth stage + + ! soil water factor + + fxw = 0._r8 + fxw = wf(c)/0.85_r8 + + ! soil nitrogen factor (Beth says: CHECK UNITS) + + if (sminn(c) > sminnthreshold1) then + fxn = 0._r8 + else if (sminn(c) > sminnthreshold2 .and. sminn(c) <= sminnthreshold1) then + fxn = 1.5_r8 - .005_r8 * (sminn(c) * 10._r8) + else if (sminn(c) <= sminnthreshold2) then + fxn = 1._r8 + end if + + ! growth stage factor + ! slevis: to replace GDDfrac, assume... + ! Beth's crit_offset_gdd_def is similar to my gddmaturity + ! Beth's ac_gdd (base 5C) similar to my hui=gddplant (base 10 + ! for soy) + ! Ranges below are not firm. Are they lit. based or tuning based? + + GDDfrac = hui(p) / gddmaturity(p) + + if (GDDfrac <= GDDfracthreshold1) then + fxg = 0._r8 + else if (GDDfrac > GDDfracthreshold1 .and. GDDfrac <= GDDfracthreshold2) then + fxg = 6.67_r8 * GDDfrac - 1._r8 + else if (GDDfrac > GDDfracthreshold2 .and. GDDfrac <= GDDfracthreshold3) then + fxg = 1._r8 + else if (GDDfrac > GDDfracthreshold3 .and. GDDfrac <= GDDfracthreshold4) then + fxg = 3.75_r8 - 5._r8 * GDDfrac + else ! GDDfrac > GDDfracthreshold4 + fxg = 0._r8 + end if + + ! calculate the nitrogen fixed by the soybean + + fxr = min(1._r8, fxw, fxn) * fxg + fxr = max(0._r8, fxr) + soyfixn(p) = fxr * soy_ndemand + soyfixn(p) = min(soyfixn(p), soy_ndemand) + + else ! if nitrogen demand met, no fixation + + soyfixn(p) = 0._r8 + + end if + + else ! if not live soybean, no fixation + + soyfixn(p) = 0._r8 + + end if + end do + + call p2c(bounds, num_soilc, filter_soilc, & + soyfixn(bounds%begp:bounds%endp), & + soyfixn_to_sminn(bounds%begc:bounds%endc)) + + end associate + + end subroutine CNSoyfix + +end module CNNDynamicsMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate1Mod.F90 new file mode 100755 index 000000000..61a0388b4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate1Mod.F90 @@ -0,0 +1,344 @@ +module CNNStateUpdate1Mod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for nitrogen state variable updates, non-mortality fluxes. + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use clm_time_manager , only : get_step_size_real + use clm_varpar , only : nlevdecomp, ndecomp_pools, ndecomp_cascade_transitions + use clm_varpar , only : i_met_lit, i_cel_lit, i_lig_lit, i_cwd, ioutn, iretransn + use clm_varctl , only : iulog, use_nitrif_denitrif, use_matrixcn, use_soil_matrixcn + use clm_varcon , only : nitrif_n2o_loss_frac + use pftconMod , only : npcropmin, pftcon + use decompMod , only : bounds_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use PatchType , only : patch + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: NStateUpdateDynPatch + public :: NStateUpdate1 + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine NStateUpdateDynPatch(bounds, num_soilc_with_inactive, filter_soilc_with_inactive, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! Update nitrogen states based on fluxes from dyn_cnbal_patch + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: num_soilc_with_inactive ! number of columns in soil filter + integer, intent(in) :: filter_soilc_with_inactive(:) ! soil column filter that includes inactive points + type(cnveg_nitrogenflux_type) , intent(in) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: c ! column index + integer :: g ! gridcell index + integer :: fc ! column filter index + integer :: j ! level index + real(r8) :: dt ! time step (seconds) + + character(len=*), parameter :: subname = 'NStateUpdateDynPatch' + !----------------------------------------------------------------------- + + associate( & + nf_veg => cnveg_nitrogenflux_inst , & + ns_veg => cnveg_nitrogenstate_inst , & + nf_soil => soilbiogeochem_nitrogenflux_inst, & + ns_soil => soilbiogeochem_nitrogenstate_inst & + ) + + dt = get_step_size_real() + + do j = 1, nlevdecomp + do fc = 1, num_soilc_with_inactive + c = filter_soilc_with_inactive(fc) + ns_soil%decomp_npools_vr_col(c,j,i_met_lit) = ns_soil%decomp_npools_vr_col(c,j,i_met_lit) + & + nf_veg%dwt_frootn_to_litr_met_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_cel_lit) = ns_soil%decomp_npools_vr_col(c,j,i_cel_lit) + & + nf_veg%dwt_frootn_to_litr_cel_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_lig_lit) = ns_soil%decomp_npools_vr_col(c,j,i_lig_lit) + & + nf_veg%dwt_frootn_to_litr_lig_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_cwd) = ns_soil%decomp_npools_vr_col(c,j,i_cwd) + & + ( nf_veg%dwt_livecrootn_to_cwdn_col(c,j) + nf_veg%dwt_deadcrootn_to_cwdn_col(c,j) ) * dt + end do + end do + + do g = bounds%begg, bounds%endg + ns_veg%seedn_grc(g) = ns_veg%seedn_grc(g) - nf_veg%dwt_seedn_to_leaf_grc(g) * dt + ns_veg%seedn_grc(g) = ns_veg%seedn_grc(g) - nf_veg%dwt_seedn_to_deadstem_grc(g) * dt + end do + + end associate + + end subroutine NStateUpdateDynPatch + + !----------------------------------------------------------------------- + subroutine NStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + use CNSharedParamsMod , only : use_fun + ! + ! !DESCRIPTION: + ! On the radiation time step, update all the prognostic nitrogen state + ! variables (except for gap-phase mortality and fire fluxes) + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,l,g,k ! indices + integer :: fp,fc ! lake filter indices + real(r8):: dt ! radiation time step (seconds) + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + + nf_veg => cnveg_nitrogenflux_inst , & ! Input: + ns_veg => cnveg_nitrogenstate_inst , & ! Output: + nf_soil => soilbiogeochem_nitrogenflux_inst & ! Output: + ) + + ! set time steps + dt = get_step_size_real() + + + ! soilbiogeochemistry fluxes TODO - this should be moved elsewhere + ! plant to litter fluxes - phenology and dynamic landcover fluxes + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if (.not. use_soil_matrixcn) then ! to be consistent with C + nf_soil%decomp_npools_sourcesink_col(c,j,i_met_lit) = & + nf_veg%phenology_n_to_litr_met_n_col(c,j) * dt + + nf_soil%decomp_npools_sourcesink_col(c,j,i_cel_lit) = & + nf_veg%phenology_n_to_litr_cel_n_col(c,j) * dt + + nf_soil%decomp_npools_sourcesink_col(c,j,i_lig_lit) = & + nf_veg%phenology_n_to_litr_lig_n_col(c,j) * dt + + ! NOTE(wjs, 2017-01-02) This used to be set to a non-zero value, but the + ! terms have been moved to CStateUpdateDynPatch. I think this is zeroed every + ! time step, but to be safe, I'm explicitly setting it to zero here. + nf_soil%decomp_npools_sourcesink_col(c,j,i_cwd) = 0._r8 + + else +! nf_soil%matrix_Ninput%V(c,j+(i_met_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_met_lit-1)*nlevdecomp) + nf_veg%phenology_n_to_litr_met_n_col(c,j) *dt +! +! nf_soil%matrix_Ninput%V(c,j+(i_cel_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_cel_lit-1)*nlevdecomp) + nf_veg%phenology_n_to_litr_cel_n_col(c,j) *dt +! +! nf_soil%matrix_Ninput%V(c,j+(i_lig_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_lig_lit-1)*nlevdecomp) + nf_veg%phenology_n_to_litr_lig_n_col(c,j) *dt + + end if + end do + end do + + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! phenology: transfer growth fluxes + if(.not. use_matrixcn)then + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) + nf_veg%leafn_xfer_to_leafn_patch(p)*dt + ns_veg%leafn_xfer_patch(p) = ns_veg%leafn_xfer_patch(p) - nf_veg%leafn_xfer_to_leafn_patch(p)*dt + ns_veg%frootn_patch(p) = ns_veg%frootn_patch(p) + nf_veg%frootn_xfer_to_frootn_patch(p)*dt + ns_veg%frootn_xfer_patch(p) = ns_veg%frootn_xfer_patch(p) - nf_veg%frootn_xfer_to_frootn_patch(p)*dt + + if (woody(ivt(p)) == 1.0_r8) then + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) + nf_veg%livestemn_xfer_to_livestemn_patch(p)*dt + ns_veg%livestemn_xfer_patch(p) = ns_veg%livestemn_xfer_patch(p) - nf_veg%livestemn_xfer_to_livestemn_patch(p)*dt + ns_veg%deadstemn_patch(p) = ns_veg%deadstemn_patch(p) + nf_veg%deadstemn_xfer_to_deadstemn_patch(p)*dt + ns_veg%deadstemn_xfer_patch(p) = ns_veg%deadstemn_xfer_patch(p) - nf_veg%deadstemn_xfer_to_deadstemn_patch(p)*dt + ns_veg%livecrootn_patch(p) = ns_veg%livecrootn_patch(p) + nf_veg%livecrootn_xfer_to_livecrootn_patch(p)*dt + ns_veg%livecrootn_xfer_patch(p) = ns_veg%livecrootn_xfer_patch(p) - nf_veg%livecrootn_xfer_to_livecrootn_patch(p)*dt + ns_veg%deadcrootn_patch(p) = ns_veg%deadcrootn_patch(p) + nf_veg%deadcrootn_xfer_to_deadcrootn_patch(p)*dt + ns_veg%deadcrootn_xfer_patch(p) = ns_veg%deadcrootn_xfer_patch(p) - nf_veg%deadcrootn_xfer_to_deadcrootn_patch(p)*dt + end if + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) + nf_veg%livestemn_xfer_to_livestemn_patch(p)*dt + ns_veg%livestemn_xfer_patch(p) = ns_veg%livestemn_xfer_patch(p) - nf_veg%livestemn_xfer_to_livestemn_patch(p)*dt + ns_veg%grainn_patch(p) = ns_veg%grainn_patch(p) + nf_veg%grainn_xfer_to_grainn_patch(p)*dt + ns_veg%grainn_xfer_patch(p) = ns_veg%grainn_xfer_patch(p) - nf_veg%grainn_xfer_to_grainn_patch(p)*dt + end if + + ! phenology: litterfall and retranslocation fluxes + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) - nf_veg%leafn_to_litter_patch(p)*dt + ns_veg%frootn_patch(p) = ns_veg%frootn_patch(p) - nf_veg%frootn_to_litter_patch(p)*dt + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) - nf_veg%leafn_to_retransn_patch(p)*dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) + nf_veg%leafn_to_retransn_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + + ! live wood turnover and retranslocation fluxes + if (woody(ivt(p)) == 1._r8) then + if(.not. use_matrixcn)then + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) - nf_veg%livestemn_to_deadstemn_patch(p)*dt + ns_veg%deadstemn_patch(p) = ns_veg%deadstemn_patch(p) + nf_veg%livestemn_to_deadstemn_patch(p)*dt + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) - nf_veg%livestemn_to_retransn_patch(p)*dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) + nf_veg%livestemn_to_retransn_patch(p)*dt + ns_veg%livecrootn_patch(p) = ns_veg%livecrootn_patch(p) - nf_veg%livecrootn_to_deadcrootn_patch(p)*dt + ns_veg%deadcrootn_patch(p) = ns_veg%deadcrootn_patch(p) + nf_veg%livecrootn_to_deadcrootn_patch(p)*dt + ns_veg%livecrootn_patch(p) = ns_veg%livecrootn_patch(p) - nf_veg%livecrootn_to_retransn_patch(p)*dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) + nf_veg%livecrootn_to_retransn_patch(p)*dt + ! WW change logic so livestem_retrans goes to npool (via free_retrans flux) + ! this should likely be done more cleanly if it works, i.e. not update fluxes w/ states + ! additional considerations for crop? + ! Matrix version of this is in CNLivewoodTurnover + if (use_fun ) then + nf_veg%free_retransn_to_npool_patch(p) = nf_veg%free_retransn_to_npool_patch(p) + nf_veg%livestemn_to_retransn_patch(p) + nf_veg%free_retransn_to_npool_patch(p) = nf_veg%free_retransn_to_npool_patch(p) + nf_veg%livecrootn_to_retransn_patch(p) + end if + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + end if + if (ivt(p) >= npcropmin) then ! Beth adds retrans from froot + if(.not. use_matrixcn)then + ns_veg%frootn_patch(p) = ns_veg%frootn_patch(p) - nf_veg%frootn_to_retransn_patch(p)*dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) + nf_veg%frootn_to_retransn_patch(p)*dt + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) - nf_veg%livestemn_to_litter_patch(p)*dt + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) - nf_veg%livestemn_to_biofueln_patch(p)*dt + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) - nf_veg%leafn_to_biofueln_patch(p)*dt + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) - nf_veg%livestemn_to_retransn_patch(p)*dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) + nf_veg%livestemn_to_retransn_patch(p)*dt + ns_veg%grainn_patch(p) = ns_veg%grainn_patch(p) & + - (nf_veg%grainn_to_food_patch(p) + nf_veg%grainn_to_seed_patch(p))*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if !not use_matrixcn + ns_veg%cropseedn_deficit_patch(p) = ns_veg%cropseedn_deficit_patch(p) & + - nf_veg%crop_seedn_to_leaf_patch(p) * dt & + + nf_veg%grainn_to_seed_patch(p) * dt + end if + + ! uptake from soil mineral N pool + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) + nf_veg%sminn_to_npool_patch(p)*dt + + ! deployment from retranslocation pool + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) + nf_veg%retransn_to_npool_patch(p)*dt + + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) + nf_veg%free_retransn_to_npool_patch(p)*dt + + ! allocation fluxes + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_leafn_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_leafn_storage_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_frootn_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_frootn_storage_patch(p)*dt + if (.not. use_matrixcn) then + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) - nf_veg%retransn_to_npool_patch(p)*dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) - nf_veg%free_retransn_to_npool_patch(p)*dt !how is retransn a state? + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) + nf_veg%npool_to_leafn_patch(p)*dt + ns_veg%leafn_storage_patch(p) = ns_veg%leafn_storage_patch(p) + nf_veg%npool_to_leafn_storage_patch(p)*dt + ns_veg%frootn_patch(p) = ns_veg%frootn_patch(p) + nf_veg%npool_to_frootn_patch(p)*dt + ns_veg%frootn_storage_patch(p) = ns_veg%frootn_storage_patch(p) + nf_veg%npool_to_frootn_storage_patch(p)*dt + else + ! No matrix code needed here + end if + + if (woody(ivt(p)) == 1._r8) then + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_livestemn_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_livestemn_storage_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_deadstemn_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_deadstemn_storage_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_livecrootn_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_livecrootn_storage_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_deadcrootn_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_deadcrootn_storage_patch(p)*dt + if(.not. use_matrixcn) then + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) + nf_veg%npool_to_livestemn_patch(p)*dt + ns_veg%livestemn_storage_patch(p) = ns_veg%livestemn_storage_patch(p) + nf_veg%npool_to_livestemn_storage_patch(p)*dt + ns_veg%deadstemn_patch(p) = ns_veg%deadstemn_patch(p) + nf_veg%npool_to_deadstemn_patch(p)*dt + ns_veg%deadstemn_storage_patch(p) = ns_veg%deadstemn_storage_patch(p) + nf_veg%npool_to_deadstemn_storage_patch(p)*dt + ns_veg%livecrootn_patch(p) = ns_veg%livecrootn_patch(p) + nf_veg%npool_to_livecrootn_patch(p)*dt + ns_veg%livecrootn_storage_patch(p) = ns_veg%livecrootn_storage_patch(p) + nf_veg%npool_to_livecrootn_storage_patch(p)*dt + ns_veg%deadcrootn_patch(p) = ns_veg%deadcrootn_patch(p) + nf_veg%npool_to_deadcrootn_patch(p)*dt + ns_veg%deadcrootn_storage_patch(p) = ns_veg%deadcrootn_storage_patch(p) + nf_veg%npool_to_deadcrootn_storage_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if ! not use_matrixcn + end if + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_livestemn_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_livestemn_storage_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_grainn_patch(p)*dt + ns_veg%npool_patch(p) = ns_veg%npool_patch(p) - nf_veg%npool_to_grainn_storage_patch(p)*dt + if(.not. use_matrixcn) then + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) + nf_veg%npool_to_livestemn_patch(p)*dt + ns_veg%livestemn_storage_patch(p) = ns_veg%livestemn_storage_patch(p) + nf_veg%npool_to_livestemn_storage_patch(p)*dt + ns_veg%grainn_patch(p) = ns_veg%grainn_patch(p) + nf_veg%npool_to_grainn_patch(p)*dt + ns_veg%grainn_storage_patch(p) = ns_veg%grainn_storage_patch(p) + nf_veg%npool_to_grainn_storage_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if ! not use_matrixcn + end if + + ! move storage pools into transfer pools + if(.not. use_matrixcn) then + ns_veg%leafn_storage_patch(p) = ns_veg%leafn_storage_patch(p) - nf_veg%leafn_storage_to_xfer_patch(p)*dt + ns_veg%leafn_xfer_patch(p) = ns_veg%leafn_xfer_patch(p) + nf_veg%leafn_storage_to_xfer_patch(p)*dt + ns_veg%frootn_storage_patch(p) = ns_veg%frootn_storage_patch(p) - nf_veg%frootn_storage_to_xfer_patch(p)*dt + ns_veg%frootn_xfer_patch(p) = ns_veg%frootn_xfer_patch(p) + nf_veg%frootn_storage_to_xfer_patch(p)*dt + + if (woody(ivt(p)) == 1._r8) then + ns_veg%livestemn_storage_patch(p) = ns_veg%livestemn_storage_patch(p) - nf_veg%livestemn_storage_to_xfer_patch(p)*dt + ns_veg%livestemn_xfer_patch(p) = ns_veg%livestemn_xfer_patch(p) + nf_veg%livestemn_storage_to_xfer_patch(p)*dt + ns_veg%deadstemn_storage_patch(p) = ns_veg%deadstemn_storage_patch(p) - nf_veg%deadstemn_storage_to_xfer_patch(p)*dt + ns_veg%deadstemn_xfer_patch(p) = ns_veg%deadstemn_xfer_patch(p) + nf_veg%deadstemn_storage_to_xfer_patch(p)*dt + ns_veg%livecrootn_storage_patch(p) = ns_veg%livecrootn_storage_patch(p) - nf_veg%livecrootn_storage_to_xfer_patch(p)*dt + ns_veg%livecrootn_xfer_patch(p) = ns_veg%livecrootn_xfer_patch(p) + nf_veg%livecrootn_storage_to_xfer_patch(p)*dt + ns_veg%deadcrootn_storage_patch(p) = ns_veg%deadcrootn_storage_patch(p) - nf_veg%deadcrootn_storage_to_xfer_patch(p)*dt + ns_veg%deadcrootn_xfer_patch(p) = ns_veg%deadcrootn_xfer_patch(p) + nf_veg%deadcrootn_storage_to_xfer_patch(p)*dt + end if + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if ! not use_matrixcn + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + if(.not. use_matrixcn)then + ns_veg%livestemn_storage_patch(p) = ns_veg%livestemn_storage_patch(p) - nf_veg%livestemn_storage_to_xfer_patch(p)*dt + ns_veg%livestemn_xfer_patch(p) = ns_veg%livestemn_xfer_patch(p) + nf_veg%livestemn_storage_to_xfer_patch(p)*dt + ns_veg%grainn_storage_patch(p) = ns_veg%grainn_storage_patch(p) - nf_veg%grainn_storage_to_xfer_patch(p)*dt + ns_veg%grainn_xfer_patch(p) = ns_veg%grainn_xfer_patch(p) + nf_veg%grainn_storage_to_xfer_patch(p)*dt + else + ! NOTE: The equivalent changes for matrix code are in CNPhenology EBK (11/26/2019) + end if ! not use_matrixcn + end if + + end do + + end associate + + end subroutine NStateUpdate1 + +end module CNNStateUpdate1Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate2Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate2Mod.F90 new file mode 100755 index 000000000..0ca87fab2 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate2Mod.F90 @@ -0,0 +1,275 @@ +module CNNStateUpdate2Mod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for nitrogen state variable update, mortality fluxes. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_time_manager , only : get_step_size_real + use clm_varpar , only : nlevsoi, nlevdecomp + use clm_varpar , only : i_met_lit, i_cel_lit, i_lig_lit, i_cwd + use clm_varctl , only : iulog, use_matrixcn,use_soil_matrixcn + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: NStateUpdate2 + public:: NStateUpdate2h + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine NStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update all the prognostic nitrogen state + ! variables affected by gap-phase mortality fluxes + ! NOTE - associate statements have been removed where there are + ! no science equations. This increases readability and maintainability + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_nitrogenflux_type) , intent(in) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,l ! indices + integer :: fp,fc ! lake filter indices + real(r8) :: dt ! radiation time step (seconds) + !----------------------------------------------------------------------- + + associate( & + nf_veg => cnveg_nitrogenflux_inst , & + ns_veg => cnveg_nitrogenstate_inst , & + nf_soil => soilbiogeochem_nitrogenflux_inst, & + ns_soil => soilbiogeochem_nitrogenstate_inst & + ) + + ! set time steps + dt = get_step_size_real() + + ! column-level nitrogen fluxes from gap-phase mortality + + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (.not. use_soil_matrixcn)then + ns_soil%decomp_npools_vr_col(c,j,i_met_lit) = & + ns_soil%decomp_npools_vr_col(c,j,i_met_lit) + nf_veg%gap_mortality_n_to_litr_met_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_cel_lit) = & + ns_soil%decomp_npools_vr_col(c,j,i_cel_lit) + nf_veg%gap_mortality_n_to_litr_cel_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_lig_lit) = & + ns_soil%decomp_npools_vr_col(c,j,i_lig_lit) + nf_veg%gap_mortality_n_to_litr_lig_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_cwd) = & + ns_soil%decomp_npools_vr_col(c,j,i_cwd) + nf_veg%gap_mortality_n_to_cwdn_col(c,j) * dt + else +! nf_soil%matrix_Ninput%V(c,j+(i_met_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_met_lit-1)*nlevdecomp) + nf_veg%gap_mortality_n_to_litr_met_n_col(c,j) * dt +! nf_soil%matrix_Ninput%V(c,j+(i_cel_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_cel_lit-1)*nlevdecomp) + nf_veg%gap_mortality_n_to_litr_cel_n_col(c,j) * dt +! nf_soil%matrix_Ninput%V(c,j+(i_lig_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_lig_lit-1)*nlevdecomp) + nf_veg%gap_mortality_n_to_litr_lig_n_col(c,j) * dt +! nf_soil%matrix_Ninput%V(c,j+(i_cwd-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_cwd-1)*nlevdecomp) + nf_veg%gap_mortality_n_to_cwdn_col(c,j) * dt + end if !not use_soil_matrix + end do + end do + + ! patch -level nitrogen fluxes from gap-phase mortality + + do fp = 1,num_soilp + p = filter_soilp(fp) + + if(.not. use_matrixcn)then + ! displayed pools + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) & + - nf_veg%m_leafn_to_litter_patch(p) * dt + ns_veg%frootn_patch(p) = ns_veg%frootn_patch(p) & + - nf_veg%m_frootn_to_litter_patch(p) * dt + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) & + - nf_veg%m_livestemn_to_litter_patch(p) * dt + ns_veg%deadstemn_patch(p) = ns_veg%deadstemn_patch(p) & + - nf_veg%m_deadstemn_to_litter_patch(p) * dt + ns_veg%livecrootn_patch(p) = ns_veg%livecrootn_patch(p) & + - nf_veg%m_livecrootn_to_litter_patch(p) * dt + ns_veg%deadcrootn_patch(p) = ns_veg%deadcrootn_patch(p) & + - nf_veg%m_deadcrootn_to_litter_patch(p) * dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) & + - nf_veg%m_retransn_to_litter_patch(p) * dt + + ! storage pools + ns_veg%leafn_storage_patch(p) = ns_veg%leafn_storage_patch(p) & + - nf_veg%m_leafn_storage_to_litter_patch(p) * dt + ns_veg%frootn_storage_patch(p) = ns_veg%frootn_storage_patch(p) & + - nf_veg%m_frootn_storage_to_litter_patch(p) * dt + ns_veg%livestemn_storage_patch(p) = ns_veg%livestemn_storage_patch(p) & + - nf_veg%m_livestemn_storage_to_litter_patch(p) * dt + ns_veg%deadstemn_storage_patch(p) = ns_veg%deadstemn_storage_patch(p) & + - nf_veg%m_deadstemn_storage_to_litter_patch(p) * dt + ns_veg%livecrootn_storage_patch(p) = ns_veg%livecrootn_storage_patch(p) & + - nf_veg%m_livecrootn_storage_to_litter_patch(p) * dt + ns_veg%deadcrootn_storage_patch(p) = ns_veg%deadcrootn_storage_patch(p) & + - nf_veg%m_deadcrootn_storage_to_litter_patch(p) * dt + + ! transfer pools + ns_veg%leafn_xfer_patch(p) = ns_veg%leafn_xfer_patch(p) & + - nf_veg%m_leafn_xfer_to_litter_patch(p) * dt + ns_veg%frootn_xfer_patch(p) = ns_veg%frootn_xfer_patch(p) & + - nf_veg%m_frootn_xfer_to_litter_patch(p) * dt + ns_veg%livestemn_xfer_patch(p) = ns_veg%livestemn_xfer_patch(p) & + - nf_veg%m_livestemn_xfer_to_litter_patch(p) * dt + ns_veg%deadstemn_xfer_patch(p) = ns_veg%deadstemn_xfer_patch(p) & + - nf_veg%m_deadstemn_xfer_to_litter_patch(p) * dt + ns_veg%livecrootn_xfer_patch(p) = ns_veg%livecrootn_xfer_patch(p) & + - nf_veg%m_livecrootn_xfer_to_litter_patch(p) * dt + ns_veg%deadcrootn_xfer_patch(p) = ns_veg%deadcrootn_xfer_patch(p) & + - nf_veg%m_deadcrootn_xfer_to_litter_patch(p) * dt + + else + ! NOTE: The equivalent changes for matrix code are in dynHarvest::CNHarvest EBK (11/26/2019) + end if !not use_matrixcn + end do + + end associate + + end subroutine NStateUpdate2 + + !----------------------------------------------------------------------- + subroutine NStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! Update all the prognostic nitrogen state + ! variables affected by harvest mortality fluxes + ! NOTE - associate statements have been removed where there are + ! no science equations. This increases readability and maintainability + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_nitrogenflux_type) , intent(in) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,l ! indices + integer :: fp,fc ! lake filter indices + real(r8):: dt ! radiation time step (seconds) + !----------------------------------------------------------------------- + + associate( & + nf_veg => cnveg_nitrogenflux_inst , & + ns_veg => cnveg_nitrogenstate_inst , & + nf_soil => soilbiogeochem_nitrogenflux_inst , & + ns_soil => soilbiogeochem_nitrogenstate_inst & + ) + + ! set time steps + dt = get_step_size_real() + + ! column-level nitrogen fluxes from harvest mortality + + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if (.not. use_soil_matrixcn)then + ns_soil%decomp_npools_vr_col(c,j,i_met_lit) = & + ns_soil%decomp_npools_vr_col(c,j,i_met_lit) + nf_veg%harvest_n_to_litr_met_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_cel_lit) = & + ns_soil%decomp_npools_vr_col(c,j,i_cel_lit) + nf_veg%harvest_n_to_litr_cel_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_lig_lit) = & + ns_soil%decomp_npools_vr_col(c,j,i_lig_lit) + nf_veg%harvest_n_to_litr_lig_n_col(c,j) * dt + ns_soil%decomp_npools_vr_col(c,j,i_cwd) = & + ns_soil%decomp_npools_vr_col(c,j,i_cwd) + nf_veg%harvest_n_to_cwdn_col(c,j) * dt + else +! nf_soil%matrix_Ninput%V(c,j+(i_met_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_met_lit-1)*nlevdecomp) + nf_veg%harvest_n_to_litr_met_n_col(c,j) * dt +! nf_soil%matrix_Ninput%V(c,j+(i_cel_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_cel_lit-1)*nlevdecomp) + nf_veg%harvest_n_to_litr_cel_n_col(c,j) * dt +! nf_soil%matrix_Ninput%V(c,j+(i_lig_lit-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_lig_lit-1)*nlevdecomp) + nf_veg%harvest_n_to_litr_lig_n_col(c,j) * dt +! nf_soil%matrix_Ninput%V(c,j+(i_cwd-1)*nlevdecomp) = & +! nf_soil%matrix_Ninput%V(c,j+(i_cwd-1)*nlevdecomp) + nf_veg%harvest_n_to_cwdn_col(c,j) * dt + end if !not use_soil_matrixcn + end do + end do + + ! patch-level nitrogen fluxes from harvest mortality + + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! displayed pools + if(.not. use_matrixcn)then + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) & + - nf_veg%hrv_leafn_to_litter_patch(p) * dt + ns_veg%frootn_patch(p) = ns_veg%frootn_patch(p) & + - nf_veg%hrv_frootn_to_litter_patch(p) * dt + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) & + - nf_veg%hrv_livestemn_to_litter_patch(p) * dt + ns_veg%deadstemn_patch(p) = ns_veg%deadstemn_patch(p) & + - nf_veg%wood_harvestn_patch(p) * dt + ns_veg%livecrootn_patch(p) = ns_veg%livecrootn_patch(p) & + - nf_veg%hrv_livecrootn_to_litter_patch(p) * dt + ns_veg%deadcrootn_patch(p) = ns_veg%deadcrootn_patch(p) & + - nf_veg%hrv_deadcrootn_to_litter_patch(p) * dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) & + - nf_veg%hrv_retransn_to_litter_patch(p) * dt + + ! storage pools + ns_veg%leafn_storage_patch(p) = ns_veg%leafn_storage_patch(p) & + - nf_veg%hrv_leafn_storage_to_litter_patch(p) * dt + ns_veg%frootn_storage_patch(p) = ns_veg%frootn_storage_patch(p) & + - nf_veg%hrv_frootn_storage_to_litter_patch(p) * dt + ns_veg%livestemn_storage_patch(p) = ns_veg%livestemn_storage_patch(p) & + - nf_veg%hrv_livestemn_storage_to_litter_patch(p) * dt + ns_veg%deadstemn_storage_patch(p) = ns_veg%deadstemn_storage_patch(p) & + - nf_veg%hrv_deadstemn_storage_to_litter_patch(p) * dt + ns_veg%livecrootn_storage_patch(p) = ns_veg%livecrootn_storage_patch(p) & + - nf_veg%hrv_livecrootn_storage_to_litter_patch(p) * dt + ns_veg%deadcrootn_storage_patch(p) = ns_veg%deadcrootn_storage_patch(p) & + - nf_veg%hrv_deadcrootn_storage_to_litter_patch(p) * dt + + ! transfer pools + ns_veg%leafn_xfer_patch(p) = ns_veg%leafn_xfer_patch(p) & + - nf_veg%hrv_leafn_xfer_to_litter_patch(p) *dt + ns_veg%frootn_xfer_patch(p) = ns_veg%frootn_xfer_patch(p) & + - nf_veg%hrv_frootn_xfer_to_litter_patch(p) *dt + ns_veg%livestemn_xfer_patch(p) = ns_veg%livestemn_xfer_patch(p) & + - nf_veg%hrv_livestemn_xfer_to_litter_patch(p) *dt + ns_veg%deadstemn_xfer_patch(p) = ns_veg%deadstemn_xfer_patch(p) & + - nf_veg%hrv_deadstemn_xfer_to_litter_patch(p) *dt + ns_veg%livecrootn_xfer_patch(p) = ns_veg%livecrootn_xfer_patch(p) & + - nf_veg%hrv_livecrootn_xfer_to_litter_patch(p) *dt + ns_veg%deadcrootn_xfer_patch(p) = ns_veg%deadcrootn_xfer_patch(p) & + - nf_veg%hrv_deadcrootn_xfer_to_litter_patch(p) *dt + else + ! NOTE: The equivalent changes for matrix code are in dynHarvest::CNHarvest EBK (11/26/2019) + end if !not use_matrixcn + + end do + + end associate + + end subroutine NStateUpdate2h + +end module CNNStateUpdate2Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate3Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate3Mod.F90 new file mode 100755 index 000000000..8243508dc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNNStateUpdate3Mod.F90 @@ -0,0 +1,229 @@ +module CNNStateUpdate3Mod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for nitrogen state variable update, mortality fluxes. + ! Also, sminn leaching flux. + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use clm_varpar , only: nlevdecomp, ndecomp_pools + use clm_time_manager , only : get_step_size_real + use clm_varctl , only : iulog, use_nitrif_denitrif,use_matrixcn,use_soil_matrixcn + use clm_varpar , only : i_cwd, i_met_lit, i_cel_lit, i_lig_lit + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: NStateUpdate3 + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine NStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update all the prognostic nitrogen state + ! variables affected by gap-phase mortality fluxes. Also the Sminn leaching flux. + ! NOTE - associate statements have been removed where there are + ! no science equations. This increases readability and maintainability. + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_nitrogenflux_type) , intent(in) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,l,k ! indices + integer :: fp,fc ! lake filter indices + real(r8):: dt ! radiation time step (seconds) + !----------------------------------------------------------------------- + + associate( & + nf_veg => cnveg_nitrogenflux_inst , & ! Input + ns_veg => cnveg_nitrogenstate_inst , & ! Output + nf_soil => soilbiogeochem_nitrogenflux_inst , & ! Input + ns_soil => soilbiogeochem_nitrogenstate_inst & ! Output + ) + + ! set time steps + dt = get_step_size_real() + + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (.not. use_nitrif_denitrif) then + ! mineral N loss due to leaching + ns_soil%sminn_vr_col(c,j) = ns_soil%sminn_vr_col(c,j) - nf_soil%sminn_leached_vr_col(c,j) * dt + else + ! mineral N loss due to leaching and runoff + ns_soil%smin_no3_vr_col(c,j) = max( ns_soil%smin_no3_vr_col(c,j) - & + ( nf_soil%smin_no3_leached_vr_col(c,j) + nf_soil%smin_no3_runoff_vr_col(c,j) ) * dt, 0._r8) + + ns_soil%sminn_vr_col(c,j) = ns_soil%smin_no3_vr_col(c,j) + ns_soil%smin_nh4_vr_col(c,j) + end if + + ! column level nitrogen fluxes from fire + ! patch-level wood to column-level CWD (uncombusted wood) + if (.not. use_soil_matrixcn)then + ns_soil%decomp_npools_vr_col(c,j,i_cwd) = ns_soil%decomp_npools_vr_col(c,j,i_cwd) + & + nf_veg%fire_mortality_n_to_cwdn_col(c,j) * dt + + ! patch-level wood to column-level litter (uncombusted wood) + ns_soil%decomp_npools_vr_col(c,j,i_met_lit) = ns_soil%decomp_npools_vr_col(c,j,i_met_lit) + & + nf_veg%m_n_to_litr_met_fire_col(c,j)* dt + ns_soil%decomp_npools_vr_col(c,j,i_cel_lit) = ns_soil%decomp_npools_vr_col(c,j,i_cel_lit) + & + nf_veg%m_n_to_litr_cel_fire_col(c,j)* dt + ns_soil%decomp_npools_vr_col(c,j,i_lig_lit) = ns_soil%decomp_npools_vr_col(c,j,i_lig_lit) + & + nf_veg%m_n_to_litr_lig_fire_col(c,j)* dt + else +! nf_soil%matrix_Ninput%V(c,j+(i_cwd-1)*nlevdecomp) = nf_soil%matrix_Ninput%V(c,j+(i_cwd-1)*nlevdecomp) + & +! nf_veg%fire_mortality_n_to_cwdn_col(c,j) * dt +! +! ! patch-level wood to column-level litter (uncombusted wood) +! nf_soil%matrix_Ninput%V(c,j+(i_met_lit-1)*nlevdecomp) = nf_soil%matrix_Ninput%V(c,j+(i_met_lit-1)*nlevdecomp) + & +! nf_veg%m_n_to_litr_met_fire_col(c,j)* dt +! nf_soil%matrix_Ninput%V(c,j+(i_cel_lit-1)*nlevdecomp) = nf_soil%matrix_Ninput%V(c,j+(i_cel_lit-1)*nlevdecomp) + & +! nf_veg%m_n_to_litr_cel_fire_col(c,j)* dt +! nf_soil%matrix_Ninput%V(c,j+(i_lig_lit-1)*nlevdecomp) = nf_soil%matrix_Ninput%V(c,j+(i_lig_lit-1)*nlevdecomp) + & +! nf_veg%m_n_to_litr_lig_fire_col(c,j)* dt + end if ! not use_soil_matrix + end do ! end of column loop + end do + + ! litter and CWD losses to fire + if(.not. use_soil_matrixcn)then + do l = 1, ndecomp_pools + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + ns_soil%decomp_npools_vr_col(c,j,l) = ns_soil%decomp_npools_vr_col(c,j,l) - & + nf_veg%m_decomp_npools_to_fire_vr_col(c,j,l) * dt + end do + end do + end do + end if ! not use_soil_matrixcn + + ! patch-level nitrogen fluxes + + do fp = 1,num_soilp + p = filter_soilp(fp) + + if(.not. use_matrixcn)then + !from fire displayed pools + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) - & + nf_veg%m_leafn_to_fire_patch(p) * dt + ns_veg%frootn_patch(p) = ns_veg%frootn_patch(p) - & + nf_veg%m_frootn_to_fire_patch(p) * dt + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) - & + nf_veg%m_livestemn_to_fire_patch(p) * dt + ns_veg%deadstemn_patch(p) = ns_veg%deadstemn_patch(p) - & + nf_veg%m_deadstemn_to_fire_patch(p) * dt + ns_veg%livecrootn_patch(p) = ns_veg%livecrootn_patch(p) - & + nf_veg%m_livecrootn_to_fire_patch(p) * dt + ns_veg%deadcrootn_patch(p) = ns_veg%deadcrootn_patch(p) - & + nf_veg%m_deadcrootn_to_fire_patch(p) * dt + + ns_veg%leafn_patch(p) = ns_veg%leafn_patch(p) - & + nf_veg%m_leafn_to_litter_fire_patch(p) * dt + ns_veg%frootn_patch(p) = ns_veg%frootn_patch(p) - & + nf_veg%m_frootn_to_litter_fire_patch(p) * dt + ns_veg%livestemn_patch(p) = ns_veg%livestemn_patch(p) - & + nf_veg%m_livestemn_to_litter_fire_patch(p) * dt - & + nf_veg%m_livestemn_to_deadstemn_fire_patch(p) * dt + ns_veg%deadstemn_patch(p) = ns_veg%deadstemn_patch(p) - & + nf_veg%m_deadstemn_to_litter_fire_patch(p) * dt + & + nf_veg%m_livestemn_to_deadstemn_fire_patch(p) * dt + ns_veg%livecrootn_patch(p) = ns_veg%livecrootn_patch(p) - & + nf_veg%m_livecrootn_to_litter_fire_patch(p) * dt - & + nf_veg%m_livecrootn_to_deadcrootn_fire_patch(p) * dt + ns_veg%deadcrootn_patch(p) = ns_veg%deadcrootn_patch(p) - & + nf_veg%m_deadcrootn_to_litter_fire_patch(p) * dt + & + nf_veg%m_livecrootn_to_deadcrootn_fire_patch(p) * dt + + ! storage pools + ns_veg%leafn_storage_patch(p) = ns_veg%leafn_storage_patch(p) - & + nf_veg%m_leafn_storage_to_fire_patch(p) * dt + ns_veg%frootn_storage_patch(p) = ns_veg%frootn_storage_patch(p) - & + nf_veg%m_frootn_storage_to_fire_patch(p) * dt + ns_veg%livestemn_storage_patch(p) = ns_veg%livestemn_storage_patch(p) - & + nf_veg%m_livestemn_storage_to_fire_patch(p) * dt + ns_veg%deadstemn_storage_patch(p) = ns_veg%deadstemn_storage_patch(p) - & + nf_veg%m_deadstemn_storage_to_fire_patch(p) * dt + ns_veg%livecrootn_storage_patch(p) = ns_veg%livecrootn_storage_patch(p) - & + nf_veg%m_livecrootn_storage_to_fire_patch(p) * dt + ns_veg%deadcrootn_storage_patch(p) = ns_veg%deadcrootn_storage_patch(p) - & + nf_veg%m_deadcrootn_storage_to_fire_patch(p) * dt + + ns_veg%leafn_storage_patch(p) = ns_veg%leafn_storage_patch(p) - & + nf_veg%m_leafn_storage_to_litter_fire_patch(p) * dt + ns_veg%frootn_storage_patch(p) = ns_veg%frootn_storage_patch(p) - & + nf_veg%m_frootn_storage_to_litter_fire_patch(p) * dt + ns_veg%livestemn_storage_patch(p) = ns_veg%livestemn_storage_patch(p) - & + nf_veg%m_livestemn_storage_to_litter_fire_patch(p) * dt + ns_veg%deadstemn_storage_patch(p) = ns_veg%deadstemn_storage_patch(p) - & + nf_veg%m_deadstemn_storage_to_litter_fire_patch(p) * dt + ns_veg%livecrootn_storage_patch(p) = ns_veg%livecrootn_storage_patch(p) - & + nf_veg%m_livecrootn_storage_to_litter_fire_patch(p) * dt + ns_veg%deadcrootn_storage_patch(p) = ns_veg%deadcrootn_storage_patch(p) - & + nf_veg%m_deadcrootn_storage_to_litter_fire_patch(p) * dt + + + ! transfer pools + ns_veg%leafn_xfer_patch(p) = ns_veg%leafn_xfer_patch(p) - & + nf_veg%m_leafn_xfer_to_fire_patch(p) * dt + ns_veg%frootn_xfer_patch(p) = ns_veg%frootn_xfer_patch(p) - & + nf_veg%m_frootn_xfer_to_fire_patch(p) * dt + ns_veg%livestemn_xfer_patch(p) = ns_veg%livestemn_xfer_patch(p) - & + nf_veg%m_livestemn_xfer_to_fire_patch(p) * dt + ns_veg%deadstemn_xfer_patch(p) = ns_veg%deadstemn_xfer_patch(p) - & + nf_veg%m_deadstemn_xfer_to_fire_patch(p) * dt + ns_veg%livecrootn_xfer_patch(p) = ns_veg%livecrootn_xfer_patch(p) - & + nf_veg%m_livecrootn_xfer_to_fire_patch(p) * dt + ns_veg%deadcrootn_xfer_patch(p) = ns_veg%deadcrootn_xfer_patch(p) - & + nf_veg%m_deadcrootn_xfer_to_fire_patch(p) * dt + + ns_veg%leafn_xfer_patch(p) = ns_veg%leafn_xfer_patch(p) - & + nf_veg%m_leafn_xfer_to_litter_fire_patch(p) * dt + ns_veg%frootn_xfer_patch(p) = ns_veg%frootn_xfer_patch(p) - & + nf_veg%m_frootn_xfer_to_litter_fire_patch(p) * dt + ns_veg%livestemn_xfer_patch(p) = ns_veg%livestemn_xfer_patch(p) - & + nf_veg%m_livestemn_xfer_to_litter_fire_patch(p) * dt + ns_veg%deadstemn_xfer_patch(p) = ns_veg%deadstemn_xfer_patch(p) - & + nf_veg%m_deadstemn_xfer_to_litter_fire_patch(p) * dt + ns_veg%livecrootn_xfer_patch(p) = ns_veg%livecrootn_xfer_patch(p) - & + nf_veg%m_livecrootn_xfer_to_litter_fire_patch(p) * dt + ns_veg%deadcrootn_xfer_patch(p) = ns_veg%deadcrootn_xfer_patch(p) - & + nf_veg%m_deadcrootn_xfer_to_litter_fire_patch(p) * dt + + ! retranslocated N pool + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) - & + nf_veg%m_retransn_to_fire_patch(p) * dt + ns_veg%retransn_patch(p) = ns_veg%retransn_patch(p) - & + nf_veg%m_retransn_to_litter_fire_patch(p) * dt + else + ! NOTE: The equivalent changes for matrix code are in CNFireBase and CNFireLi2014 codes EBK (11/26/2019) + end if !.not. use_matrixcn + end do + + end associate + + end subroutine NStateUpdate3 + +end module CNNStateUpdate3Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNPhenologyMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNPhenologyMod.F90 new file mode 100755 index 000000000..a25db441c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNPhenologyMod.F90 @@ -0,0 +1,3787 @@ +module CNPhenologyMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !MODULE: CNPhenologyMod + ! + ! !DESCRIPTION: + ! Module holding routines used in phenology model for coupled carbon + ! nitrogen code. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + ! use shr_sys_mod , only : shr_sys_flush + use decompMod , only : bounds_type + use clm_varpar , only : ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,& + igrain,igrain_st,igrain_xf,iretransn,ioutc,ioutn + use clm_varpar , only : maxveg, nlevdecomp_full + use clm_varctl , only : iulog, use_cndv, use_matrixcn + use clm_varcon , only : tfrz + use abortutils , only : endrun + use CanopyStateType , only : canopystate_type + use CNDVType , only : dgvs_type + use CNVegstateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegnitrogenstateType , only : cnveg_nitrogenstate_type + use CNVegnitrogenfluxType , only : cnveg_nitrogenflux_type + use CropType , only : crop_type + use pftconMod , only : pftcon + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use initVerticalMod , only : find_soil_layer_containing_depth + use ColumnType , only : col + use GridcellType , only : grc + use PatchType , only : patch + use atm2lndType , only : atm2lnd_type + ! use CNVegMatrixMod , only : matrix_update_phc, matrix_update_phn + ! use CNVegMatrixMod , only : matrix_update_gmc, matrix_update_gmn + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: readParams ! Read parameters + public :: CNPhenologyreadNML ! Read namelist + public :: CNPhenologyInit ! Initialization + public :: CNPhenology ! Update + ! + ! !PRIVATE DATA MEMBERS: + type, private :: params_type + real(r8) :: crit_dayl ! critical day length for senescence + real(r8) :: ndays_on ! number of days to complete leaf onset + real(r8) :: ndays_off ! number of days to complete leaf offset + real(r8) :: fstor2tran ! fraction of storage to move to transfer for each onset + real(r8) :: crit_onset_fdd ! critical number of freezing days to set gdd counter + real(r8) :: crit_onset_swi ! critical number of days > soilpsi_on for onset + real(r8) :: soilpsi_on ! critical soil water potential for leaf onset + real(r8) :: crit_offset_fdd ! critical number of freezing days to initiate offset + real(r8) :: crit_offset_swi ! critical number of water stress days to initiate offset + real(r8) :: soilpsi_off ! critical soil water potential for leaf offset + real(r8) :: lwtop ! live wood turnover proportion (annual fraction) + real(r8) :: phenology_soil_depth ! soil depth used for measuring states for phenology triggers + end type params_type + + type(params_type) :: params_inst + + real(r8) :: dt ! radiation time step delta t (seconds) + real(r8) :: fracday ! dtime as a fraction of day + real(r8) :: crit_dayl ! critical daylength for offset (seconds) + real(r8) :: ndays_on ! number of days to complete onset + real(r8) :: ndays_off ! number of days to complete offset + real(r8) :: fstor2tran ! fraction of storage to move to transfer on each onset + real(r8) :: crit_onset_fdd ! critical number of freezing days + real(r8) :: crit_onset_swi ! water stress days for offset trigger + real(r8) :: soilpsi_on ! water potential for onset trigger (MPa) + real(r8) :: crit_offset_fdd ! critical number of freezing degree days to trigger offset + real(r8) :: crit_offset_swi ! water stress days for offset trigger + real(r8) :: soilpsi_off ! water potential for offset trigger (MPa) + real(r8) :: lwtop ! live wood turnover proportion (annual fraction) + integer :: phenology_soil_layer ! soil layer used for measuring states for phenology triggers + + ! CropPhenology variables and constants + real(r8) :: p1d, p1v ! photoperiod factor constants for crop vernalization + real(r8) :: hti ! cold hardening index threshold for vernalization + real(r8) :: tbase ! base temperature for vernalization + + integer, parameter :: NOT_Planted = 999 ! If not planted yet in year + integer, parameter :: NOT_Harvested = 999 ! If not harvested yet in year + integer, parameter :: inNH = 1 ! Northern Hemisphere + integer, parameter :: inSH = 2 ! Southern Hemisphere + integer, pointer :: inhemi(:) ! Hemisphere that patch is in + + integer, allocatable :: minplantjday(:,:) ! minimum planting julian day + integer, allocatable :: maxplantjday(:,:) ! maximum planting julian day + integer :: jdayyrstart(inSH) ! julian day of start of year + + logical,parameter :: matrixcheck_ph = .True. ! Matrix check + logical,parameter :: acc_ph = .False. ! Another matrix check + + real(r8), private :: initial_seed_at_planting = 3._r8 ! Initial seed at planting + logical, private :: min_crtical_dayl_depends_on_lat = .false. ! If critical day-length for onset depends on latitude + logical, private :: onset_thresh_depends_on_veg = .false. ! If onset threshold depends on vegetation type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CNPhenologyReadNML( NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for CNPhenology + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'CNPhenologyReadNML' + character(len=*), parameter :: nmlname = 'cnphenology' + !----------------------------------------------------------------------- + namelist /cnphenology/ initial_seed_at_planting, onset_thresh_depends_on_veg, & + min_crtical_dayl_depends_on_lat + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=cnphenology, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (initial_seed_at_planting, mpicom) + call shr_mpi_bcast (onset_thresh_depends_on_veg, mpicom) + call shr_mpi_bcast (min_crtical_dayl_depends_on_lat, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=cnphenology) + write(iulog,*) ' ' + end if + + + !----------------------------------------------------------------------- + + end subroutine CNPhenologyReadNML + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !DESCRIPTION: + ! + ! !USES: + use ncdio_pio , only: file_desc_t + use paramUtilMod , only : readNcdioScalar + + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'readParams_CNPhenology' + !----------------------------------------------------------------------- + + call readNcdioScalar(ncid, 'crit_dayl', subname, params_inst%crit_dayl) + call readNcdioScalar(ncid, 'ndays_on', subname, params_inst%ndays_on) + call readNcdioScalar(ncid, 'ndays_off', subname, params_inst%ndays_off) + call readNcdioScalar(ncid, 'fstor2tran', subname, params_inst%fstor2tran) + call readNcdioScalar(ncid, 'crit_onset_fdd', subname, params_inst%crit_onset_fdd) + call readNcdioScalar(ncid, 'crit_onset_swi', subname, params_inst%crit_onset_swi) + call readNcdioScalar(ncid, 'soilpsi_on', subname, params_inst%soilpsi_on) + call readNcdioScalar(ncid, 'crit_offset_fdd', subname, params_inst%crit_offset_fdd) + call readNcdioScalar(ncid, 'crit_offset_swi', subname, params_inst%crit_offset_swi) + call readNcdioScalar(ncid, 'soilpsi_off', subname, params_inst%soilpsi_off) + call readNcdioScalar(ncid, 'lwtop_ann', subname, params_inst%lwtop) + call readNcdioScalar(ncid, 'phenology_soil_depth', subname, params_inst%phenology_soil_depth) + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine CNPhenology (bounds, num_soilc, filter_soilc, num_soilp, & + filter_soilp, num_pcropp, filter_pcropp, & + doalb, waterdiagnosticbulk_inst, wateratm2lndbulk_inst, temperature_inst, atm2lnd_inst, crop_inst, & + canopystate_inst, soilstate_inst, dgvs_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + c13_cnveg_carbonstate_inst, c14_cnveg_carbonstate_inst, & + leaf_prof_patch, froot_prof_patch, phase) + ! !USES: + use CNSharedParamsMod, only: use_fun + ! + ! !DESCRIPTION: + ! Dynamic phenology routine for coupled carbon-nitrogen code (CN) + ! 1. grass phenology + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_pcropp ! number of prog. crop patches in filter + integer , intent(in) :: filter_pcropp(:)! filter for prognostic crop patches + logical , intent(in) :: doalb ! true if time for sfc albedo calc + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(wateratm2lndbulk_type) , intent(in) :: wateratm2lndbulk_inst + type(temperature_type) , intent(inout) :: temperature_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(crop_type) , intent(inout) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(dgvs_type) , intent(inout) :: dgvs_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: c13_cnveg_carbonstate_inst + type(cnveg_carbonstate_type) , intent(inout) :: c14_cnveg_carbonstate_inst + real(r8) , intent(in) :: leaf_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: froot_prof_patch(bounds%begp:,1:) + integer , intent(in) :: phase + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(leaf_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(froot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + + ! each of the following phenology type routines includes a filter + ! to operate only on the relevant patches + + + if ( phase == 1 ) then + call CNPhenologyClimate(num_soilp, filter_soilp, num_pcropp, filter_pcropp, & + temperature_inst, cnveg_state_inst, crop_inst) + + call CNEvergreenPhenology(num_soilp, filter_soilp, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + + call CNSeasonDecidPhenology(num_soilp, filter_soilp, & + temperature_inst, waterdiagnosticbulk_inst, cnveg_state_inst, dgvs_inst, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + + call CNStressDecidPhenology(num_soilp, filter_soilp, & + soilstate_inst, temperature_inst, atm2lnd_inst, wateratm2lndbulk_inst, cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + + if (doalb .and. num_pcropp > 0 ) then + call CropPhenology(num_pcropp, filter_pcropp, & + waterdiagnosticbulk_inst, temperature_inst, crop_inst, canopystate_inst, cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, & + c13_cnveg_carbonstate_inst, c14_cnveg_carbonstate_inst) + end if + else if ( phase == 2 ) then + ! the same onset and offset routines are called regardless of + ! phenology type - they depend only on onset_flag, offset_flag, bglfr, and bgtr + + call CNOnsetGrowth(num_soilp, filter_soilp, & + cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + + call CNOffsetLitterfall(num_soilp, filter_soilp, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + + call CNBackgroundLitterfall(num_soilp, filter_soilp, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + + call CNLivewoodTurnover(num_soilp, filter_soilp, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + + call CNCropHarvestToProductPools(bounds, num_soilp, filter_soilp, num_soilc, filter_soilc, & + cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + + ! gather all patch-level litterfall fluxes to the column for litter C and N inputs + + call CNLitterToColumn(bounds, num_soilc, filter_soilc, & + cnveg_state_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, & + leaf_prof_patch(bounds%begp:bounds%endp,1:nlevdecomp_full), & + froot_prof_patch(bounds%begp:bounds%endp,1:nlevdecomp_full)) + else + call endrun( 'bad phase' ) + end if + + end subroutine CNPhenology + + !----------------------------------------------------------------------- + subroutine CNPhenologyInit(bounds) + ! + ! !DESCRIPTION: + ! Initialization of CNPhenology. Must be called after time-manager is + ! initialized, and after pftcon file is read in. + ! + ! !USES: + use clm_time_manager, only: get_step_size_real + use clm_varctl , only: use_crop + use clm_varcon , only: secspday + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + !------------------------------------------------------------------------ + + ! + ! Get time-step and what fraction of a day it is + ! + dt = get_step_size_real() + fracday = dt/secspday + + ! set constants for CNSeasonDecidPhenology + ! (critical daylength from Biome-BGC, v4.1.2) + crit_dayl=params_inst%crit_dayl + + ! Set constants for CNSeasonDecidPhenology and CNStressDecidPhenology + ndays_on=params_inst%ndays_on + ndays_off=params_inst%ndays_off + + ! set transfer parameters + fstor2tran=params_inst%fstor2tran + + call find_soil_layer_containing_depth( & + depth = params_inst%phenology_soil_depth, & + layer = phenology_soil_layer) + + ! ----------------------------------------- + ! Constants for CNStressDecidPhenology + ! ----------------------------------------- + + ! onset parameters + crit_onset_fdd=params_inst%crit_onset_fdd + ! critical onset gdd now being calculated as a function of annual + ! average 2m temp. + ! crit_onset_gdd = 150.0 ! c3 grass value + ! crit_onset_gdd = 1000.0 ! c4 grass value + crit_onset_swi=params_inst%crit_onset_swi + soilpsi_on=params_inst%soilpsi_on + + ! offset parameters + crit_offset_fdd=params_inst%crit_offset_fdd + crit_offset_swi=params_inst%crit_offset_swi + soilpsi_off=params_inst%soilpsi_off + + ! ----------------------------------------- + ! Constants for CNLivewoodTurnover + ! ----------------------------------------- + + ! set the global parameter for livewood turnover rate + ! define as an annual fraction (0.7), and convert to fraction per second + lwtop=params_inst%lwtop/31536000.0_r8 !annual fraction converted to per second + + ! ----------------------------------------- + ! Call any subroutine specific initialization routines + ! ----------------------------------------- + + if ( use_crop ) call CropPhenologyInit(bounds) + + end subroutine CNPhenologyInit + + !----------------------------------------------------------------------- + subroutine CNPhenologyClimate (num_soilp, filter_soilp, num_pcropp, filter_pcropp, & + temperature_inst, cnveg_state_inst, crop_inst) + ! + ! !DESCRIPTION: + ! For coupled carbon-nitrogen code (CN). + ! + ! !USES: + use clm_time_manager , only : get_days_per_year + use clm_time_manager , only : get_curr_date, is_first_step + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_pcropp ! number of prognostic crops in filter + integer , intent(in) :: filter_pcropp(:)! filter for prognostic crop patches + type(temperature_type) , intent(inout) :: temperature_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(crop_type) , intent(inout) :: crop_inst + ! + ! !LOCAL VARIABLES: + integer :: p ! indices + integer :: fp ! lake filter patch index + real(r8) :: dayspyr ! days per year (days) + integer :: kyr ! current year + integer :: kmo ! month of year (1, ..., 12) + integer :: kda ! day of month (1, ..., 31) + integer :: mcsec ! seconds of day (0, ..., seconds/day) + real(r8), parameter :: yravg = 20.0_r8 ! length of years to average for gdd + real(r8), parameter :: yravgm1 = yravg-1.0_r8 ! minus 1 of above + !----------------------------------------------------------------------- + + associate( & + nyrs_crop_active => crop_inst%nyrs_crop_active_patch, & ! InOut: [integer (:) ] number of years this crop patch has been active + + t_ref2m => temperature_inst%t_ref2m_patch , & ! Input: [real(r8) (:) ] 2m air temperature (K) + gdd0 => temperature_inst%gdd0_patch , & ! Output: [real(r8) (:) ] growing deg. days base 0 deg C (ddays) + gdd8 => temperature_inst%gdd8_patch , & ! Output: [real(r8) (:) ] " " " " 8 " " " + gdd10 => temperature_inst%gdd10_patch , & ! Output: [real(r8) (:) ] " " " " 10 " " " + gdd020 => temperature_inst%gdd020_patch , & ! Output: [real(r8) (:) ] 20-yr mean of gdd0 (ddays) + gdd820 => temperature_inst%gdd820_patch , & ! Output: [real(r8) (:) ] 20-yr mean of gdd8 (ddays) + gdd1020 => temperature_inst%gdd1020_patch , & ! Output: [real(r8) (:) ] 20-yr mean of gdd10 (ddays) + + tempavg_t2m => cnveg_state_inst%tempavg_t2m_patch & ! Output: [real(r8) (:) ] temp. avg 2m air temperature (K) + ) + + ! set time steps + + dayspyr = get_days_per_year() + + do fp = 1,num_soilp + p = filter_soilp(fp) + tempavg_t2m(p) = tempavg_t2m(p) + t_ref2m(p) * (fracday/dayspyr) + end do + + ! + ! The following crop related steps are done here rather than CropPhenology + ! so that they will be completed each time-step rather than with doalb. + ! + ! The following lines come from ibis's climate.f + stats.f + ! gdd SUMMATIONS ARE RELATIVE TO THE PLANTING DATE (see subr. updateAccFlds) + + if (num_pcropp > 0) then + ! get time-related info + call get_curr_date(kyr, kmo, kda, mcsec) + end if + + do fp = 1,num_pcropp + p = filter_pcropp(fp) + if (kmo == 1 .and. kda == 1 .and. nyrs_crop_active(p) == 0) then ! YR 1: + gdd020(p) = 0._r8 ! set gdd..20 variables to 0 + gdd820(p) = 0._r8 ! and crops will not be planted + gdd1020(p) = 0._r8 + end if + if (kmo == 1 .and. kda == 1 .and. mcsec == 0) then ! <-- END of EVERY YR: + if (nyrs_crop_active(p) == 1) then ! <-- END of YR 1 + gdd020(p) = gdd0(p) ! <-- END of YR 1 + gdd820(p) = gdd8(p) ! <-- END of YR 1 + gdd1020(p) = gdd10(p) ! <-- END of YR 1 + end if ! <-- END of YR 1 + gdd020(p) = (yravgm1* gdd020(p) + gdd0(p)) / yravg ! gdd..20 must be long term avgs + gdd820(p) = (yravgm1* gdd820(p) + gdd8(p)) / yravg ! so ignore results for yrs 1 & 2 + gdd1020(p) = (yravgm1* gdd1020(p) + gdd10(p)) / yravg + end if + end do + + end associate + + end subroutine CNPhenologyClimate + + !----------------------------------------------------------------------- + subroutine CNEvergreenPhenology (num_soilp, filter_soilp , & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + ! cnveg_state_inst) + ! + ! !DESCRIPTION: + ! For coupled carbon-nitrogen code (CN). + ! + ! !USES: + use clm_varcon , only : secspday + use clm_time_manager , only : get_days_per_year + use clm_varctl , only : CN_evergreen_phenology_opt + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type), intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + real(r8):: dayspyr ! Days per year + integer :: p ! indices + integer :: fp ! lake filter patch index + + real(r8):: tranr + real(r8):: t1 ! temporary variable + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + evergreen => pftcon%evergreen , & ! Input: binary flag for evergreen leaf habit (0 or 1) + leaf_long => pftcon%leaf_long , & ! Input: leaf longevity (yrs) + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) leaf C storage + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) fine root C storage + livestemc_storage => cnveg_carbonstate_inst%livestemc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) live stem C storage + deadstemc_storage => cnveg_carbonstate_inst%deadstemc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) dead stem C storage + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) live coarse root C storage + deadcrootc_storage => cnveg_carbonstate_inst%deadcrootc_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) dead coarse root C storage + gresp_storage => cnveg_carbonstate_inst%gresp_storage_patch , & ! Input: [real(r8) (:)] (gC/m2) growth respiration storage + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! InOut: [real(r8) (:)] (gC/m2) leaf C transfer + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! InOut: [real(r8) (:)] (gC/m2) fine root C transfer + livestemc_xfer => cnveg_carbonstate_inst%livestemc_xfer_patch , & ! InOut: [real(r8) (:)] (gC/m2) live stem C transfer + deadstemc_xfer => cnveg_carbonstate_inst%deadstemc_xfer_patch , & ! InOut: [real(r8) (:)] (gC/m2) dead stem C transfer + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! InOut: [real(r8) (:)] (gC/m2) live coarse root C transfer + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! InOut: [real(r8) (:)] (gC/m2) dead coarse root C transfer + + leafn_storage => cnveg_nitrogenstate_inst%leafn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) leaf N storage + frootn_storage => cnveg_nitrogenstate_inst%frootn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) fine root N storage + livestemn_storage => cnveg_nitrogenstate_inst%livestemn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) live stem N storage + deadstemn_storage => cnveg_nitrogenstate_inst%deadstemn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) dead stem N storage + livecrootn_storage => cnveg_nitrogenstate_inst%livecrootn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) live coarse root N storage + deadcrootn_storage => cnveg_nitrogenstate_inst%deadcrootn_storage_patch , & ! Input: [real(r8) (:)] (gN/m2) dead coarse root N storage + leafn_xfer => cnveg_nitrogenstate_inst%leafn_xfer_patch , & ! InOut: [real(r8) (:)] (gN/m2) leaf N transfer + frootn_xfer => cnveg_nitrogenstate_inst%frootn_xfer_patch , & ! InOut: [real(r8) (:)] (gN/m2) fine root N transfer + livestemn_xfer => cnveg_nitrogenstate_inst%livestemn_xfer_patch , & ! InOut: [real(r8) (:)] (gN/m2) live stem N transfer + deadstemn_xfer => cnveg_nitrogenstate_inst%deadstemn_xfer_patch , & ! InOut: [real(r8) (:)] (gN/m2) dead stem N transfer + livecrootn_xfer => cnveg_nitrogenstate_inst%livecrootn_xfer_patch , & ! InOut: [real(r8) (:)] (gN/m2) live coarse root N transfer + deadcrootn_xfer => cnveg_nitrogenstate_inst%deadcrootn_xfer_patch , & ! InOut: [real(r8) (:)] (gN/m2) dead coarse root N transfer + + leafc_storage_to_xfer => cnveg_carbonflux_inst%leafc_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + frootc_storage_to_xfer => cnveg_carbonflux_inst%frootc_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + livestemc_storage_to_xfer => cnveg_carbonflux_inst%livestemc_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + deadstemc_storage_to_xfer => cnveg_carbonflux_inst%deadstemc_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + livecrootc_storage_to_xfer => cnveg_carbonflux_inst%livecrootc_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + deadcrootc_storage_to_xfer => cnveg_carbonflux_inst%deadcrootc_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + gresp_storage_to_xfer => cnveg_carbonflux_inst%gresp_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + leafc_xfer_to_leafc => cnveg_carbonflux_inst%leafc_xfer_to_leafc_patch , & ! InOut: [real(r8) (:)] + frootc_xfer_to_frootc => cnveg_carbonflux_inst%frootc_xfer_to_frootc_patch , & ! InOut: [real(r8) (:)] + livestemc_xfer_to_livestemc => cnveg_carbonflux_inst%livestemc_xfer_to_livestemc_patch , & ! InOut: [real(r8) (:)] + deadstemc_xfer_to_deadstemc => cnveg_carbonflux_inst%deadstemc_xfer_to_deadstemc_patch , & ! InOut: [real(r8) (:)] + livecrootc_xfer_to_livecrootc => cnveg_carbonflux_inst%livecrootc_xfer_to_livecrootc_patch , & ! InOut: [real(r8) (:)] + deadcrootc_xfer_to_deadcrootc => cnveg_carbonflux_inst%deadcrootc_xfer_to_deadcrootc_patch , & ! InOut: [real(r8) (:)] + + leafn_storage_to_xfer => cnveg_nitrogenflux_inst%leafn_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + frootn_storage_to_xfer => cnveg_nitrogenflux_inst%frootn_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + livestemn_storage_to_xfer => cnveg_nitrogenflux_inst%livestemn_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + deadstemn_storage_to_xfer => cnveg_nitrogenflux_inst%deadstemn_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + livecrootn_storage_to_xfer => cnveg_nitrogenflux_inst%livecrootn_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + deadcrootn_storage_to_xfer => cnveg_nitrogenflux_inst%deadcrootn_storage_to_xfer_patch , & ! InOut: [real(r8) (:)] + leafn_xfer_to_leafn => cnveg_nitrogenflux_inst%leafn_xfer_to_leafn_patch , & ! InOut: [real(r8) (:)] + frootn_xfer_to_frootn => cnveg_nitrogenflux_inst%frootn_xfer_to_frootn_patch , & ! InOut: [real(r8) (:)] + livestemn_xfer_to_livestemn => cnveg_nitrogenflux_inst%livestemn_xfer_to_livestemn_patch , & ! InOut: [real(r8) (:)] + deadstemn_xfer_to_deadstemn => cnveg_nitrogenflux_inst%deadstemn_xfer_to_deadstemn_patch , & ! InOut: [real(r8) (:)] + livecrootn_xfer_to_livecrootn => cnveg_nitrogenflux_inst%livecrootn_xfer_to_livecrootn_patch , & ! InOut: [real(r8) (:)] + deadcrootn_xfer_to_deadcrootn => cnveg_nitrogenflux_inst%deadcrootn_xfer_to_deadcrootn_patch , & ! InOut: [real(r8) (:)] + + bglfr => cnveg_state_inst%bglfr_patch , & ! Output: [real(r8) (:) ] background litterfall rate (1/s) + bgtr => cnveg_state_inst%bgtr_patch , & ! Output: [real(r8) (:) ] background transfer growth rate (1/s) + lgsf => cnveg_state_inst%lgsf_patch , & ! Output: [real(r8) (:) ] long growing season factor [0-1] + + ileafst_to_ileafxf_phc => cnveg_carbonflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phc => cnveg_carbonflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phc => cnveg_carbonflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phc => cnveg_carbonflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phc => cnveg_carbonflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phc => cnveg_carbonflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phc => cnveg_carbonflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phc => cnveg_carbonflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phc => cnveg_carbonflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phc => cnveg_carbonflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phc => cnveg_carbonflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phc => cnveg_carbonflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phc => cnveg_carbonflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phc => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phc => cnveg_carbonflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phc => cnveg_carbonflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phc => cnveg_carbonflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + igrain_to_iout_phc => cnveg_carbonflux_inst%igrain_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ileafst_to_ileafxf_phn => cnveg_nitrogenflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phn => cnveg_nitrogenflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phn => cnveg_nitrogenflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phn => cnveg_nitrogenflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phn => cnveg_nitrogenflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phn => cnveg_nitrogenflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phn => cnveg_nitrogenflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phn => cnveg_nitrogenflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phn => cnveg_nitrogenflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phn => cnveg_nitrogenflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phn => cnveg_nitrogenflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phn => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phn => cnveg_nitrogenflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phn => cnveg_nitrogenflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phn => cnveg_nitrogenflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + ileaf_to_iretransn_phn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to retranslocation pool + ilivestem_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to retranslocation pool + ilivecroot_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivecroot_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root pool to retranslocation pool + igrain_to_iout_phn => cnveg_nitrogenflux_inst%igrain_to_iout_ph & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ) + + dayspyr = get_days_per_year() + + do fp = 1,num_soilp + p = filter_soilp(fp) + if (evergreen(ivt(p)) == 1._r8) then + bglfr(p) = 1._r8/(leaf_long(ivt(p)) * dayspyr * secspday) + bgtr(p) = 0._r8 + lgsf(p) = 0._r8 + end if + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (CN_evergreen_phenology_opt == 1) then + do fp = 1,num_soilp + p = filter_soilp(fp) + if (evergreen(ivt(p)) == 1._r8) then + + tranr=0.0002_r8 + ! set carbon fluxes for shifting storage pools to transfer pools + if (use_matrixcn) then +! leafc_storage_to_xfer(p) = leafc_storage(p) * matrix_update_phc(p,ileafst_to_ileafxf_phc,tranr/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! frootc_storage_to_xfer(p) = frootc_storage(p) * matrix_update_phc(p,ifrootst_to_ifrootxf_phc,tranr/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! if (woody(ivt(p)) == 1.0_r8) then +! livestemc_storage_to_xfer(p) = livestemc_storage(p) * matrix_update_phc(p,ilivestemst_to_ilivestemxf_phc,tranr/dt ,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadstemc_storage_to_xfer(p) = deadstemc_storage(p) * matrix_update_phc(p,ideadstemst_to_ideadstemxf_phc,tranr/dt ,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! livecrootc_storage_to_xfer(p) = livecrootc_storage(p) * matrix_update_phc(p,ilivecrootst_to_ilivecrootxf_phc,tranr/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadcrootc_storage_to_xfer(p) = deadcrootc_storage(p) * matrix_update_phc(p,ideadcrootst_to_ideadcrootxf_phc,tranr/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + leafc_storage_to_xfer(p) = tranr * leafc_storage(p)/dt + frootc_storage_to_xfer(p) = tranr * frootc_storage(p)/dt + if (woody(ivt(p)) == 1.0_r8) then + livestemc_storage_to_xfer(p) = tranr * livestemc_storage(p)/dt + deadstemc_storage_to_xfer(p) = tranr * deadstemc_storage(p)/dt + livecrootc_storage_to_xfer(p) = tranr * livecrootc_storage(p)/dt + deadcrootc_storage_to_xfer(p) = tranr * deadcrootc_storage(p)/dt + gresp_storage_to_xfer(p) = tranr * gresp_storage(p)/dt + end if + end if !use_matrixcn + + ! set nitrogen fluxes for shifting storage pools to transfer pools + if (use_matrixcn) then +! leafn_storage_to_xfer(p) = leafn_storage(p) * matrix_update_phn(p,ileafst_to_ileafxf_phn,tranr/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! frootn_storage_to_xfer(p) = frootn_storage(p) * matrix_update_phn(p,ifrootst_to_ifrootxf_phn,tranr/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! if (woody(ivt(p)) == 1.0_r8) then +! livestemn_storage_to_xfer(p) = livestemn_storage(p) * matrix_update_phn(p,ilivestemst_to_ilivestemxf_phn,tranr/dt ,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadstemn_storage_to_xfer(p) = deadstemn_storage(p) * matrix_update_phn(p,ideadstemst_to_ideadstemxf_phn,tranr/dt ,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! livecrootn_storage_to_xfer(p) = livecrootn_storage(p) * matrix_update_phn(p,ilivecrootst_to_ilivecrootxf_phn,tranr/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadcrootn_storage_to_xfer(p) = deadcrootn_storage(p) * matrix_update_phn(p,ideadcrootst_to_ideadcrootxf_phn,tranr/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + leafn_storage_to_xfer(p) = tranr * leafn_storage(p)/dt + frootn_storage_to_xfer(p) = tranr * frootn_storage(p)/dt + if (woody(ivt(p)) == 1.0_r8) then + livestemn_storage_to_xfer(p) = tranr * livestemn_storage(p)/dt + deadstemn_storage_to_xfer(p) = tranr * deadstemn_storage(p)/dt + livecrootn_storage_to_xfer(p) = tranr * livecrootn_storage(p)/dt + deadcrootn_storage_to_xfer(p) = tranr * deadcrootn_storage(p)/dt + end if + end if !use_matrixcn + + t1 = 1.0_r8 / dt + + if (use_matrixcn) then +! leafc_xfer_to_leafc(p) = leafc_xfer(p) * matrix_update_phc(p,ileafxf_to_ileaf_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! frootc_xfer_to_frootc(p) = frootc_xfer(p) * matrix_update_phc(p,ifrootxf_to_ifroot_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! +! leafn_xfer_to_leafn(p) = leafn_xfer(p) * matrix_update_phn(p,ileafxf_to_ileaf_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! frootn_xfer_to_frootn(p) = frootn_xfer(p) * matrix_update_phn(p,ifrootxf_to_ifroot_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! if (woody(ivt(p)) == 1.0_r8) then +! livestemc_xfer_to_livestemc(p) = livestemc_xfer(p) * matrix_update_phc(p,ilivestemxf_to_ilivestem_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadstemc_xfer_to_deadstemc(p) = deadstemc_xfer(p) * matrix_update_phc(p,ideadstemxf_to_ideadstem_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! livecrootc_xfer_to_livecrootc(p) = livecrootc_xfer(p) * matrix_update_phc(p,ilivecrootxf_to_ilivecroot_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadcrootc_xfer_to_deadcrootc(p) = deadcrootc_xfer(p) * matrix_update_phc(p,ideadcrootxf_to_ideadcroot_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! +! livestemn_xfer_to_livestemn(p) = livestemn_xfer(p) * matrix_update_phn(p,ilivestemxf_to_ilivestem_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadstemn_xfer_to_deadstemn(p) = deadstemn_xfer(p) * matrix_update_phn(p,ideadstemxf_to_ideadstem_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! livecrootn_xfer_to_livecrootn(p) = livecrootn_xfer(p) * matrix_update_phn(p,ilivecrootxf_to_ilivecroot_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadcrootn_xfer_to_deadcrootn(p) = deadcrootn_xfer(p) * matrix_update_phn(p,ideadcrootxf_to_ideadcroot_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + leafc_xfer_to_leafc(p) = t1 * leafc_xfer(p) + frootc_xfer_to_frootc(p) = t1 * frootc_xfer(p) + + leafn_xfer_to_leafn(p) = t1 * leafn_xfer(p) + frootn_xfer_to_frootn(p) = t1 * frootn_xfer(p) + if (woody(ivt(p)) == 1.0_r8) then + livestemc_xfer_to_livestemc(p) = t1 * livestemc_xfer(p) + deadstemc_xfer_to_deadstemc(p) = t1 * deadstemc_xfer(p) + livecrootc_xfer_to_livecrootc(p) = t1 * livecrootc_xfer(p) + deadcrootc_xfer_to_deadcrootc(p) = t1 * deadcrootc_xfer(p) + + livestemn_xfer_to_livestemn(p) = t1 * livestemn_xfer(p) + deadstemn_xfer_to_deadstemn(p) = t1 * deadstemn_xfer(p) + livecrootn_xfer_to_livecrootn(p) = t1 * livecrootn_xfer(p) + deadcrootn_xfer_to_deadcrootn(p) = t1 * deadcrootn_xfer(p) + end if + end if !use_matrixcn + + end if ! end of if (evergreen(ivt(p)) == 1._r8) then + + end do ! end of pft loop + + end if ! end of if (CN_evergreen_phenology_opt == 1) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + end associate + + end subroutine CNEvergreenPhenology + + !----------------------------------------------------------------------- + subroutine CNSeasonDecidPhenology (num_soilp, filter_soilp , & + temperature_inst, waterdiagnosticbulk_inst, cnveg_state_inst, dgvs_inst , & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! For coupled carbon-nitrogen code (CN). + ! This routine handles the seasonal deciduous phenology code (temperate + ! deciduous vegetation that has only one growing season per year). + ! + ! !USES: + use shr_const_mod , only: SHR_CONST_TKFRZ, SHR_CONST_PI + use clm_varcon , only: secspday + use clm_varctl , only: use_cndv + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(temperature_type) , intent(in) :: temperature_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(dgvs_type) , intent(inout) :: dgvs_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: g,c,p !indices + integer :: fp !lake filter patch index + real(r8):: ws_flag !winter-summer solstice flag (0 or 1) + real(r8):: crit_onset_gdd !critical onset growing degree-day sum + real(r8):: crit_daylat !latitudinal light gradient in arctic-boreal + real(r8):: onset_thresh !flag onset threshold + real(r8):: soilt + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + dayl => grc%dayl , & ! Input: [real(r8) (:) ] daylength (s) + prev_dayl => grc%prev_dayl , & ! Input: [real(r8) (:) ] daylength from previous time step (s) + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + season_decid => pftcon%season_decid , & ! Input: binary flag for seasonal-deciduous leaf habit (0 or 1) +!KO + season_decid_temperate => pftcon%season_decid_temperate , & ! Input: binary flag for seasonal-deciduous temperate leaf habit (0 or 1) +!KO + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + soila10 => temperature_inst%soila10_patch , & ! Input: [real(r8) (:) ] + t_a5min => temperature_inst%t_a5min_patch , & ! input: [real(r8) (:) ] + snow_5day => waterdiagnosticbulk_inst%snow_5day_col , & ! input: [real(r8) (:) ] + + pftmayexist => dgvs_inst%pftmayexist_patch , & ! Output: [logical (:) ] exclude seasonal decid patches from tropics + + annavg_t2m => cnveg_state_inst%annavg_t2m_patch , & ! Input: [real(r8) (:) ] annual average 2m air temperature (K) + dormant_flag => cnveg_state_inst%dormant_flag_patch , & ! Output: [real(r8) (:) ] dormancy flag + days_active => cnveg_state_inst%days_active_patch , & ! Output: [real(r8) (:) ] number of days since last dormancy + onset_flag => cnveg_state_inst%onset_flag_patch , & ! Output: [real(r8) (:) ] onset flag + onset_counter => cnveg_state_inst%onset_counter_patch , & ! Output: [real(r8) (:) ] onset counter (seconds) + onset_gddflag => cnveg_state_inst%onset_gddflag_patch , & ! Output: [real(r8) (:) ] onset freeze flag + onset_gdd => cnveg_state_inst%onset_gdd_patch , & ! Output: [real(r8) (:) ] onset growing degree days + offset_flag => cnveg_state_inst%offset_flag_patch , & ! Output: [real(r8) (:) ] offset flag + offset_counter => cnveg_state_inst%offset_counter_patch , & ! Output: [real(r8) (:) ] offset counter (seconds) + bglfr => cnveg_state_inst%bglfr_patch , & ! Output: [real(r8) (:) ] background litterfall rate (1/s) + bgtr => cnveg_state_inst%bgtr_patch , & ! Output: [real(r8) (:) ] background transfer growth rate (1/s) + lgsf => cnveg_state_inst%lgsf_patch , & ! Output: [real(r8) (:) ] long growing season factor [0-1] + + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C storage + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C storage + livestemc_storage => cnveg_carbonstate_inst%livestemc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C storage + deadstemc_storage => cnveg_carbonstate_inst%deadstemc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C storage + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C storage + deadcrootc_storage => cnveg_carbonstate_inst%deadcrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C storage + gresp_storage => cnveg_carbonstate_inst%gresp_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) growth respiration storage + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) leaf C transfer + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) fine root C transfer + livestemc_xfer => cnveg_carbonstate_inst%livestemc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) live stem C transfer + deadstemc_xfer => cnveg_carbonstate_inst%deadstemc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) dead stem C transfer + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) live coarse root C transfer + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + + leafn_storage => cnveg_nitrogenstate_inst%leafn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N storage + frootn_storage => cnveg_nitrogenstate_inst%frootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N storage + livestemn_storage => cnveg_nitrogenstate_inst%livestemn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N storage + deadstemn_storage => cnveg_nitrogenstate_inst%deadstemn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N storage + livecrootn_storage => cnveg_nitrogenstate_inst%livecrootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N storage + deadcrootn_storage => cnveg_nitrogenstate_inst%deadcrootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N storage + leafn_xfer => cnveg_nitrogenstate_inst%leafn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) leaf N transfer + frootn_xfer => cnveg_nitrogenstate_inst%frootn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) fine root N transfer + livestemn_xfer => cnveg_nitrogenstate_inst%livestemn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) live stem N transfer + deadstemn_xfer => cnveg_nitrogenstate_inst%deadstemn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) dead stem N transfer + livecrootn_xfer => cnveg_nitrogenstate_inst%livecrootn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) live coarse root N transfer + deadcrootn_xfer => cnveg_nitrogenstate_inst%deadcrootn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) dead coarse root N transfer + + prev_leafc_to_litter => cnveg_carbonflux_inst%prev_leafc_to_litter_patch , & ! Output: [real(r8) (:) ] previous timestep leaf C litterfall flux (gC/m2/s) + prev_frootc_to_litter => cnveg_carbonflux_inst%prev_frootc_to_litter_patch , & ! Output: [real(r8) (:) ] previous timestep froot C litterfall flux (gC/m2/s) + leafc_xfer_to_leafc => cnveg_carbonflux_inst%leafc_xfer_to_leafc_patch , & ! Output: [real(r8) (:) ] + frootc_xfer_to_frootc => cnveg_carbonflux_inst%frootc_xfer_to_frootc_patch , & ! Output: [real(r8) (:) ] + livestemc_xfer_to_livestemc => cnveg_carbonflux_inst%livestemc_xfer_to_livestemc_patch , & ! Output: [real(r8) (:) ] + deadstemc_xfer_to_deadstemc => cnveg_carbonflux_inst%deadstemc_xfer_to_deadstemc_patch , & ! Output: [real(r8) (:) ] + livecrootc_xfer_to_livecrootc => cnveg_carbonflux_inst%livecrootc_xfer_to_livecrootc_patch , & ! Output: [real(r8) (:) ] + deadcrootc_xfer_to_deadcrootc => cnveg_carbonflux_inst%deadcrootc_xfer_to_deadcrootc_patch , & ! Output: [real(r8) (:) ] + leafc_storage_to_xfer => cnveg_carbonflux_inst%leafc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + frootc_storage_to_xfer => cnveg_carbonflux_inst%frootc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + livestemc_storage_to_xfer => cnveg_carbonflux_inst%livestemc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + deadstemc_storage_to_xfer => cnveg_carbonflux_inst%deadstemc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + livecrootc_storage_to_xfer => cnveg_carbonflux_inst%livecrootc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + deadcrootc_storage_to_xfer => cnveg_carbonflux_inst%deadcrootc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + gresp_storage_to_xfer => cnveg_carbonflux_inst%gresp_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + + leafn_xfer_to_leafn => cnveg_nitrogenflux_inst%leafn_xfer_to_leafn_patch , & ! Output: [real(r8) (:) ] + frootn_xfer_to_frootn => cnveg_nitrogenflux_inst%frootn_xfer_to_frootn_patch , & ! Output: [real(r8) (:) ] + livestemn_xfer_to_livestemn => cnveg_nitrogenflux_inst%livestemn_xfer_to_livestemn_patch , & ! Output: [real(r8) (:) ] + deadstemn_xfer_to_deadstemn => cnveg_nitrogenflux_inst%deadstemn_xfer_to_deadstemn_patch , & ! Output: [real(r8) (:) ] + livecrootn_xfer_to_livecrootn => cnveg_nitrogenflux_inst%livecrootn_xfer_to_livecrootn_patch , & ! Output: [real(r8) (:) ] + deadcrootn_xfer_to_deadcrootn => cnveg_nitrogenflux_inst%deadcrootn_xfer_to_deadcrootn_patch , & ! Output: [real(r8) (:) ] + leafn_storage_to_xfer => cnveg_nitrogenflux_inst%leafn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + frootn_storage_to_xfer => cnveg_nitrogenflux_inst%frootn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + livestemn_storage_to_xfer => cnveg_nitrogenflux_inst%livestemn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + deadstemn_storage_to_xfer => cnveg_nitrogenflux_inst%deadstemn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + livecrootn_storage_to_xfer => cnveg_nitrogenflux_inst%livecrootn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + deadcrootn_storage_to_xfer => cnveg_nitrogenflux_inst%deadcrootn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + ileafst_to_ileafxf_phc => cnveg_carbonflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phc => cnveg_carbonflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phc => cnveg_carbonflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phc => cnveg_carbonflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phc => cnveg_carbonflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phc => cnveg_carbonflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phc => cnveg_carbonflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phc => cnveg_carbonflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phc => cnveg_carbonflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phc => cnveg_carbonflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phc => cnveg_carbonflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phc => cnveg_carbonflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phc => cnveg_carbonflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phc => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phc => cnveg_carbonflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phc => cnveg_carbonflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phc => cnveg_carbonflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + igrain_to_iout_phc => cnveg_carbonflux_inst%igrain_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ileafst_to_ileafxf_phn => cnveg_nitrogenflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phn => cnveg_nitrogenflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phn => cnveg_nitrogenflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phn => cnveg_nitrogenflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phn => cnveg_nitrogenflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phn => cnveg_nitrogenflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phn => cnveg_nitrogenflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phn => cnveg_nitrogenflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phn => cnveg_nitrogenflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phn => cnveg_nitrogenflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phn => cnveg_nitrogenflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phn => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phn => cnveg_nitrogenflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phn => cnveg_nitrogenflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phn => cnveg_nitrogenflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + ileaf_to_iretransn_phn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to retranslocation pool + ilivestem_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to retranslocation pool + ilivecroot_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivecroot_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root pool to retranslocation pool + igrain_to_iout_phn => cnveg_nitrogenflux_inst%igrain_to_iout_ph & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ) + + ! start patch loop + + + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = patch%gridcell(p) + + if (season_decid(ivt(p)) == 1._r8) then + + ! set background litterfall rate, background transfer rate, and + ! long growing season factor to 0 for seasonal deciduous types + bglfr(p) = 0._r8 + bgtr(p) = 0._r8 + lgsf(p) = 0._r8 + + ! onset gdd sum from Biome-BGC, v4.1.2 + crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_t2m(p) - SHR_CONST_TKFRZ)) + + ! set flag for solstice period (winter->summer = 1, summer->winter = 0) + if (dayl(g) >= prev_dayl(g)) then + ws_flag = 1._r8 + else + ws_flag = 0._r8 + end if + + ! update offset_counter and test for the end of the offset period + if (offset_flag(p) == 1.0_r8) then + ! decrement counter for offset period + offset_counter(p) = offset_counter(p) - dt + + ! if this is the end of the offset_period, reset phenology + ! flags and indices + if (offset_counter(p) < dt/2._r8) then + ! this code block was originally handled by call cn_offset_cleanup(p) + ! inlined during vectorization + + offset_flag(p) = 0._r8 + offset_counter(p) = 0._r8 + dormant_flag(p) = 1._r8 + days_active(p) = 0._r8 + if (use_cndv) then + pftmayexist(p) = .true. + end if + + ! reset the previous timestep litterfall flux memory + prev_leafc_to_litter(p) = 0._r8 + prev_frootc_to_litter(p) = 0._r8 + end if + end if + + ! update onset_counter and test for the end of the onset period + if (onset_flag(p) == 1.0_r8) then + ! decrement counter for onset period + onset_counter(p) = onset_counter(p) - dt + + ! if this is the end of the onset period, reset phenology + ! flags and indices + if (onset_counter(p) < dt/2._r8) then + ! this code block was originally handled by call cn_onset_cleanup(p) + ! inlined during vectorization + + onset_flag(p) = 0.0_r8 + onset_counter(p) = 0.0_r8 + ! set all transfer growth rates to 0.0 + leafc_xfer_to_leafc(p) = 0.0_r8 + frootc_xfer_to_frootc(p) = 0.0_r8 + leafn_xfer_to_leafn(p) = 0.0_r8 + frootn_xfer_to_frootn(p) = 0.0_r8 + if (woody(ivt(p)) == 1.0_r8) then + livestemc_xfer_to_livestemc(p) = 0.0_r8 + deadstemc_xfer_to_deadstemc(p) = 0.0_r8 + livecrootc_xfer_to_livecrootc(p) = 0.0_r8 + deadcrootc_xfer_to_deadcrootc(p) = 0.0_r8 + livestemn_xfer_to_livestemn(p) = 0.0_r8 + deadstemn_xfer_to_deadstemn(p) = 0.0_r8 + livecrootn_xfer_to_livecrootn(p) = 0.0_r8 + deadcrootn_xfer_to_deadcrootn(p) = 0.0_r8 + end if + ! set transfer pools to 0.0 + leafc_xfer(p) = 0.0_r8 + leafn_xfer(p) = 0.0_r8 + frootc_xfer(p) = 0.0_r8 + frootn_xfer(p) = 0.0_r8 + if (woody(ivt(p)) == 1.0_r8) then + livestemc_xfer(p) = 0.0_r8 + livestemn_xfer(p) = 0.0_r8 + deadstemc_xfer(p) = 0.0_r8 + deadstemn_xfer(p) = 0.0_r8 + livecrootc_xfer(p) = 0.0_r8 + livecrootn_xfer(p) = 0.0_r8 + deadcrootc_xfer(p) = 0.0_r8 + deadcrootn_xfer(p) = 0.0_r8 + end if + end if + end if + + ! test for switching from dormant period to growth period + if (dormant_flag(p) == 1.0_r8) then + onset_thresh = 0.0_r8 + ! Test to turn on growing degree-day sum, if off. + ! switch on the growing degree day sum on the winter solstice + + if (onset_gddflag(p) == 0._r8 .and. ws_flag == 1._r8) then + onset_gddflag(p) = 1._r8 + onset_gdd(p) = 0._r8 + end if + + ! Test to turn off growing degree-day sum, if on. + ! This test resets the growing degree day sum if it gets past + ! the summer solstice without reaching the threshold value. + ! In that case, it will take until the next winter solstice + ! before the growing degree-day summation starts again. + + if (onset_gddflag(p) == 1._r8 .and. ws_flag == 0._r8) then + onset_gddflag(p) = 0._r8 + onset_gdd(p) = 0._r8 + end if + + ! if the gdd flag is set, and if the soil is above freezing + ! then accumulate growing degree days for onset trigger + + soilt = t_soisno(c, phenology_soil_layer) + if (onset_gddflag(p) == 1.0_r8 .and. soilt > SHR_CONST_TKFRZ) then + onset_gdd(p) = onset_gdd(p) + (soilt-SHR_CONST_TKFRZ)*fracday + end if +!KO !separate into Arctic boreal and lower latitudes +!KO if (onset_gdd(p) > crit_onset_gdd .and. abs(grc%latdeg(g))<45.0_r8) then +!KO onset_thresh=1.0_r8 +!KO else if (onset_gddflag(p) == 1.0_r8 .and. soila10(p) > SHR_CONST_TKFRZ .and. & +!KO t_a5min(p) > SHR_CONST_TKFRZ .and. ws_flag==1.0_r8 .and. & +!KO dayl(g)>(crit_dayl/2.0_r8) .and. snow_5day(c)<0.1_r8) then +!KO onset_thresh=1.0_r8 +!KO end if +!KO + if ( onset_thresh_depends_on_veg ) then + ! separate into non-arctic seasonally deciduous pfts (temperate broadleaf deciduous + ! tree) and arctic/boreal seasonally deciduous pfts (boreal needleleaf deciduous tree, + ! boreal broadleaf deciduous tree, boreal broadleaf deciduous shrub, C3 arctic grass) + if (onset_gdd(p) > crit_onset_gdd .and. season_decid_temperate(ivt(p)) == 1) then + onset_thresh=1.0_r8 + else if (season_decid_temperate(ivt(p)) == 0 .and. onset_gddflag(p) == 1.0_r8 .and. & + soila10(p) > SHR_CONST_TKFRZ .and. & + t_a5min(p) > SHR_CONST_TKFRZ .and. ws_flag==1.0_r8 .and. & + dayl(g)>(crit_dayl/2.0_r8) .and. snow_5day(c)<0.1_r8) then + onset_thresh=1.0_r8 + end if + else + ! set onset_flag if critical growing degree-day sum is exceeded + if (onset_gdd(p) > crit_onset_gdd) onset_thresh = 1.0_r8 + end if +!KO + ! If onset is being triggered + if (onset_thresh == 1.0_r8) then + onset_flag(p) = 1.0_r8 + dormant_flag(p) = 0.0_r8 + onset_gddflag(p) = 0.0_r8 + onset_gdd(p) = 0.0_r8 + onset_thresh = 0.0_r8 + onset_counter(p) = ndays_on * secspday + + ! move all the storage pools into transfer pools, + ! where they will be transfered to displayed growth over the onset period. + ! this code was originally handled with call cn_storage_to_xfer(p) + ! inlined during vectorization + + ! set carbon fluxes for shifting storage pools to transfer pools + if(use_matrixcn)then +! leafc_storage_to_xfer(p) = leafc_storage(p) * matrix_update_phc(p,ileafst_to_ileafxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! frootc_storage_to_xfer(p) = frootc_storage(p) * matrix_update_phc(p,ifrootst_to_ifrootxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! +! if (woody(ivt(p)) == 1.0_r8) then +! livestemc_storage_to_xfer(p) = livestemc_storage(p) * matrix_update_phc(p,ilivestemst_to_ilivestemxf_phc ,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadstemc_storage_to_xfer(p) = deadstemc_storage(p) * matrix_update_phc(p,ideadstemst_to_ideadstemxf_phc ,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! livecrootc_storage_to_xfer(p) = livecrootc_storage(p) * matrix_update_phc(p,ilivecrootst_to_ilivecrootxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadcrootc_storage_to_xfer(p) = deadcrootc_storage(p) * matrix_update_phc(p,ideadcrootst_to_ideadcrootxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! gresp_storage_to_xfer(p) = fstor2tran * gresp_storage(p)/dt +! end if +! leafn_storage_to_xfer(p) = leafn_storage(p) * matrix_update_phn(p,ileafst_to_ileafxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! frootn_storage_to_xfer(p) = frootn_storage(p) * matrix_update_phn(p,ifrootst_to_ifrootxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! +! if (woody(ivt(p)) == 1.0_r8) then +! livestemn_storage_to_xfer(p) = livestemn_storage(p) * matrix_update_phn(p,ilivestemst_to_ilivestemxf_phn ,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadstemn_storage_to_xfer(p) = deadstemn_storage(p) * matrix_update_phn(p,ideadstemst_to_ideadstemxf_phn ,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! livecrootn_storage_to_xfer(p) = livecrootn_storage(p) * matrix_update_phn(p,ilivecrootst_to_ilivecrootxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadcrootn_storage_to_xfer(p) = deadcrootn_storage(p) * matrix_update_phn(p,ideadcrootst_to_ideadcrootxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + leafc_storage_to_xfer(p) = fstor2tran * leafc_storage(p)/dt + frootc_storage_to_xfer(p) = fstor2tran * frootc_storage(p)/dt + if (woody(ivt(p)) == 1.0_r8) then + livestemc_storage_to_xfer(p) = fstor2tran * livestemc_storage(p)/dt + deadstemc_storage_to_xfer(p) = fstor2tran * deadstemc_storage(p)/dt + livecrootc_storage_to_xfer(p) = fstor2tran * livecrootc_storage(p)/dt + deadcrootc_storage_to_xfer(p) = fstor2tran * deadcrootc_storage(p)/dt + gresp_storage_to_xfer(p) = fstor2tran * gresp_storage(p)/dt + end if + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer(p) = fstor2tran * leafn_storage(p)/dt + frootn_storage_to_xfer(p) = fstor2tran * frootn_storage(p)/dt + if (woody(ivt(p)) == 1.0_r8) then + livestemn_storage_to_xfer(p) = fstor2tran * livestemn_storage(p)/dt + deadstemn_storage_to_xfer(p) = fstor2tran * deadstemn_storage(p)/dt + livecrootn_storage_to_xfer(p) = fstor2tran * livecrootn_storage(p)/dt + deadcrootn_storage_to_xfer(p) = fstor2tran * deadcrootn_storage(p)/dt + end if + end if ! use_matrixcn + end if + + ! test for switching from growth period to offset period + else if (offset_flag(p) == 0.0_r8) then + if (use_cndv) then + ! If days_active > 355, then remove patch in + ! CNDVEstablishment at the end of the year. + ! days_active > 355 is a symptom of seasonal decid. patches occurring in + ! gridcells where dayl never drops below crit_dayl. + ! This results in TLAI>1e4 in a few gridcells. + days_active(p) = days_active(p) + fracday + if (days_active(p) > 355._r8) pftmayexist(p) = .false. + end if + + if ( min_crtical_dayl_depends_on_lat )then + ! use 15 hr (54000 min) at ~65N from eitel 2019, to ~11hours in temperate regions + ! 15hr-11hr/(65N-45N)=linear slope = 720 min/latitude + crit_daylat=54000-720*(65-abs(grc%latdeg(g))) + if (crit_daylat < crit_dayl) then + crit_daylat = crit_dayl !maintain previous offset from White 2001 as minimum + end if + else + crit_daylat = crit_dayl + end if + + ! only begin to test for offset daylength once past the summer sol + if (ws_flag == 0._r8 .and. dayl(g) < crit_daylat) then + offset_flag(p) = 1._r8 + offset_counter(p) = ndays_off * secspday + prev_leafc_to_litter(p) = 0._r8 + prev_frootc_to_litter(p) = 0._r8 + end if + end if + + end if ! end if seasonal deciduous + + end do ! end of patch loop + + end associate + + end subroutine CNSeasonDecidPhenology + + !----------------------------------------------------------------------- + subroutine CNStressDecidPhenology (num_soilp, filter_soilp , & + soilstate_inst, temperature_inst, atm2lnd_inst, wateratm2lndbulk_inst, cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, & + cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! This routine handles phenology for vegetation types, such as grasses and + ! tropical drought deciduous trees, that respond to cold and drought stress + ! signals and that can have multiple growing seasons in a given year. + ! This routine allows for the possibility that leaves might persist year-round + ! in the absence of a suitable stress trigger, by switching to an essentially + ! evergreen habit, but maintaining a deciduous leaf longevity, while waiting + ! for the next stress trigger. This is in contrast to the seasonal deciduous + ! algorithm (for temperate deciduous trees) that forces a single growing season + ! per year. + ! + ! !USES: + use clm_time_manager , only : get_days_per_year + use CNSharedParamsMod, only : use_fun + use clm_varcon , only : secspday + use shr_const_mod , only : SHR_CONST_TKFRZ, SHR_CONST_PI + use CNSharedParamsMod, only : CNParamsShareInst + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(wateratm2lndbulk_type) , intent(in) :: wateratm2lndbulk_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + real(r8),parameter :: secspqtrday = secspday / 4 ! seconds per quarter day + integer :: g,c,p ! indices + integer :: fp ! lake filter patch index + real(r8):: dayspyr ! days per year + real(r8):: crit_onset_gdd ! degree days for onset trigger + real(r8):: soilt ! temperature of top soil layer + real(r8):: psi ! water stress of top soil layer + real(r8):: rain_threshold ! rain threshold for leaf on [mm] + logical :: additional_onset_condition ! additional condition for leaf onset + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + dayl => grc%dayl , & ! Input: [real(r8) (:) ] daylength (s) + + prec10 => wateratm2lndbulk_inst%prec10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of tot. precipitation + leaf_long => pftcon%leaf_long , & ! Input: leaf longevity (yrs) + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + stress_decid => pftcon%stress_decid , & ! Input: binary flag for stress-deciduous leaf habit (0 or 1) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: fine root C:N (gC/gN) + + soilpsi => soilstate_inst%soilpsi_col , & ! Input: [real(r8) (:,:) ] soil water potential in each soil layer (MPa) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + dormant_flag => cnveg_state_inst%dormant_flag_patch , & ! Output: [real(r8) (:) ] dormancy flag + days_active => cnveg_state_inst%days_active_patch , & ! Output: [real(r8) (:) ] number of days since last dormancy + onset_flag => cnveg_state_inst%onset_flag_patch , & ! Output: [real(r8) (:) ] onset flag + onset_counter => cnveg_state_inst%onset_counter_patch , & ! Output: [real(r8) (:) ] onset counter (seconds) + onset_gddflag => cnveg_state_inst%onset_gddflag_patch , & ! Output: [real(r8) (:) ] onset freeze flag + onset_fdd => cnveg_state_inst%onset_fdd_patch , & ! Output: [real(r8) (:) ] onset freezing degree days counter + onset_gdd => cnveg_state_inst%onset_gdd_patch , & ! Output: [real(r8) (:) ] onset growing degree days + onset_swi => cnveg_state_inst%onset_swi_patch , & ! Output: [real(r8) (:) ] onset soil water index + offset_flag => cnveg_state_inst%offset_flag_patch , & ! Output: [real(r8) (:) ] offset flag + offset_counter => cnveg_state_inst%offset_counter_patch , & ! Output: [real(r8) (:) ] offset counter (seconds) + offset_fdd => cnveg_state_inst%offset_fdd_patch , & ! Output: [real(r8) (:) ] offset freezing degree days counter + offset_swi => cnveg_state_inst%offset_swi_patch , & ! Output: [real(r8) (:) ] offset soil water index + lgsf => cnveg_state_inst%lgsf_patch , & ! Output: [real(r8) (:) ] long growing season factor [0-1] + bglfr => cnveg_state_inst%bglfr_patch , & ! Output: [real(r8) (:) ] background litterfall rate (1/s) + bgtr => cnveg_state_inst%bgtr_patch , & ! Output: [real(r8) (:) ] background transfer growth rate (1/s) + annavg_t2m => cnveg_state_inst%annavg_t2m_patch , & ! Output: [real(r8) (:) ] annual average 2m air temperature (K) + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C + leafc_storage => cnveg_carbonstate_inst%leafc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C storage + frootc_storage => cnveg_carbonstate_inst%frootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C storage + livestemc_storage => cnveg_carbonstate_inst%livestemc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C storage + deadstemc_storage => cnveg_carbonstate_inst%deadstemc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C storage + livecrootc_storage => cnveg_carbonstate_inst%livecrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C storage + deadcrootc_storage => cnveg_carbonstate_inst%deadcrootc_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C storage + gresp_storage => cnveg_carbonstate_inst%gresp_storage_patch , & ! Input: [real(r8) (:) ] (gC/m2) growth respiration storage + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) leaf C transfer + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) fine root C transfer + livestemc_xfer => cnveg_carbonstate_inst%livestemc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) live stem C transfer + deadstemc_xfer => cnveg_carbonstate_inst%deadstemc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) dead stem C transfer + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) live coarse root C transfer + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + leafn_storage => cnveg_nitrogenstate_inst%leafn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N storage + frootn_storage => cnveg_nitrogenstate_inst%frootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N storage + livestemn_storage => cnveg_nitrogenstate_inst%livestemn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N storage + deadstemn_storage => cnveg_nitrogenstate_inst%deadstemn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N storage + livecrootn_storage => cnveg_nitrogenstate_inst%livecrootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N storage + deadcrootn_storage => cnveg_nitrogenstate_inst%deadcrootn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N storage + leafn_xfer => cnveg_nitrogenstate_inst%leafn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) leaf N transfer + frootn_xfer => cnveg_nitrogenstate_inst%frootn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) fine root N transfer + livestemn_xfer => cnveg_nitrogenstate_inst%livestemn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) live stem N transfer + deadstemn_xfer => cnveg_nitrogenstate_inst%deadstemn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) dead stem N transfer + livecrootn_xfer => cnveg_nitrogenstate_inst%livecrootn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) live coarse root N transfer + deadcrootn_xfer => cnveg_nitrogenstate_inst%deadcrootn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) dead coarse root N transfer + + prev_leafc_to_litter => cnveg_carbonflux_inst%prev_leafc_to_litter_patch , & ! Output: [real(r8) (:) ] previous timestep leaf C litterfall flux (gC/m2/s) + prev_frootc_to_litter => cnveg_carbonflux_inst%prev_frootc_to_litter_patch , & ! Output: [real(r8) (:) ] previous timestep froot C litterfall flux (gC/m2/s) + leafc_xfer_to_leafc => cnveg_carbonflux_inst%leafc_xfer_to_leafc_patch , & ! Output: [real(r8) (:) ] + frootc_xfer_to_frootc => cnveg_carbonflux_inst%frootc_xfer_to_frootc_patch , & ! Output: [real(r8) (:) ] + livestemc_xfer_to_livestemc => cnveg_carbonflux_inst%livestemc_xfer_to_livestemc_patch , & ! Output: [real(r8) (:) ] + deadstemc_xfer_to_deadstemc => cnveg_carbonflux_inst%deadstemc_xfer_to_deadstemc_patch , & ! Output: [real(r8) (:) ] + livecrootc_xfer_to_livecrootc => cnveg_carbonflux_inst%livecrootc_xfer_to_livecrootc_patch , & ! Output: [real(r8) (:) ] + deadcrootc_xfer_to_deadcrootc => cnveg_carbonflux_inst%deadcrootc_xfer_to_deadcrootc_patch , & ! Output: [real(r8) (:) ] + leafc_storage_to_xfer => cnveg_carbonflux_inst%leafc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + frootc_storage_to_xfer => cnveg_carbonflux_inst%frootc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + livestemc_storage_to_xfer => cnveg_carbonflux_inst%livestemc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + deadstemc_storage_to_xfer => cnveg_carbonflux_inst%deadstemc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + livecrootc_storage_to_xfer => cnveg_carbonflux_inst%livecrootc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + deadcrootc_storage_to_xfer => cnveg_carbonflux_inst%deadcrootc_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + gresp_storage_to_xfer => cnveg_carbonflux_inst%gresp_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + + leafn_xfer_to_leafn => cnveg_nitrogenflux_inst%leafn_xfer_to_leafn_patch , & ! Output: [real(r8) (:) ] + frootn_xfer_to_frootn => cnveg_nitrogenflux_inst%frootn_xfer_to_frootn_patch , & ! Output: [real(r8) (:) ] + livestemn_xfer_to_livestemn => cnveg_nitrogenflux_inst%livestemn_xfer_to_livestemn_patch , & ! Output: [real(r8) (:) ] + deadstemn_xfer_to_deadstemn => cnveg_nitrogenflux_inst%deadstemn_xfer_to_deadstemn_patch , & ! Output: [real(r8) (:) ] + livecrootn_xfer_to_livecrootn => cnveg_nitrogenflux_inst%livecrootn_xfer_to_livecrootn_patch , & ! Output: [real(r8) (:) ] + deadcrootn_xfer_to_deadcrootn => cnveg_nitrogenflux_inst%deadcrootn_xfer_to_deadcrootn_patch , & ! Output: [real(r8) (:) ] + leafn_storage_to_xfer => cnveg_nitrogenflux_inst%leafn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + frootn_storage_to_xfer => cnveg_nitrogenflux_inst%frootn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + livestemn_storage_to_xfer => cnveg_nitrogenflux_inst%livestemn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + deadstemn_storage_to_xfer => cnveg_nitrogenflux_inst%deadstemn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + livecrootn_storage_to_xfer => cnveg_nitrogenflux_inst%livecrootn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + deadcrootn_storage_to_xfer => cnveg_nitrogenflux_inst%deadcrootn_storage_to_xfer_patch , & ! Output: [real(r8) (:) ] + ileafst_to_ileafxf_phc => cnveg_carbonflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phc => cnveg_carbonflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phc => cnveg_carbonflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phc => cnveg_carbonflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phc => cnveg_carbonflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phc => cnveg_carbonflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phc => cnveg_carbonflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phc => cnveg_carbonflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phc => cnveg_carbonflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phc => cnveg_carbonflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phc => cnveg_carbonflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phc => cnveg_carbonflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phc => cnveg_carbonflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phc => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phc => cnveg_carbonflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phc => cnveg_carbonflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phc => cnveg_carbonflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + igrain_to_iout_phc => cnveg_carbonflux_inst%igrain_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ileafst_to_ileafxf_phn => cnveg_nitrogenflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phn => cnveg_nitrogenflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phn => cnveg_nitrogenflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phn => cnveg_nitrogenflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phn => cnveg_nitrogenflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phn => cnveg_nitrogenflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phn => cnveg_nitrogenflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phn => cnveg_nitrogenflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phn => cnveg_nitrogenflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phn => cnveg_nitrogenflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phn => cnveg_nitrogenflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phn => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phn => cnveg_nitrogenflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phn => cnveg_nitrogenflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phn => cnveg_nitrogenflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + ileaf_to_iretransn_phn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to retranslocation pool + ilivestem_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to retranslocation pool + ilivecroot_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivecroot_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root pool to retranslocation pool + igrain_to_iout_phn => cnveg_nitrogenflux_inst%igrain_to_iout_ph & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ) + + ! set time steps + dayspyr = get_days_per_year() + + ! specify rain threshold for leaf onset + rain_threshold = 20._r8 + + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = patch%gridcell(p) + + ! jkolassa Jun 2024: make water stress threshold depedent on the wilting point + ! at a given location instead of using global constant value + ! (following similar implementation in older versions of + ! Catchment-CN) + soilpsi_on = soilstate_inst%psiwilt_col(c,1) + soilpsi_off = soilstate_inst%psiwilt_col(c,1) + + if (stress_decid(ivt(p)) == 1._r8) then + soilt = t_soisno(c, phenology_soil_layer) + psi = soilpsi(c, phenology_soil_layer) + + ! onset gdd sum from Biome-BGC, v4.1.2 + crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_t2m(p) - SHR_CONST_TKFRZ)) + + + ! update offset_counter and test for the end of the offset period + if (offset_flag(p) == 1._r8) then + ! decrement counter for offset period + offset_counter(p) = offset_counter(p) - dt + + ! if this is the end of the offset_period, reset phenology + ! flags and indices + if (offset_counter(p) < dt/2._r8) then + ! this code block was originally handled by call cn_offset_cleanup(p) + ! inlined during vectorization + offset_flag(p) = 0._r8 + offset_counter(p) = 0._r8 + dormant_flag(p) = 1._r8 + days_active(p) = 0._r8 + + ! reset the previous timestep litterfall flux memory + prev_leafc_to_litter(p) = 0._r8 + prev_frootc_to_litter(p) = 0._r8 + end if + end if + + ! update onset_counter and test for the end of the onset period + if (onset_flag(p) == 1.0_r8) then + ! decrement counter for onset period + onset_counter(p) = onset_counter(p) - dt + + ! if this is the end of the onset period, reset phenology + ! flags and indices + if (onset_counter(p) < dt/2._r8) then + ! this code block was originally handled by call cn_onset_cleanup(p) + ! inlined during vectorization + onset_flag(p) = 0._r8 + onset_counter(p) = 0._r8 + ! set all transfer growth rates to 0.0 + leafc_xfer_to_leafc(p) = 0._r8 + frootc_xfer_to_frootc(p) = 0._r8 + leafn_xfer_to_leafn(p) = 0._r8 + frootn_xfer_to_frootn(p) = 0._r8 + if (woody(ivt(p)) == 1.0_r8) then + livestemc_xfer_to_livestemc(p) = 0._r8 + deadstemc_xfer_to_deadstemc(p) = 0._r8 + livecrootc_xfer_to_livecrootc(p) = 0._r8 + deadcrootc_xfer_to_deadcrootc(p) = 0._r8 + livestemn_xfer_to_livestemn(p) = 0._r8 + deadstemn_xfer_to_deadstemn(p) = 0._r8 + livecrootn_xfer_to_livecrootn(p) = 0._r8 + deadcrootn_xfer_to_deadcrootn(p) = 0._r8 + end if + ! set transfer pools to 0.0 + leafc_xfer(p) = 0._r8 + leafn_xfer(p) = 0._r8 + frootc_xfer(p) = 0._r8 + frootn_xfer(p) = 0._r8 + if (woody(ivt(p)) == 1.0_r8) then + livestemc_xfer(p) = 0._r8 + livestemn_xfer(p) = 0._r8 + deadstemc_xfer(p) = 0._r8 + deadstemn_xfer(p) = 0._r8 + livecrootc_xfer(p) = 0._r8 + livecrootn_xfer(p) = 0._r8 + deadcrootc_xfer(p) = 0._r8 + deadcrootn_xfer(p) = 0._r8 + end if + end if + end if + + ! test for switching from dormant period to growth period + if (dormant_flag(p) == 1._r8) then + + ! keep track of the number of freezing degree days in this + ! dormancy period (only if the freeze flag has not previously been set + ! for this dormancy period + + if (onset_gddflag(p) == 0._r8 .and. soilt < SHR_CONST_TKFRZ) onset_fdd(p) = onset_fdd(p) + fracday + + ! if the number of freezing degree days exceeds a critical value, + ! then onset will require both wet soils and a critical soil + ! temperature sum. If this case is triggered, reset any previously + ! accumulated value in onset_swi, so that onset now depends on + ! the accumulated soil water index following the freeze trigger + + if (onset_fdd(p) > crit_onset_fdd) then + onset_gddflag(p) = 1._r8 + onset_fdd(p) = 0._r8 + onset_swi(p) = 0._r8 + end if + + ! if the freeze flag is set, and if the soil is above freezing + ! then accumulate growing degree days for onset trigger + + if (onset_gddflag(p) == 1._r8 .and. soilt > SHR_CONST_TKFRZ) then + onset_gdd(p) = onset_gdd(p) + (soilt-SHR_CONST_TKFRZ)*fracday + end if + + ! if soils are wet, accumulate soil water index for onset trigger + additional_onset_condition = .true. + if(CNParamsShareInst%constrain_stress_deciduous_onset) then + ! if additional constraint condition not met, set to false + if ((prec10(p) * (3600.0_r8*10.0_r8*24.0_r8)) < rain_threshold) then + additional_onset_condition = .false. + endif + endif + + if (psi >= soilpsi_on) then + onset_swi(p) = onset_swi(p) + fracday + endif + + ! if critical soil water index is exceeded, set onset_flag, and + ! then test for soil temperature criteria + + ! Adding in Kyla's rainfall trigger when fun on. RF. prec10 (mm/s) needs to be higher than 8mm over 10 days. + + if (onset_swi(p) > crit_onset_swi.and. additional_onset_condition) then + onset_flag(p) = 1._r8 + + ! only check soil temperature criteria if freeze flag set since + ! beginning of last dormancy. If freeze flag set and growing + ! degree day sum (since freeze trigger) is lower than critical + ! value, then override the onset_flag set from soil water. + + if (onset_gddflag(p) == 1._r8 .and. onset_gdd(p) < crit_onset_gdd) onset_flag(p) = 0._r8 + end if + + ! only allow onset if dayl > 6hrs + if (onset_flag(p) == 1._r8 .and. dayl(g) <= secspqtrday) then + onset_flag(p) = 0._r8 + end if + + ! if this is the beginning of the onset period + ! then reset the phenology flags and indices + + if (onset_flag(p) == 1._r8) then + dormant_flag(p) = 0._r8 + days_active(p) = 0._r8 + onset_gddflag(p) = 0._r8 + onset_fdd(p) = 0._r8 + onset_gdd(p) = 0._r8 + onset_swi(p) = 0._r8 + onset_counter(p) = ndays_on * secspday + + ! call subroutine to move all the storage pools into transfer pools, + ! where they will be transfered to displayed growth over the onset period. + ! this code was originally handled with call cn_storage_to_xfer(p) + ! inlined during vectorization + + ! set carbon fluxes for shifting storage pools to transfer pools + if (use_matrixcn) then +! leafc_storage_to_xfer(p) = leafc_storage(p) * matrix_update_phc(p,ileafst_to_ileafxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! frootc_storage_to_xfer(p) = frootc_storage(p) * matrix_update_phc(p,ifrootst_to_ifrootxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! if (woody(ivt(p)) == 1.0_r8) then +! livestemc_storage_to_xfer(p) = livestemc_storage(p) * matrix_update_phc(p,ilivestemst_to_ilivestemxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadstemc_storage_to_xfer(p) = deadstemc_storage(p) * matrix_update_phc(p,ideadstemst_to_ideadstemxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! livecrootc_storage_to_xfer(p) = livecrootc_storage(p) * matrix_update_phc(p,ilivecrootst_to_ilivecrootxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadcrootc_storage_to_xfer(p) = deadcrootc_storage(p) * matrix_update_phc(p,ideadcrootst_to_ideadcrootxf_phc,fstor2tran/dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! end if +! +! leafn_storage_to_xfer(p) = leafn_storage(p) * matrix_update_phn(p,ileafst_to_ileafxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! frootn_storage_to_xfer(p) = frootn_storage(p) * matrix_update_phn(p,ifrootst_to_ifrootxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! if (woody(ivt(p)) == 1.0_r8) then +! livestemn_storage_to_xfer(p) = livestemn_storage(p) * matrix_update_phn(p,ilivestemst_to_ilivestemxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadstemn_storage_to_xfer(p) = deadstemn_storage(p) * matrix_update_phn(p,ideadstemst_to_ideadstemxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! livecrootn_storage_to_xfer(p) = livecrootn_storage(p) * matrix_update_phn(p,ilivecrootst_to_ilivecrootxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadcrootn_storage_to_xfer(p) = deadcrootn_storage(p) * matrix_update_phn(p,ideadcrootst_to_ideadcrootxf_phn,fstor2tran/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + leafc_storage_to_xfer(p) = fstor2tran * leafc_storage(p)/dt + frootc_storage_to_xfer(p) = fstor2tran * frootc_storage(p)/dt + if (woody(ivt(p)) == 1.0_r8) then + livestemc_storage_to_xfer(p) = fstor2tran * livestemc_storage(p)/dt + deadstemc_storage_to_xfer(p) = fstor2tran * deadstemc_storage(p)/dt + livecrootc_storage_to_xfer(p) = fstor2tran * livecrootc_storage(p)/dt + deadcrootc_storage_to_xfer(p) = fstor2tran * deadcrootc_storage(p)/dt + gresp_storage_to_xfer(p) = fstor2tran * gresp_storage(p)/dt + end if + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer(p) = fstor2tran * leafn_storage(p)/dt + frootn_storage_to_xfer(p) = fstor2tran * frootn_storage(p)/dt + if (woody(ivt(p)) == 1.0_r8) then + livestemn_storage_to_xfer(p) = fstor2tran * livestemn_storage(p)/dt + deadstemn_storage_to_xfer(p) = fstor2tran * deadstemn_storage(p)/dt + livecrootn_storage_to_xfer(p) = fstor2tran * livecrootn_storage(p)/dt + deadcrootn_storage_to_xfer(p) = fstor2tran * deadcrootn_storage(p)/dt + end if + end if + end if + + ! test for switching from growth period to offset period + else if (offset_flag(p) == 0._r8) then + + ! if soil water potential lower than critical value, accumulate + ! as stress in offset soil water index + + if (psi <= soilpsi_off) then + offset_swi(p) = offset_swi(p) + fracday + + ! if the offset soil water index exceeds critical value, and + ! if this is not the middle of a previously initiated onset period, + ! then set flag to start the offset period and reset index variables + + if (offset_swi(p) >= crit_offset_swi .and. onset_flag(p) == 0._r8) offset_flag(p) = 1._r8 + + ! if soil water potential higher than critical value, reduce the + ! offset water stress index. By this mechanism, there must be a + ! sustained period of water stress to initiate offset. + + else if (psi >= soilpsi_on) then + offset_swi(p) = offset_swi(p) - fracday + offset_swi(p) = max(offset_swi(p),0._r8) + end if + + ! decrease freezing day accumulator for warm soil + if (offset_fdd(p) > 0._r8 .and. soilt > SHR_CONST_TKFRZ) then + offset_fdd(p) = offset_fdd(p) - fracday + offset_fdd(p) = max(0._r8, offset_fdd(p)) + end if + + ! increase freezing day accumulator for cold soil + if (soilt <= SHR_CONST_TKFRZ) then + offset_fdd(p) = offset_fdd(p) + fracday + + ! if freezing degree day sum is greater than critical value, initiate offset + if (offset_fdd(p) > crit_offset_fdd .and. onset_flag(p) == 0._r8) offset_flag(p) = 1._r8 + end if + + ! force offset if daylength is < 6 hrs + if (dayl(g) <= secspqtrday) then + offset_flag(p) = 1._r8 + end if + + ! if this is the beginning of the offset period + ! then reset flags and indices + if (offset_flag(p) == 1._r8) then + offset_fdd(p) = 0._r8 + offset_swi(p) = 0._r8 + offset_counter(p) = ndays_off * secspday + prev_leafc_to_litter(p) = 0._r8 + prev_frootc_to_litter(p) = 0._r8 + end if + end if + + ! keep track of number of days since last dormancy for control on + ! fraction of new growth to send to storage for next growing season + + if (dormant_flag(p) == 0.0_r8) then + days_active(p) = days_active(p) + fracday + end if + + ! calculate long growing season factor (lgsf) + ! only begin to calculate a lgsf greater than 0.0 once the number + ! of days active exceeds days/year. + lgsf(p) = max(min(3.0_r8*(days_active(p)-leaf_long(ivt(p))*dayspyr )/dayspyr, 1._r8),0._r8) + ! RosieF. 5 Nov 2015. Changed this such that the increase in leaf turnover is faster after + ! trees enter the 'fake evergreen' state. Otherwise, they have a whole year of + ! cheating, with less litterfall than they should have, resulting in very high LAI. + ! Further, the 'fake evergreen' state (where lgsf>0) is entered at the end of a single leaf lifespan + ! and not a whole year. The '3' is arbitrary, given that this entire system is quite abstract. + + + ! set background litterfall rate, when not in the phenological offset period + if (offset_flag(p) == 1._r8) then + bglfr(p) = 0._r8 + else + ! calculate the background litterfall rate (bglfr) + ! in units 1/s, based on leaf longevity (yrs) and correction for long growing season + + bglfr(p) = (1._r8/(leaf_long(ivt(p))*dayspyr*secspday))*lgsf(p) + end if + + ! set background transfer rate when active but not in the phenological onset period + if (onset_flag(p) == 1._r8) then + bgtr(p) = 0._r8 + else + ! the background transfer rate is calculated as the rate that would result + ! in complete turnover of the storage pools in one year at steady state, + ! once lgsf has reached 1.0 (after 730 days active). + + bgtr(p) = (1._r8/(dayspyr*secspday))*lgsf(p) + + ! set carbon fluxes for shifting storage pools to transfer pools + + ! reduced the amount of stored carbon flowing to display pool by only counting the delta + ! between leafc and leafc_store in the flux. RosieF, Nov5 2015. + leafc_storage_to_xfer(p) = max(0.0_r8,(leafc_storage(p)-leafc(p))) * bgtr(p) + frootc_storage_to_xfer(p) = max(0.0_r8,(frootc_storage(p)-frootc(p))) * bgtr(p) + if (use_matrixcn) then +! if(leafc_storage(p) .gt. 0)then +! leafc_storage_to_xfer(p) = leafc_storage(p) * matrix_update_phc(p,ileafst_to_ileafxf_phc,& +! leafc_storage_to_xfer(p) / leafc_storage(p), dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! leafc_storage_to_xfer(p) = 0 +! end if +! if(frootc_storage(p) .gt. 0)then +! frootc_storage_to_xfer(p) = frootc_storage(p) * matrix_update_phc(p,ifrootst_to_ifrootxf_phc,& +! frootc_storage_to_xfer(p) / frootc_storage(p), dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! frootc_storage_to_xfer(p) = 0 +! end if +! if (woody(ivt(p)) == 1.0_r8) then +! livestemc_storage_to_xfer(p) = livestemc_storage(p) * matrix_update_phc(p,ilivestemst_to_ilivestemxf_phc ,bgtr(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadstemc_storage_to_xfer(p) = deadstemc_storage(p) * matrix_update_phc(p,ideadstemst_to_ideadstemxf_phc ,bgtr(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! livecrootc_storage_to_xfer(p) = livecrootc_storage(p) * matrix_update_phc(p,ilivecrootst_to_ilivecrootxf_phc,bgtr(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadcrootc_storage_to_xfer(p) = deadcrootc_storage(p) * matrix_update_phc(p,ideadcrootst_to_ideadcrootxf_phc,bgtr(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + if (woody(ivt(p)) == 1.0_r8) then + livestemc_storage_to_xfer(p) = livestemc_storage(p) * bgtr(p) + deadstemc_storage_to_xfer(p) = deadstemc_storage(p) * bgtr(p) + livecrootc_storage_to_xfer(p) = livecrootc_storage(p) * bgtr(p) + deadcrootc_storage_to_xfer(p) = deadcrootc_storage(p) * bgtr(p) + gresp_storage_to_xfer(p) = gresp_storage(p) * bgtr(p) + end if + end if !use_matrixcn + + ! set nitrogen fluxes for shifting storage pools to transfer pools + if (use_matrixcn) then +! leafn_storage_to_xfer(p) = leafn_storage(p) * matrix_update_phn(p,ileafst_to_ileafxf_phn,bgtr(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! frootn_storage_to_xfer(p) = frootn_storage(p) * matrix_update_phn(p,ifrootst_to_ifrootxf_phn,bgtr(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! if (woody(ivt(p)) == 1.0_r8) then +! livestemn_storage_to_xfer(p) = livestemn_storage(p) * matrix_update_phn(p,ilivestemst_to_ilivestemxf_phn,bgtr(p) ,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadstemn_storage_to_xfer(p) = deadstemn_storage(p) * matrix_update_phn(p,ideadstemst_to_ideadstemxf_phn,bgtr(p) ,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! livecrootn_storage_to_xfer(p) = livecrootn_storage(p) * matrix_update_phn(p,ilivecrootst_to_ilivecrootxf_phn,bgtr(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadcrootn_storage_to_xfer(p) = deadcrootn_storage(p) * matrix_update_phn(p,ideadcrootst_to_ideadcrootxf_phn,bgtr(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + leafn_storage_to_xfer(p) = leafn_storage(p) * bgtr(p) + frootn_storage_to_xfer(p) = frootn_storage(p) * bgtr(p) + if (woody(ivt(p)) == 1.0_r8) then + livestemn_storage_to_xfer(p) = livestemn_storage(p) * bgtr(p) + deadstemn_storage_to_xfer(p) = deadstemn_storage(p) * bgtr(p) + livecrootn_storage_to_xfer(p) = livecrootn_storage(p) * bgtr(p) + deadcrootn_storage_to_xfer(p) = deadcrootn_storage(p) * bgtr(p) + end if + end if !use_matrixcn + end if + + end if ! end if stress deciduous + + end do ! end of patch loop + + end associate + + end subroutine CNStressDecidPhenology + + !----------------------------------------------------------------------- + subroutine CropPhenology(num_pcropp, filter_pcropp , & + waterdiagnosticbulk_inst, temperature_inst, crop_inst, canopystate_inst, cnveg_state_inst , & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst,& + c13_cnveg_carbonstate_inst, c14_cnveg_carbonstate_inst) + + ! !DESCRIPTION: + ! Code from AgroIBIS to determine crop phenology and code from CN to + ! handle CN fluxes during the phenological onset & offset periods. + + ! !USES: + use clm_time_manager , only : get_curr_date, get_curr_calday, get_days_per_year, get_rad_step_size + use pftconMod , only : ntmp_corn, nswheat, nwwheat, ntmp_soybean + use pftconMod , only : nirrig_tmp_corn, nirrig_swheat, nirrig_wwheat, nirrig_tmp_soybean + use pftconMod , only : ntrp_corn, nsugarcane, ntrp_soybean, ncotton, nrice + use pftconMod , only : nirrig_trp_corn, nirrig_sugarcane, nirrig_trp_soybean + use pftconMod , only : nirrig_cotton, nirrig_rice + use pftconMod , only : nmiscanthus, nirrig_miscanthus, nswitchgrass, nirrig_switchgrass + + use clm_varcon , only : spval, secspday + use clm_varctl , only : use_fertilizer + use clm_varctl , only : use_c13, use_c14 + use clm_varcon , only : c13ratio, c14ratio + ! + ! !ARGUMENTS: + integer , intent(in) :: num_pcropp ! number of prog crop patches in filter + integer , intent(in) :: filter_pcropp(:) ! filter for prognostic crop patches + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(temperature_type) , intent(in) :: temperature_inst + type(crop_type) , intent(inout) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: c13_cnveg_carbonstate_inst + type(cnveg_carbonstate_type) , intent(inout) :: c14_cnveg_carbonstate_inst + ! + ! LOCAL VARAIBLES: + integer kyr ! current year + integer kmo ! month of year (1, ..., 12) + integer kda ! day of month (1, ..., 31) + integer mcsec ! seconds of day (0, ..., seconds/day) + integer jday ! julian day of the year + integer fp,p ! patch indices + integer c ! column indices + integer g ! gridcell indices + integer h ! hemisphere indices + integer idpp ! number of days past planting + real(r8) :: dtrad ! radiation time step delta t (seconds) + real(r8) dayspyr ! days per year + real(r8) crmcorn ! comparitive relative maturity for corn + real(r8) ndays_on ! number of days to fertilize + !------------------------------------------------------------------------ + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + leaf_long => pftcon%leaf_long , & ! Input: leaf longevity (yrs) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + manunitro => pftcon%manunitro , & ! Input: max manure to be applied in total (kgN/m2) + mxmat => pftcon%mxmat , & ! Input: + minplanttemp => pftcon%minplanttemp , & ! Input: + planttemp => pftcon%planttemp , & ! Input: + gddmin => pftcon%gddmin , & ! Input: + hybgdd => pftcon%hybgdd , & ! Input: + lfemerg => pftcon%lfemerg , & ! Input: + grnfill => pftcon%grnfill , & ! Input: + + t_ref2m_min => temperature_inst%t_ref2m_min_patch , & ! Input: [real(r8) (:) ] daily minimum of average 2 m height surface air temperature (K) + t10 => temperature_inst%t_a10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of the 2 m temperature (K) + a5tmin => temperature_inst%t_a5min_patch , & ! Input: [real(r8) (:) ] 5-day running mean of min 2-m temperature + a10tmin => temperature_inst%t_a10min_patch , & ! Input: [real(r8) (:) ] 10-day running mean of min 2-m temperature + gdd020 => temperature_inst%gdd020_patch , & ! Input: [real(r8) (:) ] 20 yr mean of gdd0 + gdd820 => temperature_inst%gdd820_patch , & ! Input: [real(r8) (:) ] 20 yr mean of gdd8 + gdd1020 => temperature_inst%gdd1020_patch , & ! Input: [real(r8) (:) ] 20 yr mean of gdd10 + + fertnitro => crop_inst%fertnitro_patch , & ! Input: [real(r8) (:) ] fertilizer nitrogen + hui => crop_inst%gddplant_patch , & ! Input: [real(r8) (:) ] gdd since planting (gddplant) + leafout => crop_inst%gddtsoi_patch , & ! Input: [real(r8) (:) ] gdd from top soil layer temperature + harvdate => crop_inst%harvdate_patch , & ! Output: [integer (:) ] harvest date + croplive => crop_inst%croplive_patch , & ! Output: [logical (:) ] Flag, true if planted, not harvested + cropplant => crop_inst%cropplant_patch , & ! Output: [logical (:) ] Flag, true if crop may be planted + vf => crop_inst%vf_patch , & ! Output: [real(r8) (:) ] vernalization factor + peaklai => cnveg_state_inst%peaklai_patch , & ! Output: [integer (:) ] 1: max allowed lai; 0: not at max + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index, no burying by snow + + idop => cnveg_state_inst%idop_patch , & ! Output: [integer (:) ] date of planting + gddmaturity => cnveg_state_inst%gddmaturity_patch , & ! Output: [real(r8) (:) ] gdd needed to harvest + huileaf => cnveg_state_inst%huileaf_patch , & ! Output: [real(r8) (:) ] heat unit index needed from planting to leaf emergence + huigrain => cnveg_state_inst%huigrain_patch , & ! Output: [real(r8) (:) ] same to reach vegetative maturity + cumvd => cnveg_state_inst%cumvd_patch , & ! Output: [real(r8) (:) ] cumulative vernalization d?ependence? + hdidx => cnveg_state_inst%hdidx_patch , & ! Output: [real(r8) (:) ] cold hardening index? + bglfr => cnveg_state_inst%bglfr_patch , & ! Output: [real(r8) (:) ] background litterfall rate (1/s) + bgtr => cnveg_state_inst%bgtr_patch , & ! Output: [real(r8) (:) ] background transfer growth rate (1/s) + lgsf => cnveg_state_inst%lgsf_patch , & ! Output: [real(r8) (:) ] long growing season factor [0-1] + onset_flag => cnveg_state_inst%onset_flag_patch , & ! Output: [real(r8) (:) ] onset flag + offset_flag => cnveg_state_inst%offset_flag_patch , & ! Output: [real(r8) (:) ] offset flag + onset_counter => cnveg_state_inst%onset_counter_patch , & ! Output: [real(r8) (:) ] onset counter + offset_counter => cnveg_state_inst%offset_counter_patch , & ! Output: [real(r8) (:) ] offset counter + + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Output: [real(r8) (:) ] (gC/m2) leaf C transfer + + crop_seedc_to_leaf => cnveg_carbonflux_inst%crop_seedc_to_leaf_patch, & ! Output: [real(r8) (:) ] (gC/m2/s) seed source to leaf + + fert_counter => cnveg_nitrogenflux_inst%fert_counter_patch , & ! Output: [real(r8) (:) ] >0 fertilize; <=0 not (seconds) + leafn_xfer => cnveg_nitrogenstate_inst%leafn_xfer_patch , & ! Output: [real(r8) (:) ] (gN/m2) leaf N transfer + crop_seedn_to_leaf => cnveg_nitrogenflux_inst%crop_seedn_to_leaf_patch, & ! Output: [real(r8) (:) ] (gN/m2/s) seed source to leaf + cphase => crop_inst%cphase_patch , & ! Output: [real(r8) (:)] phenology phase + fert => cnveg_nitrogenflux_inst%fert_patch & ! Output: [real(r8) (:) ] (gN/m2/s) fertilizer applied each timestep + ) + + ! get time info + dayspyr = get_days_per_year() + jday = get_curr_calday() + call get_curr_date(kyr, kmo, kda, mcsec) + dtrad = real( get_rad_step_size(), r8 ) + + if (use_fertilizer) then + ndays_on = 20._r8 ! number of days to fertilize + else + ndays_on = 0._r8 ! number of days to fertilize + end if + + do fp = 1, num_pcropp + p = filter_pcropp(fp) + c = patch%column(p) + g = patch%gridcell(p) + h = inhemi(p) + + ! background litterfall and transfer rates; long growing season factor + + bglfr(p) = 0._r8 ! this value changes later in a crop's life cycle + bgtr(p) = 0._r8 + lgsf(p) = 0._r8 + + ! --------------------------------- + ! from AgroIBIS subroutine planting + ! --------------------------------- + + ! in order to allow a crop to be planted only once each year + ! initialize cropplant = .false., but hold it = .true. through the end of the year + + ! initialize other variables that are calculated for crops + ! on an annual basis in cropresidue subroutine + + if ( jday == jdayyrstart(h) .and. mcsec == 0 )then + + ! make sure variables aren't changed at beginning of the year + ! for a crop that is currently planted, such as + ! WINTER TEMPERATE CEREAL = winter (wheat + barley + rye) + ! represented here by the winter wheat pft + + if (.not. croplive(p)) then + cropplant(p) = .false. + idop(p) = NOT_Planted + + ! keep next for continuous, annual winter temperate cereal crop; + ! if we removed elseif, + ! winter cereal grown continuously would amount to a cereal/fallow + ! rotation because cereal would only be planted every other year + + else if (croplive(p) .and. (ivt(p) == nwwheat .or. ivt(p) == nirrig_wwheat)) then + cropplant(p) = .false. + ! else ! not possible to have croplive and ivt==cornORsoy? (slevis) + end if + + end if + + if ( (.not. croplive(p)) .and. (.not. cropplant(p)) ) then + + ! gdd needed for * chosen crop and a likely hybrid (for that region) * + ! to reach full physiological maturity + + ! based on accumulated seasonal average growing degree days from + ! April 1 - Sept 30 (inclusive) + ! for corn and soybeans in the United States - + ! decided upon by what the typical average growing season length is + ! and the gdd needed to reach maturity in those regions + + ! first choice is used for spring temperate cereal and/or soybeans and maize + + ! slevis: ibis reads xinpdate in io.f from control.crops.nc variable name 'plantdate' + ! According to Chris Kucharik, the dataset of + ! xinpdate was generated from a previous model run at 0.5 deg resolution + + ! winter temperate cereal : use gdd0 as a limit to plant winter cereal + + if (ivt(p) == nwwheat .or. ivt(p) == nirrig_wwheat) then + + ! add check to only plant winter cereal after other crops (soybean, maize) + ! have been harvested + + ! *** remember order of planting is crucial - in terms of which crops you want + ! to be grown in what order *** + + ! in this case, corn or soybeans are assumed to be planted before + ! cereal would be in any particular year that both patches are allowed + ! to grow in the same grid cell (e.g., double-cropping) + + ! slevis: harvdate below needs cropplant(p) above to be cropplant(p,ivt(p)) + ! where ivt(p) has rotated to winter cereal because + ! cropplant through the end of the year for a harvested crop. + ! Also harvdate(p) should be harvdate(p,ivt(p)) and should be + ! updated on Jan 1st instead of at harvest (slevis) + if (a5tmin(p) /= spval .and. & + a5tmin(p) <= minplanttemp(ivt(p)) .and. & + jday >= minplantjday(ivt(p),h) .and. & + (gdd020(p) /= spval .and. & + gdd020(p) >= gddmin(ivt(p)))) then + + cumvd(p) = 0._r8 + hdidx(p) = 0._r8 + vf(p) = 0._r8 + croplive(p) = .true. + cropplant(p) = .true. + idop(p) = jday + harvdate(p) = NOT_Harvested + gddmaturity(p) = hybgdd(ivt(p)) + leafc_xfer(p) = initial_seed_at_planting + leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset + crop_seedc_to_leaf(p) = leafc_xfer(p)/dt + crop_seedn_to_leaf(p) = leafn_xfer(p)/dt + + ! because leafc_xfer is set above rather than incremneted through the normal process, must also set its isotope + ! pools here. use totvegc_patch as the closest analogue if nonzero, and use initial value otherwise + if (use_c13) then + if ( cnveg_carbonstate_inst%totvegc_patch(p) .gt. 0._r8) then + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * & + c13_cnveg_carbonstate_inst%totvegc_patch(p) / cnveg_carbonstate_inst%totvegc_patch(p) + else + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * c13ratio + endif + endif + if (use_c14) then + if ( cnveg_carbonstate_inst%totvegc_patch(p) .gt. 0._r8) then + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * & + c14_cnveg_carbonstate_inst%totvegc_patch(p) / cnveg_carbonstate_inst%totvegc_patch(p) + else + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * c14ratio + endif + endif + + ! latest possible date to plant winter cereal and after all other + ! crops were harvested for that year + + else if (jday >= maxplantjday(ivt(p),h) .and. & + gdd020(p) /= spval .and. & + gdd020(p) >= gddmin(ivt(p))) then + + cumvd(p) = 0._r8 + hdidx(p) = 0._r8 + vf(p) = 0._r8 + croplive(p) = .true. + cropplant(p) = .true. + idop(p) = jday + harvdate(p) = NOT_Harvested + gddmaturity(p) = hybgdd(ivt(p)) + leafc_xfer(p) = initial_seed_at_planting + leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset + crop_seedc_to_leaf(p) = leafc_xfer(p)/dt + crop_seedn_to_leaf(p) = leafn_xfer(p)/dt + + ! because leafc_xfer is set above rather than incremneted through the normal process, must also set its isotope + ! pools here. use totvegc_patch as the closest analogue if nonzero, and use initial value otherwise + if (use_c13) then + if ( cnveg_carbonstate_inst%totvegc_patch(p) .gt. 0._r8) then + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * & + c13_cnveg_carbonstate_inst%totvegc_patch(p) / cnveg_carbonstate_inst%totvegc_patch(p) + else + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * c13ratio + endif + endif + if (use_c14) then + if ( cnveg_carbonstate_inst%totvegc_patch(p) .gt. 0._r8) then + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * & + c14_cnveg_carbonstate_inst%totvegc_patch(p) / cnveg_carbonstate_inst%totvegc_patch(p) + else + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * c14ratio + endif + endif + else + gddmaturity(p) = 0._r8 + end if + + else ! not winter cereal... slevis: added distinction between NH and SH + ! slevis: The idea is that jday will equal idop sooner or later in the year + ! while the gdd part is either true or false for the year. + if (t10(p) /= spval.and. a10tmin(p) /= spval .and. & + t10(p) > planttemp(ivt(p)) .and. & + a10tmin(p) > minplanttemp(ivt(p)) .and. & + jday >= minplantjday(ivt(p),h) .and. & + jday <= maxplantjday(ivt(p),h) .and. & + t10(p) /= spval .and. a10tmin(p) /= spval .and. & + gdd820(p) /= spval .and. & + gdd820(p) >= gddmin(ivt(p))) then + + ! impose limit on growing season length needed + ! for crop maturity - for cold weather constraints + croplive(p) = .true. + cropplant(p) = .true. + idop(p) = jday + harvdate(p) = NOT_Harvested + + ! go a specified amount of time before/after + ! climatological date + if (ivt(p) == ntmp_soybean .or. ivt(p) == nirrig_tmp_soybean .or. & + ivt(p) == ntrp_soybean .or. ivt(p) == nirrig_trp_soybean) then + gddmaturity(p) = min(gdd1020(p), hybgdd(ivt(p))) + end if + + if (ivt(p) == ntmp_corn .or. ivt(p) == nirrig_tmp_corn .or. & + ivt(p) == ntrp_corn .or. ivt(p) == nirrig_trp_corn .or. & + ivt(p) == nsugarcane .or. ivt(p) == nirrig_sugarcane .or. & + ivt(p) == nmiscanthus .or. ivt(p) == nirrig_miscanthus .or. & + ivt(p) == nswitchgrass .or. ivt(p) == nirrig_switchgrass) then + gddmaturity(p) = max(950._r8, min(gdd820(p)*0.85_r8, hybgdd(ivt(p)))) + gddmaturity(p) = max(950._r8, min(gddmaturity(p)+150._r8, 1850._r8)) + end if + if (ivt(p) == nswheat .or. ivt(p) == nirrig_swheat .or. & + ivt(p) == ncotton .or. ivt(p) == nirrig_cotton .or. & + ivt(p) == nrice .or. ivt(p) == nirrig_rice) then + gddmaturity(p) = min(gdd020(p), hybgdd(ivt(p))) + end if + + leafc_xfer(p) = initial_seed_at_planting + leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset + crop_seedc_to_leaf(p) = leafc_xfer(p)/dt + crop_seedn_to_leaf(p) = leafn_xfer(p)/dt + + ! because leafc_xfer is set above rather than incremneted through the normal process, must also set its isotope + ! pools here. use totvegc_patch as the closest analogue if nonzero, and use initial value otherwise + if (use_c13) then + if ( cnveg_carbonstate_inst%totvegc_patch(p) .gt. 0._r8) then + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * & + c13_cnveg_carbonstate_inst%totvegc_patch(p) / cnveg_carbonstate_inst%totvegc_patch(p) + else + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * c13ratio + endif + endif + if (use_c14) then + if ( cnveg_carbonstate_inst%totvegc_patch(p) .gt. 0._r8) then + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * & + c14_cnveg_carbonstate_inst%totvegc_patch(p) / cnveg_carbonstate_inst%totvegc_patch(p) + else + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * c14ratio + endif + endif + + + ! If hit the max planting julian day -- go ahead and plant + else if (jday == maxplantjday(ivt(p),h) .and. gdd820(p) > 0._r8 .and. & + gdd820(p) /= spval ) then + croplive(p) = .true. + cropplant(p) = .true. + idop(p) = jday + harvdate(p) = NOT_Harvested + + if (ivt(p) == ntmp_soybean .or. ivt(p) == nirrig_tmp_soybean .or. & + ivt(p) == ntrp_soybean .or. ivt(p) == nirrig_trp_soybean) then + gddmaturity(p) = min(gdd1020(p), hybgdd(ivt(p))) + end if + + if (ivt(p) == ntmp_corn .or. ivt(p) == nirrig_tmp_corn .or. & + ivt(p) == ntrp_corn .or. ivt(p) == nirrig_trp_corn .or. & + ivt(p) == nsugarcane .or. ivt(p) == nirrig_sugarcane .or. & + ivt(p) == nmiscanthus .or. ivt(p) == nirrig_miscanthus .or. & + ivt(p) == nswitchgrass .or. ivt(p) == nirrig_switchgrass) then + gddmaturity(p) = max(950._r8, min(gdd820(p)*0.85_r8, hybgdd(ivt(p)))) + end if + if (ivt(p) == nswheat .or. ivt(p) == nirrig_swheat .or. & + ivt(p) == ncotton .or. ivt(p) == nirrig_cotton .or. & + ivt(p) == nrice .or. ivt(p) == nirrig_rice) then + gddmaturity(p) = min(gdd020(p), hybgdd(ivt(p))) + end if + + leafc_xfer(p) = initial_seed_at_planting + leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset + crop_seedc_to_leaf(p) = leafc_xfer(p)/dt + crop_seedn_to_leaf(p) = leafn_xfer(p)/dt + + ! because leafc_xfer is set above rather than incremneted through the normal process, must also set its isotope + ! pools here. use totvegc_patch as the closest analogue if nonzero, and use initial value otherwise + if (use_c13) then + if ( cnveg_carbonstate_inst%totvegc_patch(p) .gt. 0._r8) then + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * & + c13_cnveg_carbonstate_inst%totvegc_patch(p) / cnveg_carbonstate_inst%totvegc_patch(p) + else + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * c13ratio + endif + endif + if (use_c14) then + if ( cnveg_carbonstate_inst%totvegc_patch(p) .gt. 0._r8) then + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * & + c14_cnveg_carbonstate_inst%totvegc_patch(p) / cnveg_carbonstate_inst%totvegc_patch(p) + else + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = leafc_xfer(p) * c14ratio + endif + endif + + else + gddmaturity(p) = 0._r8 + end if + end if ! crop patch distinction + + ! crop phenology (gdd thresholds) controlled by gdd needed for + ! maturity (physiological) which is based on the average gdd + ! accumulation and hybrids in United States from April 1 - Sept 30 + + ! calculate threshold from phase 1 to phase 2: + ! threshold for attaining leaf emergence (based on fraction of + ! gdd(i) -- climatological average) + ! Hayhoe and Dwyer, 1990, Can. J. Soil Sci 70:493-497 + ! Carlson and Gage, 1989, Agric. For. Met., 45: 313-324 + ! J.T. Ritchie, 1991: Modeling Plant and Soil systems + + huileaf(p) = lfemerg(ivt(p)) * gddmaturity(p) ! 3-7% in cereal + + ! calculate threshhold from phase 2 to phase 3: + ! from leaf emergence to beginning of grain-fill period + ! this hypothetically occurs at the end of tassling, not the beginning + ! tassel initiation typically begins at 0.5-0.55 * gddmaturity + + ! calculate linear relationship between huigrain fraction and relative + ! maturity rating for maize + + if (ivt(p) == ntmp_corn .or. ivt(p) == nirrig_tmp_corn .or. & + ivt(p) == ntrp_corn .or. ivt(p) == nirrig_trp_corn .or. & + ivt(p) == nsugarcane .or. ivt(p) == nirrig_sugarcane .or. & + ivt(p) == nmiscanthus .or. ivt(p) == nirrig_miscanthus .or. & + ivt(p) == nswitchgrass .or. ivt(p) == nirrig_switchgrass) then + ! the following estimation of crmcorn from gddmaturity is based on a linear + ! regression using data from Pioneer-brand corn hybrids (Kucharik, 2003, + ! Earth Interactions 7:1-33: fig. 2) + crmcorn = max(73._r8, min(135._r8, (gddmaturity(p)+ 53.683_r8)/13.882_r8)) + + ! the following adjustment of grnfill based on crmcorn is based on a tuning + ! of Agro-IBIS to give reasonable results for max LAI and the seasonal + ! progression of LAI growth (pers. comm. C. Kucharik June 10, 2010) + huigrain(p) = -0.002_r8 * (crmcorn - 73._r8) + grnfill(ivt(p)) + + huigrain(p) = min(max(huigrain(p), grnfill(ivt(p))-0.1_r8), grnfill(ivt(p))) + huigrain(p) = huigrain(p) * gddmaturity(p) ! Cabelguenne et + else + huigrain(p) = grnfill(ivt(p)) * gddmaturity(p) ! al. 1999 + end if + + end if ! crop not live nor planted + + ! ---------------------------------- + ! from AgroIBIS subroutine phenocrop + ! ---------------------------------- + + ! all of the phenology changes are based on the total number of gdd needed + ! to change to the next phase - based on fractions of the total gdd typical + ! for that region based on the April 1 - Sept 30 window of development + + ! crop phenology (gdd thresholds) controlled by gdd needed for + ! maturity (physiological) which is based on the average gdd + ! accumulation and hybrids in United States from April 1 - Sept 30 + + ! Phase 1: Planting to leaf emergence (now in CNAllocation) + ! Phase 2: Leaf emergence to beginning of grain fill (general LAI accumulation) + ! Phase 3: Grain fill to physiological maturity and harvest (LAI decline) + ! Harvest: if gdd past grain fill initiation exceeds limit + ! or number of days past planting reaches a maximum, the crop has + ! reached physiological maturity and plant is harvested; + ! crop could be live or dead at this stage - these limits + ! could lead to reaching physiological maturity or determining + ! a harvest date for a crop killed by an early frost (see next comments) + ! --- --- --- + ! keeping comments without the code (slevis): + ! if minimum temperature, t_ref2m_min <= freeze kill threshold, tkill + ! for 3 consecutive days and lai is above a minimum, + ! plant will be damaged/killed. This function is more for spring freeze events + ! or for early fall freeze events + + ! spring temperate cereal is affected by this, winter cereal kill function + ! is determined in crops.f - is a more elaborate function of + ! cold hardening of the plant + + ! currently simulates too many grid cells killed by freezing temperatures + + ! removed on March 12 2002 - C. Kucharik + ! until it can be a bit more refined, or used at a smaller scale. + ! we really have no way of validating this routine + ! too difficult to implement on 0.5 degree scale grid cells + ! --- --- --- + + onset_flag(p) = 0._r8 ! CN terminology to trigger certain + offset_flag(p) = 0._r8 ! carbon and nitrogen transfers + + if (croplive(p)) then + cphase(p) = 1._r8 + + ! call vernalization if winter temperate cereal planted, living, and the + ! vernalization factor is not 1; + ! vf affects the calculation of gddtsoi & gddplant + + if (t_ref2m_min(p) < 1.e30_r8 .and. vf(p) /= 1._r8 .and. & + (ivt(p) == nwwheat .or. ivt(p) == nirrig_wwheat)) then + call vernalization(p, & + canopystate_inst, temperature_inst, waterdiagnosticbulk_inst, cnveg_state_inst, & + crop_inst) + end if + + ! days past planting may determine harvest + + if (jday >= idop(p)) then + idpp = jday - idop(p) + else + idpp = int(dayspyr) + jday - idop(p) + end if + + ! onset_counter initialized to zero when .not. croplive + ! offset_counter relevant only at time step of harvest + + onset_counter(p) = onset_counter(p) - dt + + ! enter phase 2 onset for one time step: + ! transfer seed carbon to leaf emergence + + if (peaklai(p) >= 1) then + hui(p) = max(hui(p),huigrain(p)) + endif + + if (leafout(p) >= huileaf(p) .and. hui(p) < huigrain(p) .and. idpp < mxmat(ivt(p))) then + cphase(p) = 2._r8 + if (abs(onset_counter(p)) > 1.e-6_r8) then + onset_flag(p) = 1._r8 + onset_counter(p) = dt + fert_counter(p) = ndays_on * secspday + if (ndays_on .gt. 0) then + fert(p) = (manunitro(ivt(p)) * 1000._r8 + fertnitro(p))/ fert_counter(p) + else + fert(p) = 0._r8 + end if + else + ! this ensures no re-entry to onset of phase2 + ! b/c onset_counter(p) = onset_counter(p) - dt + ! at every time step + + onset_counter(p) = dt + end if + + ! enter harvest for one time step: + ! - transfer live biomass to litter and to crop yield + ! - send xsmrpool to the atmosphere + ! if onset and harvest needed to last longer than one timestep + ! the onset_counter would change from dt and you'd need to make + ! changes to the offset subroutine below + + else if (hui(p) >= gddmaturity(p) .or. idpp >= mxmat(ivt(p))) then + if (harvdate(p) >= NOT_Harvested) harvdate(p) = jday + croplive(p) = .false. ! no re-entry in greater if-block + cphase(p) = 4._r8 + if (tlai(p) > 0._r8) then ! plant had emerged before harvest + offset_flag(p) = 1._r8 + offset_counter(p) = dt + else ! plant never emerged from the ground + ! Revert planting transfers; this will replenish the crop seed deficit. + ! We subtract from any existing value in crop_seedc_to_leaf / + ! crop_seedn_to_leaf in the unlikely event that we enter this block of + ! code in the same time step where the planting transfer originally + ! occurred. + crop_seedc_to_leaf(p) = crop_seedc_to_leaf(p) - leafc_xfer(p)/dt + crop_seedn_to_leaf(p) = crop_seedn_to_leaf(p) - leafn_xfer(p)/dt + leafc_xfer(p) = 0._r8 + leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) + if (use_c13) then + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = 0._r8 + endif + if (use_c14) then + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = 0._r8 + endif + + end if + + ! enter phase 3 while previous criteria fail and next is true; + ! in terms of order, phase 3 occurs before harvest, but when + ! harvest *can* occur, we want it to have first priority. + ! AgroIBIS uses a complex formula for lai decline. + ! Use CN's simple formula at least as a place holder (slevis) + + else if (hui(p) >= huigrain(p)) then + cphase(p) = 3._r8 + bglfr(p) = 1._r8/(leaf_long(ivt(p))*dayspyr*secspday) + end if + + ! continue fertilizer application while in phase 2; + ! assumes that onset of phase 2 took one time step only + + if (fert_counter(p) <= 0._r8) then + fert(p) = 0._r8 + else ! continue same fert application every timestep + fert_counter(p) = fert_counter(p) - dtrad + end if + + else ! crop not live + ! next 2 lines conserve mass if leaf*_xfer > 0 due to interpinic. + ! We subtract from any existing value in crop_seedc_to_leaf / + ! crop_seedn_to_leaf in the unlikely event that we enter this block of + ! code in the same time step where the planting transfer originally + ! occurred. + crop_seedc_to_leaf(p) = crop_seedc_to_leaf(p) - leafc_xfer(p)/dt + crop_seedn_to_leaf(p) = crop_seedn_to_leaf(p) - leafn_xfer(p)/dt + onset_counter(p) = 0._r8 + leafc_xfer(p) = 0._r8 + leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) + if (use_c13) then + c13_cnveg_carbonstate_inst%leafc_xfer_patch(p) = 0._r8 + endif + if (use_c14) then + c14_cnveg_carbonstate_inst%leafc_xfer_patch(p) = 0._r8 + endif + end if ! croplive + + end do ! prognostic crops loop + + end associate + + end subroutine CropPhenology + + !----------------------------------------------------------------------- + subroutine CropPhenologyInit(bounds) + ! + ! !DESCRIPTION: + ! Initialization of CropPhenology. Must be called after time-manager is + ! initialized, and after pftcon file is read in. + ! + ! !USES: + use pftconMod , only: npcropmin, npcropmax + use clm_time_manager, only: get_calday + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + ! + ! LOCAL VARAIBLES: + integer :: p,g,n,i ! indices + !------------------------------------------------------------------------ + + allocate( inhemi(bounds%begp:bounds%endp) ) + + allocate( minplantjday(0:maxveg,inSH)) ! minimum planting julian day + allocate( maxplantjday(0:maxveg,inSH)) ! minimum planting julian day + + ! Julian day for the start of the year (mid-winter) + jdayyrstart(inNH) = 1 + jdayyrstart(inSH) = 182 + + ! Convert planting dates into julian day + minplantjday(:,:) = huge(1) + maxplantjday(:,:) = huge(1) + do n = npcropmin, npcropmax + if (pftcon%is_pft_known_to_model(n)) then + minplantjday(n, inNH) = int( get_calday( pftcon%mnNHplantdate(n), 0 ) ) + maxplantjday(n, inNH) = int( get_calday( pftcon%mxNHplantdate(n), 0 ) ) + + minplantjday(n, inSH) = int( get_calday( pftcon%mnSHplantdate(n), 0 ) ) + maxplantjday(n, inSH) = int( get_calday( pftcon%mxSHplantdate(n), 0 ) ) + end if + end do + + ! Figure out what hemisphere each PATCH is in + do p = bounds%begp, bounds%endp + g = patch%gridcell(p) + ! Northern hemisphere + if ( grc%latdeg(g) > 0.0_r8 )then + inhemi(p) = inNH + else + inhemi(p) = inSH + end if + end do + + ! + ! Constants for Crop vernalization + ! + ! photoperiod factor calculation + ! genetic constant - can be modified + + p1d = 0.004_r8 ! average for genotypes from Ritchey, 1991. + ! Modeling plant & soil systems: Wheat phasic developmt + p1v = 0.003_r8 ! average for genotypes from Ritchey, 1991. + + hti = 1._r8 + tbase = 0._r8 + + end subroutine CropPhenologyInit + + !----------------------------------------------------------------------- + subroutine vernalization(p, & + canopystate_inst, temperature_inst, waterdiagnosticbulk_inst, cnveg_state_inst, crop_inst) + ! + ! !DESCRIPTION: + ! + ! * * * only call for winter temperate cereal * * * + ! + ! subroutine calculates vernalization and photoperiod effects on + ! gdd accumulation in winter temperate cereal varieties. Thermal time accumulation + ! is reduced in 1st period until plant is fully vernalized. During this + ! time of emergence to spikelet formation, photoperiod can also have a + ! drastic effect on plant development. + ! + ! !ARGUMENTS: + integer , intent(in) :: p ! PATCH index running over + type(canopystate_type) , intent(in) :: canopystate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(crop_type) , intent(inout) :: crop_inst + ! + ! LOCAL VARAIBLES: + real(r8) tcrown ! ? + real(r8) vd, vd1, vd2 ! vernalization dependence + real(r8) tkil ! Freeze kill threshold + integer c,g ! indices + !------------------------------------------------------------------------ + + associate( & + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index, no burying by snow + + t_ref2m => temperature_inst%t_ref2m_patch , & ! Input: [real(r8) (:) ] 2 m height surface air temperature (K) + t_ref2m_min => temperature_inst%t_ref2m_min_patch , & ! Input: [real(r8) (:) ] daily minimum of average 2 m height surface air temperature (K) + t_ref2m_max => temperature_inst%t_ref2m_max_patch , & ! Input: [real(r8) (:) ] daily maximum of average 2 m height surface air temperature (K) + + snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) + + hdidx => cnveg_state_inst%hdidx_patch , & ! Output: [real(r8) (:) ] cold hardening index? + cumvd => cnveg_state_inst%cumvd_patch , & ! Output: [real(r8) (:) ] cumulative vernalization d?ependence? + gddmaturity => cnveg_state_inst%gddmaturity_patch , & ! Output: [real(r8) (:) ] gdd needed to harvest + huigrain => cnveg_state_inst%huigrain_patch , & ! Output: [real(r8) (:) ] heat unit index needed to reach vegetative maturity + + vf => crop_inst%vf_patch & ! Output: [real(r8) (:) ] vernalization factor for cereal + ) + + c = patch%column(p) + + ! for all equations - temperatures must be in degrees (C) + ! calculate temperature of crown of crop (e.g., 3 cm soil temperature) + ! snow depth in centimeters + + if (t_ref2m(p) < tfrz) then !slevis: t_ref2m inst of td=daily avg (K) + tcrown = 2._r8 + (t_ref2m(p) - tfrz) * (0.4_r8 + 0.0018_r8 * & + (min(snow_depth(c)*100._r8, 15._r8) - 15._r8)**2) + else !slevis: snow_depth inst of adsnod=daily average (m) + tcrown = t_ref2m(p) - tfrz + end if + + ! vernalization factor calculation + ! if vf(p) = 1. then plant is fully vernalized - and thermal time + ! accumulation in phase 1 will be unaffected + ! refers to gddtsoi & gddplant, defined in the accumulation routines (slevis) + ! reset vf, cumvd, and hdidx to 0 at planting of crop (slevis) + + if (t_ref2m_max(p) > tfrz) then + if (t_ref2m_min(p) <= tfrz+15._r8) then + vd1 = 1.4_r8 - 0.0778_r8 * tcrown + vd2 = 0.5_r8 + 13.44_r8 / ((t_ref2m_max(p)-t_ref2m_min(p)+3._r8)**2) * tcrown + vd = max(0._r8, min(1._r8, vd1, vd2)) + cumvd(p) = cumvd(p) + vd + end if + + if (cumvd(p) < 10._r8 .and. t_ref2m_max(p) > tfrz+30._r8) then + cumvd(p) = cumvd(p) - 0.5_r8 * (t_ref2m_max(p) - tfrz - 30._r8) + end if + cumvd(p) = max(0._r8, cumvd(p)) ! must be > 0 + + vf(p) = 1._r8 - p1v * (50._r8 - cumvd(p)) + vf(p) = max(0._r8, min(vf(p), 1._r8)) ! must be between 0 - 1 + end if + + ! calculate cold hardening of plant + ! determines for winter cereal varieties whether the plant has completed + ! a period of cold hardening to protect it from freezing temperatures. If + ! not, then exposure could result in death or killing of plants. + + ! there are two distinct phases of hardening + + if (t_ref2m_min(p) <= tfrz-3._r8 .or. hdidx(p) /= 0._r8) then + if (hdidx(p) >= hti) then ! done with phase 1 + hdidx(p) = hdidx(p) + 0.083_r8 + hdidx(p) = min(hdidx(p), hti*2._r8) + end if + + if (t_ref2m_max(p) >= tbase + tfrz + 10._r8) then + hdidx(p) = hdidx(p) - 0.02_r8 * (t_ref2m_max(p)-tbase-tfrz-10._r8) + if (hdidx(p) > hti) hdidx(p) = hdidx(p) - 0.02_r8 * (t_ref2m_max(p)-tbase-tfrz-10._r8) + hdidx(p) = max(0._r8, hdidx(p)) + end if + + else if (tcrown >= tbase-1._r8) then + if (tcrown <= tbase+8._r8) then + hdidx(p) = hdidx(p) + 0.1_r8 - (tcrown-tbase+3.5_r8)**2 / 506._r8 + if (hdidx(p) >= hti .and. tcrown <= tbase + 0._r8) then + hdidx(p) = hdidx(p) + 0.083_r8 + hdidx(p) = min(hdidx(p), hti*2._r8) + end if + end if + + if (t_ref2m_max(p) >= tbase + tfrz + 10._r8) then + hdidx(p) = hdidx(p) - 0.02_r8 * (t_ref2m_max(p)-tbase-tfrz-10._r8) + if (hdidx(p) > hti) hdidx(p) = hdidx(p) - 0.02_r8 * (t_ref2m_max(p)-tbase-tfrz-10._r8) + hdidx(p) = max(0._r8, hdidx(p)) + end if + end if + + ! calculate what the cereal killing temperature + ! there is a linear inverse relationship between + ! hardening of the plant and the killing temperature or + ! threshold that the plant can withstand + ! when plant is fully-hardened (hdidx = 2), the killing threshold is -18 C + + ! will have to develop some type of relationship that reduces LAI and + ! biomass pools in response to cold damaged crop + + if (t_ref2m_min(p) <= tfrz - 6._r8) then + tkil = (tbase - 6._r8) - 6._r8 * hdidx(p) + if (tkil >= tcrown) then + if ((0.95_r8 - 0.02_r8 * (tcrown - tkil)**2) >= 0.02_r8) then + write (iulog,*) 'crop damaged by cold temperatures at p,c =', p,c + else if (tlai(p) > 0._r8) then ! slevis: kill if past phase1 + gddmaturity(p) = 0._r8 ! by forcing through + huigrain(p) = 0._r8 ! harvest + write (iulog,*) '95% of crop killed by cold temperatures at p,c =', p,c + end if + end if + end if + + end associate + + end subroutine vernalization + + !----------------------------------------------------------------------- + subroutine CNOnsetGrowth (num_soilp, filter_soilp, & + cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! Determines the flux of stored C and N from transfer pools to display + ! pools during the phenological onset period. + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(in) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: p ! indices + integer :: fp ! lake filter patch index + real(r8):: t1 ! temporary variable + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + + onset_flag => cnveg_state_inst%onset_flag_patch , & ! Input: [real(r8) (:) ] onset flag + onset_counter => cnveg_state_inst%onset_counter_patch , & ! Input: [real(r8) (:) ] onset days counter + bgtr => cnveg_state_inst%bgtr_patch , & ! Input: [real(r8) (:) ] background transfer growth rate (1/s) + + leafc_xfer => cnveg_carbonstate_inst%leafc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C transfer + frootc_xfer => cnveg_carbonstate_inst%frootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C transfer + livestemc_xfer => cnveg_carbonstate_inst%livestemc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C transfer + deadstemc_xfer => cnveg_carbonstate_inst%deadstemc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C transfer + livecrootc_xfer => cnveg_carbonstate_inst%livecrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C transfer + deadcrootc_xfer => cnveg_carbonstate_inst%deadcrootc_xfer_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + + leafn_xfer => cnveg_nitrogenstate_inst%leafn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N transfer + frootn_xfer => cnveg_nitrogenstate_inst%frootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N transfer + livestemn_xfer => cnveg_nitrogenstate_inst%livestemn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N transfer + deadstemn_xfer => cnveg_nitrogenstate_inst%deadstemn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead stem N transfer + livecrootn_xfer => cnveg_nitrogenstate_inst%livecrootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N transfer + deadcrootn_xfer => cnveg_nitrogenstate_inst%deadcrootn_xfer_patch , & ! Input: [real(r8) (:) ] (gN/m2) dead coarse root N transfer + + leafc_xfer_to_leafc => cnveg_carbonflux_inst%leafc_xfer_to_leafc_patch , & ! Output: [real(r8) (:) ] + frootc_xfer_to_frootc => cnveg_carbonflux_inst%frootc_xfer_to_frootc_patch , & ! Output: [real(r8) (:) ] + livestemc_xfer_to_livestemc => cnveg_carbonflux_inst%livestemc_xfer_to_livestemc_patch , & ! Output: [real(r8) (:) ] + deadstemc_xfer_to_deadstemc => cnveg_carbonflux_inst%deadstemc_xfer_to_deadstemc_patch , & ! Output: [real(r8) (:) ] + livecrootc_xfer_to_livecrootc => cnveg_carbonflux_inst%livecrootc_xfer_to_livecrootc_patch , & ! Output: [real(r8) (:) ] + deadcrootc_xfer_to_deadcrootc => cnveg_carbonflux_inst%deadcrootc_xfer_to_deadcrootc_patch , & ! Output: [real(r8) (:) ] + + leafn_xfer_to_leafn => cnveg_nitrogenflux_inst%leafn_xfer_to_leafn_patch , & ! Output: [real(r8) (:) ] + frootn_xfer_to_frootn => cnveg_nitrogenflux_inst%frootn_xfer_to_frootn_patch , & ! Output: [real(r8) (:) ] + livestemn_xfer_to_livestemn => cnveg_nitrogenflux_inst%livestemn_xfer_to_livestemn_patch , & ! Output: [real(r8) (:) ] + deadstemn_xfer_to_deadstemn => cnveg_nitrogenflux_inst%deadstemn_xfer_to_deadstemn_patch , & ! Output: [real(r8) (:) ] + livecrootn_xfer_to_livecrootn => cnveg_nitrogenflux_inst%livecrootn_xfer_to_livecrootn_patch , & ! Output: [real(r8) (:) ] + deadcrootn_xfer_to_deadcrootn => cnveg_nitrogenflux_inst%deadcrootn_xfer_to_deadcrootn_patch , & ! Output: [real(r8) (:) ] + ileafst_to_ileafxf_phc => cnveg_carbonflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phc => cnveg_carbonflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phc => cnveg_carbonflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phc => cnveg_carbonflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phc => cnveg_carbonflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phc => cnveg_carbonflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phc => cnveg_carbonflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phc => cnveg_carbonflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phc => cnveg_carbonflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phc => cnveg_carbonflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phc => cnveg_carbonflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phc => cnveg_carbonflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phc => cnveg_carbonflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phc => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phc => cnveg_carbonflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phc => cnveg_carbonflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phc => cnveg_carbonflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + igrain_to_iout_phc => cnveg_carbonflux_inst%igrain_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ileafst_to_ileafxf_phn => cnveg_nitrogenflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phn => cnveg_nitrogenflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phn => cnveg_nitrogenflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phn => cnveg_nitrogenflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phn => cnveg_nitrogenflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phn => cnveg_nitrogenflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phn => cnveg_nitrogenflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phn => cnveg_nitrogenflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phn => cnveg_nitrogenflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phn => cnveg_nitrogenflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phn => cnveg_nitrogenflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phn => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phn => cnveg_nitrogenflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phn => cnveg_nitrogenflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phn => cnveg_nitrogenflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + ileaf_to_iretransn_phn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to retranslocation pool + ilivestem_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to retranslocation pool + ilivecroot_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivecroot_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root pool to retranslocation pool + igrain_to_iout_phn => cnveg_nitrogenflux_inst%igrain_to_iout_ph & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ) + + ! patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! only calculate these fluxes during onset period + if (onset_flag(p) == 1._r8) then + + ! The transfer rate is a linearly decreasing function of time, + ! going to zero on the last timestep of the onset period + + if (abs(onset_counter(p) - dt) <= dt/2._r8) then + t1 = 1.0_r8 / dt + else + t1 = 2.0_r8 / (onset_counter(p)) + end if + if (use_matrixcn)then +! leafc_xfer_to_leafc(p) = leafc_xfer(p) * matrix_update_phc(p,ileafxf_to_ileaf_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! frootc_xfer_to_frootc(p) = frootc_xfer(p) * matrix_update_phc(p,ifrootxf_to_ifroot_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! leafn_xfer_to_leafn(p) = leafn_xfer(p) * matrix_update_phn(p,ileafxf_to_ileaf_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! frootn_xfer_to_frootn(p) = frootn_xfer(p) * matrix_update_phn(p,ifrootxf_to_ifroot_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! if (woody(ivt(p)) == 1.0_r8) then +! +! livestemc_xfer_to_livestemc(p) = livestemc_xfer(p) * matrix_update_phc(p,ilivestemxf_to_ilivestem_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadstemc_xfer_to_deadstemc(p) = deadstemc_xfer(p) * matrix_update_phc(p,ideadstemxf_to_ideadstem_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! livecrootc_xfer_to_livecrootc(p) = livecrootc_xfer(p) * matrix_update_phc(p,ilivecrootxf_to_ilivecroot_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadcrootc_xfer_to_deadcrootc(p) = deadcrootc_xfer(p) * matrix_update_phc(p,ideadcrootxf_to_ideadcroot_phc,t1,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! +! livestemn_xfer_to_livestemn(p) = livestemn_xfer(p) * matrix_update_phn(p,ilivestemxf_to_ilivestem_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadstemn_xfer_to_deadstemn(p) = deadstemn_xfer(p) * matrix_update_phn(p,ideadstemxf_to_ideadstem_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! livecrootn_xfer_to_livecrootn(p) = livecrootn_xfer(p) * matrix_update_phn(p,ilivecrootxf_to_ilivecroot_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadcrootn_xfer_to_deadcrootn(p) = deadcrootn_xfer(p) * matrix_update_phn(p,ideadcrootxf_to_ideadcroot_phn,t1,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + leafc_xfer_to_leafc(p) = t1 * leafc_xfer(p) + frootc_xfer_to_frootc(p) = t1 * frootc_xfer(p) + leafn_xfer_to_leafn(p) = t1 * leafn_xfer(p) + frootn_xfer_to_frootn(p) = t1 * frootn_xfer(p) + if (woody(ivt(p)) == 1.0_r8) then + livestemc_xfer_to_livestemc(p) = t1 * livestemc_xfer(p) + deadstemc_xfer_to_deadstemc(p) = t1 * deadstemc_xfer(p) + livecrootc_xfer_to_livecrootc(p) = t1 * livecrootc_xfer(p) + deadcrootc_xfer_to_deadcrootc(p) = t1 * deadcrootc_xfer(p) + livestemn_xfer_to_livestemn(p) = t1 * livestemn_xfer(p) + deadstemn_xfer_to_deadstemn(p) = t1 * deadstemn_xfer(p) + livecrootn_xfer_to_livecrootn(p) = t1 * livecrootn_xfer(p) + deadcrootn_xfer_to_deadcrootn(p) = t1 * deadcrootn_xfer(p) + end if + end if !use_matrixcn + + end if ! end if onset period + + ! calculate the background rate of transfer growth (used for stress + ! deciduous algorithm). In this case, all of the mass in the transfer + ! pools should be moved to displayed growth in each timestep. + + if (bgtr(p) > 0._r8) then + if(use_matrixcn)then +! leafc_xfer_to_leafc(p) = leafc_xfer(p) * matrix_update_phc(p,ileafxf_to_ileaf_phc,1._r8 / dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! frootc_xfer_to_frootc(p) = frootc_xfer(p) * matrix_update_phc(p,ifrootxf_to_ifroot_phc,1._r8 / dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! leafn_xfer_to_leafn(p) = leafn_xfer(p) * matrix_update_phn(p,ileafxf_to_ileaf_phn,1._r8 / dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! frootn_xfer_to_frootn(p) = frootn_xfer(p) * matrix_update_phn(p,ifrootxf_to_ifroot_phn,1._r8 / dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! if (woody(ivt(p)) == 1.0_r8) then +! +! livestemc_xfer_to_livestemc(p) = livestemc_xfer(p) * matrix_update_phc(p,ilivestemxf_to_ilivestem_phc,1._r8 / dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadstemc_xfer_to_deadstemc(p) = deadstemc_xfer(p) * matrix_update_phc(p,ideadstemxf_to_ideadstem_phc,1._r8 / dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! livecrootc_xfer_to_livecrootc(p) = livecrootc_xfer(p) * matrix_update_phc(p,ilivecrootxf_to_ilivecroot_phc,1._r8 / dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! deadcrootc_xfer_to_deadcrootc(p) = deadcrootc_xfer(p) * matrix_update_phc(p,ideadcrootxf_to_ideadcroot_phc,1._r8 / dt,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! +! livestemn_xfer_to_livestemn(p) = livestemn_xfer(p) * matrix_update_phn(p,ilivestemxf_to_ilivestem_phn,1._r8 / dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadstemn_xfer_to_deadstemn(p) = deadstemn_xfer(p) * matrix_update_phn(p,ideadstemxf_to_ideadstem_phn,1._r8 / dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! livecrootn_xfer_to_livecrootn(p) = livecrootn_xfer(p) * matrix_update_phn(p,ilivecrootxf_to_ilivecroot_phn,1._r8 / dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! deadcrootn_xfer_to_deadcrootn(p) = deadcrootn_xfer(p) * matrix_update_phn(p,ideadcrootxf_to_ideadcroot_phn,1._r8 / dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + leafc_xfer_to_leafc(p) = leafc_xfer(p) / dt + frootc_xfer_to_frootc(p) = frootc_xfer(p) / dt + leafn_xfer_to_leafn(p) = leafn_xfer(p) / dt + frootn_xfer_to_frootn(p) = frootn_xfer(p) / dt + if (woody(ivt(p)) == 1.0_r8) then + livestemc_xfer_to_livestemc(p) = livestemc_xfer(p) / dt + deadstemc_xfer_to_deadstemc(p) = deadstemc_xfer(p) / dt + livecrootc_xfer_to_livecrootc(p) = livecrootc_xfer(p) / dt + deadcrootc_xfer_to_deadcrootc(p) = deadcrootc_xfer(p) / dt + livestemn_xfer_to_livestemn(p) = livestemn_xfer(p) / dt + deadstemn_xfer_to_deadstemn(p) = deadstemn_xfer(p) / dt + livecrootn_xfer_to_livecrootn(p) = livecrootn_xfer(p) / dt + deadcrootn_xfer_to_deadcrootn(p) = deadcrootn_xfer(p) / dt + end if + end if !use_matrixcn + end if ! end if bgtr + + end do ! end patch loop + + end associate + + end subroutine CNOnsetGrowth + + !----------------------------------------------------------------------- + subroutine CNOffsetLitterfall (num_soilp, filter_soilp, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! Determines the flux of C and N from displayed pools to litter + ! pools during the phenological offset period. + ! + ! !USES: + use pftconMod , only : npcropmin + use pftconMod , only : nmiscanthus, nirrig_miscanthus, nswitchgrass, nirrig_switchgrass + + use CNSharedParamsMod, only : use_fun + use clm_varctl , only : CNratio_floating + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type), intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: p, c ! indices + integer :: fp ! lake filter patch index + real(r8):: t1 ! temporary variable + real(r8):: denom ! temporary variable for divisor + real(r8) :: ntovr_leaf + real(r8) :: fr_leafn_to_litter ! fraction of the nitrogen turnover that goes to litter; remaining fraction is retranslocated + real(r8) :: grainc_to_out, grainn_to_out ! Temporary for grain Carbon and grain Nitrogen output + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + + biofuel_harvfrac => pftcon%biofuel_harvfrac , & ! Input: cut a fraction of leaf & stem for biofuel (-) + + lflitcn => pftcon%lflitcn , & ! Input: leaf litter C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: fine root C:N (gC/gN) + graincn => pftcon%graincn , & ! Input: grain C:N (gC/gN) + + offset_flag => cnveg_state_inst%offset_flag_patch , & ! Input: [real(r8) (:) ] offset flag + offset_counter => cnveg_state_inst%offset_counter_patch , & ! Input: [real(r8) (:) ] offset days counter + + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C + grainc => cnveg_carbonstate_inst%grainc_patch , & ! Input: [real(r8) (:) ] (gC/m2) grain C + cropseedc_deficit => cnveg_carbonstate_inst%cropseedc_deficit_patch , & ! Input: [real(r8) (:) ] (gC/m2) crop seed C deficit + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) livestem C + cropseedn_deficit => cnveg_nitrogenstate_inst%cropseedn_deficit_patch , & ! Input: [real(r8) (:) ] (gC/m2) crop seed N deficit + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) livestem N + + cpool_to_grainc => cnveg_carbonflux_inst%cpool_to_grainc_patch , & ! Input: [real(r8) (:) ] allocation to grain C (gC/m2/s) + npool_to_grainn => cnveg_nitrogenflux_inst%npool_to_grainn_patch , & ! Input: [real(r8) (:) ] allocation to grain N (gN/m2/s) + grainn => cnveg_nitrogenstate_inst%grainn_patch , & ! Input: [real(r8) (:) ] (kgN/m2) grain N + cpool_to_livestemc => cnveg_carbonflux_inst%cpool_to_livestemc_patch , & ! Input: [real(r8) (:) ] allocation to live stem C (gC/m2/s) + cpool_to_leafc => cnveg_carbonflux_inst%cpool_to_leafc_patch , & ! Input: [real(r8) (:) ] allocation to leaf C (gC/m2/s) + cpool_to_frootc => cnveg_carbonflux_inst%cpool_to_frootc_patch , & ! Input: [real(r8) (:) ] allocation to fine root C (gC/m2/s) + prev_leafc_to_litter => cnveg_carbonflux_inst%prev_leafc_to_litter_patch , & ! Output: [real(r8) (:) ] previous timestep leaf C litterfall flux (gC/m2/s) + prev_frootc_to_litter => cnveg_carbonflux_inst%prev_frootc_to_litter_patch , & ! Output: [real(r8) (:) ] previous timestep froot C litterfall flux (gC/m2/s) + leafc_to_litter => cnveg_carbonflux_inst%leafc_to_litter_patch , & ! Output: [real(r8) (:) ] leaf C litterfall (gC/m2/s) + frootc_to_litter => cnveg_carbonflux_inst%frootc_to_litter_patch , & ! Output: [real(r8) (:) ] fine root C litterfall (gC/m2/s) + livestemc_to_litter => cnveg_carbonflux_inst%livestemc_to_litter_patch , & ! Output: [real(r8) (:) ] live stem C litterfall (gC/m2/s) + grainc_to_food => cnveg_carbonflux_inst%grainc_to_food_patch , & ! Output: [real(r8) (:) ] grain C to food (gC/m2/s) + grainc_to_seed => cnveg_carbonflux_inst%grainc_to_seed_patch , & ! Output: [real(r8) (:) ] grain C to seed (gC/m2/s) + leafc_to_biofuelc => cnveg_carbonflux_inst%leafc_to_biofuelc_patch , & ! Output: [real(r8) (:) ] leaf C to biofuel C (gC/m2/s) + livestemc_to_biofuelc => cnveg_carbonflux_inst%livestemc_to_biofuelc_patch , & ! Output: [real(r8) (:) ] livestem C to biofuel C (gC/m2/s) + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N + + livestemn_to_litter => cnveg_nitrogenflux_inst%livestemn_to_litter_patch , & ! Output: [real(r8) (:) ] livestem N to litter (gN/m2/s) + grainn_to_food => cnveg_nitrogenflux_inst%grainn_to_food_patch , & ! Output: [real(r8) (:) ] grain N to food (gN/m2/s) + grainn_to_seed => cnveg_nitrogenflux_inst%grainn_to_seed_patch , & ! Output: [real(r8) (:) ] grain N to seed (gN/m2/s) + leafn_to_biofueln => cnveg_nitrogenflux_inst%leafn_to_biofueln_patch , & ! Output: [real(r8) (:) ] leaf N to biofuel N (gN/m2/s) + livestemn_to_biofueln => cnveg_nitrogenflux_inst%livestemn_to_biofueln_patch, & ! Output: [real(r8) (:) ] livestem N to biofuel N (gN/m2/s) + leafn_to_litter => cnveg_nitrogenflux_inst%leafn_to_litter_patch , & ! Output: [real(r8) (:) ] leaf N litterfall (gN/m2/s) + leafn_to_retransn => cnveg_nitrogenflux_inst%leafn_to_retransn_patch , & ! Input: [real(r8) (:) ] leaf N to retranslocated N pool (gN/m2/s) + free_retransn_to_npool=> cnveg_nitrogenflux_inst%free_retransn_to_npool_patch , & ! Input: [real(r8) (:) ] free leaf N to retranslocated N pool (gN/m2/s) + paid_retransn_to_npool=> cnveg_nitrogenflux_inst%retransn_to_npool_patch, & ! Input: [real(r8) (:) ] free leaf N to retranslocated N pool (gN/m2/s) + frootn_to_litter => cnveg_nitrogenflux_inst%frootn_to_litter_patch , & ! Output: [real(r8) (:) ] fine root N litterfall (gN/m2/s) + leafc_to_litter_fun => cnveg_carbonflux_inst%leafc_to_litter_fun_patch , & ! Output: [real(r8) (:) ] leaf C litterfall used by FUN (gC/m2/s) + leafcn_offset => cnveg_state_inst%leafcn_offset_patch , & ! Output: [real(r8) (:) ] Leaf C:N used by FUN + + ileafst_to_ileafxf_phc => cnveg_carbonflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phc => cnveg_carbonflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phc => cnveg_carbonflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phc => cnveg_carbonflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phc => cnveg_carbonflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phc => cnveg_carbonflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phc => cnveg_carbonflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phc => cnveg_carbonflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phc => cnveg_carbonflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phc => cnveg_carbonflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phc => cnveg_carbonflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phc => cnveg_carbonflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phc => cnveg_carbonflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phc => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phc => cnveg_carbonflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ileaf_to_iout_gmc => cnveg_carbonflux_inst%ileaf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from leaf pool to outside of vegetation pools + ileaf_to_iout_gmn => cnveg_nitrogenflux_inst%ileaf_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phc => cnveg_carbonflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phc => cnveg_carbonflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + igrain_to_iout_phc => cnveg_carbonflux_inst%igrain_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ileafst_to_ileafxf_phn => cnveg_nitrogenflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phn => cnveg_nitrogenflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phn => cnveg_nitrogenflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phn => cnveg_nitrogenflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phn => cnveg_nitrogenflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phn => cnveg_nitrogenflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phn => cnveg_nitrogenflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phn => cnveg_nitrogenflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phn => cnveg_nitrogenflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phn => cnveg_nitrogenflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phn => cnveg_nitrogenflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phn => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phn => cnveg_nitrogenflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phn => cnveg_nitrogenflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phn => cnveg_nitrogenflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + ilivestem_to_iout_gmc => cnveg_carbonflux_inst%ilivestem_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related C transfer from live stem pool to outside of vegetation pools + ilivestem_to_iout_gmn => cnveg_nitrogenflux_inst%ilivestem_to_iout_gm , & ! Input: [integer (:)] Index of gap mortality related N transfer from live stem pool to outside of vegetation pools + ileaf_to_iretransn_phn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to retranslocation pool + ilivestem_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to retranslocation pool + ilivecroot_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivecroot_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root pool to retranslocation pool + igrain_to_iout_phn => cnveg_nitrogenflux_inst%igrain_to_iout_ph & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ) + + ! The litterfall transfer rate starts at 0.0 and increases linearly + ! over time, with displayed growth going to 0.0 on the last day of litterfall + + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! only calculate fluxes during offset period + if (offset_flag(p) == 1._r8) then + + if (abs(offset_counter(p) - dt) <= dt/2._r8) then + t1 = 1.0_r8 / dt + frootc_to_litter(p) = t1 * frootc(p) + cpool_to_frootc(p) + + ! biofuel_harvfrac is only non-zero for prognostic crops. + leafc_to_litter(p) = t1 * leafc(p)*(1._r8-biofuel_harvfrac(ivt(p))) + cpool_to_leafc(p) + + if (use_matrixcn) then +! if(leafc(p) .gt. 0)then +! leafc_to_litter(p) = leafc(p) * matrix_update_phc(p,ileaf_to_iout_phc,leafc_to_litter(p) / leafc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! leafc_to_litter(p) = 0 +! end if +! if(frootc(p) .gt. 0)then +! frootc_to_litter(p) = frootc(p) * matrix_update_phc(p,ifroot_to_iout_phc,frootc_to_litter(p) / frootc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! frootc_to_litter(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + end if ! use_matrixcn + ! this assumes that offset_counter == dt for crops + ! if this were ever changed, we'd need to add code to the "else" + if (ivt(p) >= npcropmin) then + ! Replenish the seed deficits from grain, if there is enough + ! available grain. (If there is not enough available grain, the seed + ! deficits will accumulate until there is eventually enough grain to + ! replenish them.) + grainc_to_seed(p) = t1 * min(-cropseedc_deficit(p), grainc(p)) + grainn_to_seed(p) = t1 * min(-cropseedn_deficit(p), grainn(p)) + ! Send the remaining grain to the food product pool + grainc_to_food(p) = t1 * grainc(p) + cpool_to_grainc(p) - grainc_to_seed(p) + grainn_to_food(p) = t1 * grainn(p) + npool_to_grainn(p) - grainn_to_seed(p) + + ! Cut a certain fraction (i.e., biofuel_harvfrac(ivt(p))) (e.g., biofuel_harvfrac(ivt(p)=70% for bioenergy crops) of leaf C + ! and move this fration of leaf C to biofuel C, rather than move it to litter + leafc_to_biofuelc(p) = t1 * leafc(p) * biofuel_harvfrac(ivt(p)) + leafn_to_biofueln(p) = t1 * leafn(p) * biofuel_harvfrac(ivt(p)) + + ! Cut a certain fraction (i.e., biofuel_harvfrac(ivt(p))) (e.g., biofuel_harvfrac(ivt(p)=70% for bioenergy crops) of livestem C + ! and move this fration of leaf C to biofuel C, rather than move it to litter + livestemc_to_litter(p) = t1 * livestemc(p)*(1._r8-biofuel_harvfrac(ivt(p))) + cpool_to_livestemc(p) + livestemc_to_biofuelc(p) = t1 * livestemc(p) * biofuel_harvfrac(ivt(p)) + livestemn_to_biofueln(p) = t1 * livestemn(p) * biofuel_harvfrac(ivt(p)) + + if(use_matrixcn)then +! if(grainc(p) .gt. 0)then +! grainc_to_out = grainc(p) * matrix_update_phc(p,igrain_to_iout_phc,(grainc_to_seed(p) + grainc_to_food(p)) / grainc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! grainc_to_seed(p) = 0 +! grainc_to_food(p) = 0 +! end if +! if(grainn(p) .gt. 0)then +! grainn_to_out = grainn(p) * matrix_update_phn(p,igrain_to_iout_phn,(grainn_to_seed(p) + grainn_to_food(p)) / grainn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! grainn_to_seed(p) = 0 +! grainn_to_food(p) = 0 +! end if +! if(livestemc(p) .gt. 0)then +! livestemc_to_litter(p) = livestemc(p) * matrix_update_phc(p,ilivestem_to_iout_phc,livestemc_to_litter(p) / livestemc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! livestemc_to_litter(p) = 0 +! end if +! if(livestemn(p) .gt. 0)then +! livestemn_to_biofueln(p) = livestemn(p) * matrix_update_gmn(p,ilivestem_to_iout_gmn,livestemn_to_biofueln(p) / livestemn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! else +! livestemn_to_biofueln(p) = 0 +! end if +! if(leafn(p) > 0)then +! leafn_to_biofueln(p) = leafn(p) * matrix_update_gmn(p,ileaf_to_iout_gmn,leafn_to_biofueln(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! else +! leafn_to_biofueln(p) = 0 +! end if +! if (leafc(p) > 0)then +! leafc_to_biofuelc(p) = leafc(p) * matrix_update_gmc(p,ileaf_to_iout_gmc,leafc_to_biofuelc(p) / leafc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,.True.) +! else +! leafc_to_biofuelc(p) = 0 +! end if +! if(livestemc(p) .gt. 0)then +! livestemc_to_biofuelc(p) = livestemc(p) * matrix_update_gmc(p,ilivestem_to_iout_gmc,livestemc_to_biofuelc(p) / livestemc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,.True.) +! else +! livestemc_to_biofuelc(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + end if ! use_matrixcn + end if + else + t1 = dt * 2.0_r8 / (offset_counter(p) * offset_counter(p)) + leafc_to_litter(p) = prev_leafc_to_litter(p) + t1*(leafc(p) - prev_leafc_to_litter(p)*offset_counter(p)) + frootc_to_litter(p) = prev_frootc_to_litter(p) + t1*(frootc(p) - prev_frootc_to_litter(p)*offset_counter(p)) + + if (use_matrixcn) then +! if(leafc(p) .gt. 0)then +! leafc_to_litter(p) = leafc(p) * matrix_update_phc(p,ileaf_to_iout_phc,leafc_to_litter(p) / leafc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! leafc_to_litter(p) = 0 +! end if +! if(frootc(p) .gt. 0)then +! frootc_to_litter(p) = frootc(p) * matrix_update_phc(p,ifroot_to_iout_phc,frootc_to_litter(p) / frootc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! frootc_to_litter(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + end if !use_matrixcn + end if + + if ( use_fun ) then + if(leafc_to_litter(p)*dt.gt.leafc(p))then + leafc_to_litter(p) = leafc(p)/dt + cpool_to_leafc(p) + if (use_matrixcn) then +! if(leafc(p) .gt. 0)then +! leafc_to_litter(p) = leafc(p) * matrix_update_phc(p,ileaf_to_iout_phc,leafc_to_litter(p) / leafc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! leafc_to_litter(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + endif + if(frootc_to_litter(p)*dt.gt.frootc(p))then + frootc_to_litter(p) = frootc(p)/dt + cpool_to_frootc(p) + if (use_matrixcn) then +! if(frootc(p) .gt. 0)then +! frootc_to_litter(p) = frootc(p) * matrix_update_phc(p,ifroot_to_iout_phc,frootc_to_litter(p) / frootc(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! else +! frootc_to_litter(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + endif + end if + + + if ( use_fun ) then + leafc_to_litter_fun(p) = leafc_to_litter(p) + leafn_to_retransn(p) = paid_retransn_to_npool(p) + free_retransn_to_npool(p) + if (leafn(p).gt.0._r8) then + if (leafn(p)-leafn_to_retransn(p)*dt.gt.0._r8) then + leafcn_offset(p) = leafc(p)/(leafn(p)-leafn_to_retransn(p)*dt) + else + leafcn_offset(p) = leafc(p)/leafn(p) + end if + else + leafcn_offset(p) = leafcn(ivt(p)) + end if + leafn_to_litter(p) = leafc_to_litter(p)/leafcn_offset(p) - leafn_to_retransn(p) + leafn_to_litter(p) = max(leafn_to_litter(p),0._r8) + if (use_matrixcn) then +! if(leafn(p) .gt. 0)then +! leafn_to_litter(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iout_phn,leafn_to_litter(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! leafn_to_retransn(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iretransn_phn,leafn_to_retransn(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! leafn_to_litter(p) = 0 +! leafn_to_retransn(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + end if !use_matrixcn + + denom = ( leafn_to_retransn(p) + leafn_to_litter(p) ) + if ( denom /= 0.0_r8 ) then + fr_leafn_to_litter = leafn_to_litter(p) / ( leafn_to_retransn(p) + leafn_to_litter(p) ) + else if ( leafn_to_litter(p) == 0.0_r8 ) then + fr_leafn_to_litter = 0.0_r8 + else + fr_leafn_to_litter = 1.0_r8 + end if + + else + if (CNratio_floating .eqv. .true.) then + fr_leafn_to_litter = 0.5_r8 ! assuming 50% of nitrogen turnover goes to litter + end if + ! calculate the leaf N litterfall and retranslocation + leafn_to_litter(p) = leafc_to_litter(p) / lflitcn(ivt(p)) + leafn_to_retransn(p) = (leafc_to_litter(p) / leafcn(ivt(p))) - leafn_to_litter(p) + + if (use_matrixcn) then +! if(leafn(p) .gt. 0)then +! leafn_to_litter(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iout_phn,leafn_to_litter(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! leafn_to_retransn(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iretransn_phn,leafn_to_retransn(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! leafn_to_litter(p) = 0 +! leafn_to_retransn(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + end if + + ! calculate fine root N litterfall (no retranslocation of fine root N) + frootn_to_litter(p) = frootc_to_litter(p) / frootcn(ivt(p)) + if (use_matrixcn) then +! if(frootn(p) .gt. 0)then +! frootn_to_litter(p) = frootn(p) * matrix_update_phn(p,ifroot_to_iout_phn,frootn_to_litter(p) / frootn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! frootn_to_litter(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + + if (CNratio_floating .eqv. .true.) then + if (leafc(p) == 0.0_r8) then + ntovr_leaf = 0.0_r8 + else + ntovr_leaf = leafc_to_litter(p) * (leafn(p) / leafc(p)) + end if + + leafn_to_litter(p) = fr_leafn_to_litter * ntovr_leaf + leafn_to_retransn(p) = ntovr_leaf - leafn_to_litter(p) + if (use_matrixcn) then +! if(leafn(p) .gt. 0)then +! leafn_to_litter(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iout_phn,leafn_to_litter(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! leafn_to_retransn(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iretransn_phn,leafn_to_retransn(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! leafn_to_litter(p) = 0 +! leafn_to_retransn(p) = 0 +! end if + end if !use_matrixcn + if (frootc(p) == 0.0_r8) then + frootn_to_litter(p) = 0.0_r8 + else + frootn_to_litter(p) = frootc_to_litter(p) * (frootn(p) / frootc(p)) + end if + if (use_matrixcn) then +! if(frootn(p) .gt. 0)then +! frootn_to_litter(p) = frootn(p) * matrix_update_phn(p,ifroot_to_iout_phn,frootn_to_litter(p) / frootn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! frootn_to_litter(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + end if + + if ( use_fun ) then + if(frootn_to_litter(p)*dt.gt.frootn(p))then + if (.not. use_matrixcn) then + frootn_to_litter(p) = frootn(p)/dt + else + ! frootn_to_litter(p) = frootn(p) * matrix_update_phn(p,ifroot_to_iout_phn,1._r8/dt,dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) + end if + endif + end if + + if (ivt(p) >= npcropmin) then + ! NOTE(slevis, 2014-12) results in -ve livestemn and -ve totpftn + !X! livestemn_to_litter(p) = livestemc_to_litter(p) / livewdcn(ivt(p)) + ! NOTE(slevis, 2014-12) Beth Drewniak suggested this instead + livestemn_to_litter(p) = livestemn(p) / dt * (1._r8 - biofuel_harvfrac(ivt(p))) + if(use_matrixcn)then + ! livestemn_to_litter(p) = livestemn(p) * matrix_update_phn(p,ilivestem_to_iout_phn, (1._r8- biofuel_harvfrac(ivt(p)))/dt, dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) + end if + end if + + ! save the current litterfall fluxes + prev_leafc_to_litter(p) = leafc_to_litter(p) + prev_frootc_to_litter(p) = frootc_to_litter(p) + + end if ! end if offset period + + end do ! end patch loop + !matrix for leafn_to_retran will be added in allocation subroutine + + end associate + + end subroutine CNOffsetLitterfall + + !----------------------------------------------------------------------- + subroutine CNBackgroundLitterfall (num_soilp, filter_soilp, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! Determines the flux of C and N from displayed pools to litter + ! pools as the result of background litter fall. + ! + ! !USES: + use CNSharedParamsMod , only : use_fun + use clm_varctl , only : CNratio_floating + ! !ARGUMENTS: + implicit none + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type), intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: p ! indices + integer :: fp ! lake filter patch index + real(r8) :: fr_leafn_to_litter ! fraction of the nitrogen turnover that goes to litter; remaining fraction is retranslocated + real(r8) :: ntovr_leaf + real(r8) :: denom + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + lflitcn => pftcon%lflitcn , & ! Input: leaf litter C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: fine root C:N (gC/gN) + + bglfr => cnveg_state_inst%bglfr_patch , & ! Input: [real(r8) (:) ] background litterfall rate (1/s) + + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) fine root C + + leafc_to_litter => cnveg_carbonflux_inst%leafc_to_litter_patch , & ! Output: [real(r8) (:) ] + frootc_to_litter => cnveg_carbonflux_inst%frootc_to_litter_patch , & ! Output: [real(r8) (:) ] + + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N + leafn_to_litter => cnveg_nitrogenflux_inst%leafn_to_litter_patch , & ! Output: [real(r8) (:) ] + leafn_to_retransn => cnveg_nitrogenflux_inst%leafn_to_retransn_patch , & ! Output: [real(r8) (:) ] + frootn_to_litter => cnveg_nitrogenflux_inst%frootn_to_litter_patch , & ! Output: [real(r8) (:) ] + leafc_to_litter_fun => cnveg_carbonflux_inst%leafc_to_litter_fun_patch, & ! Output: [real(r8) (:) ] leaf C litterfall used by FUN (gC/m2/s) + leafcn_offset => cnveg_state_inst%leafcn_offset_patch , & ! Output: [real(r8) (:) ] Leaf C:N used by FUN + free_retransn_to_npool=> cnveg_nitrogenflux_inst%free_retransn_to_npool_patch , & ! Input: [real(r8) (:) ] free leaf N to retranslocated N pool (gN/m2/s) + paid_retransn_to_npool=> cnveg_nitrogenflux_inst%retransn_to_npool_patch , & ! Input: [real(r8) (:) ] free leaf N to retranslocated N pool (gN/m2/s) + + ileafst_to_ileafxf_phc => cnveg_carbonflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phc => cnveg_carbonflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phc => cnveg_carbonflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phc => cnveg_carbonflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phc => cnveg_carbonflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phc => cnveg_carbonflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phc => cnveg_carbonflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phc => cnveg_carbonflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phc => cnveg_carbonflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phc => cnveg_carbonflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phc => cnveg_carbonflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phc => cnveg_carbonflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phc => cnveg_carbonflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phc => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phc => cnveg_carbonflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phc => cnveg_carbonflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phc => cnveg_carbonflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + igrain_to_iout_phc => cnveg_carbonflux_inst%igrain_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ileafst_to_ileafxf_phn => cnveg_nitrogenflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phn => cnveg_nitrogenflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phn => cnveg_nitrogenflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phn => cnveg_nitrogenflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phn => cnveg_nitrogenflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phn => cnveg_nitrogenflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phn => cnveg_nitrogenflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phn => cnveg_nitrogenflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phn => cnveg_nitrogenflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phn => cnveg_nitrogenflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phn => cnveg_nitrogenflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phn => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phn => cnveg_nitrogenflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phn => cnveg_nitrogenflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phn => cnveg_nitrogenflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + ileaf_to_iretransn_phn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to retranslocation pool + ilivestem_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to retranslocation pool + ilivecroot_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivecroot_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root pool to retranslocation pool + igrain_to_iout_phn => cnveg_nitrogenflux_inst%igrain_to_iout_ph & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ) + + ! patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! only calculate these fluxes if the background litterfall rate is non-zero + if (bglfr(p) > 0._r8) then + ! units for bglfr are already 1/s + leafc_to_litter(p) = bglfr(p) * leafc(p) + frootc_to_litter(p) = bglfr(p) * frootc(p) + if (use_matrixcn) then + ! leafc_to_litter(p) = leafc(p) * matrix_update_phc(p,ileaf_to_iout_phc,bglfr(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) + ! x_updatefrootc_to_litter(p) = frootc(p) * matrix_update_phc(p,ifroot_to_iout_phc,bglfr(p),dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) + end if + if ( use_fun ) then + leafc_to_litter_fun(p) = leafc_to_litter(p) + leafn_to_retransn(p) = paid_retransn_to_npool(p) + free_retransn_to_npool(p) + if (leafn(p).gt.0._r8) then + if (leafn(p)-leafn_to_retransn(p)*dt.gt.0._r8) then + leafcn_offset(p) = leafc(p)/(leafn(p)-leafn_to_retransn(p)*dt) + else + leafcn_offset(p) = leafc(p)/leafn(p) + end if + else + leafcn_offset(p) = leafcn(ivt(p)) + end if + leafn_to_litter(p) = leafc_to_litter(p)/leafcn_offset(p) - leafn_to_retransn(p) + leafn_to_litter(p) = max(leafn_to_litter(p),0._r8) + if(use_matrixcn)then +! if(leafn(p) .ne. 0._r8)then +! leafn_to_litter(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iout_phn,leafn_to_litter(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! leafn_to_retransn(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iretransn_phn,leafn_to_retransn(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + + denom = ( leafn_to_retransn(p) + leafn_to_litter(p) ) + if ( denom /= 0.0_r8 ) then + fr_leafn_to_litter = leafn_to_litter(p) / ( leafn_to_retransn(p) + leafn_to_litter(p) ) + else if ( leafn_to_litter(p) == 0.0_r8 ) then + fr_leafn_to_litter = 0.0_r8 + else + fr_leafn_to_litter = 1.0_r8 + end if + + + else + if (CNratio_floating .eqv. .true.) then + fr_leafn_to_litter = 0.5_r8 ! assuming 50% of nitrogen turnover goes to litter + end if + ! calculate the leaf N litterfall and retranslocation + leafn_to_litter(p) = leafc_to_litter(p) / lflitcn(ivt(p)) + leafn_to_retransn(p) = (leafc_to_litter(p) / leafcn(ivt(p))) - leafn_to_litter(p) + + if (use_matrixcn) then +! if(leafn(p) .ne. 0)then +! leafn_to_litter(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iout_phn,leafn_to_litter(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! leafn_to_retransn(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iretransn_phn,leafn_to_retransn(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + end if + + ! calculate fine root N litterfall (no retranslocation of fine root N) + frootn_to_litter(p) = frootc_to_litter(p) / frootcn(ivt(p)) + + if (CNratio_floating .eqv. .true.) then + if (leafc(p) == 0.0_r8) then + ntovr_leaf = 0.0_r8 + else + ntovr_leaf = leafc_to_litter(p) * (leafn(p) / leafc(p)) + end if + + leafn_to_litter(p) = fr_leafn_to_litter * ntovr_leaf + leafn_to_retransn(p) = ntovr_leaf - leafn_to_litter(p) + if (use_matrixcn) then +! if(leafn(p) .gt. 0)then +! leafn_to_litter(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iout_phn,leafn_to_litter(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! leafn_to_retransn(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iretransn_phn,leafn_to_retransn(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! leafn_to_litter(p) = 0 +! leafn_to_retransn(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + if (frootc(p) == 0.0_r8) then + frootn_to_litter(p) = 0.0_r8 + else + frootn_to_litter(p) = frootc_to_litter(p) * (frootn(p) / frootc(p)) + end if + end if + + if ( use_fun ) then + if(frootn_to_litter(p)*dt.gt.frootn(p))then + frootn_to_litter(p) = frootn(p)/dt + endif + end if + + if (use_matrixcn) then +! if(frootn(p) .ne. 0)then +! frootn_to_litter(p) = frootn(p) * matrix_update_phn(p,ifroot_to_iout_phn,frootn_to_litter(p) / frootn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + end if + + end do + !matrix for retransn_to_leafn will be added in allocation subroutine + end associate + + end subroutine CNBackgroundLitterfall + + !----------------------------------------------------------------------- + subroutine CNLivewoodTurnover (num_soilp, filter_soilp, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! Determines the flux of C and N from live wood to + ! dead wood pools, for stem and coarse root. + ! + use CNSharedParamsMod, only: use_fun + use clm_varctl , only : CNratio_floating + ! !ARGUMENTS: + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: p ! indices + integer :: fp ! lake filter patch index + real(r8):: ctovr ! temporary variable for carbon turnover + real(r8):: ntovr ! temporary variable for nitrogen turnover + !----------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + livewdcn => pftcon%livewdcn , & ! Input: live wood (phloem and ray parenchyma) C:N (gC/gN) + deadwdcn => pftcon%deadwdcn , & ! Input: dead wood (xylem and heartwood) C:N (gC/gN) + + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live coarse root C + + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) live stem N + livecrootn => cnveg_nitrogenstate_inst%livecrootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) live coarse root N + retransn => cnveg_nitrogenstate_inst%retransn_patch , & ! Output: [real(r8) (:)] + + livestemc_to_deadstemc => cnveg_carbonflux_inst%livestemc_to_deadstemc_patch , & ! Output: [real(r8) (:) ] + livecrootc_to_deadcrootc => cnveg_carbonflux_inst%livecrootc_to_deadcrootc_patch , & ! Output: [real(r8) (:) ] + + livestemn_to_deadstemn => cnveg_nitrogenflux_inst%livestemn_to_deadstemn_patch , & ! Output: [real(r8) (:) ] + livestemn_to_retransn => cnveg_nitrogenflux_inst%livestemn_to_retransn_patch , & ! Output: [real(r8) (:) ] + livecrootn_to_deadcrootn => cnveg_nitrogenflux_inst%livecrootn_to_deadcrootn_patch , & ! Output: [real(r8) (:) ] + livecrootn_to_retransn => cnveg_nitrogenflux_inst%livecrootn_to_retransn_patch , & ! Output: [real(r8) (:) ] + free_retransn_to_npool => cnveg_nitrogenflux_inst%free_retransn_to_npool_patch , & ! Input: [real(r8) (:) ] free leaf N to retranslocated N pool (gN/m2/s) + ileafst_to_ileafxf_phc => cnveg_carbonflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phc => cnveg_carbonflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phc => cnveg_carbonflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phc => cnveg_carbonflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phc => cnveg_carbonflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phc => cnveg_carbonflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phc => cnveg_carbonflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phc => cnveg_carbonflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phc => cnveg_carbonflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phc => cnveg_carbonflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phc => cnveg_carbonflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phc => cnveg_carbonflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phc => cnveg_carbonflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phc => cnveg_carbonflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phc => cnveg_carbonflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phc => cnveg_carbonflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phc => cnveg_carbonflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + igrain_to_iout_phc => cnveg_carbonflux_inst%igrain_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ileafst_to_ileafxf_phn => cnveg_nitrogenflux_inst%ileafst_to_ileafxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf storage pool to leaf transfer pool + ileafxf_to_ileaf_phn => cnveg_nitrogenflux_inst%ileafxf_to_ileaf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf transfer pool to leaf pool + ifrootst_to_ifrootxf_phn => cnveg_nitrogenflux_inst%ifrootst_to_ifrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root storage pool to fine root transfer pool + ifrootxf_to_ifroot_phn => cnveg_nitrogenflux_inst%ifrootxf_to_ifroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root transfer pool to fine root pool + ilivestemst_to_ilivestemxf_phn => cnveg_nitrogenflux_inst%ilivestemst_to_ilivestemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem storage pool to live stem transfer pool + ilivestemxf_to_ilivestem_phn => cnveg_nitrogenflux_inst%ilivestemxf_to_ilivestem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem transfer pool to live stem pool + ideadstemst_to_ideadstemxf_phn => cnveg_nitrogenflux_inst%ideadstemst_to_ideadstemxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem storage pool to dead stem transfer pool + ideadstemxf_to_ideadstem_phn => cnveg_nitrogenflux_inst%ideadstemxf_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead stem transfer pool to dead stem pool + ilivecrootst_to_ilivecrootxf_phn => cnveg_nitrogenflux_inst%ilivecrootst_to_ilivecrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root storage pool to live coarse root transfer pool + ilivecrootxf_to_ilivecroot_phn => cnveg_nitrogenflux_inst%ilivecrootxf_to_ilivecroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root transfer pool to live coarse root pool + ideadcrootst_to_ideadcrootxf_phn => cnveg_nitrogenflux_inst%ideadcrootst_to_ideadcrootxf_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root storage pool to dead coarse root transfer pool + ideadcrootxf_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ideadcrootxf_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from dead coarse root transfer pool to dead coarse root pool + ilivestem_to_ideadstem_phn => cnveg_nitrogenflux_inst%ilivestem_to_ideadstem_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to dead stem pool + ilivecroot_to_ideadcroot_phn => cnveg_nitrogenflux_inst%ilivecroot_to_ideadcroot_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root to dead coarse root pool + ileaf_to_iout_phn => cnveg_nitrogenflux_inst%ileaf_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to outside of vegetation pools + ifroot_to_iout_phn => cnveg_nitrogenflux_inst%ifroot_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from fine root pool to outside of vegetation pools + ilivestem_to_iout_phn => cnveg_nitrogenflux_inst%ilivestem_to_iout_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to outside of vegetation pools + ileaf_to_iretransn_phn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from leaf pool to retranslocation pool + ilivestem_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live stem pool to retranslocation pool + ilivecroot_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivecroot_to_iretransn_ph , & ! Input: [integer (:)] Index of phenology related C transfer from live coarse root pool to retranslocation pool + iretransn_to_iout => cnveg_nitrogenflux_inst%iretransn_to_iout_ph , & ! Input: [integer ] + igrain_to_iout_phn => cnveg_nitrogenflux_inst%igrain_to_iout_ph & ! Input: [integer (:)] Index of phenology related C transfer from grain pool to outside of vegetation pools + ) + + + + ! patch loop +ptch: do fp = 1,num_soilp + p = filter_soilp(fp) + + ! only calculate these fluxes for woody types + if (woody(ivt(p)) > 0._r8) then + + ! live stem to dead stem turnover + + ctovr = livestemc(p) * lwtop + ntovr = ctovr / livewdcn(ivt(p)) + livestemc_to_deadstemc(p) = ctovr + livestemn_to_deadstemn(p) = ctovr / deadwdcn(ivt(p)) + if( use_matrixcn)then +! livestemc_to_deadstemc(p) = livestemc(p) * matrix_update_phc(p,ilivestem_to_ideadstem_phc,lwtop,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) +! if (livestemn(p) .gt. 0.0_r8) then +! livestemn_to_deadstemn(p) = livestemn(p) * matrix_update_phn(p,ilivestem_to_ideadstem_phn,livestemn_to_deadstemn(p)/livestemn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! livestemn_to_deadstemn(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + end if + if (CNratio_floating .eqv. .true.) then + if (livestemc(p) == 0.0_r8) then + ntovr = 0.0_r8 + livestemn_to_deadstemn(p) = 0.0_r8 + else + ntovr = ctovr * (livestemn(p) / livestemc(p)) + livestemn_to_deadstemn(p) = ctovr / deadwdcn(ivt(p)) + end if + + if (use_matrixcn)then +! if (livestemn(p) .gt. 0.0_r8) then +! livestemn_to_deadstemn(p) = livestemn(p) * matrix_update_phn(p,ilivestem_to_ideadstem_phn,& +! livestemn_to_deadstemn(p) / livestemn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! else +! livestemn_to_deadstemn(p) = 0 +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if + end if + + livestemn_to_retransn(p) = ntovr - livestemn_to_deadstemn(p) + !matrix for livestemn_to_retransn will be added in allocation subroutine + + ! live coarse root to dead coarse root turnover + + ctovr = livecrootc(p) * lwtop + ntovr = ctovr / livewdcn(ivt(p)) + if(.not. use_matrixcn)then + ! NOTE: The non matrix version of this is in CNCStateUpdate1::CStateUpdate1 EBK (11/26/2019) + ! and CNNStateUpdate1::NStateUpdate1 + livecrootc_to_deadcrootc(p) = ctovr + livecrootn_to_deadcrootn(p) = ctovr / deadwdcn(ivt(p)) + else + ! livecrootc_to_deadcrootc(p) = livecrootc(p) * matrix_update_phc(p,ilivecroot_to_ideadcroot_phc,lwtop,dt,cnveg_carbonflux_inst,matrixcheck_ph,acc_ph) + ! livecrootn_to_deadcrootn(p) = livecrootn(p) * matrix_update_phn(p,ilivecroot_to_ideadcroot_phn,lwtop/deadwdcn(ivt(p)),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) + end if !use_matrixcn + + if (CNratio_floating .eqv. .true.) then + if (livecrootc(p) == 0.0_r8) then + ntovr = 0.0_r8 + livecrootn_to_deadcrootn(p) = 0.0_r8 + else + ntovr = ctovr * (livecrootn(p) / livecrootc(p)) + livecrootn_to_deadcrootn(p) = ctovr / deadwdcn(ivt(p)) + end if + + if (use_matrixcn)then +! if (livecrootn(p) .ne.0.0_r8 )then +! livecrootn_to_deadcrootn(p) = matrix_update_phn(p,ilivecroot_to_ideadcroot_phn,& +! livecrootn_to_deadcrootn(p) / livecrootn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) * livecrootn(p) +! end if + else + ! NOTE: The non matrix version of this is in CNNStateUpdate1::NStateUpdate1 EBK (11/26/2019) + end if !use_matrixcn + end if + + livecrootn_to_retransn(p) = ntovr - livecrootn_to_deadcrootn(p) + if(use_matrixcn)then +! if(livecrootn(p) .gt. 0.0_r8) then +! livecrootn_to_retransn(p) = matrix_update_phn(p,ilivecroot_to_iretransn_phn,& +! livecrootn_to_retransn(p) / livecrootn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) * livecrootn(p) +! else +! livecrootn_to_retransn(p) = 0 +! end if +! if(livestemn(p) .gt. 0.0_r8) then +! livestemn_to_retransn(p) = matrix_update_phn(p,ilivestem_to_iretransn_phn,& +! livestemn_to_retransn(p) / livestemn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) * livestemn(p) +! else +! livestemn_to_retransn(p) = 0 +! end if +! ! WW change logic so livestem_retrans goes to npool (via +! ! free_retrans flux) +! ! this should likely be done more cleanly if it works, i.e. not +! ! update fluxes w/ states +! ! additional considerations for crop? +! ! The non-matrix version of this is in NStateUpdate1 +! if (use_fun) then +! if (retransn(p) .gt. 0._r8) then +! ! The acc matrix check MUST be turned on, or this will +! ! fail with Nitrogen balance error EBK 03/11/2021 +! free_retransn_to_npool(p) = free_retransn_to_npool(p) + retransn(p) * matrix_update_phn(p,iretransn_to_iout, & +! (livestemn_to_retransn(p) + livecrootn_to_retransn(p)) / retransn(p),dt, & +! cnveg_nitrogenflux_inst, matrixcheck_ph, acc=.true.) +! else +! free_retransn_to_npool(p) = 0._r8 +! end if +! end if + end if !use_matrixcn + + end if + + end do ptch + + end associate + + end subroutine CNLivewoodTurnover + + !----------------------------------------------------------------------- + subroutine CNCropHarvestToProductPools(bounds, num_soilp, filter_soilp, num_soilc, filter_soilc, & + cnveg_carbonflux_inst, cnveg_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! If using prognostic crop, then move any necessary harvested amounts into fluxes + ! destined for the product pools. + ! + ! !USES: + use clm_varctl , only : use_crop + use clm_varctl , only : use_grainproduct + use subgridAveMod , only : p2c + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: fp, p + + character(len=*), parameter :: subname = 'CNCropHarvestToProductPools' + !----------------------------------------------------------------------- + + if (use_crop) then + do fp = 1, num_soilp + p = filter_soilp(fp) + cnveg_carbonflux_inst%grainc_to_cropprodc_patch(p) = cnveg_carbonflux_inst%leafc_to_biofuelc_patch(p) + & + cnveg_carbonflux_inst%livestemc_to_biofuelc_patch(p) + cnveg_nitrogenflux_inst%grainn_to_cropprodn_patch(p) = cnveg_nitrogenflux_inst%leafn_to_biofueln_patch(p) + & + cnveg_nitrogenflux_inst%livestemn_to_biofueln_patch(p) + end do + + if (use_grainproduct) then + do fp = 1, num_soilp + p = filter_soilp(fp) + cnveg_carbonflux_inst%grainc_to_cropprodc_patch(p) = cnveg_carbonflux_inst%grainc_to_cropprodc_patch(p) + & + cnveg_carbonflux_inst%grainc_to_food_patch(p) + cnveg_nitrogenflux_inst%grainn_to_cropprodn_patch(p) = cnveg_nitrogenflux_inst%grainn_to_cropprodn_patch(p) + & + cnveg_nitrogenflux_inst%grainn_to_food_patch(p) + end do + end if + + call p2c (bounds, num_soilc, filter_soilc, & + cnveg_carbonflux_inst%grainc_to_cropprodc_patch(bounds%begp:bounds%endp), & + cnveg_carbonflux_inst%grainc_to_cropprodc_col(bounds%begc:bounds%endc)) + + call p2c (bounds, num_soilc, filter_soilc, & + cnveg_nitrogenflux_inst%grainn_to_cropprodn_patch(bounds%begp:bounds%endp), & + cnveg_nitrogenflux_inst%grainn_to_cropprodn_col(bounds%begc:bounds%endc)) + + end if + + end subroutine CNCropHarvestToProductPools + + !----------------------------------------------------------------------- + subroutine CNLitterToColumn (bounds, num_soilc, filter_soilc, & + cnveg_state_inst,cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, & + leaf_prof_patch, froot_prof_patch) + ! + ! !DESCRIPTION: + ! called at the end of cn_phenology to gather all patch-level litterfall fluxes + ! to the column level and assign them to the three litter pools + ! + ! !USES: + use clm_varpar , only : max_patch_per_col, nlevdecomp + use pftconMod , only : npcropmin + use clm_varctl , only : use_grainproduct + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(cnveg_state_type) , intent(in) :: cnveg_state_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + real(r8) , intent(in) :: leaf_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: froot_prof_patch(bounds%begp:,1:) + ! + ! !LOCAL VARIABLES: + integer :: fc,c,pi,p,j ! indices + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(leaf_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(froot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), sourcefile, __LINE__) + + associate( & + leaf_prof => leaf_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of leaves + froot_prof => froot_prof_patch , & ! Input: [real(r8) (:,:) ] (1/m) profile of fine roots + + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + wtcol => patch%wtcol , & ! Input: [real(r8) (:) ] weight (relative to column) for this patch (0-1) + + lf_flab => pftcon%lf_flab , & ! Input: leaf litter labile fraction + lf_fcel => pftcon%lf_fcel , & ! Input: leaf litter cellulose fraction + lf_flig => pftcon%lf_flig , & ! Input: leaf litter lignin fraction + fr_flab => pftcon%fr_flab , & ! Input: fine root litter labile fraction + fr_fcel => pftcon%fr_fcel , & ! Input: fine root litter cellulose fraction + fr_flig => pftcon%fr_flig , & ! Input: fine root litter lignin fraction + + leafc_to_litter => cnveg_carbonflux_inst%leafc_to_litter_patch , & ! Input: [real(r8) (:) ] leaf C litterfall (gC/m2/s) + frootc_to_litter => cnveg_carbonflux_inst%frootc_to_litter_patch , & ! Input: [real(r8) (:) ] fine root N litterfall (gN/m2/s) + livestemc_to_litter => cnveg_carbonflux_inst%livestemc_to_litter_patch , & ! Input: [real(r8) (:) ] live stem C litterfall (gC/m2/s) + grainc_to_food => cnveg_carbonflux_inst%grainc_to_food_patch , & ! Input: [real(r8) (:) ] grain C to food (gC/m2/s) + phenology_c_to_litr_met_c => cnveg_carbonflux_inst%phenology_c_to_litr_met_c_col , & ! Output: [real(r8) (:,:) ] C fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gC/m3/s) + phenology_c_to_litr_cel_c => cnveg_carbonflux_inst%phenology_c_to_litr_cel_c_col , & ! Output: [real(r8) (:,:) ] C fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gC/m3/s) + phenology_c_to_litr_lig_c => cnveg_carbonflux_inst%phenology_c_to_litr_lig_c_col , & ! Output: [real(r8) (:,:) ] C fluxes associated with phenology (litterfall and crop) to litter lignin pool (gC/m3/s) + + livestemn_to_litter => cnveg_nitrogenflux_inst%livestemn_to_litter_patch , & ! Input: [real(r8) (:) ] livestem N to litter (gN/m2/s) + grainn_to_food => cnveg_nitrogenflux_inst%grainn_to_food_patch , & ! Input: [real(r8) (:) ] grain N to food (gN/m2/s) + leafn_to_litter => cnveg_nitrogenflux_inst%leafn_to_litter_patch , & ! Input: [real(r8) (:) ] leaf N litterfall (gN/m2/s) + frootn_to_litter => cnveg_nitrogenflux_inst%frootn_to_litter_patch , & ! Input: [real(r8) (:) ] fine root N litterfall (gN/m2/s) + phenology_n_to_litr_met_n => cnveg_nitrogenflux_inst%phenology_n_to_litr_met_n_col , & ! Output: [real(r8) (:,:) ] N fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gN/m3/s) + phenology_n_to_litr_cel_n => cnveg_nitrogenflux_inst%phenology_n_to_litr_cel_n_col , & ! Output: [real(r8) (:,:) ] N fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gN/m3/s) + phenology_n_to_litr_lig_n => cnveg_nitrogenflux_inst%phenology_n_to_litr_lig_n_col & ! Output: [real(r8) (:,:) ] N fluxes associated with phenology (litterfall and crop) to litter lignin pool (gN/m3/s) + ) + + do j = 1, nlevdecomp + do pi = 1,max_patch_per_col + do fc = 1,num_soilc + c = filter_soilc(fc) + + if ( pi <= col%npatches(c) ) then + p = col%patchi(c) + pi - 1 + if (patch%active(p)) then + ! leaf litter carbon fluxes + phenology_c_to_litr_met_c(c,j) = phenology_c_to_litr_met_c(c,j) & + + leafc_to_litter(p) * lf_flab(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_c_to_litr_cel_c(c,j) = phenology_c_to_litr_cel_c(c,j) & + + leafc_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_c_to_litr_lig_c(c,j) = phenology_c_to_litr_lig_c(c,j) & + + leafc_to_litter(p) * lf_flig(ivt(p)) * wtcol(p) * leaf_prof(p,j) + + ! leaf litter nitrogen fluxes + phenology_n_to_litr_met_n(c,j) = phenology_n_to_litr_met_n(c,j) & + + leafn_to_litter(p) * lf_flab(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_n_to_litr_cel_n(c,j) = phenology_n_to_litr_cel_n(c,j) & + + leafn_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_n_to_litr_lig_n(c,j) = phenology_n_to_litr_lig_n(c,j) & + + leafn_to_litter(p) * lf_flig(ivt(p)) * wtcol(p) * leaf_prof(p,j) + + ! fine root litter carbon fluxes + phenology_c_to_litr_met_c(c,j) = phenology_c_to_litr_met_c(c,j) & + + frootc_to_litter(p) * fr_flab(ivt(p)) * wtcol(p) * froot_prof(p,j) + phenology_c_to_litr_cel_c(c,j) = phenology_c_to_litr_cel_c(c,j) & + + frootc_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p) * froot_prof(p,j) + phenology_c_to_litr_lig_c(c,j) = phenology_c_to_litr_lig_c(c,j) & + + frootc_to_litter(p) * fr_flig(ivt(p)) * wtcol(p) * froot_prof(p,j) + + ! fine root litter nitrogen fluxes + phenology_n_to_litr_met_n(c,j) = phenology_n_to_litr_met_n(c,j) & + + frootn_to_litter(p) * fr_flab(ivt(p)) * wtcol(p) * froot_prof(p,j) + phenology_n_to_litr_cel_n(c,j) = phenology_n_to_litr_cel_n(c,j) & + + frootn_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p) * froot_prof(p,j) + phenology_n_to_litr_lig_n(c,j) = phenology_n_to_litr_lig_n(c,j) & + + frootn_to_litter(p) * fr_flig(ivt(p)) * wtcol(p) * froot_prof(p,j) + + ! agroibis puts crop stem litter together with leaf litter + ! so I've used the leaf lf_f* parameters instead of making + ! new ones for now (slevis) + ! also for simplicity I've put "food" into the litter pools + + if (ivt(p) >= npcropmin) then ! add livestemc to litter + ! stem litter carbon fluxes + phenology_c_to_litr_met_c(c,j) = phenology_c_to_litr_met_c(c,j) & + + livestemc_to_litter(p) * lf_flab(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_c_to_litr_cel_c(c,j) = phenology_c_to_litr_cel_c(c,j) & + + livestemc_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_c_to_litr_lig_c(c,j) = phenology_c_to_litr_lig_c(c,j) & + + livestemc_to_litter(p) * lf_flig(ivt(p)) * wtcol(p) * leaf_prof(p,j) + + ! stem litter nitrogen fluxes + phenology_n_to_litr_met_n(c,j) = phenology_n_to_litr_met_n(c,j) & + + livestemn_to_litter(p) * lf_flab(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_n_to_litr_cel_n(c,j) = phenology_n_to_litr_cel_n(c,j) & + + livestemn_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_n_to_litr_lig_n(c,j) = phenology_n_to_litr_lig_n(c,j) & + + livestemn_to_litter(p) * lf_flig(ivt(p)) * wtcol(p) * leaf_prof(p,j) + + if (.not. use_grainproduct) then + ! grain litter carbon fluxes + phenology_c_to_litr_met_c(c,j) = phenology_c_to_litr_met_c(c,j) & + + grainc_to_food(p) * lf_flab(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_c_to_litr_cel_c(c,j) = phenology_c_to_litr_cel_c(c,j) & + + grainc_to_food(p) * lf_fcel(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_c_to_litr_lig_c(c,j) = phenology_c_to_litr_lig_c(c,j) & + + grainc_to_food(p) * lf_flig(ivt(p)) * wtcol(p) * leaf_prof(p,j) + + ! grain litter nitrogen fluxes + phenology_n_to_litr_met_n(c,j) = phenology_n_to_litr_met_n(c,j) & + + grainn_to_food(p) * lf_flab(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_n_to_litr_cel_n(c,j) = phenology_n_to_litr_cel_n(c,j) & + + grainn_to_food(p) * lf_fcel(ivt(p)) * wtcol(p) * leaf_prof(p,j) + phenology_n_to_litr_lig_n(c,j) = phenology_n_to_litr_lig_n(c,j) & + + grainn_to_food(p) * lf_flig(ivt(p)) * wtcol(p) * leaf_prof(p,j) + end if + + + end if + end if + end if + + end do + + end do + end do + + end associate + + end subroutine CNLitterToColumn + +end module CNPhenologyMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNPrecisionControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNPrecisionControlMod.F90 new file mode 100755 index 000000000..e904c7f2b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNPrecisionControlMod.F90 @@ -0,0 +1,865 @@ +module CNPrecisionControlMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! controls on very low values in critical state variables + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use PatchType , only : patch + use abortutils , only : endrun + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: CNPrecisionControlReadNML + public:: CNPrecisionControl + + ! !PUBLIC DATA: + real(r8), public :: ccrit = 1.e-8_r8 ! critical carbon state value for truncation (gC/m2) + real(r8), public :: cnegcrit = -6.e+1_r8 ! critical negative carbon state value for abort (gC/m2) + real(r8), public :: ncrit = 1.e-8_r8 ! critical nitrogen state value for truncation (gN/m2) + real(r8), public :: nnegcrit = -7.e+0_r8 ! critical negative nitrogen state value for abort (gN/m2) + real(r8), public, parameter :: n_min = 0.000000001_r8 ! Minimum Nitrogen value to use when calculating CN ratio (gN/m2) + + ! !PRIVATE DATA: + logical, private :: prec_control_for_froot = .true. ! If true do precision control for frootc/frootn + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CNPrecisionControlReadNML( NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for CN Precision control + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog, use_nguardrail + use shr_log_mod , only : errMsg => shr_log_errMsg + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'CNPrecisionControlReadNML' + character(len=*), parameter :: nmlname = 'cnprecision_inparm' + !----------------------------------------------------------------------- + namelist /cnprecision_inparm/ ncrit, ccrit, cnegcrit, nnegcrit + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=cnprecision_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (ncrit , mpicom) + call shr_mpi_bcast (ccrit , mpicom) + call shr_mpi_bcast (nnegcrit, mpicom) + call shr_mpi_bcast (cnegcrit, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=cnprecision_inparm) + write(iulog,*) ' ' + end if + + ! Have precision control for froot be determined by use_nguardrail setting + prec_control_for_froot = .not. use_nguardrail + + end subroutine CNPrecisionControlReadNML + + !----------------------------------------------------------------------- + subroutine CNPrecisionControl(bounds, num_soilp, filter_soilp, & + cnveg_carbonstate_inst, c13_cnveg_carbonstate_inst, c14_cnveg_carbonstate_inst, & + cnveg_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! Force leaf and deadstem c and n to 0 if they get too small. + ! + ! !USES: + use clm_varctl , only : iulog, use_c13, use_c14 + use clm_varctl , only : use_crop + use pftconMod , only : nc3crop + use decompMod , only : bounds_type + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: num_soilp ! number of soil patchs in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonstate_type) , intent(inout) :: c13_cnveg_carbonstate_inst + type(cnveg_carbonstate_type) , intent(inout) :: c14_cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: p,j,k ! indices + integer :: fp ! filter indices + integer :: num_truncatep ! number of points in filter_truncatep + integer :: filter_truncatep(bounds%endp-bounds%begp+1) ! filter for points that need truncation + real(r8):: pc(bounds%begp:bounds%endp) ! truncation terms for patch-level corrections Carbon + real(r8):: pn(bounds%begp:bounds%endp) ! truncation terms for patch-level corrections nitrogen + real(r8):: pc13(bounds%begp:bounds%endp) ! truncation terms for patch-level corrections + real(r8):: pc14(bounds%begp:bounds%endp) ! truncation terms for patch-level corrections + !----------------------------------------------------------------------- + + ! cnveg_carbonstate_inst%cpool_patch Output: [real(r8) (:) ] (gC/m2) temporary photosynthate C pool + ! cnveg_carbonstate_inst%deadcrootc_patch Output: [real(r8) (:) ] (gC/m2) dead coarse root C + ! cnveg_carbonstate_inst%deadcrootc_storage_patch Output: [real(r8) (:) ] (gC/m2) dead coarse root C storage + ! cnveg_carbonstate_inst%deadcrootc_xfer_patch Output: [real(r8) (:) ] (gC/m2) dead coarse root C transfer + ! cnveg_carbonstate_inst%deadstemc_patch Output: [real(r8) (:) ] (gC/m2) dead stem C + ! cnveg_carbonstate_inst%deadstemc_storage_patch Output: [real(r8) (:) ] (gC/m2) dead stem C storage + ! cnveg_carbonstate_inst%deadstemc_xfer_patch Output: [real(r8) (:) ] (gC/m2) dead stem C transfer + ! cnveg_carbonstate_inst%frootc_patch Output: [real(r8) (:) ] (gC/m2) fine root C + ! cnveg_carbonstate_inst%frootc_storage_patch Output: [real(r8) (:) ] (gC/m2) fine root C storage + ! cnveg_carbonstate_inst%frootc_xfer_patch Output: [real(r8) (:) ] (gC/m2) fine root C transfer + ! cnveg_carbonstate_inst%gresp_storage_patch Output: [real(r8) (:) ] (gC/m2) growth respiration storage + ! cnveg_carbonstate_inst%gresp_xfer_patch Output: [real(r8) (:) ] (gC/m2) growth respiration transfer + ! cnveg_carbonstate_inst%leafc_patch Output: [real(r8) (:) ] (gC/m2) leaf C + ! cnveg_carbonstate_inst%leafc_storage_patch Output: [real(r8) (:) ] (gC/m2) leaf C storage + ! cnveg_carbonstate_inst%leafc_xfer_patch Output: [real(r8) (:) ] (gC/m2) leaf C transfer + ! cnveg_carbonstate_inst%livecrootc_patch Output: [real(r8) (:) ] (gC/m2) live coarse root C + ! cnveg_carbonstate_inst%livecrootc_storage_patch Output: [real(r8) (:) ] (gC/m2) live coarse root C storage + ! cnveg_carbonstate_inst%livecrootc_xfer_patch Output: [real(r8) (:) ] (gC/m2) live coarse root C transfer + ! cnveg_carbonstate_inst%livestemc_patch Output: [real(r8) (:) ] (gC/m2) live stem C + ! cnveg_carbonstate_inst%livestemc_storage_patch Output: [real(r8) (:) ] (gC/m2) live stem C storage + ! cnveg_carbonstate_inst%livestemc_xfer_patch Output: [real(r8) (:) ] (gC/m2) live stem C transfer + ! cnveg_carbonstate_inst%ctrunc_patch Output: [real(r8) (:) ] (gC/m2) patch-level sink for C truncation + ! cnveg_carbonstate_inst%xsmrpool_patch Output: [real(r8) (:) ] (gC/m2) execss maint resp C pool + ! cnveg_carbonstate_inst%grainc_patch Output: [real(r8) (:) ] (gC/m2) grain C + ! cnveg_carbonstate_inst%grainc_storage_patch Output: [real(r8) (:) ] (gC/m2) grain C storage + ! cnveg_carbonstate_inst%grainc_xfer_patch Output: [real(r8) (:) ] (gC/m2) grain C transfer + + ! cnveg_nitrogenstate_inst%deadcrootn_patch Output: [real(r8) (:) ] (gN/m2) dead coarse root N + ! cnveg_nitrogenstate_inst%deadcrootn_storage_patch Output: [real(r8) (:) ] (gN/m2) dead coarse root N storage + ! cnveg_nitrogenstate_inst%deadcrootn_xfer_patch Output: [real(r8) (:) ] (gN/m2) dead coarse root N transfer + ! cnveg_nitrogenstate_inst%deadstemn_patch Output: [real(r8) (:) ] (gN/m2) dead stem N + ! cnveg_nitrogenstate_inst%deadstemn_storage_patch Output: [real(r8) (:) ] (gN/m2) dead stem N storage + ! cnveg_nitrogenstate_inst%deadstemn_xfer_patch Output: [real(r8) (:) ] (gN/m2) dead stem N transfer + ! cnveg_nitrogenstate_inst%frootn_patch Output: [real(r8) (:) ] (gN/m2) fine root N + ! cnveg_nitrogenstate_inst%frootn_storage_patch Output: [real(r8) (:) ] (gN/m2) fine root N storage + ! cnveg_nitrogenstate_inst%frootn_xfer_patch Output: [real(r8) (:) ] (gN/m2) fine root N transfer + ! cnveg_nitrogenstate_inst%leafn_patch Output: [real(r8) (:) ] (gN/m2) leaf N + ! cnveg_nitrogenstate_inst%leafn_storage_patch Output: [real(r8) (:) ] (gN/m2) leaf N storage + ! cnveg_nitrogenstate_inst%leafn_xfer_patch Output: [real(r8) (:) ] (gN/m2) leaf N transfer + ! cnveg_nitrogenstate_inst%livecrootn_patch Output: [real(r8) (:) ] (gN/m2) live coarse root N + ! cnveg_nitrogenstate_inst%livecrootn_storage_patch Output: [real(r8) (:) ] (gN/m2) live coarse root N storage + ! cnveg_nitrogenstate_inst%livecrootn_xfer_patch Output: [real(r8) (:) ] (gN/m2) live coarse root N transfer + ! cnveg_nitrogenstate_inst%grainn_patch Output: [real(r8) (:) ] (gC/m2) grain N + ! cnveg_nitrogenstate_inst%grainn_storage_patch Output: [real(r8) (:) ] (gC/m2) grain N storage + ! cnveg_nitrogenstate_inst%grainn_xfer_patch Output: [real(r8) (:) ] (gC/m2) grain N transfer + ! cnveg_nitrogenstate_inst%livestemn_patch Output: [real(r8) (:) ] (gN/m2) live stem N + ! cnveg_nitrogenstate_inst%livestemn_storage_patch Output: [real(r8) (:) ] (gN/m2) live stem N storage + ! cnveg_nitrogenstate_inst%livestemn_xfer_patch Output: [real(r8) (:) ] (gN/m2) live stem N transfer + ! cnveg_nitrogenstate_inst%npool_patch Output: [real(r8) (:) ] (gN/m2) temporary plant N pool + ! cnveg_nitrogenstate_inst%ntrunc_patch Output: [real(r8) (:) ] (gN/m2) patch-level sink for N truncation + ! cnveg_nitrogenstate_inst%retransn_patch Output: [real(r8) (:) ] (gN/m2) plant pool of retranslocated N + + + associate( & + cs => cnveg_carbonstate_inst , & + ns => cnveg_nitrogenstate_inst , & + c13cs => c13_cnveg_carbonstate_inst , & + c14cs => c14_cnveg_carbonstate_inst & + ) + + ! patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! initialize the patch-level C and N truncation terms + pc(p) = 0._r8 + pn(p) = 0._r8 + if ( use_c13 ) pc13(p) = 0._r8 + if ( use_c14 ) pc14(p) = 0._r8 + end do + + ! do tests on state variables for precision control + ! for linked C-N state variables, perform precision test on + ! the C component, but truncate C, C13, and N components + + ! leaf C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%leafc_patch(bounds%begp:bounds%endp), & + ns%leafn_patch(bounds%begp:bounds%endp), & + pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep) + + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%leafc_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%leafc_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + + ! leaf storage C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%leafc_storage_patch(bounds%begp:bounds%endp), & + ns%leafn_storage_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%leafc_storage_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%leafc_storage_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! leaf transfer C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%leafc_xfer_patch(bounds%begp:bounds%endp), & + ns%leafn_xfer_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%leafc_xfer_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%leafc_xfer_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! froot C and N + ! EBK KO DML: For some reason frootc/frootn can go negative and allowing + ! it to be negative is important for C4 crops (otherwise they die) Jun/3/2016 + if ( prec_control_for_froot ) then + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%frootc_patch(bounds%begp:bounds%endp), & + ns%frootn_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep, allowneg=.true.) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%frootc_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%frootc_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + end if + + ! froot storage C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%frootc_storage_patch(bounds%begp:bounds%endp), & + ns%frootn_storage_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%frootc_storage_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%frootc_storage_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! froot transfer C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%frootc_xfer_patch(bounds%begp:bounds%endp), & + ns%frootn_xfer_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%frootc_xfer_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%frootc_xfer_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + if ( use_crop )then + ! grain C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%grainc_patch(bounds%begp:bounds%endp), & + ns%grainn_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep, croponly=.true. ) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%grainc_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%grainc_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! grain storage C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%grainc_storage_patch(bounds%begp:bounds%endp), & + ns%grainn_storage_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep, croponly=.true. ) + + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%grainc_storage_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%grainc_storage_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! grain transfer C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%grainc_xfer_patch(bounds%begp:bounds%endp), & + ns%grainn_xfer_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep, croponly=.true.) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%grainc_xfer_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%grainc_xfer_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! grain transfer C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%cropseedc_deficit_patch(bounds%begp:bounds%endp), & + ns%cropseedn_deficit_patch(bounds%begp:bounds%endp), pc(bounds%begp:), & + pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep, & + allowneg=.true., croponly=.true. ) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%cropseedc_deficit_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%cropseedc_deficit_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + end if + + ! livestem C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%livestemc_patch(bounds%begp:bounds%endp), & + ns%livestemn_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%livestemc_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%livestemc_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! livestem storage C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%livestemc_storage_patch(bounds%begp:bounds%endp), & + ns%livestemn_storage_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%livestemc_storage_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%livestemc_storage_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + ! livestem transfer C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%livestemc_xfer_patch(bounds%begp:bounds%endp), & + ns%livestemn_xfer_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%livestemc_xfer_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%livestemc_xfer_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! deadstem C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%deadstemc_patch(bounds%begp:bounds%endp), & + ns%deadstemn_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%deadstemc_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%deadstemc_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + ! deadstem storage C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%deadstemc_storage_patch(bounds%begp:bounds%endp), & + ns%deadstemn_storage_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%deadstemc_storage_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%deadstemc_storage_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! deadstem transfer C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%deadstemc_xfer_patch(bounds%begp:bounds%endp), & + ns%deadstemn_xfer_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%deadstemc_xfer_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%deadstemc_xfer_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! livecroot C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%livecrootc_patch(bounds%begp:bounds%endp), & + ns%livecrootn_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%livecrootc_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%livecrootc_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! livecroot storage C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%livecrootc_storage_patch(bounds%begp:bounds%endp), & + ns%livecrootn_storage_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%livecrootc_storage_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%livecrootc_storage_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! livecroot transfer C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%livecrootc_xfer_patch(bounds%begp:bounds%endp), & + ns%livecrootn_xfer_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%livecrootc_xfer_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%livecrootc_xfer_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! deadcroot C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%deadcrootc_patch(bounds%begp:bounds%endp), & + ns%deadcrootn_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), __LINE__, & + num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%deadcrootc_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%deadcrootc_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! deadcroot storage C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%deadcrootc_storage_patch(bounds%begp:bounds%endp), & + ns%deadcrootn_storage_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%deadcrootc_storage_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%deadcrootc_storage_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! deadcroot transfer C and N + call TruncateCandNStates( bounds, filter_soilp, num_soilp, cs%deadcrootc_xfer_patch(bounds%begp:bounds%endp), & + ns%deadcrootn_xfer_patch(bounds%begp:bounds%endp), pc(bounds%begp:), pn(bounds%begp:), & + __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%deadcrootc_xfer_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%deadcrootc_xfer_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! gresp_storage (C only) + call TruncateCStates( bounds, filter_soilp, num_soilp, cs%gresp_storage_patch(bounds%begp:bounds%endp), & + pc(bounds%begp:), __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%gresp_storage_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%gresp_storage_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! gresp_xfer(c only) + call TruncateCStates( bounds, filter_soilp, num_soilp, cs%gresp_xfer_patch(bounds%begp:bounds%endp), & + pc(bounds%begp:), __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%gresp_xfer_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%gresp_xfer_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + ! cpool (C only) + call TruncateCStates( bounds, filter_soilp, num_soilp, cs%cpool_patch(bounds%begp:bounds%endp), & + pc(bounds%begp:), __LINE__, num_truncatep, filter_truncatep) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%cpool_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%cpool_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + if ( use_crop )then + ! xsmrpool (C only) + ! xsmr is a pool to balance the budget and as such can be freely negative + call TruncateCStates( bounds, filter_soilp, num_soilp, cs%xsmrpool_patch(bounds%begp:bounds%endp), & + pc(bounds%begp:), __LINE__, num_truncatep, filter_truncatep, & + allowneg=.true., croponly=.true. ) + if (use_c13) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c13cs%xsmrpool_patch(bounds%begp:bounds%endp), pc13(bounds%begp:bounds%endp), & + __LINE__) + end if + if (use_c14) then + call TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + c14cs%xsmrpool_patch(bounds%begp:bounds%endp), pc14(bounds%begp:bounds%endp), & + __LINE__) + end if + + end if + + ! retransn (N only) + call TruncateNStates( bounds, filter_soilp, num_soilp, ns%retransn_patch(bounds%begp:bounds%endp), pn(bounds%begp:), & + __LINE__ ) + + ! npool (N only) + call TruncateNStates( bounds, filter_soilp, num_soilp, ns%npool_patch(bounds%begp:bounds%endp), pn(bounds%begp:), & + __LINE__ ) + + ! patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + + cs%ctrunc_patch(p) = cs%ctrunc_patch(p) + pc(p) + + ns%ntrunc_patch(p) = ns%ntrunc_patch(p) + pn(p) + + if ( use_c13 ) then + c13cs%ctrunc_patch(p) = c13cs%ctrunc_patch(p) + pc13(p) + endif + if ( use_c14 ) then + c14cs%ctrunc_patch(p) = c14cs%ctrunc_patch(p) + pc14(p) + endif + end do + + end associate + + end subroutine CNPrecisionControl + + subroutine TruncateCandNStates( bounds, filter_soilp, num_soilp, carbon_patch, nitrogen_patch, pc, pn, lineno, & + num_truncatep, filter_truncatep, croponly, allowneg ) + ! + ! !DESCRIPTION: + ! Truncate paired Carbon and Nitrogen states. If a paired carbon and nitrogen state iare too small truncate + ! the pair of them to zero. + ! + ! !USES: + use shr_log_mod, only : errMsg => shr_log_errMsg + use clm_varctl , only : use_c13, use_c14, use_nguardrail, use_matrixcn + use clm_varctl , only : iulog + use pftconMod , only : nc3crop + use decompMod , only : bounds_type + ! + ! !ARGUMENTS: + implicit none + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: num_soilp ! number of soil patchs in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + real(r8), intent(inout) :: carbon_patch(bounds%begp:) + real(r8), intent(inout) :: nitrogen_patch(bounds%begp:) + real(r8), intent(inout) :: pc(bounds%begp:) + real(r8), intent(inout) :: pn(bounds%begp:) + integer, intent(in) :: lineno + integer, intent(out) :: num_truncatep ! number of points in filter_truncatep + integer, intent(out) :: filter_truncatep(:) ! filter for points that need truncation + logical , intent(in) , optional :: croponly + logical , intent(in) , optional :: allowneg + + logical :: lcroponly, lallowneg + integer :: fp, p + + SHR_ASSERT_ALL_FL((ubound(carbon_patch) == (/bounds%endp/)), 'ubnd(carb)'//sourcefile, lineno) + SHR_ASSERT_ALL_FL((ubound(nitrogen_patch) == (/bounds%endp/)), 'ubnd(nitro)'//sourcefile, lineno) + SHR_ASSERT_ALL_FL((ubound(pc) == (/bounds%endp/)), 'ubnd(pc)'//sourcefile, lineno) + SHR_ASSERT_ALL_FL((ubound(pn) == (/bounds%endp/)), 'ubnd(pn)'//sourcefile, lineno) + + ! patch loop + lcroponly = .false. + if ( present(croponly) )then + if ( croponly ) lcroponly = .true. + end if + lallowneg = .false. + if ( present(allowneg) )then + if ( allowneg ) lallowneg = .true. + end if + + num_truncatep = 0 + do fp = 1,num_soilp + p = filter_soilp(fp) + + if ( .not. lcroponly .or. (patch%itype(p) >= nc3crop) ) then + if ( .not. lallowneg .and. ((carbon_patch(p) < cnegcrit) .or. (nitrogen_patch(p) < nnegcrit)) ) then + write(iulog,*) 'ERROR: Carbon or Nitrogen patch negative = ', carbon_patch(p), nitrogen_patch(p) + write(iulog,*) 'ERROR: limits = ', cnegcrit, nnegcrit + call endrun(msg='ERROR: carbon or nitrogen state critically negative '//errMsg(sourcefile, lineno)) + else + if (use_matrixcn)then + if ( (carbon_patch(p) < ccrit .and. carbon_patch(p) > -ccrit * 1.e+6) .or. (use_nguardrail .and. nitrogen_patch(p) < ncrit .and. nitrogen_patch(p) > -ncrit*1.e+6) ) then + num_truncatep = num_truncatep + 1 + filter_truncatep(num_truncatep) = p + + pc(p) = pc(p) + carbon_patch(p) + carbon_patch(p) = 0._r8 + + pn(p) = pn(p) + nitrogen_patch(p) + nitrogen_patch(p) = 0._r8 + + end if + else + if ( abs(carbon_patch(p)) < ccrit .or. (use_nguardrail .and. abs(nitrogen_patch(p)) < ncrit ) ) then + num_truncatep = num_truncatep + 1 + filter_truncatep(num_truncatep) = p + + pc(p) = pc(p) + carbon_patch(p) + carbon_patch(p) = 0._r8 + + pn(p) = pn(p) + nitrogen_patch(p) + nitrogen_patch(p) = 0._r8 + + end if + end if + end if + end if + end do + end subroutine TruncateCandNStates + + subroutine TruncateCStates( bounds, filter_soilp, num_soilp, carbon_patch, pc, lineno, & + num_truncatep, filter_truncatep, croponly, allowneg ) + ! + ! !DESCRIPTION: + ! Truncate Carbon states. If a carbon state is too small truncate it to + ! zero. + ! + ! !USES: + use abortutils , only : endrun + use clm_varctl , only : iulog + use shr_log_mod, only : errMsg => shr_log_errMsg + use clm_varctl , only : use_c13, use_c14 + use pftconMod , only : nc3crop + use decompMod , only : bounds_type + ! + ! !ARGUMENTS: + implicit none + type(bounds_type), intent(in) :: bounds ! bounds + integer , intent(in) :: num_soilp ! number of soil patchs in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + real(r8) , intent(inout) :: carbon_patch(bounds%begp:) + real(r8) , intent(inout) :: pc(bounds%begp:) + integer , intent(in) :: lineno + integer , intent(out) :: num_truncatep ! number of points in filter_truncatep + integer , intent(out) :: filter_truncatep(:) ! filter for points that need truncation + logical , intent(in) , optional :: croponly + logical , intent(in) , optional :: allowneg + + logical :: lcroponly, lallowneg + integer :: fp, p + + SHR_ASSERT_ALL_FL((ubound(carbon_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(pc) == (/bounds%endp/)), sourcefile, __LINE__) + + if ( -ccrit < cnegcrit )then + call endrun(msg='ERROR: cnegcrit should be less than -ccrit: '//errMsg(sourcefile, lineno)) + end if + lcroponly = .false. + if ( present(croponly) )then + if ( croponly ) lcroponly = .true. + end if + lallowneg = .false. + if ( present(allowneg) )then + if ( allowneg ) lallowneg = .true. + end if + + num_truncatep = 0 + do fp = 1,num_soilp + p = filter_soilp(fp) + + if ( .not. lcroponly .or. (patch%itype(p) >= nc3crop) ) then + if ( .not. lallowneg .and. (carbon_patch(p) < cnegcrit) ) then + write(iulog,*) 'ERROR: Carbon patch negative = ', carbon_patch(p) + write(iulog,*) 'ERROR: limit = ', cnegcrit + call endrun(msg='ERROR: carbon state critically negative '//errMsg(sourcefile, lineno)) + else if ( abs(carbon_patch(p)) < ccrit) then + + num_truncatep = num_truncatep + 1 + filter_truncatep(num_truncatep) = p + + pc(p) = pc(p) + carbon_patch(p) + carbon_patch(p) = 0._r8 + end if + end if + end do + end subroutine TruncateCStates + + subroutine TruncateNStates( bounds, filter_soilp, num_soilp, nitrogen_patch, pn, lineno ) + ! + ! !DESCRIPTION: + ! Truncate Nitrogen states. If a nitrogen state is too small truncate it to + ! zero. + ! + ! !USES: + use abortutils , only : endrun + use shr_log_mod, only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog + use decompMod , only : bounds_type + ! + ! !ARGUMENTS: + implicit none + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: num_soilp ! number of soil patchs in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + real(r8), intent(inout) :: nitrogen_patch(bounds%begp:) + real(r8), intent(inout) :: pn(bounds%begp:) + integer, intent(in) :: lineno + + integer :: fp, p + + SHR_ASSERT_ALL_FL((ubound(nitrogen_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(pn) == (/bounds%endp/)), sourcefile, __LINE__) + do fp = 1,num_soilp + p = filter_soilp(fp) + if ( nitrogen_patch(p) < nnegcrit ) then + !write(iulog,*) 'WARNING: Nitrogen patch negative = ', nitrogen_patch + !call endrun(msg='ERROR: nitrogen state critically negative'//errMsg(sourcefile, lineno)) + else if ( abs(nitrogen_patch(p)) < ncrit) then + pn(p) = pn(p) + nitrogen_patch(p) + nitrogen_patch(p) = 0._r8 + + end if + end do + end subroutine TruncateNStates + + !----------------------------------------------------------------------- + subroutine TruncateAdditional( bounds, num_truncatep, filter_truncatep, & + state_patch, truncation_patch, lineno) + ! + ! !DESCRIPTION: + ! Given a filter of points for which we have already determined that truncation should + ! occur, do the truncation for the given patch-level state, putting the truncation + ! amount in truncation_patch. + ! + use decompMod , only : bounds_type + ! !ARGUMENTS: + implicit none + type(bounds_type) , intent (in) :: bounds ! bounds + integer , intent (in) :: num_truncatep ! number of points in filter_truncatep + integer , intent (in) :: filter_truncatep(:) ! filter for points that need truncation + real(r8) , intent (inout) :: state_patch(bounds%begp: ) + real(r8) , intent (inout) :: truncation_patch(bounds%begp: ) + integer , intent (in) :: lineno + ! + ! !LOCAL VARIABLES: + integer :: fp, p + character(len=*), parameter :: subname = 'TruncateAdditional' + !----------------------------------------------------------------------- + + SHR_ASSERT_FL((ubound(state_patch, 1) == bounds%endp), 'state_patch ' //sourcefile, lineno) + SHR_ASSERT_FL((ubound(truncation_patch, 1) == bounds%endp), 'truncation_patch '//sourcefile, lineno) + + do fp = 1, num_truncatep + p = filter_truncatep(fp) + truncation_patch(p) = truncation_patch(p) + state_patch(p) + state_patch(p) = 0._r8 + end do + + end subroutine TruncateAdditional + +end module CNPrecisionControlMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNRootDynMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNRootDynMod.F90 new file mode 100755 index 000000000..8929f7f90 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNRootDynMod.F90 @@ -0,0 +1,277 @@ +module CNRootDynMod + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Module holding routines used for determining fine root distribution for all pfts. +! Includes dynamic root depth for crops +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_time_manager , only : get_step_size_real + use clm_varpar , only : nlevsoi, nlevgrnd + use clm_varctl , only : use_vertsoilc, use_bedrock + use decompMod , only : bounds_type + use pftconMod , only : noveg, npcropmin, pftcon + use ColumnType , only : col + use PatchType , only : patch + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegnitrogenstateType , only : cnveg_nitrogenstate_type + use SoilStateType , only : soilstate_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use CropType , only : crop_type + +! !PUBLIC TYPES: + implicit none + save + private + public :: CNRootDyn +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +! +subroutine CNRootDyn(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, cnveg_carbonflux_inst, & + cnveg_state_inst, crop_inst, soilstate_inst, soilbiogeochem_nitrogenstate_inst) +! +! !DESCRIPTION: +! This routine determine the fine root distribution +! Needs to be called after the photosynthesis calculation +! May need to update other subroutines that use the fixed root profile for calculations +! i.e. CNVerticalProfileMod +! +! !USES: + + +! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds ! bounds + integer, intent(in) :: num_soilc + integer, intent(in) :: filter_soilc(:) + integer, intent(in) :: num_soilp ! number of soil pfts in filter + integer, intent(in) :: filter_soilp(:) ! filter for soil pfts + type(cnveg_state_type) , intent(in) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(crop_type) , intent(in) :: crop_inst + type(soilbiogeochem_nitrogenstate_type) , intent(in) :: soilbiogeochem_nitrogenstate_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + +! +! !LOCAL VARIABLES: + + integer :: f,c,p,lev,j ! indices + real(r8):: dt ! radiation time step delta t (seconds) + real(r8), allocatable :: w_limit(:) + real(r8), allocatable :: rswa(:,:) ! soil water availability in each soil layer + real(r8), allocatable :: rsmn(:,:) ! soil nitrogen availability in each soil layer + real(r8), allocatable :: sumrswa(:) ! scaling soil water availability in each soil layer + real(r8), allocatable :: sumrsmn(:) ! scaling soil mineral N availability in each soil layer + real(r8) :: frootc_dz(bounds%begp:bounds%endp, 1:nlevgrnd) + real(r8), allocatable :: sumfrootc(:) ! fine root carbon total before turnover in each step + real(r8):: minpsi ! minimum soil moisture potential + real(r8):: psi + real(r8):: maxpsi + real(r8):: new_growth + +!----------------------------------------------------------------------- + ! Assign local pointers to derived type arrays (in) + associate(& + ivt => patch%itype , & ! Input: [integer (:)] pft vegetation type + pcolumn => patch%column , & ! Input: [integer (:)] pft's column index + roota_par => pftcon%roota_par , & ! Input: [real(r8) (:)] pft's roota index + rootb_par => pftcon%rootb_par , & ! Input: [real(r8) (:)] pft's rootb index + root_dmx => pftcon%root_dmx , & ! Input: [real(r8) (:)] crop maximum root depth + cpool_to_frootc => cnveg_carbonflux_inst%cpool_to_frootc_patch , & ! Input: [real(r8) (:)] allocation to fine root C (gC/m2/s) + frootc_xfer_to_frootc => cnveg_carbonflux_inst%frootc_xfer_to_frootc_patch , & ! Input: [real(r8) (:)] fine root C growth from storage (gC/m2/s) + dormant_flag => cnveg_state_inst%dormant_flag_patch , & ! Input: [real(r8) (:)] dormancy flag + root_depth => soilstate_inst%root_depth_patch , & ! InOut: [real(r8) (:)] current root depth + dz => col%dz , & ! Input: layer thickness (m) (-nlevsno+1:nlevgrnd) + zi => col%zi , & ! Input: interface level below a "z" level (m) (-nlevsno+0:nlevgrnd) + rootfr => soilstate_inst%rootfr_patch , & ! Output: [real(r8) (:,:)] fraction of roots in each soil layer + sucsat => soilstate_inst%sucsat_col , & ! Input: minimum soil suction (mm) + soilpsi => soilstate_inst%soilpsi_col , & ! Input: soil water potential in each soil layer (MPa) + sminn_vr => soilbiogeochem_nitrogenstate_inst%sminn_vr_col , & ! Iniput: [real(r8) (:,:)] (gN/m3) soil mineral N + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:)] (gC/m2) fine root C + hui => crop_inst%gddplant_patch , & ! Input: [real(r8) (:)] =gdd since planting (gddplant) + croplive => crop_inst%croplive_patch , & ! Input: [logical (:)] flag, true if planted, not harvested + huigrain => cnveg_state_inst%huigrain_patch & ! Input: [real(r8) (:)] same to reach vegetative maturity + ) + +! set time steps + dt = get_step_size_real() + +! set minpsi to permanent wilting point + minpsi = -1.5_r8 + + allocate(sumrswa(bounds%begp:bounds%endp)) + allocate(sumrsmn(bounds%begp:bounds%endp)) + allocate(sumfrootc(bounds%begp:bounds%endp)) + allocate(rswa(bounds%begp:bounds%endp,nlevgrnd)) + allocate(rsmn(bounds%begp:bounds%endp,nlevgrnd)) + allocate(w_limit(bounds%begp:bounds%endp)) + +!initialize to 0 + w_limit(bounds%begp:bounds%endp) = 0._r8 + sumrswa(bounds%begp:bounds%endp) = 0._r8 + sumrsmn(bounds%begp:bounds%endp) = 0._r8 + sumfrootc(bounds%begp:bounds%endp) = 0._r8 + rswa(bounds%begp:bounds%endp,:) = 0._r8 + rsmn(bounds%begp:bounds%endp,:) = 0._r8 + + frootc_dz(bounds%begp:bounds%endp,1:nlevgrnd) = 0._r8 + + +!--------------------------------------------------------------- +! Set root depth, dynamic for crops, fixed for other vegetation +!--------------------------------------------------------------- + + do f = 1, num_soilp + p = filter_soilp(f) + c = pcolumn(p) + if (ivt(p) /= noveg) then + if((ivt(p)) >= npcropmin)then !skip generic crop types + if(huigrain(p) > 0._r8)then + root_depth(p) = max(zi(c,2), min(hui(p)/huigrain(p)* root_dmx(ivt(p)), root_dmx(ivt(p)))) + end if + else + ! this can be changed to any depth (i.e. the maximum soil depth) + root_depth(p) = zi(c,nlevsoi) + end if + if (use_bedrock) then + root_depth(p) = min(root_depth(p),zi(c,col%nbedrock(c))) + end if + else + root_depth(p) = 0._r8 + end if + end do + +!---------------------------------------------------------------- +! ! calculate a weighting function by soil depth that depends on the + ! fine root distribution per pft and depth and the pft weight on the column. + ! This will be used to weight the temperature and water potential scalars + ! for decomposition control. + + ! calculate the rate constant scalar for soil water content. + ! Uses the log relationship with water potential given in + ! Andren, O., and K. Paustian, 1987. Barley straw decomposition in the field: + ! a comparison of models. Ecology, 68(5):1190-1200. + ! and supported by data in + ! Orchard, V.A., and F.J. Cook, 1983. Relationship between soil respiration + ! and soil moisture. Soil Biol. Biochem., 15(4):447-453. + + do j = 1,nlevsoi + do f = 1,num_soilp + p = filter_soilp(f) + c = pcolumn(p) + maxpsi = sucsat(c,j) * (-9.8e-6_r8) + psi = min(soilpsi(c,j),maxpsi) + if (psi > minpsi) then +! First calculate water in the root zone + if(root_depth(p) > 0.15_r8 .and. (zi(c,j) <= root_depth(p) .or. & + (zi(c,j-1) < root_depth(p) .and. zi(c,j) > root_depth(p)))) then + w_limit(p) = w_limit(p) + max(0._r8,log(minpsi/psi)/log(minpsi/maxpsi))*rootfr(p,j) + end if +! Calculate the water in each soil layer + if (root_depth(p) >= zi(c,j) .or. & + (zi(c,j-1) < root_depth(p) .and. zi(c,j) > root_depth(p))) then + rswa(p,j) = max(0._r8, (log(minpsi/psi)/log(minpsi/maxpsi))) + end if + end if + sumrswa(p) = sumrswa(p) + rswa(p,j) + +! Calculate the nitrogen profile in each layer +! For now, the profile for each PFT is equivilent to the +! column profile, in the future, this could be changed to a weighted profile + if(use_vertsoilc) then !for vertical soil profile + rsmn(p,j) = sminn_vr(c,j) + else ! need to calculate a profile, top 0.2m are constant, and decrease linearly + if(zi(c,j) <= 0.2_r8)then + rsmn(p,j) = dz(c,j) + end if + if(zi(c,j) > 0.2_r8)then + rsmn(p,j) = dz(c,j) * (zi(c,nlevsoi) - zi(c,j)) / (zi(c,nlevsoi) - 0.2_r8) + end if + end if + if (root_depth(p) >= zi(c,j).or. & + (zi(c,j-1) < root_depth(p) .and. zi(c,j) > root_depth(p))) then + sumrsmn(p) = sumrsmn(p) + rsmn(p,j) + end if + end do + end do + + +!-------------------------------------------------------------------- +! Now calculate the density of roots in each soil layer for each pft +! based on this timesteps growth +!-------------------------------------------------------------------- + do lev = 1, nlevgrnd + + do f = 1, num_soilp + p = filter_soilp(f) + c = pcolumn(p) + + new_growth = (cpool_to_frootc(p) + frootc_xfer_to_frootc(p))*dt + if(zi(c,lev) <= root_depth(p) .or. & + (zi(c,lev-1) < root_depth(p) .and. zi(c,lev) > root_depth(p))) then + if(sumrswa(p) <= 0._r8 .or. sumrsmn(p) <= 0._r8) then +! when sumrswa or sumrsmn are less than or equal to 0 rootfr will not be updated + else + frootc_dz(p,lev) = (frootc(p))*rootfr(p,lev) & + + new_growth * ((1._r8 - w_limit(p)) * rswa(p,lev) / sumrswa(p) & + + w_limit(p) * rsmn(p,lev) / sumrsmn(p)) + end if + else + frootc_dz(p,lev) = 0._r8 + end if + + sumfrootc(p) = sumfrootc(p) + frootc_dz(p,lev) + + end do + end do +!---------------------------------- +!Calculate root fraction +!---------------------------------- + + do lev = 1, nlevgrnd + do f = 1, num_soilp + p = filter_soilp(f) + c = pcolumn(p) + if(sumfrootc(p) > 0._r8)then + rootfr(p,lev) = frootc_dz(p,lev)/sumfrootc(p) + end if + if(ivt(p) >= npcropmin .and. .not. croplive(p))then +! CROPS are dormant, there are no roots! +! but, need an initial frootr so crops can start root production + if (lev < 2)then + rootfr(p,lev) = .5_r8*( exp(-roota_par(patch%itype(p)) * zi(c,lev-1)) & + + exp(-rootb_par(patch%itype(p)) * zi(c,lev-1)) & + - exp(-roota_par(patch%itype(p)) * zi(c,lev )) & + - exp(-rootb_par(patch%itype(p)) * zi(c,lev )) ) + elseif (lev == 2) then + rootfr(p,lev) = .5_r8*( exp(-roota_par(patch%itype(p)) * zi(c,lev-1)) & + + exp(-rootb_par(patch%itype(p)) * zi(c,lev-1)) ) + else + rootfr(p,lev) = 0.0_r8 + end if + + end if + end do + end do + +!********************** + deallocate(sumrswa) + deallocate(sumrsmn) + deallocate(sumfrootc) + deallocate(rsmn) + deallocate(rswa) + deallocate(w_limit) + + end associate + + end subroutine CNRootDyn + +end module CNRootDynMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNSharedParamsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNSharedParamsMod.F90 new file mode 100755 index 000000000..cf60816b8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNSharedParamsMod.F90 @@ -0,0 +1,195 @@ +module CNSharedParamsMod + + !----------------------------------------------------------------------- + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use ncdio_pio , only : file_desc_t + use ncdio_pio , only : ncd_io + use clm_varpar , only : nlevgrnd + + implicit none + + ! CNParamsShareInst. PGI wants the type decl. public but the instance + ! is indeed protected. A generic private statement at the start of the module + ! overrides the protected functionality with PGI + + type, public :: CNParamsShareType + real(r8) :: Q10 ! temperature dependence + real(r8) :: minpsi ! minimum soil water potential for heterotrophic resp + real(r8) :: cwd_fcel ! cellulose fraction of coarse woody debris + real(r8) :: cwd_flig ! lignin fraction of coarse woody debris + real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates + real(r8) :: decomp_depth_efolding ! e-folding depth for reduction in decomposition (m) + real(r8) :: mino2lim ! minimum anaerobic decomposition rate as a fraction of potential aerobic rate + real(r8) :: organic_max ! organic matter content (kg/m3) where soil is assumed to act like peat + logical :: constrain_stress_deciduous_onset ! if true use additional constraint on stress deciduous onset trigger + end type CNParamsShareType + + type(CNParamsShareType), protected :: CNParamsShareInst + + logical, public :: use_fun = .true. ! Use the FUN2.0 model + integer, public :: nlev_soildecomp_standard = nlevgrnd + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CNParamsReadShared(ncid, namelist_file) + + use ncdio_pio , only : file_desc_t + + type(file_desc_t), intent(inout) :: ncid ! pio netCDF file id + character(len=*), optional, intent(in) :: namelist_file + + call CNParamsReadShared_netcdf(ncid) + call CNParamsReadShared_namelist(namelist_file) + + end subroutine CNParamsReadShared + + !----------------------------------------------------------------------- + subroutine CNParamsReadShared_netcdf(ncid) + ! + ! use ncdio_pio , only : file_desc_t, ncd_io + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + ! + implicit none + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + character(len=32) :: subname = 'CNParamsReadShared' + character(len=100) :: errCode = '-Error reading in CN and BGC shared params file. Var:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in parameter + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + ! + ! netcdf read here + ! + tString='q10_mr' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + CNParamsShareInst%Q10=tempr + + tString='minpsi_hr' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + CNParamsShareInst%minpsi=tempr + + tString='cwd_fcel' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + CNParamsShareInst%cwd_fcel=tempr + + tString='cwd_flig' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + CNParamsShareInst%cwd_flig=tempr + + tString='froz_q10' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + CNParamsShareInst%froz_q10=tempr + + tString='mino2lim' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + CNParamsShareInst%mino2lim=tempr + !CNParamsShareInst%mino2lim=0.2_r8 + + tString='organic_max' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + CNParamsShareInst%organic_max=tempr + + end subroutine CNParamsReadShared_netcdf + + !----------------------------------------------------------------------- + subroutine CNParamsReadShared_namelist(namelist_file) + ! + ! !DESCRIPTION: + ! Read and initialize CN Shared parameteres from the namelist. + ! + ! !USES: + use fileutils , only : relavu, getavu + use spmdMod , only : masterproc, mpicom, MPI_REAL8, MPI_LOGICAL + use shr_nl_mod , only : shr_nl_find_group_name + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog + use abortutils , only : endrun + use shr_mpi_mod , only : shr_mpi_bcast + + ! + implicit none + ! + + character(len=*), intent(in) :: namelist_file + + integer :: i,j,n ! loop indices + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + real(r8) :: decomp_depth_efolding = 0.0_r8 + logical :: constrain_stress_deciduous_onset = .false. + + character(len=32) :: subroutine_name = 'CNParamsReadNamelist' + character(len=10) :: namelist_group = 'bgc_shared' + + !----------------------------------------------------------------------- + + ! ---------------------------------------------------------------------- + ! Namelist Variables + ! ---------------------------------------------------------------------- + + namelist /bgc_shared/ & + decomp_depth_efolding, & + constrain_stress_deciduous_onset + + + ! Read namelist from standard input. + if (masterproc) then + + write(iulog,*) 'Attempting to read CN/BGC shared namelist parameters .....' + unitn = getavu() + write(iulog,*) 'Read in ' // namelist_group // ' namelist from: ', trim(namelist_file) + open( unitn, file=trim(namelist_file), status='old' ) + call shr_nl_find_group_name(unitn, namelist_group, status=ierr) + if (ierr == 0) then + read(unitn, bgc_shared, iostat=ierr) + if (ierr /= 0) then + call endrun(msg='error in reading in ' // namelist_group // ' namelist' // & + errMsg(sourcefile, __LINE__)) + end if + else + call endrun(msg='error in finding ' // namelist_group // ' namelist' // & + errMsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + + end if ! masterproc + + ! Broadcast the parameters from master + call shr_mpi_bcast ( decomp_depth_efolding, mpicom ) + call shr_mpi_bcast ( constrain_stress_deciduous_onset, mpicom ) + + ! Save the parameter to the instance + CNParamsShareInst%decomp_depth_efolding = decomp_depth_efolding + CNParamsShareInst%constrain_stress_deciduous_onset = constrain_stress_deciduous_onset + + ! Output read parameters to the lnd.log + if (masterproc) then + write(iulog,*) 'CN/BGC shared namelist parameters:' + write(iulog,*)' ' + write(iulog,*)' decomp_depth_efolding = ', decomp_depth_efolding + write(iulog,*)' constrain_stress_deciduous_onset = ',constrain_stress_deciduous_onset + + write(iulog,*) + + end if + + end subroutine CNParamsReadShared_namelist + +end module CNSharedParamsMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegStructUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegStructUpdateMod.F90 new file mode 100755 index 000000000..b9fdfe6f8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegStructUpdateMod.F90 @@ -0,0 +1,327 @@ +module CNVegStructUpdateMod + + !----------------------------------------------------------------------- + ! Module for vegetation structure updates (LAI, SAI, htop, hbot) + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_PI + use clm_varctl , only : iulog, use_cndv + use CNDVType , only : dgv_ecophyscon + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use FrictionVelocityMod , only : frictionvel_type + use CNDVType , only : dgvs_type + use CNVegStateType , only : cnveg_state_type + use CropType , only : crop_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type, spinup_factor_deadwood + use CanopyStateType , only : canopystate_type + use PatchType , only : patch + use decompMod , only : bounds_type + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: CNVegStructUpdate + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine CNVegStructUpdate(bounds,num_soilp, filter_soilp, & + waterdiagnosticbulk_inst, frictionvel_inst, dgvs_inst, cnveg_state_inst, crop_inst, & + cnveg_carbonstate_inst, canopystate_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, use C state variables and epc to diagnose + ! vegetation structure (LAI, SAI, height) + ! + ! !USES: + use pftconMod , only : noveg, nc3crop, nc3irrig, nbrdlf_evr_shrub, nbrdlf_dcd_brl_shrub + use pftconMod , only : npcropmin + use pftconMod , only : ntmp_corn, nirrig_tmp_corn + use pftconMod , only : ntrp_corn, nirrig_trp_corn + use pftconMod , only : nsugarcane, nirrig_sugarcane + use pftconMod , only : nmiscanthus, nirrig_miscanthus, nswitchgrass, nirrig_switchgrass + + use pftconMod , only : pftcon + use clm_varctl , only : spinup_state, use_biomass_heat_storage + use clm_varcon , only : c_to_b + use clm_time_manager , only : get_rad_step_size + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of column soil points in patch filter + integer , intent(in) :: filter_soilp(:) ! patch filter for soil points + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(frictionvel_type) , intent(in) :: frictionvel_inst + type(dgvs_type) , intent(in) :: dgvs_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(crop_type) , intent(in) :: crop_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + ! + ! !REVISION HISTORY: + ! 10/28/03: Created by Peter Thornton + ! 2/29/08, David Lawrence: revised snow burial fraction for short vegetation + ! + ! !LOCAL VARIABLES: + integer :: p,c,g ! indices + integer :: fp ! lake filter indices + real(r8) :: stocking ! #stems / ha (stocking density) + real(r8) :: ol ! thickness of canopy layer covered by snow (m) + real(r8) :: fb ! fraction of canopy layer covered by snow + real(r8) :: tlai_old ! for use in Zeng tsai formula + real(r8) :: tsai_old ! for use in Zeng tsai formula + real(r8) :: tsai_min ! PATCH derived minimum tsai + real(r8) :: tsai_alpha ! monthly decay rate of tsai + real(r8) :: dt ! radiation time step (sec) + real(r8) :: frac_sno_adjusted ! frac_sno adjusted per frac_sno_threshold + + real(r8), parameter :: dtsmonth = 2592000._r8 ! number of seconds in a 30 day month (60x60x24x30) + real(r8), parameter :: frac_sno_threshold = 0.999_r8 ! frac_sno values greater than this are treated as 1 + !----------------------------------------------------------------------- + ! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 + ! + ! tsai(p) = max( tsai_alpha(ivt(p))*tsai_old + max(tlai_old-tlai(p),0_r8), tsai_min(ivt(p)) ) + ! notes: + ! * RHS tsai & tlai are from previous timestep + ! * should create tsai_alpha(ivt(p)) & tsai_min(ivt(p)) in pftconMod.F90 - slevis + ! * all non-crop patches use same values: + ! crop tsai_alpha,tsai_min = 0.0,0.1 + ! noncrop tsai_alpha,tsai_min = 0.5,1.0 (includes bare soil and urban) + !------------------------------------------------------------------------------- + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + slatop => pftcon%slatop , & ! Input: specific leaf area at top of canopy, projected area basis [m^2/gC] + dsladlai => pftcon%dsladlai , & ! Input: dSLA/dLAI, projected area basis [m^2/gC] + z0mr => pftcon%z0mr , & ! Input: ratio of momentum roughness length to canopy top height (-) + displar => pftcon%displar , & ! Input: ratio of displacement height to canopy top height (-) + dwood => pftcon%dwood , & ! Input: density of wood (gC/m^3) + ztopmx => pftcon%ztopmx , & ! Input: + laimx => pftcon%laimx , & ! Input: + nstem => pftcon%nstem , & ! Input: Tree number density (#ind/m2) + taper => pftcon%taper , & ! Input: ratio of height:radius_breast_height (tree allometry) + fbw => pftcon%fbw , & ! Input: Fraction of fresh biomass that is water + + allom2 => dgv_ecophyscon%allom2 , & ! Input: [real(r8) (:) ] ecophys const + allom3 => dgv_ecophyscon%allom3 , & ! Input: [real(r8) (:) ] ecophys const + + nind => dgvs_inst%nind_patch , & ! Input: [real(r8) (:) ] number of individuals (#/m**2) + fpcgrid => dgvs_inst%fpcgrid_patch , & ! Input: [real(r8) (:) ] fractional area of patch (pft area/nat veg area) + + frac_sno => waterdiagnosticbulk_inst%frac_sno_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) + + forc_hgt_u_patch => frictionvel_inst%forc_hgt_u_patch , & ! Input: [real(r8) (:) ] observational height of wind at patch-level [m] + + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] (gC/m2) leaf C + deadstemc => cnveg_carbonstate_inst%deadstemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) dead stem C + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) (:) ] (gC/m2) live stem C + + farea_burned => cnveg_state_inst%farea_burned_col , & ! Input: [real(r8) (:) ] F. Li and S. Levis + htmx => cnveg_state_inst%htmx_patch , & ! Output: [real(r8) (:) ] max hgt attained by a crop during yr (m) + peaklai => cnveg_state_inst%peaklai_patch , & ! Output: [integer (:) ] 1: max allowed lai; 0: not at max + + harvdate => crop_inst%harvdate_patch , & ! Input: [integer (:) ] harvest date + + ! *** Key Output from CN*** + tlai => canopystate_inst%tlai_patch , & ! Output: [real(r8) (:) ] one-sided leaf area index, no burying by snow + tsai => canopystate_inst%tsai_patch , & ! Output: [real(r8) (:) ] one-sided stem area index, no burying by snow + stem_biomass => canopystate_inst%stem_biomass_patch , & ! Output: [real(r8) (:) ] Aboveground stem biomass (kg/m**2) + leaf_biomass => canopystate_inst%leaf_biomass_patch , & ! Output: [real(r8) (:) ] Aboveground leave biomass (kg/m**2) + htop => canopystate_inst%htop_patch , & ! Output: [real(r8) (:) ] canopy top (m) + hbot => canopystate_inst%hbot_patch , & ! Output: [real(r8) (:) ] canopy bottom (m) + elai => canopystate_inst%elai_patch , & ! Output: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Output: [real(r8) (:) ] one-sided stem area index with burying by snow + frac_veg_nosno_alb => canopystate_inst%frac_veg_nosno_alb_patch & ! Output: [integer (:) ] frac of vegetation not covered by snow [-] + ) + + dt = real( get_rad_step_size(), r8 ) + + ! patch loop + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + g = patch%gridcell(p) + + if (ivt(p) /= noveg) then + + tlai_old = tlai(p) ! n-1 value + tsai_old = tsai(p) ! n-1 value + + ! update the leaf area index based on leafC and SLA + ! Eq 3 from Thornton and Zimmerman, 2007, J Clim, 20, 3902-3923. + if (dsladlai(ivt(p)) > 0._r8) then + tlai(p) = (slatop(ivt(p))*(exp(leafc(p)*dsladlai(ivt(p))) - 1._r8))/dsladlai(ivt(p)) + else + tlai(p) = slatop(ivt(p)) * leafc(p) + end if + tlai(p) = max(0._r8, tlai(p)) + + ! update the stem area index and height based on LAI, stem mass, and veg type. + ! With the exception of htop for woody vegetation, this follows the DGVM logic. + + ! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 (see notes) + ! Assumes doalb time step .eq. CLM time step, SAI min and monthly decay factor + ! alpha are set by PFT, and alpha is scaled to CLM time step by multiplying by + ! dt and dividing by dtsmonth (seconds in average 30 day month) + ! tsai_min scaled by 0.5 to match MODIS satellite derived values + if (ivt(p) == nc3crop .or. ivt(p) == nc3irrig) then ! generic crops + + tsai_alpha = 1.0_r8-1.0_r8*dt/dtsmonth + tsai_min = 0.1_r8 + else + tsai_alpha = 1.0_r8-0.5_r8*dt/dtsmonth + tsai_min = 1.0_r8 + end if + tsai_min = tsai_min * 0.5_r8 + tsai(p) = max(tsai_alpha*tsai_old+max(tlai_old-tlai(p),0._r8),tsai_min) + + ! calculate vegetation physiological parameters used in biomass heat storage + if (use_biomass_heat_storage) then + ! Assumes fbw (fraction of biomass that is water) is the same for leaves and stems + leaf_biomass(p) = max(0.0025_r8,leafc(p)) & + * c_to_b * 1.e-3_r8 / (1._r8 - fbw(ivt(p))) + + if (woody(ivt(p)) == 1._r8) then + stem_biomass(p) = (spinup_factor_deadwood*deadstemc(p) + livestemc(p)) & + * c_to_b * 1.e-3_r8 / (1._r8 - fbw(ivt(p))) + else + stem_biomass(p) = 0._r8 + end if + else + leaf_biomass(p) = 0._r8 + stem_biomass(p) = 0._r8 + end if + if (woody(ivt(p)) == 1._r8) then + + ! trees and shrubs for now have a very simple allometry, with hard-wired + ! stem taper (height:radius) and nstem from PFT parameter file + if (use_cndv) then + + if (fpcgrid(p) > 0._r8 .and. nind(p) > 0._r8) then + + stocking = nind(p)/fpcgrid(p) !#ind/m2 nat veg area -> #ind/m2 patch area + htop(p) = allom2(ivt(p)) * ( (24._r8 * deadstemc(p) / & + (SHR_CONST_PI * stocking * dwood(ivt(p)) * taper(ivt(p))))**(1._r8/3._r8) )**allom3(ivt(p)) ! lpj's htop w/ cn's stemdiam + + else + htop(p) = 0._r8 + end if + + else + !correct height calculation if doing accelerated spinup + htop(p) = ((3._r8 * deadstemc(p) * spinup_factor_deadwood * taper(ivt(p)) * taper(ivt(p)))/ & + (SHR_CONST_PI * nstem(ivt(p)) * dwood(ivt(p))))**(1._r8/3._r8) + + endif + ! + ! Peter Thornton, 5/3/2004 + ! Adding test to keep htop from getting too close to forcing height for windspeed + ! Also added for grass, below, although it is not likely to ever be an issue. + htop(p) = min(htop(p),(forc_hgt_u_patch(p)/(displar(ivt(p))+z0mr(ivt(p))))-3._r8) + + ! Peter Thornton, 8/11/2004 + ! Adding constraint to keep htop from going to 0.0. + ! This becomes an issue when fire mortality is pushing deadstemc + ! to 0.0. + htop(p) = max(htop(p), 0.01_r8) + + hbot(p) = max(0._r8, min(3._r8, htop(p)-1._r8)) + + else if (ivt(p) >= npcropmin) then ! prognostic crops + + if (tlai(p) >= laimx(ivt(p))) peaklai(p) = 1 ! used in CNAllocation + + if (ivt(p) == ntmp_corn .or. ivt(p) == nirrig_tmp_corn .or. & + ivt(p) == ntrp_corn .or. ivt(p) == nirrig_trp_corn .or. & + ivt(p) == nsugarcane .or. ivt(p) == nirrig_sugarcane .or. & + ivt(p) == nmiscanthus .or. ivt(p) == nirrig_miscanthus .or. & + ivt(p) == nswitchgrass .or. ivt(p) == nirrig_switchgrass) then + tsai(p) = 0.1_r8 * tlai(p) + else + tsai(p) = 0.2_r8 * tlai(p) + end if + + ! "stubble" after harvest + if (harvdate(p) < 999 .and. tlai(p) == 0._r8) then + tsai(p) = 0.25_r8*(1._r8-farea_burned(c)*0.90_r8) !changed by F. Li and S. Levis + htmx(p) = 0._r8 + peaklai(p) = 0 + end if + !if (harvdate(p) < 999 .and. tlai(p) > 0._r8) write(iulog,*) 'CNVegStructUpdate: tlai>0 after harvest!' ! remove after initial debugging? + + ! canopy top and bottom heights + htop(p) = ztopmx(ivt(p)) * (min(tlai(p)/(laimx(ivt(p))-1._r8),1._r8))**2 + htmx(p) = max(htmx(p), htop(p)) + htop(p) = max(0.05_r8, max(htmx(p),htop(p))) + hbot(p) = 0.02_r8 + + else ! generic crops and ... + + ! grasses + + ! height for grasses depends only on LAI + htop(p) = max(0.25_r8, tlai(p) * 0.25_r8) + + htop(p) = min(htop(p),(forc_hgt_u_patch(p)/(displar(ivt(p))+z0mr(ivt(p))))-3._r8) + + ! Peter Thornton, 8/11/2004 + ! Adding constraint to keep htop from going to 0.0. + htop(p) = max(htop(p), 0.01_r8) + + hbot(p) = max(0.0_r8, min(0.05_r8, htop(p)-0.20_r8)) + end if + + else + + tlai(p) = 0._r8 + tsai(p) = 0._r8 + htop(p) = 0._r8 + hbot(p) = 0._r8 + + end if + + ! adjust lai and sai for burying by snow. + ! snow burial fraction for short vegetation (e.g. grasses, crops) changes with vegetation height + ! accounts for a 20% bending factor, as used in Lombardozzi et al. (2018) GRL 45(18), 9889-9897 + + ! NOTE: The following snow burial code is duplicated in SatellitePhenologyMod. + ! Changes in one place should be accompanied by similar changes in the other. + + if (ivt(p) > noveg .and. ivt(p) <= nbrdlf_dcd_brl_shrub ) then + ol = min( max(snow_depth(c)-hbot(p), 0._r8), htop(p)-hbot(p)) + fb = 1._r8 - ol / max(1.e-06_r8, htop(p)-hbot(p)) + else + fb = 1._r8 - (max(min(snow_depth(c),max(0.05,htop(p)*0.8_r8)),0._r8)/(max(0.05,htop(p)*0.8_r8))) + !depth of snow required for complete burial of grasses + endif + + if (frac_sno(c) <= frac_sno_threshold) then + frac_sno_adjusted = frac_sno(c) + else + ! avoid tiny but non-zero elai and esai that can cause radiation and/or photosynthesis code to blow up + frac_sno_adjusted = 1._r8 + end if + + elai(p) = max(tlai(p)*(1.0_r8 - frac_sno_adjusted) + tlai(p)*fb*frac_sno_adjusted, 0.0_r8) + esai(p) = max(tsai(p)*(1.0_r8 - frac_sno_adjusted) + tsai(p)*fb*frac_sno_adjusted, 0.0_r8) + + ! Fraction of vegetation free of snow + if ((elai(p) + esai(p)) > 0._r8) then + frac_veg_nosno_alb(p) = 1 + else + frac_veg_nosno_alb(p) = 0 + end if + + end do + + end associate + + end subroutine CNVegStructUpdate + +end module CNVegStructUpdateMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegetationFacade.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegetationFacade.F90 new file mode 100755 index 000000000..a792cf7cf --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegetationFacade.F90 @@ -0,0 +1,1682 @@ +module CNVegetationFacade + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Facade for the CN Vegetation subsystem. + ! + ! (A "facade", in software engineering terms, is a unified interface to a set of + ! interfaces in a subsystem. The facade defines a higher-level interface that makes the + ! subsystem easier to use.) + ! + ! NOTE(wjs, 2016-02-19) I envision that we will introduce an abstract base class + ! (VegBase). Then both CNVeg and EDVeg will extend VegBase. The rest of the CLM code can + ! then have an instance of VegBase, which depending on the run, can be either a CNVeg or + ! EDVeg instance. + ! + ! In addition, we probably want an implementation when running without CN or fates - i.e., + ! an SPVeg inst. This would provide implementations for get_leafn_patch, + ! get_downreg_patch, etc., so that we don't need to handle the non-cn case here (note + ! that, currently, we return NaN for most of these getters, because these arrays are + ! invalid and shouldn't be used when running in SP mode). Also, in its EcosystemDynamics + ! routine, it would call SatellitePhenology (but note that the desired interface for + ! EcosystemDynamics would be quite different... could just pass everything needed by any + ! model, and ignore unneeded arguments). Then we can get rid of comments in this module + ! like, "only call if use_cn is true", as well as use_cn conditionals in this module. + ! + ! NOTE(wjs, 2016-02-23) Currently, SatellitePhenology is called even when running with + ! CN, for the sake of dry deposition. This seems weird to me, and my gut feeling - + ! without understanding it well - is that this should be rewritten to depend on LAI from + ! CN rather than from satellite phenology. Until that is done, the separation between SP + ! and other Veg modes will be messier. + ! + ! NOTE(wjs, 2016-02-23) Currently, this class coordinates calls to soil BGC routines as + ! well as veg BGC routines (even though it doesn't contain any soil BGC types). This is + ! because CNDriver coordinates both the veg & soil BGC. We should probably split up + ! CNDriver so that there is a cleaner separation between veg BGC and soil BGC, to allow + ! easier swapping of (for example) CN and ED. At that point, this class could + ! coordinate just the calls to veg BGC routines, with a similar facade class + ! coordinating the calls to soil BGC routines. + ! + ! !USES: +#include "shr_assert.h" + use shr_kind_mod , only : r8 => shr_kind_r8 + use nanMod , only : nan + use shr_log_mod , only : errMsg => shr_log_errMsg + use perf_mod , only : t_startf, t_stopf + use decompMod , only : bounds_type + use clm_varctl , only : iulog, use_cn, use_cndv, use_c13, use_c14 + use abortutils , only : endrun + use spmdMod , only : masterproc + use clm_time_manager , only : get_curr_date + use clm_time_manager , only : get_nstep, is_first_step + use CNBalanceCheckMod , only : cn_balance_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use FireMethodType , only : fire_method_type + use CNProductsMod , only : cn_products_type + use NutrientCompetitionMethodMod , only : nutrient_competition_method_type +! use SpeciesIsotopeType , only : species_isotope_type +! use SpeciesNonIsotopeType , only : species_non_isotope_type + use CanopyStateType , only : canopystate_type + use PhotosynthesisMod , only : photosyns_type + use atm2lndType , only : atm2lnd_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use WaterFluxBulkType , only : waterfluxbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use CropType , only : crop_type + use ch4Mod , only : ch4_type + use CNDVType , only : dgvs_type + ! use CNDVDriverMod , only : CNDVDriver, CNDVHIST + use EnergyFluxType , only : energyflux_type + use SaturatedExcessRunoffMod , only : saturated_excess_runoff_type + use FrictionVelocityMod , only : frictionvel_type + use ActiveLayerMod , only : active_layer_type + use SoilBiogeochemStateType , only : soilBiogeochem_state_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemCarbonFluxType , only : soilBiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use CNFireEmissionsMod , only : fireemis_type, CNFireEmisUpdate + !use CNDriverMod , only : CNDriverInit + use CNDriverMod , only : CNDriverSummarizeStates, CNDriverSummarizeFluxes + use CNDriverMod , only : CNDriverNoLeaching, CNDriverLeaching + use CNCStateUpdate1Mod , only : CStateUpdateDynPatch + use CNNStateUpdate1Mod , only : NStateUpdateDynPatch + use CNVegStructUpdateMod , only : CNVegStructUpdate + use CNAnnualUpdateMod , only : CNAnnualUpdate + !use dynConsBiogeochemMod , only : dyn_cnbal_patch, dyn_cnbal_col + !use dynCNDVMod , only : dynCNDV_init, dynCNDV_interp + use CNPrecisionControlMod , only: CNPrecisionControl + use SoilBiogeochemPrecisionControlMod , only: SoilBiogeochemPrecisionControl + use GridcellType , only : grc + ! + implicit none + private + + ! !PUBLIC TYPES: + + type, public :: cn_vegetation_type + ! FIXME(bja, 2016-06) These need to be public for use when fates is + ! turned on. Should either be moved out of here or create some ED + ! version of the facade.... + type(cnveg_state_type) :: cnveg_state_inst + type(cnveg_carbonstate_type) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) :: cnveg_carbonflux_inst + + !X!private + + type(cnveg_carbonstate_type) :: c13_cnveg_carbonstate_inst + type(cnveg_carbonstate_type) :: c14_cnveg_carbonstate_inst + type(cnveg_carbonflux_type) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) :: cnveg_nitrogenflux_inst + + type(cn_products_type) :: c_products_inst + type(cn_products_type) :: c13_products_inst + type(cn_products_type) :: c14_products_inst + type(cn_products_type) :: n_products_inst + + type(cn_balance_type) :: cn_balance_inst + class(fire_method_type), allocatable :: cnfire_method + type(dgvs_type) :: dgvs_inst + + ! Control variables + logical, private :: reseed_dead_plants ! Flag to indicate if should reseed dead plants when starting up the model + logical, private :: dribble_crophrv_xsmrpool_2atm = .False. ! Flag to indicate if should harvest xsmrpool to the atmosphere + + ! TODO(wjs, 2016-02-19) Evaluate whether some other variables should be moved in + ! here. Whether they should be moved in depends on how tightly they are tied in with + ! the other CN Vegetation stuff. A question to ask is: Is this module used when + ! running with SP or ED? If so, then it should probably remain outside of CNVeg. + ! + ! From the clm_instMod section on "CN vegetation types": + ! - nutrient_competition_method + ! - I'm pretty sure this should be moved into here; it's just a little messy to do + ! so, because of how it's initialized (specifically, the call to readParameters + ! in clm_initializeMod). + ! + ! From the clm_instMod section on "general biogeochem types": + ! - ch4_inst + ! - probably not: really seems to belong in soilbiogeochem + ! - crop_inst + ! - dust_inst + ! - vocemis_inst + ! - fireemis_inst + ! - drydepvel_inst + + contains + procedure, public :: Init +! procedure, public :: InitAccBuffer +! procedure, public :: InitAccVars +! procedure, public :: UpdateAccVars + ! procedure, public :: Restart + + ! procedure, public :: Init2 ! Do initialization in initialize phase, after subgrid weights are determined + procedure, public :: InitEachTimeStep ! Do initializations at the start of each time step + ! procedure, public :: InterpFileInputs ! Interpolate inputs from files + ! procedure, public :: UpdateSubgridWeights ! Update subgrid weights if running with prognostic patch weights + ! procedure, public :: DynamicAreaConservation ! Conserve C & N with updates in subgrid weights + procedure, public :: InitColumnBalance ! Set the starting point for col-level balance checks + procedure, public :: InitGridcellBalance ! Set the starting point for gridcell-level balance checks + procedure, public :: EcosystemDynamicsPreDrainage ! Do the main science that needs to be done before hydrology-drainage + procedure, public :: EcosystemDynamicsPostDrainage ! Do the main science that needs to be done after hydrology-drainage + procedure, public :: BalanceCheck ! Check the carbon and nitrogen balance + ! procedure, public :: EndOfTimeStepVegDynamics ! Do vegetation dynamics that should be done at the end of each time step + ! procedure, public :: WriteHistory ! Do any history writes that are specific to veg dynamics + + procedure, public :: get_net_carbon_exchange_grc ! Get gridcell-level net carbon exchange array + procedure, public :: get_leafn_patch ! Get patch-level leaf nitrogen array + procedure, public :: get_downreg_patch ! Get patch-level downregulation array + procedure, public :: get_root_respiration_patch ! Get patch-level root respiration array + procedure, public :: get_annsum_npp_patch ! Get patch-level annual sum NPP array + procedure, public :: get_agnpp_patch ! Get patch-level aboveground NPP array + procedure, public :: get_bgnpp_patch ! Get patch-level belowground NPP array + procedure, public :: get_froot_carbon_patch ! Get patch-level fine root carbon array + procedure, public :: get_croot_carbon_patch ! Get patch-level coarse root carbon array + procedure, public :: get_totvegc_col ! Get column-level total vegetation carbon array + + procedure, private :: CNReadNML ! Read in the CN general namelist + end type cn_vegetation_type + type(cn_vegetation_type), public, target, save :: bgc_vegetation_inst + + ! !PRIVATE DATA MEMBERS: + + integer, private :: skip_steps ! Number of steps to skip at startup + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + subroutine Init(this, bounds, NLFilename, nch, ityp, fveg, cncol, cnpft, paramfile, cn5_cold_start) + + ! + ! !DESCRIPTION: + ! Initialize a CNVeg object. + ! + ! Should be called regardless of whether use_cn is true + ! + ! !USES: + use CNFireFactoryMod , only : create_cnfire_method + use clm_varcon , only : c13ratio, c14ratio + use MAPL , only : NetCDF4_FileFormatter, pFIO_READ + use clm_varpar , only : num_zon, num_veg, & + var_col, var_pft + + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: NLFilename ! namelist filename + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: ityp ! PFT index + real, dimension(nch,NUM_VEG,NUM_ZON), intent(in) :: fveg ! PFT fraction + real, dimension(nch,NUM_ZON,VAR_COL), intent(in) :: cncol ! gkw: column CN restart + real, dimension(nch,NUM_ZON,NUM_VEG,VAR_PFT), intent(in) :: cnpft ! gkw: PFT CN restart + character(300), intent(in) :: paramfile + logical, optional, intent(in) :: cn5_cold_start + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: rc, status + type(Netcdf4_fileformatter) :: ncid + + character(len=*), parameter :: subname = 'Init' + !----------------------------------------------------------------------- + + begp = bounds%begp + endp = bounds%endp + + ! Note - always initialize the memory for cnveg_state_inst (used in biogeophys/) + call this%cnveg_state_inst%Init(bounds, nch, ityp, fveg, cncol, cnpft) + + + if (use_cn) then + + ! Read in the general CN namelist + ! call this%CNReadNML( NLFilename ) ! MUST be called first as passes down control information to others + + call this%cnveg_carbonstate_inst%Init (bounds, NLFilename, nch, ityp, fveg, cncol, cnpft) + + if (use_c13) then + call this%c13_cnveg_carbonstate_inst%Init (bounds, NLFilename, nch, ityp, fveg, cncol, cnpft) + end if + if (use_c14) then + call this%c14_cnveg_carbonstate_inst%Init (bounds, NLFilename, nch, ityp, fveg, cncol, cnpft) + end if + call this%cnveg_carbonflux_inst%Init (bounds, nch, ityp, fveg, cncol, cnpft, 'c12', cn5_cold_start) + if (use_c13) then + call this%c13_cnveg_carbonflux_inst%Init (bounds, nch, ityp, fveg, cncol, cnpft, 'c13', cn5_cold_start) + end if + if (use_c14) then + call this%c14_cnveg_carbonflux_inst%Init (bounds, nch, ityp, fveg, cncol, cnpft, 'c14', cn5_cold_start) + end if + call this%cnveg_nitrogenstate_inst%Init (bounds, nch, ityp, fveg, cncol, cnpft) + call this%cnveg_nitrogenflux_inst%Init (bounds, nch, ityp, fveg, cncol, cnpft) + + call this%c_products_inst%Init (bounds, nch, cncol, 'C') + if (use_c13) then + call this%c13_products_inst%Init (bounds, nch, cncol, 'C') + end if + if (use_c14) then + call this%c14_products_inst%Init (bounds, nch, cncol, 'C') + end if + call this%n_products_inst%Init (bounds, nch, cncol, 'N') + + call this%cn_balance_inst%Init(bounds) + + ! Initialize the memory for the dgvs_inst data structure regardless of whether + ! use_cndv is true so that it can be used in associate statements (nag compiler + ! complains otherwise) + call this%dgvs_inst%Init(bounds) + end if + + call create_cnfire_method(NLFilename, this%cnfire_method) + call this%cnfire_method%FireInit(bounds) + + call ncid%open(trim(paramfile),pFIO_READ, RC=status) + call this%cnfire_method%CNFireReadParams( ncid ) + call ncid%close(rc=status) + + end subroutine Init + + !----------------------------------------------------------------------- +! subroutine Init(this, bounds, NLFilename, nskip_steps, params_ncid) +! ! +! ! !DESCRIPTION: +! ! Initialize a CNVeg object. +! ! +! ! Should be called regardless of whether use_cn is true +! ! +! ! !USES: +! use CNFireFactoryMod , only : create_cnfire_method +! use clm_varcon , only : c13ratio, c14ratio +! use ncdio_pio , only : file_desc_t +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type), intent(inout) :: this +! type(bounds_type), intent(in) :: bounds +! character(len=*) , intent(in) :: NLFilename ! namelist filename +! integer , intent(in) :: nskip_steps ! Number of steps to skip at startup +! type(file_desc_t), intent(inout) :: params_ncid ! NetCDF handle to parameter file +! ! +! ! !LOCAL VARIABLES: +! integer :: begp, endp +! +! character(len=*), parameter :: subname = 'Init' +! !----------------------------------------------------------------------- +! +! begp = bounds%begp +! endp = bounds%endp +! +! ! Note - always initialize the memory for cnveg_state_inst (used in biogeophys/) +! call this%cnveg_state_inst%Init(bounds) +! +! skip_steps = nskip_steps +! +! if (use_cn) then +! +! ! Read in the general CN namelist +! call this%CNReadNML( NLFilename ) ! MUST be called first as passes down control information to others +! +! call this%cnveg_carbonstate_inst%Init(bounds, carbon_type='c12', ratio=1._r8, & +! NLFilename=NLFilename, dribble_crophrv_xsmrpool_2atm=this%dribble_crophrv_xsmrpool_2atm ) +! if (use_c13) then +! call this%c13_cnveg_carbonstate_inst%Init(bounds, carbon_type='c13', ratio=c13ratio, & +! NLFilename=NLFilename, dribble_crophrv_xsmrpool_2atm=this%dribble_crophrv_xsmrpool_2atm, & +! c12_cnveg_carbonstate_inst=this%cnveg_carbonstate_inst) +! end if +! if (use_c14) then +! call this%c14_cnveg_carbonstate_inst%Init(bounds, carbon_type='c14', ratio=c14ratio, & +! NLFilename=NLFilename, dribble_crophrv_xsmrpool_2atm=this%dribble_crophrv_xsmrpool_2atm, & +! c12_cnveg_carbonstate_inst=this%cnveg_carbonstate_inst) +! end if +! call this%cnveg_carbonflux_inst%Init(bounds, carbon_type='c12', dribble_crophrv_xsmrpool_2atm=this%dribble_crophrv_xsmrpool_2atm ) +! if (use_c13) then +! call this%c13_cnveg_carbonflux_inst%Init(bounds, carbon_type='c13', dribble_crophrv_xsmrpool_2atm=this%dribble_crophrv_xsmrpool_2atm) +! end if +! if (use_c14) then +! call this%c14_cnveg_carbonflux_inst%Init(bounds, carbon_type='c14', dribble_crophrv_xsmrpool_2atm=this%dribble_crophrv_xsmrpool_2atm) +! end if +! call this%cnveg_nitrogenstate_inst%Init(bounds, & +! this%cnveg_carbonstate_inst%leafc_patch(begp:endp), & +! this%cnveg_carbonstate_inst%leafc_storage_patch(begp:endp), & +! this%cnveg_carbonstate_inst%frootc_patch(begp:endp), & +! this%cnveg_carbonstate_inst%frootc_storage_patch(begp:endp), & +! this%cnveg_carbonstate_inst%deadstemc_patch(begp:endp) ) +! call this%cnveg_nitrogenflux_inst%Init(bounds) +! +! call this%c_products_inst%Init(bounds, species_non_isotope_type('C')) +! if (use_c13) then +! call this%c13_products_inst%Init(bounds, species_isotope_type('C', '13')) +! end if +! if (use_c14) then +! call this%c14_products_inst%Init(bounds, species_isotope_type('C', '14')) +! end if +! call this%n_products_inst%Init(bounds, species_non_isotope_type('N')) +! +! call this%cn_balance_inst%Init(bounds) +! +! ! Initialize the memory for the dgvs_inst data structure regardless of whether +! ! use_cndv is true so that it can be used in associate statements (nag compiler +! ! complains otherwise) +! call this%dgvs_inst%Init(bounds) +! end if +! +! call create_cnfire_method(NLFilename, this%cnfire_method) +! call this%cnfire_method%CNFireReadParams( params_ncid ) +! +! end subroutine Init + + !----------------------------------------------------------------------- + subroutine CNReadNML( this, NLFilename ) + ! + ! !DESCRIPTION: + ! Read in the general CN control namelist + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(inout) :: this + character(len=*) , intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'CNReadNML' + character(len=*), parameter :: nmlname = 'cn_general' ! MUST match what is in namelist below + !----------------------------------------------------------------------- + logical :: reseed_dead_plants + logical :: dribble_crophrv_xsmrpool_2atm + namelist /cn_general/ reseed_dead_plants, dribble_crophrv_xsmrpool_2atm + + reseed_dead_plants = this%reseed_dead_plants + dribble_crophrv_xsmrpool_2atm = this%dribble_crophrv_xsmrpool_2atm + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=cn_general, iostat=ierr) ! Namelist name here MUST be the same as in nmlname above! + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (reseed_dead_plants , mpicom) + call shr_mpi_bcast (dribble_crophrv_xsmrpool_2atm , mpicom) + + this%reseed_dead_plants = reseed_dead_plants + this%dribble_crophrv_xsmrpool_2atm = dribble_crophrv_xsmrpool_2atm + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=cn_general) ! Name here MUST be the same as in nmlname above! + write(iulog,*) ' ' + end if + + !----------------------------------------------------------------------- + + end subroutine CNReadNML + + + !----------------------------------------------------------------------- +! subroutine InitAccBuffer(this, bounds) +! ! +! ! !DESCRIPTION: +! ! Initialize accumulation buffer for types contained here +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type), intent(inout) :: this +! type(bounds_type), intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'InitAccBuffer' +! !----------------------------------------------------------------------- +! +! if (use_cndv) then +! call this%dgvs_inst%InitAccBuffer(bounds) +! end if +! +! end subroutine InitAccBuffer +! +! !----------------------------------------------------------------------- +! subroutine InitAccVars(this, bounds) +! ! +! ! !DESCRIPTION: +! ! Initialize variables that are associated with accumulated fields +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type), intent(inout) :: this +! type(bounds_type), intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'InitAccVars' +! !----------------------------------------------------------------------- +! +! if (use_cndv) then +! call this%dgvs_inst%initAccVars(bounds) +! end if +! +! end subroutine InitAccVars +! +! !----------------------------------------------------------------------- +! subroutine UpdateAccVars(this, bounds, t_a10_patch, t_ref2m_patch) +! ! +! ! !DESCRIPTION: +! ! Update accumulated variables +! ! +! ! Should be called every time step +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type), intent(inout) :: this +! type(bounds_type), intent(in) :: bounds +! ! NOTE(wjs, 2016-02-23) These need to be pointers to agree with the interface of +! ! UpdateAccVars in CNDVType (they are pointers there as a workaround for a compiler +! ! bug). +! real(r8), pointer , intent(in) :: t_a10_patch(:) ! 10-day running mean of the 2 m temperature (K) +! real(r8), pointer , intent(in) :: t_ref2m_patch(:) ! 2 m height surface air temperature (K) +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'UpdateAccVars' +! !----------------------------------------------------------------------- +! +! SHR_ASSERT_ALL_FL((ubound(t_a10_patch) == (/bounds%endp/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(t_ref2m_patch) == (/bounds%endp/)), sourcefile, __LINE__) +! +! if (use_cndv) then +! call this%dgvs_inst%UpdateAccVars(bounds, & +! t_a10_patch = t_a10_patch, & +! t_ref2m_patch = t_ref2m_patch) +! end if +! +! end subroutine UpdateAccVars + + + !----------------------------------------------------------------------- +! subroutine Restart(this, bounds, ncid, flag) +! ! +! ! !DESCRIPTION: +! ! Handle restart (read / write) for CNVeg +! ! +! ! Should be called regardless of whether use_cn is true +! ! +! ! !USES: +! use ncdio_pio, only : file_desc_t +! use clm_varcon, only : c3_r2, c14ratio +! use clm_varctl, only : use_soil_matrixcn, use_matrixcn +! use CNVegMatrixMod, only : CNVegMatrixRest +! use CNSoilMatrixMod, only : CNSoilMatrixRest +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type), intent(inout) :: this +! type(bounds_type), intent(in) :: bounds +! type(file_desc_t), intent(inout) :: ncid +! character(len=*) , intent(in) :: flag +! integer :: reseed_patch(bounds%endp-bounds%begp+1) +! integer :: num_reseed_patch +! ! +! ! !LOCAL VARIABLES: +! +! integer :: begp, endp +! real(r8) :: spinup_factor4deadwood ! Spinup factor used for deadwood (dead-stem and dead course root) +! +! character(len=*), parameter :: subname = 'Restart' +! !----------------------------------------------------------------------- +! +! if (use_cn) then +! begp = bounds%begp +! endp = bounds%endp +! call this%cnveg_carbonstate_inst%restart(bounds, ncid, flag=flag, carbon_type='c12', & +! reseed_dead_plants=this%reseed_dead_plants, filter_reseed_patch=reseed_patch, & +! num_reseed_patch=num_reseed_patch, spinup_factor4deadwood=spinup_factor4deadwood ) +! if ( flag /= 'read' .and. num_reseed_patch /= 0 )then +! call endrun(msg="ERROR num_reseed should be zero and is not"//errmsg(sourcefile, __LINE__)) +! end if +! if ( flag /= 'read' .and. spinup_factor4deadwood /= 10_r8 )then +! call endrun(msg="ERROR spinup_factor4deadwood should be 10 and is not"//errmsg(sourcefile, __LINE__)) +! end if +! if (use_c13) then +! call this%c13_cnveg_carbonstate_inst%restart(bounds, ncid, flag=flag, carbon_type='c13', & +! reseed_dead_plants=this%reseed_dead_plants, c12_cnveg_carbonstate_inst=this%cnveg_carbonstate_inst) +! end if +! if (use_c14) then +! call this%c14_cnveg_carbonstate_inst%restart(bounds, ncid, flag=flag, carbon_type='c14', & +! reseed_dead_plants=this%reseed_dead_plants, c12_cnveg_carbonstate_inst=this%cnveg_carbonstate_inst) +! end if +! +! call this%cnveg_carbonflux_inst%restart(bounds, ncid, flag=flag, carbon_type='c12') +! if (use_c13) then +! call this%c13_cnveg_carbonflux_inst%restart(bounds, ncid, flag=flag, carbon_type='c13') +! end if +! if (use_c14) then +! call this%c14_cnveg_carbonflux_inst%restart(bounds, ncid, flag=flag, carbon_type='c14') +! end if +! +! call this%cnveg_nitrogenstate_inst%restart(bounds, ncid, flag=flag, & +! leafc_patch=this%cnveg_carbonstate_inst%leafc_patch(begp:endp), & +! leafc_storage_patch=this%cnveg_carbonstate_inst%leafc_storage_patch(begp:endp), & +! frootc_patch=this%cnveg_carbonstate_inst%frootc_patch(begp:endp), & +! frootc_storage_patch=this%cnveg_carbonstate_inst%frootc_storage_patch(begp:endp), & +! deadstemc_patch=this%cnveg_carbonstate_inst%deadstemc_patch(begp:endp), & +! filter_reseed_patch=reseed_patch, num_reseed_patch=num_reseed_patch, & +! spinup_factor_deadwood=spinup_factor4deadwood ) +! call this%cnveg_nitrogenflux_inst%restart(bounds, ncid, flag=flag) +! call this%cnveg_state_inst%restart(bounds, ncid, flag=flag, & +! cnveg_carbonstate=this%cnveg_carbonstate_inst, & +! cnveg_nitrogenstate=this%cnveg_nitrogenstate_inst, & +! filter_reseed_patch=reseed_patch, num_reseed_patch=num_reseed_patch) +! +! call this%c_products_inst%restart(bounds, ncid, flag) +! if (use_c13) then +! call this%c13_products_inst%restart(bounds, ncid, flag, & +! template_for_missing_fields = this%c_products_inst, & +! template_multiplier = c3_r2) +! end if +! if (use_c14) then +! call this%c14_products_inst%restart(bounds, ncid, flag, & +! template_for_missing_fields = this%c_products_inst, & +! template_multiplier = c14ratio) +! end if +! call this%n_products_inst%restart(bounds, ncid, flag) +! +! if ( use_matrixcn )then +! call CNVegMatrixRest( ncid, flag ) +! end if +! end if +! +! if ( use_soil_matrixcn )then +! call CNSoilMatrixRest( ncid, flag ) +! end if +! +! if (use_cndv) then +! call this%dgvs_inst%Restart(bounds, ncid, flag=flag) +! end if +! +! end subroutine Restart + + !----------------------------------------------------------------------- +! subroutine Init2(this, bounds, NLFilename) +! ! +! ! !DESCRIPTION: +! ! Do initialization that is needed in the initialize phase, after subgrid weights are +! ! determined +! ! +! ! Should only be called if use_cn is true +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type) , intent(inout) :: this +! type(bounds_type) , intent(in) :: bounds +! character(len=*) , intent(in) :: NLFilename ! namelist filename +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'Init2' +! !----------------------------------------------------------------------- +! +! call CNDriverInit(bounds, NLFilename, this%cnfire_method) +! +! if (use_cndv) then +! call dynCNDV_init(bounds, this%dgvs_inst) +! end if +! +! end subroutine Init2 + + + !----------------------------------------------------------------------- + subroutine InitEachTimeStep(this, bounds, num_soilc, filter_soilc) + ! + ! !DESCRIPTION: + ! Do initializations that need to be done at the start of every time step + ! + ! This includes zeroing fluxes + ! + ! Should only be called if use_cn is true + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'InitEachTimeStep' + !----------------------------------------------------------------------- + + call this%cnveg_carbonflux_inst%ZeroDWT(bounds) + if (use_c13) then + call this%c13_cnveg_carbonflux_inst%ZeroDWT(bounds) + end if + if (use_c14) then + call this%c14_cnveg_carbonflux_inst%ZeroDWT(bounds) + end if + call this%cnveg_nitrogenflux_inst%ZeroDWT(bounds) + call this%cnveg_carbonstate_inst%ZeroDWT(bounds) + call this%cnveg_nitrogenstate_inst%ZeroDWT(bounds) + + end subroutine InitEachTimeStep + + !----------------------------------------------------------------------- +! subroutine InterpFileInputs(this, bounds) +! ! +! ! !DESCRIPTION: +! ! Interpolate inputs from files +! ! +! ! NOTE(wjs, 2016-02-23) Stuff done here could probably be done at the end of +! ! InitEachTimeStep, rather than in this separate routine, except for the fact that +! ! (currently) this Interp stuff is done with proc bounds rather thna clump bounds. I +! ! think that is needed so that you don't update a given stream multiple times. If we +! ! rework the handling of threading / clumps so that there is a separate object for +! ! each clump, then I think this problem would disappear - at which point we could +! ! remove this Interp routine, moving its body to the end of InitEachTimeStep. +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type) , intent(inout) :: this +! type(bounds_type) , intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'InterpFileInputs' +! !----------------------------------------------------------------------- +! +! call this%cnfire_method%FireInterp(bounds) +! +! end subroutine InterpFileInputs + + + !----------------------------------------------------------------------- +! subroutine UpdateSubgridWeights(this, bounds) +! ! +! ! !DESCRIPTION: +! ! Update subgrid weights if running with prognostic patch weights +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type) , intent(inout) :: this +! type(bounds_type) , intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'UpdateSubgridWeights' +! !----------------------------------------------------------------------- +! +! if (use_cndv) then +! call dynCNDV_interp(bounds, this%dgvs_inst) +! end if +! +! end subroutine UpdateSubgridWeights + + + !----------------------------------------------------------------------- +! subroutine DynamicAreaConservation(this, bounds, clump_index, & +! num_soilp_with_inactive, filter_soilp_with_inactive, & +! num_soilc_with_inactive, filter_soilc_with_inactive, & +! prior_weights, patch_state_updater, column_state_updater, & +! canopystate_inst, photosyns_inst, & +! soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & +! c13_soilbiogeochem_carbonstate_inst, c14_soilbiogeochem_carbonstate_inst, & +! soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, ch4_inst, soilbiogeochem_state_inst) +! ! +! ! !DESCRIPTION: +! ! Conserve C & N with updates in subgrid weights +! ! +! ! Should only be called if use_cn is true +! ! +! ! !USES: +! use dynPriorWeightsMod , only : prior_weights_type +! use dynPatchStateUpdaterMod, only : patch_state_updater_type +! use dynColumnStateUpdaterMod, only : column_state_updater_type +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type), intent(inout) :: this +! type(bounds_type) , intent(in) :: bounds +! +! ! Index of clump on which we're currently operating. Note that this implies that this +! ! routine must be called from within a clump loop. +! integer , intent(in) :: clump_index +! +! integer , intent(in) :: num_soilp_with_inactive ! number of points in filter_soilp_with_inactive +! integer , intent(in) :: filter_soilp_with_inactive(:) ! soil patch filter that includes inactive points +! integer , intent(in) :: num_soilc_with_inactive ! number of points in filter_soilc_with_inactive +! integer , intent(in) :: filter_soilc_with_inactive(:) ! soil column filter that includes inactive points +! type(prior_weights_type) , intent(in) :: prior_weights ! weights prior to the subgrid weight updates +! type(patch_state_updater_type) , intent(in) :: patch_state_updater +! type(column_state_updater_type) , intent(in) :: column_state_updater +! type(canopystate_type) , intent(inout) :: canopystate_inst +! type(photosyns_type) , intent(inout) :: photosyns_inst +! type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst +! type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst +! type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst +! type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst +! type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst +! type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst +! type(ch4_type) , intent(inout) :: ch4_inst +! type(soilbiogeochem_state_type) , intent(in) :: soilbiogeochem_state_inst +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'DynamicAreaConservation' +! !----------------------------------------------------------------------- +! +! call t_startf('dyn_cnbal_patch') +! call dyn_cnbal_patch(bounds, & +! num_soilp_with_inactive, filter_soilp_with_inactive, & +! prior_weights, patch_state_updater, & +! canopystate_inst, photosyns_inst, & +! this%cnveg_state_inst, & +! this%cnveg_carbonstate_inst, this%c13_cnveg_carbonstate_inst, this%c14_cnveg_carbonstate_inst, & +! this%cnveg_carbonflux_inst, this%c13_cnveg_carbonflux_inst, this%c14_cnveg_carbonflux_inst, & +! this%cnveg_nitrogenstate_inst, this%cnveg_nitrogenflux_inst, & +! soilbiogeochem_carbonflux_inst, soilbiogeochem_state_inst) +! call t_stopf('dyn_cnbal_patch') +! +! ! It is important to update column-level state variables based on the fluxes +! ! generated by dyn_cnbal_patch (which handles the change in aboveground / patch-level +! ! C/N due to shrinking patches), before calling dyn_cnbal_col (which handles the +! ! change in belowground / column-level C/N due to changing column areas). This way, +! ! any aboveground biomass which is sent to litter or soil due to shrinking patch +! ! areas is accounted for by the column-level conservation. This is important if +! ! column weights on the grid cell are changing at the same time as patch weights on +! ! the grid cell (which will typically be the case when columns change in area). +! ! +! ! The filters here need to include inactive points as well as active points so that +! ! we correctly update column states in columns that have just shrunk to 0 area - +! ! since those column states are still important in the following dyn_cnbal_col. +! call t_startf('CNUpdateDynPatch') +! call CStateUpdateDynPatch(bounds, num_soilc_with_inactive, filter_soilc_with_inactive, & +! this%cnveg_carbonflux_inst, this%cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst ) +! if (use_c13) then +! call CStateUpdateDynPatch(bounds, num_soilc_with_inactive, filter_soilc_with_inactive, & +! this%c13_cnveg_carbonflux_inst, this%c13_cnveg_carbonstate_inst, & +! c13_soilbiogeochem_carbonstate_inst) +! end if +! if (use_c14) then +! call CStateUpdateDynPatch(bounds, num_soilc_with_inactive, filter_soilc_with_inactive, & +! this%c14_cnveg_carbonflux_inst, this%c14_cnveg_carbonstate_inst, & +! c14_soilbiogeochem_carbonstate_inst) +! end if +! call NStateUpdateDynPatch(bounds, num_soilc_with_inactive, filter_soilc_with_inactive, & +! this%cnveg_nitrogenflux_inst, this%cnveg_nitrogenstate_inst, soilbiogeochem_nitrogenstate_inst, & +! soilbiogeochem_nitrogenflux_inst ) +! call t_stopf('CNUpdateDynPatch') +! +! ! This call fixes issue #741 by performing precision control on decomp_cpools_vr_col +! call t_startf('SoilBiogeochemPrecisionControl') +! call SoilBiogeochemPrecisionControl(num_soilc_with_inactive, filter_soilc_with_inactive, & +! soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & +! c14_soilbiogeochem_carbonstate_inst,soilbiogeochem_nitrogenstate_inst) +! call t_stopf('SoilBiogeochemPrecisionControl') +! +! call t_startf('dyn_cnbal_col') +! call dyn_cnbal_col(bounds, clump_index, column_state_updater, & +! soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & +! c14_soilbiogeochem_carbonstate_inst, soilbiogeochem_nitrogenstate_inst, & +! ch4_inst) +! call t_stopf('dyn_cnbal_col') +! +! end subroutine DynamicAreaConservation + + !----------------------------------------------------------------------- + subroutine InitColumnBalance(this, bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! Set the starting point for column-level balance checks. + ! + ! This should be called after DynamicAreaConservation, since the changes made by + ! DynamicAreaConservation can break column-level conservation checks. + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all active columns + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'InitColumnBalance' + !----------------------------------------------------------------------- + + call CNDriverSummarizeStates(bounds, & + num_allc, filter_allc, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + this%cnveg_carbonstate_inst, & + this%c13_cnveg_carbonstate_inst, & + this%c14_cnveg_carbonstate_inst, & + this%cnveg_nitrogenstate_inst, & + soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenstate_inst) + + call this%cn_balance_inst%BeginCNColumnBalance( & + bounds, num_soilc, filter_soilc, & + this%cnveg_carbonstate_inst, this%cnveg_nitrogenstate_inst) + + end subroutine InitColumnBalance + + + !----------------------------------------------------------------------- + subroutine InitGridcellBalance(this, bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, & + soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! Set the starting point for gridcell-level balance checks. + ! + ! Gridcell level: + ! Called before DynamicAreaConservation. + ! + ! !USES: + use subgridAveMod, only : c2g + ! + ! !ARGUMENTS: + class(cn_vegetation_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all active columns + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'InitGridcellBalance' + !----------------------------------------------------------------------- + + call CNDriverSummarizeStates(bounds, & + num_allc, filter_allc, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + this%cnveg_carbonstate_inst, & + this%c13_cnveg_carbonstate_inst, & + this%c14_cnveg_carbonstate_inst, & + this%cnveg_nitrogenstate_inst, & + soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenstate_inst) + + ! total gridcell carbon (TOTGRIDCELLC) + call c2g( bounds = bounds, & + carr = this%cnveg_carbonstate_inst%totc_col(bounds%begc:bounds%endc), & + garr = this%cnveg_carbonstate_inst%totc_grc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + ! total gridcell nitrogen (TOTGRIDCELLN) + call c2g( bounds = bounds, & + carr = this%cnveg_nitrogenstate_inst%totn_col(bounds%begc:bounds%endc), & + garr = this%cnveg_nitrogenstate_inst%totn_grc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + call this%cn_balance_inst%BeginCNGridcellBalance( bounds, & + this%cnveg_carbonflux_inst, & + this%cnveg_carbonstate_inst, this%cnveg_nitrogenstate_inst, & + this%c_products_inst, this%n_products_inst) + + end subroutine InitGridcellBalance + + + !----------------------------------------------------------------------- + subroutine EcosystemDynamicsPreDrainage(this, bounds, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + num_actfirec, filter_actfirec, & + num_actfirep, filter_actfirep, & + num_pcropp, filter_pcropp, & + num_exposedvegp, filter_exposedvegp, & + num_noexposedvegp, filter_noexposedvegp, & + doalb, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_state_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & + active_layer_inst, & + atm2lnd_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, waterfluxbulk_inst, & + wateratm2lndbulk_inst, canopystate_inst, soilstate_inst, temperature_inst, & + crop_inst, ch4_inst, & + photosyns_inst, saturated_excess_runoff_inst, energyflux_inst, & + nutrient_competition_method, fireemis_inst) + ! + ! !DESCRIPTION: + ! Do the main science for CN vegetation that needs to be done before hydrology-drainage + ! + ! Should only be called if use_cn is true + ! + ! !USES: + + ! + ! !ARGUMENTS: + class(cn_vegetation_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(out) :: num_actfirec ! number of soil columns on fire in filter + integer , intent(out) :: filter_actfirec(:)! filter for soil columns on fire + integer , intent(out) :: num_actfirep ! number of soil patches on fire in filter + integer , intent(out) :: filter_actfirep(:)! filter for soil patches on fire + integer , intent(in) :: num_pcropp ! number of prog. crop patches in filter + integer , intent(in) :: filter_pcropp(:) ! filter for prognostic crop patches + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + logical , intent(in) :: doalb ! true = surface albedo calculation time step + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(active_layer_type) , intent(in) :: active_layer_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(wateratm2lndbulk_type) , intent(inout) :: wateratm2lndbulk_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(inout) :: temperature_inst + type(crop_type) , intent(inout) :: crop_inst + type(ch4_type) , intent(in) :: ch4_inst + type(photosyns_type) , intent(in) :: photosyns_inst + type(saturated_excess_runoff_type) , intent(in) :: saturated_excess_runoff_inst + type(energyflux_type) , intent(in) :: energyflux_inst + class(nutrient_competition_method_type) , intent(inout) :: nutrient_competition_method + type(fireemis_type) , intent(inout) :: fireemis_inst + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'EcosystemDynamicsPreDrainage' + !----------------------------------------------------------------------- + + ! call crop_inst%CropIncrementYear(num_pcropp, filter_pcropp) + + call CNDriverNoLeaching(bounds, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + num_actfirec, filter_actfirec, & + num_actfirep, filter_actfirep, & + num_pcropp, filter_pcropp, & + num_exposedvegp, filter_exposedvegp, & + num_noexposedvegp, filter_noexposedvegp, & + doalb, & + this%cnveg_state_inst, & + this%cnveg_carbonflux_inst, this%cnveg_carbonstate_inst, & + this%c13_cnveg_carbonflux_inst, this%c13_cnveg_carbonstate_inst, & + this%c14_cnveg_carbonflux_inst, this%c14_cnveg_carbonstate_inst, & + this%cnveg_nitrogenflux_inst, this%cnveg_nitrogenstate_inst, & + this%c_products_inst, this%c13_products_inst, this%c14_products_inst, & + this%n_products_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_state_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst, & + active_layer_inst, & + atm2lnd_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, waterfluxbulk_inst, & + wateratm2lndbulk_inst, canopystate_inst, soilstate_inst, temperature_inst, & + crop_inst, ch4_inst, & + this%dgvs_inst, photosyns_inst, saturated_excess_runoff_inst, energyflux_inst, & + nutrient_competition_method, this%cnfire_method, this%dribble_crophrv_xsmrpool_2atm) + + ! fire carbon emissions + call CNFireEmisUpdate(bounds, num_soilp, filter_soilp, & + this%cnveg_carbonflux_inst, this%cnveg_carbonstate_inst, fireemis_inst ) + + call CNAnnualUpdate(bounds, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + this%cnveg_state_inst, this%cnveg_carbonflux_inst) + + end subroutine EcosystemDynamicsPreDrainage + + !----------------------------------------------------------------------- + subroutine EcosystemDynamicsPostDrainage(this, bounds, num_allc, filter_allc, & + num_soilc, filter_soilc, num_soilp, filter_soilp, num_actfirec, filter_actfirec, num_actfirep, filter_actfirep,& + doalb, crop_inst, soilstate_inst, soilbiogeochem_state_inst, & + waterstatebulk_inst, waterdiagnosticbulk_inst, waterfluxbulk_inst, frictionvel_inst, canopystate_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonflux_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonflux_inst, c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! Do the main science for CN vegetation that needs to be done after hydrology-drainage + ! + ! Should only be called if use_cn is true + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all active columns + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_actfirec ! number of soil columns on fire in filter + integer , intent(in) :: filter_actfirec(:) ! filter for soil columns on fire + integer , intent(in) :: num_actfirep ! number of soil patches on fire in filter + integer , intent(in) :: filter_actfirep(:) ! filter for soil patches on fire + logical , intent(in) :: doalb ! true = surface albedo calculation time step + type(crop_type) , intent(in) :: crop_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(frictionvel_type) , intent(in) :: frictionvel_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'EcosystemDynamicsPostDrainage' + !----------------------------------------------------------------------- + + ! Update the nitrogen leaching rate as a function of soluble mineral N + ! and total soil water outflow. + + call CNDriverLeaching(bounds, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + num_actfirec, filter_actfirec, & + num_actfirep, filter_actfirep, & + waterstatebulk_inst, waterfluxbulk_inst, soilstate_inst, this%cnveg_state_inst, & + this%cnveg_carbonflux_inst, this%cnveg_carbonstate_inst, soilbiogeochem_carbonstate_inst, & + soilbiogeochem_carbonflux_inst,soilbiogeochem_state_inst, & + this%cnveg_nitrogenflux_inst, this%cnveg_nitrogenstate_inst, & + soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst,& + this%c13_cnveg_carbonstate_inst,this%c14_cnveg_carbonstate_inst, & + this%c13_cnveg_carbonflux_inst,this%c14_cnveg_carbonflux_inst, & + c13_soilbiogeochem_carbonstate_inst,c14_soilbiogeochem_carbonstate_inst,& + c13_soilbiogeochem_carbonflux_inst,c14_soilbiogeochem_carbonflux_inst) + + ! Set controls on very low values in critical state variables + + call t_startf('CNPrecisionControl') + call CNPrecisionControl(bounds, num_soilp, filter_soilp, & + this%cnveg_carbonstate_inst, this%c13_cnveg_carbonstate_inst, & + this%c14_cnveg_carbonstate_inst, this%cnveg_nitrogenstate_inst) + call t_stopf('CNPrecisionControl') + + call t_startf('SoilBiogeochemPrecisionControl') + call SoilBiogeochemPrecisionControl(num_soilc, filter_soilc, & + soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst,soilbiogeochem_nitrogenstate_inst) + call t_stopf('SoilBiogeochemPrecisionControl') + + ! Call to all CN summary routines + + call CNDriverSummarizeStates(bounds, & + num_allc, filter_allc, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + this%cnveg_carbonstate_inst, & + this%c13_cnveg_carbonstate_inst, & + this%c14_cnveg_carbonstate_inst, & + this%cnveg_nitrogenstate_inst, & + soilbiogeochem_carbonstate_inst, & + c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, & + soilbiogeochem_nitrogenstate_inst) + + call CNDriverSummarizeFluxes(bounds, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + this%cnveg_carbonflux_inst, & + this%c13_cnveg_carbonflux_inst, & + this%c14_cnveg_carbonflux_inst, & + this%cnveg_nitrogenflux_inst, & + this%c_products_inst, this%c13_products_inst, this%c14_products_inst, & + soilbiogeochem_carbonflux_inst, & + c13_soilbiogeochem_carbonflux_inst, & + c14_soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenflux_inst) + + ! On the radiation time step, use C state variables to calculate + ! vegetation structure (LAI, SAI, height) + + if (doalb) then + call CNVegStructUpdate(bounds,num_soilp, filter_soilp, & + waterdiagnosticbulk_inst, frictionvel_inst, this%dgvs_inst, this%cnveg_state_inst, & + crop_inst, this%cnveg_carbonstate_inst, canopystate_inst) + end if + + end subroutine EcosystemDynamicsPostDrainage + + !----------------------------------------------------------------------- + subroutine BalanceCheck(this, bounds, num_soilc, filter_soilc, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenflux_inst, & + atm2lnd_inst) + ! + ! !DESCRIPTION: + ! Check the carbon and nitrogen balance + ! + ! Should only be called if use_cn is true + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'BalanceCheck' + !----------------------------------------------------------------------- + + + call this%cn_balance_inst%CBalanceCheck( & + bounds, num_soilc, filter_soilc, & + soilbiogeochem_carbonflux_inst, & + this%cnveg_carbonflux_inst, & + this%cnveg_carbonstate_inst, & + this%c_products_inst) + + call this%cn_balance_inst%NBalanceCheck( & + bounds, num_soilc, filter_soilc, & + soilbiogeochem_nitrogenflux_inst, & + this%cnveg_nitrogenflux_inst, & + this%cnveg_nitrogenstate_inst, & + this%n_products_inst, & + atm2lnd_inst) + + end subroutine BalanceCheck + + !----------------------------------------------------------------------- +! subroutine EndOfTimeStepVegDynamics(this, bounds, num_natvegp, filter_natvegp, & +! atm2lnd_inst, wateratm2lndbulk_inst) +! ! +! ! !DESCRIPTION: +! ! Do vegetation dynamics that should be done at the end of each time step +! ! +! ! Should only be called if use_cn is true +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type), intent(inout) :: this +! type(bounds_type) , intent(in) :: bounds +! integer , intent(inout) :: num_natvegp ! number of naturally-vegetated patches in filter +! integer , intent(inout) :: filter_natvegp(:) ! filter for naturally-vegetated patches +! type(atm2lnd_type) , intent(inout) :: atm2lnd_inst +! type(wateratm2lndbulk_type) , intent(inout) :: wateratm2lndbulk_inst +! ! +! ! !LOCAL VARIABLES: +! integer :: nstep ! time step number +! 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 :: kyr ! thousand years, equals 2 at end of first year +! +! character(len=*), parameter :: subname = 'EndOfTimeStepVegDynamics' +! !----------------------------------------------------------------------- +! +! if (use_cndv) then +! ! Call dv (dynamic vegetation) at last time step of year +! +! call t_startf('d2dgvm') +! if (is_end_curr_year() .and. .not. is_first_step()) then +! +! ! Get date info. kyr is used in lpj(). At end of first year, kyr = 2. +! call get_curr_date(yr, mon, day, sec) +! ncdate = yr*10000 + mon*100 + day +! call get_ref_date(yr, mon, day, sec) +! nbdate = yr*10000 + mon*100 + day +! kyr = ncdate/10000 - nbdate/10000 + 1 +! +! if (masterproc) then +! nstep = get_nstep() +! write(iulog,*) 'End of year. CNDV called now: ncdate=', & +! ncdate,' nbdate=',nbdate,' kyr=',kyr,' nstep=', nstep +! end if +! +! call CNDVDriver(bounds, & +! num_natvegp, filter_natvegp, kyr, & +! atm2lnd_inst, wateratm2lndbulk_inst, & +! this%cnveg_carbonflux_inst, this%cnveg_carbonstate_inst, this%dgvs_inst) +! end if +! call t_stopf('d2dgvm') +! end if +! +! end subroutine EndOfTimeStepVegDynamics + + !----------------------------------------------------------------------- +! subroutine WriteHistory(this, bounds) +! ! +! ! !DESCRIPTION: +! ! Do any history writes that are specific to vegetation dynamics +! ! +! ! NOTE(wjs, 2016-02-23) This could probably be combined with +! ! EndOfTimeStepVegDynamics, except for the fact that (currently) history writes are +! ! done with proc bounds rather than clump bounds. If that were changed, then the body +! ! of this could be moved into EndOfTimeStepVegDynamics, inside a "if (.not. +! ! use_noio)" conditional. +! ! +! ! Should only be called if use_cn is true +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(cn_vegetation_type), intent(in) :: this +! type(bounds_type) , intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'WriteHistory' +! !----------------------------------------------------------------------- +! +! ! Write to CNDV history buffer if appropriate +! if (use_cndv) then +! if (is_end_curr_year() .and. .not. is_first_step()) then +! call t_startf('clm_drv_io_hdgvm') +! call CNDVHist( bounds, this%dgvs_inst ) +! if (masterproc) write(iulog,*) 'Annual CNDV calculations are complete' +! call t_stopf('clm_drv_io_hdgvm') +! end if +! end if +! +! end subroutine WriteHistory + + + !----------------------------------------------------------------------- + function get_net_carbon_exchange_grc(this, bounds) result(net_carbon_exchange_grc) + ! + ! !DESCRIPTION: + ! Get gridcell-level net carbon exchange array + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) :: net_carbon_exchange_grc(bounds%begg:bounds%endg) ! function result: net carbon exchange between land and atmosphere, includes fire, landuse, harvest and hrv_xsmrpool flux, positive for source (gC/m2/s) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_net_carbon_exchange_grc' + !----------------------------------------------------------------------- + + if (use_cn) then + net_carbon_exchange_grc(bounds%begg:bounds%endg) = & + -this%cnveg_carbonflux_inst%nbp_grc(bounds%begg:bounds%endg) + else + net_carbon_exchange_grc(bounds%begg:bounds%endg) = 0._r8 + end if + + end function get_net_carbon_exchange_grc + + + !----------------------------------------------------------------------- + function get_leafn_patch(this, bounds) result(leafn_patch) + ! + ! !DESCRIPTION: + ! Get patch-level leaf nitrogen array + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) :: leafn_patch(bounds%begp:bounds%endp) ! function result: leaf N (gN/m2) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_leafn_patch' + !----------------------------------------------------------------------- + + if (use_cn) then + leafn_patch(bounds%begp:bounds%endp) = & + this%cnveg_nitrogenstate_inst%leafn_patch(bounds%begp:bounds%endp) + else + leafn_patch(bounds%begp:bounds%endp) = nan + end if + + end function get_leafn_patch + + !----------------------------------------------------------------------- + function get_downreg_patch(this, bounds) result(downreg_patch) + ! + ! !DESCRIPTION: + ! Get patch-level downregulation array + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) :: downreg_patch(bounds%begp:bounds%endp) ! function result: fractional reduction in GPP due to N limitation (dimensionless) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_downreg_patch' + !----------------------------------------------------------------------- + + if (use_cn) then + downreg_patch(bounds%begp:bounds%endp) = & + this%cnveg_state_inst%downreg_patch(bounds%begp:bounds%endp) + else + downreg_patch(bounds%begp:bounds%endp) = nan + end if + + end function get_downreg_patch + + !----------------------------------------------------------------------- + function get_root_respiration_patch(this, bounds) result(root_respiration_patch) + ! + ! !DESCRIPTION: + ! Get patch-level root respiration array + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) :: root_respiration_patch(bounds%begp:bounds%endp) ! function result: root respiration (fine root MR + total root GR) (gC/m2/s) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_root_respiration_patch' + !----------------------------------------------------------------------- + + if (use_cn) then + root_respiration_patch(bounds%begp:bounds%endp) = & + this%cnveg_carbonflux_inst%rr_patch(bounds%begp:bounds%endp) + else + root_respiration_patch(bounds%begp:bounds%endp) = nan + end if + + end function get_root_respiration_patch + + ! TODO(wjs, 2016-02-19) annsum_npp, agnpp and bgnpp are all needed for the estimation + ! of tillers in ch4Mod. Rather than providing getters for these three things so that + ! ch4Mod can estimate tillers, it would probably be better if the tiller estimation + ! algorithm was moved into some CNVeg-specific module, and then tillers could be + ! queried directly. + + !----------------------------------------------------------------------- + function get_annsum_npp_patch(this, bounds) result(annsum_npp_patch) + ! + ! !DESCRIPTION: + ! Get patch-level annual sum NPP array + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) :: annsum_npp_patch(bounds%begp:bounds%endp) ! function result: annual sum NPP (gC/m2/yr) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_annsum_npp_patch' + !----------------------------------------------------------------------- + + if (use_cn) then + annsum_npp_patch(bounds%begp:bounds%endp) = & + this%cnveg_carbonflux_inst%annsum_npp_patch(bounds%begp:bounds%endp) + else + annsum_npp_patch(bounds%begp:bounds%endp) = nan + end if + + end function get_annsum_npp_patch + + !----------------------------------------------------------------------- + function get_agnpp_patch(this, bounds) result(agnpp_patch) + ! + ! !DESCRIPTION: + ! Get patch-level aboveground NPP array + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) :: agnpp_patch(bounds%begp:bounds%endp) ! function result: aboveground NPP (gC/m2/s) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_agnpp_patch' + !----------------------------------------------------------------------- + + if (use_cn) then + agnpp_patch(bounds%begp:bounds%endp) = & + this%cnveg_carbonflux_inst%agnpp_patch(bounds%begp:bounds%endp) + else + agnpp_patch(bounds%begp:bounds%endp) = nan + end if + + end function get_agnpp_patch + + !----------------------------------------------------------------------- + function get_bgnpp_patch(this, bounds) result(bgnpp_patch) + ! + ! !DESCRIPTION: + ! Get patch-level belowground NPP array + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) :: bgnpp_patch(bounds%begp:bounds%endp) ! function result: belowground NPP (gC/m2/s) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_bgnpp_patch' + !----------------------------------------------------------------------- + + if (use_cn) then + bgnpp_patch(bounds%begp:bounds%endp) = & + this%cnveg_carbonflux_inst%bgnpp_patch(bounds%begp:bounds%endp) + else + bgnpp_patch(bounds%begp:bounds%endp) = nan + end if + + end function get_bgnpp_patch + + !----------------------------------------------------------------------- + function get_froot_carbon_patch(this, bounds, tlai) result(froot_carbon_patch) + ! + ! !DESCRIPTION: + ! Get patch-level fine root carbon array + ! + ! !USES: + use pftconMod , only : pftcon + use PatchType , only : patch + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) , intent(in) :: tlai( bounds%begp: ) + real(r8) :: froot_carbon_patch(bounds%begp:bounds%endp) ! function result: (gC/m2) + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'get_froot_carbon_patch' + integer :: p + !----------------------------------------------------------------------- + + if (use_cn) then + froot_carbon_patch(bounds%begp:bounds%endp) = & + this%cnveg_carbonstate_inst%frootc_patch(bounds%begp:bounds%endp) + else +! To get leaf biomass: +! bleaf = LAI / slatop +! g/m2 = m2/m2 / m2/g +! To get root biomass: +! broot = bleaf * froot_leaf(ivt(p)) +! g/m2 = g/m2 * g/g + do p=bounds%begp, bounds%endp + if (pftcon%slatop(patch%itype(p)) > 0._r8) then + froot_carbon_patch(p) = tlai(p) & + / pftcon%slatop(patch%itype(p)) & + *pftcon%froot_leaf(patch%itype(p)) + else + froot_carbon_patch(p) = 0._r8 + endif + enddo + end if + + end function get_froot_carbon_patch + + !----------------------------------------------------------------------- + function get_croot_carbon_patch(this, bounds, tlai) result(croot_carbon_patch) + ! + ! !DESCRIPTION: + ! Get patch-level live coarse root carbon array + ! + ! !USES: + use pftconMod , only : pftcon + use PatchType , only : patch + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) , intent(in) :: tlai( bounds%begp: ) + real(r8) :: croot_carbon_patch(bounds%begp:bounds%endp) ! function result: (gC/m2) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_croot_carbon_patch' + integer :: p + !----------------------------------------------------------------------- + + if (use_cn) then + croot_carbon_patch(bounds%begp:bounds%endp) = & + this%cnveg_carbonstate_inst%livecrootc_patch(bounds%begp:bounds%endp) + else +! To get leaf biomass: +! bleaf = LAI / slatop +! g/m2 = m2/m2 / m2/g +! To get root biomass: +! broot = bleaf * froot_leaf(ivt(p)) +! g/m2 = g/m2 * g/g + do p=bounds%begp, bounds%endp + if (pftcon%slatop(patch%itype(p)) > 0._r8) then + croot_carbon_patch(p) = tlai(p) & + / pftcon%slatop(patch%itype(p)) & + *pftcon%stem_leaf(patch%itype(p)) & + *pftcon%croot_stem(patch%itype(p)) + else + croot_carbon_patch(p) = 0._r8 + endif + enddo + end if + + end function get_croot_carbon_patch + + !----------------------------------------------------------------------- + function get_totvegc_col(this, bounds) result(totvegc_col) + ! + ! !DESCRIPTION: + ! Get column-level total vegetation carbon array + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_vegetation_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + real(r8) :: totvegc_col(bounds%begc:bounds%endc) ! function result: (gC/m2) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'get_totvegc_col' + !----------------------------------------------------------------------- + + if (use_cn) then + totvegc_col(bounds%begc:bounds%endc) = & + this%cnveg_carbonstate_inst%totvegc_col(bounds%begc:bounds%endc) + else + totvegc_col(bounds%begc:bounds%endc) = nan + end if + + end function get_totvegc_col + + +end module CNVegetationFacade diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CN_init_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CN_init_mod.F90 new file mode 100755 index 000000000..d3b046724 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CN_init_mod.F90 @@ -0,0 +1,390 @@ +#include "MAPL_Generic.h" + +module CN_initMod + + use ESMF + + use clm_varcon , only : clm_varcon_init + use clm_varpar , only : VAR_COL, VAR_PFT, clm_varpar_init + use clm_varctl , only : use_century_decomp, init_clm_varctl + use clm_time_manager , only : get_step_size, update_rad_dtime + use decompMod , only : bounds + use filterMod + use CNVegNitrogenStateType + use CNVegCarbonStateType + use atm2lndType + use TemperatureType + use SoilStateType + use WaterDiagnosticBulkType + use CanopyStateType + use SolarAbsorbedType + use SurfaceAlbedoType + use OzoneBaseMod + use pftconMod + use WaterFluxType + use SoilBiogeochemCarbonStateType + use SoilBiogeochemNitrogenStateType + use CNProductsMod + use SoilBiogeochemStateType + use CNVegStateType + use CNVegCarbonFluxType + use CNVegNitrogenFluxType + use GridcellType + use WaterFluxBulkType + use SoilBiogeochemCarbonFluxType + use SoilBiogeochemNitrogenFluxType + use PatchType + use ColumnType + use ch4Mod + use SoilBiogeochemDecompCascadeConType, only : init_decomp_cascade_constants + use ActiveLayerMod + use CropType + use CNDVType + use LandunitType , only : lun + use RootBiophysMod + use CNMRespMod , only : readCNMRespParams => readParams, CNMRespReadNML + use CNSharedParamsMod , only : CNParamsReadShared + use spmdMod + use Wateratm2lndBulkType + use WaterDiagnosticBulkType + use Wateratm2lndType + use EnergyFluxType + use SaturatedExcessRunoffMod + use WaterStateBulkType + use WaterStateType + use FrictionVelocityMod + use PhotosynthesisMod + use CNVegetationFacade + use initSubgridMod + use CN2CLMType + use WaterType , only : water_type + use CNBalanceCheckMod + + use SoilBiogeochemDecompCascadeBGCMod , only : init_decompcascade_bgc, DecompCascadeBGCreadNML + use SoilBiogeochemDecompCascadeBGCMod , only : readSoilBiogeochemDecompBgcParams => readParams + use SoilBiogeochemDecompCascadeCNMod , only : init_decompcascade_cn + use SoilBiogeochemDecompCascadeCNMod , only : readSoilBiogeochemDecompCnParams => readParams + use NutrientCompetitionFactoryMod , only : create_nutrient_competition_method + use NutrientCompetitionMethodMod , only : nutrient_competition_method_type + use SoilBiogeochemDecompMod , only : readSoilBiogeochemDecompParams => readParams + use CNPhenologyMod , only : readCNPhenolParams => readParams + use SoilBiogeochemLittVertTranspMod , only : readSoilBiogeochemLittVertTranspParams => readParams + use CNPhenologyMod , only : CNPhenologyReadNML, CNPhenologyInit + use dynSubgridControlMod , only : dynSubgridControl_init + use CNFireFactoryMod , only : CNFireReadNML, create_cnfire_method + use FireMethodType , only : fire_method_type + use SoilBiogeochemNLeachingMod , only : readSoilBiogeochemNLeachingParams => readParams + use SoilBiogeochemCompetitionMod , only : readSoilBiogeochemCompetitionParams => readParams + use SoilBiogeochemCompetitionMod , only : SoilBiogeochemCompetitionInit + use SoilBiogeochemPotentialMod , only : readSoilBiogeochemPotentialParams => readParams + use CNGapMortalityMod , only : readCNGapMortalityParams => readParams + use CNFUNMod , only : readCNFUNParams => readParams, & + CNFUNInit + use CNNDynamicsMod , only : CNNDynamicsReadNML + use SurfaceAlbedoMod , only: SurfaceAlbedo_readnl + use SoilBiogeochemPrecisionControlMod , only: SoilBiogeochemPrecisionControlInit + use SoilBiogeochemNitrifDenitrifMod , only : readSoilBiogeochemNitrifDenitrifParams => readParams + use SoilStateInitTimeConstMod , only : readParams_SoilStateInitTimeConst => readParams, & + SoilStateInitTimeConst + use clm_varpar , only : numpft, num_zon, num_veg, var_pft, var_col, & + nlevgrnd, nlevsoi + + use MAPL , only : NetCDF4_FileFormatter, pFIO_READ + + implicit none + private + + !type(photosyns_type), public :: photosyns_inst + class(nutrient_competition_method_type), public, allocatable :: nutrient_competition_method + class(fire_method_type), allocatable :: cnfire_method + type(saturated_excess_runoff_type), public :: saturated_excess_runoff_inst +! type(water_type), public :: water_inst +! type(bounds_type), public :: bounds +! type(patch_type) :: patch +! type(column_type) :: col +! type(landunit_type) :: lun +! type(cnveg_nitrogenstate_type), public :: cnveg_nitrogenstate_inst +! type(cnveg_carbonstate_type), public :: cnveg_carbonstate_inst +! type(atm2lnd_type), public :: atm2lnd_inst +! type(temperature_type), public :: temperature_inst +! type(soilstate_type), public :: soilstate_inst +! type(waterdiagnosticbulk_type), public :: waterdiagnosticbulk_inst +! type(wateratm2lnd_type), public :: wateratm2lnd_inst + ! type(canopystate_type), public :: canopystate_inst + ! type(solarabs_type), public :: solarabs_inst +! type(surfalb_type), public :: surfalb_inst +! type(ozone_base_type), public :: ozone_inst +! type(pftcon_type) :: pftcon + type(waterflux_type), public :: waterflux_inst +! type(soilbiogeochem_carbonstate_type), public :: soilbiogeochem_carbonstate_inst +! type(soilbiogeochem_nitrogenstate_type), public :: soilbiogeochem_nitrogenstate_inst +! type(cn_products_type), public :: c_products_inst +! type(cn_products_type), public :: n_products_inst +! type(soilbiogeochem_state_type), public :: soilbiogeochem_state_inst +! type(cnveg_state_type), public :: cnveg_state_inst +! type(cnveg_carbonflux_type), public :: cnveg_carbonflux_inst +! type(cnveg_nitrogenflux_type), public :: cnveg_nitrogenflux_inst + !type(gridcell_type) :: grc +! type(soilbiogeochem_carbonflux_type), public :: soilbiogeochem_carbonflux_inst +! type(soilbiogeochem_nitrogenflux_type), public :: soilbiogeochem_nitrogenflux_inst +! type(ch4_type), public :: ch4_inst +! type(crop_type), public :: crop_inst +! type(dgvs_type), public :: dgvs_inst +! type(energyflux_type), public :: energyflux_inst +! type(waterstatebulk_type), public :: waterstatebulk_inst +! type(waterstate_type), public :: waterstate_inst +! type(frictionvel_type), public :: frictionvel_inst +! type(cn_vegetation_type), public :: bgc_vegetation_inst + type(waterfluxbulk_type), public :: waterfluxbulk_inst + ! type(active_layer_type), public :: active_layer_inst + + + +! !PUBLIC MEMBER FUNCTIONS: + public :: CN_init + + contains + +!------------------------------------------------------ + subroutine CN_init(nch,ityp,fveg,cncol,cnpft,lats,lons,dtcn,water_inst,bgc_vegetation_inst,cn5_cold_start) + + !ARGUMENTS + implicit none + !INPUT/OUTPUT + integer, intent(in) :: nch ! number of tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + real, dimension(nch,num_zon,var_col), intent(in) :: cncol ! column-level CN restart variables + real, dimension(nch,num_zon,num_veg,var_pft), intent(in) :: cnpft ! patch/pft-level CN restart variables + real, dimension(nch), intent(in) :: lats ! Catchment tile latitudes [rad] + real, dimension(nch), intent(in) :: lons ! Catchment tile longitudes [rad] + real, intent(in) :: dtcn ! Catchment-CN step size + logical, optional, intent(in) :: cn5_cold_start ! cold start for the CLM variables that are new in Catchment-CN5.0 + type(water_type), intent(out) :: water_inst + type(cn_vegetation_type), intent(out) :: bgc_vegetation_inst + !LOCAL + +! type(bounds_type) :: bounds +!! type(patch_type) :: patch +!! type(column_type) :: col +!! type(landunit_type) :: lun +! type(cnveg_nitrogenstate_type) :: cnveg_nitrogenstate_inst +! type(cnveg_carbonstate_type) :: cnveg_carbonstate_inst +! type(atm2lnd_type) :: atm2lnd_inst +! type(temperature_type) :: temperature_inst +! type(soilstate_type) :: soilstate_inst +! type(waterdiagnosticbulk_type) :: waterdiagnosticbulk_inst +! type(wateratm2lndbulk_type) :: wateratm2lndbulk_inst +! type(wateratm2lnd_type) :: wateratm2lnd_inst +! type(canopystate_type) :: canopystate_inst +! type(solarabs_type) :: solarabs_inst +! type(surfalb_type) :: surfalb_inst +! type(ozone_base_type) :: ozone_inst +!! type(pftcon_type) :: pftcon +! type(waterflux_type) :: waterflux_inst +! type(soilbiogeochem_carbonstate_type) :: soilbiogeochem_carbonstate_inst +! type(soilbiogeochem_nitrogenstate_type) :: soilbiogeochem_nitrogenstate_inst +! type(cn_products_type) :: c_products_inst +! type(cn_products_type) :: n_products_inst +! type(soilbiogeochem_state_type) :: soilbiogeochem_state_inst +! type(cnveg_state_type) :: cnveg_state_inst +! type(cnveg_carbonflux_type) :: cnveg_carbonflux_inst +! type(cnveg_nitrogenflux_type) :: cnveg_nitrogenflux_inst +! !type(gridcell_type) :: grc +! type(soilbiogeochem_carbonflux_type) :: soilbiogeochem_carbonflux_inst +! type(soilbiogeochem_nitrogenflux_type) :: soilbiogeochem_nitrogenflux_inst +! type(ch4_type) :: ch4_inst +! type(crop_type) :: crop_inst +! type(dgvs_type) :: dgvs_inst +! type(saturated_excess_runoff_type) :: saturated_excess_runoff_inst +! type(energyflux_type) :: energyflux_inst +! type(waterstatebulk_type) :: waterstatebulk_inst +! type(waterstate_type) :: waterstate_inst +! type(frictionvel_type) :: frictionvel_inst +! type(cn_vegetation_type) :: bgc_vegetation_inst +! type(waterfluxbulk_type) :: waterfluxbulk_inst +! type(active_layer_type) :: active_layer_inst + + character(300) :: paramfile + character(300) :: NLFilename + type(Netcdf4_fileformatter) :: ncid + integer :: rc, status, ndt + + !----------------------------------------- + + paramfile = '/discover/nobackup/jkolassa/CLM/parameter_files/ctsm51_params.c210923.nc' + +! initialize CN step size + + ndt = get_step_size( nint(dtcn) ) + +! initialize CN model +! ------------------- + + call spmd_init() + + call clm_varpar_init() + + call clm_varcon_init() + + call init_clm_varctl() + + call bounds%Init (nch) + + ! initialize subrgid types + + call patch%Init (bounds, nch, ityp, fveg) + + call col%Init (bounds, nch) + + call lun%Init (bounds, nch) + + call grc%Init (bounds, nch, cnpft, lats, lons) + + ! create subgrid structure + + call clm_ptrs_compdown (bounds) + + ! initialize filters + + call allocFilters (bounds, nch, ityp, fveg) + + ! read parameters and configurations from namelist file + + NLFilename = trim('/discover/nobackup/jkolassa/new/CatchCN5.1.nml') + call CNPhenologyReadNML ( NLFilename ) + call dynSubgridControl_init ( ) + call CNFireReadNML ( NLFilename ) + call CNNDynamicsReadNML ( NLFilename ) + call photosyns_inst%ReadNML ( NLFilename ) + call canopystate_inst%ReadNML ( NLFilename ) + call DecompCascadeBGCreadNML ( NLFilename ) + call CNMRespReadNML ( NLFilename ) + call SurfaceAlbedo_readnl ( NLFilename ) + + ! initialize states and fluxes + + call pftcon%init_pftcon_type () + + call bgc_vegetation_inst%Init(bounds, NLFilename, nch, ityp, fveg, cncol, cnpft, paramfile, cn5_cold_start) + + call atm2lnd_inst%Init (bounds) + + call temperature_inst%Init (bounds) + + call soilstate_inst%Init (bounds) + + call SoilStateInitTimeConst (bounds, soilstate_inst, NLFilename) ! sets hydraulic and thermal soil properties + + call water_inst%Init (bounds) + + call canopystate_inst%Init (bounds, nch, ityp, fveg, cncol, cnpft, cn5_cold_start) + + call solarabs_inst%Init (bounds) + + call surfalb_inst%Init (bounds, nch, cncol, cnpft) + + call ozone_inst%Init (bounds) + + call photosyns_inst%Init (bounds, nch, ityp, fveg, cncol, cnpft, cn5_cold_start) + + call soilbiogeochem_carbonstate_inst%Init(bounds, nch, cncol) + + call soilbiogeochem_nitrogenstate_inst%Init(bounds, nch, cncol) + + call soilbiogeochem_state_inst%Init (bounds, nch, cncol, cnpft, ityp, fveg) + + call soilbiogeochem_carbonflux_inst%Init (bounds) + + call soilbiogeochem_nitrogenflux_inst%Init(bounds) + + call ch4_inst%Init (bounds) + + call init_decomp_cascade_constants (use_century_decomp) + + call active_layer_inst%Init (bounds) + + call crop_inst%Init (bounds) + + call dgvs_inst%Init (bounds) + + call saturated_excess_runoff_inst%Init(bounds) + + call energyflux_inst%Init (bounds) + + call frictionvel_inst%Init (bounds) + + call cn_balance_inst%Init (bounds) + + ! calls to original CTSM initialization routines + + ! initialize rooting profile parameters from namelist + + call init_rootprof(NLFilename) + + ! initialize root fractions + call init_vegrootfr(bounds, nlevsoi, nlevgrnd, & + soilstate_inst%rootfr_patch(bounds%begp:bounds%endp,1:nlevgrnd),'water') + call init_vegrootfr(bounds, nlevsoi, nlevgrnd, & + soilstate_inst%crootfr_patch(bounds%begp:bounds%endp,1:nlevgrnd),'carbon') + + ! allocate CLM arrays that are not allocated in their modules + + allocate(nutrient_competition_method, & + source=create_nutrient_competition_method(bounds)) ! jkolassa: this allocates and initializes the nutrient_competition_method_type + + ! initialize CLM parameters from parameter file + + call ncid%open(trim(paramfile),pFIO_READ, RC=status) + + call readCNMRespParams(ncid) + call CNParamsReadShared(ncid, NLFilename) ! this is called CN params but really is for the soil biogeochem parameters + call readSoilBiogeochemDecompCnParams(ncid) + call readSoilBiogeochemDecompBgcParams(ncid) + call nutrient_competition_method%readParams(ncid) + call readSoilBiogeochemDecompParams(ncid) + call readCNPhenolParams(ncid) + call readSoilBiogeochemLittVertTranspParams(ncid) + call photosyns_inst%ReadParams( ncid ) + call readSoilBiogeochemNLeachingParams(ncid) + call readSoilBiogeochemCompetitionParams(ncid) + call readSoilBiogeochemPotentialParams(ncid) + call readCNGapMortalityParams(ncid) + call readCNFUNParams(ncid) + call readSoilBiogeochemNitrifDenitrifParams(ncid) + !call readParams_SoilStateInitTimeConst(ncid) + + call ncid%close(rc=status) + + ! initialize types that depend on parameters + + call CNPhenologyInit (bounds) + call SoilBiogeochemCompetitionInit (bounds) + call CNFUNInit(bounds,bgc_vegetation_inst%cnveg_state_inst,bgc_vegetation_inst%cnveg_carbonstate_inst,bgc_vegetation_inst%cnveg_nitrogenstate_inst) + + ! Initialize precision control for soil biogeochemistry (use soilbiogeochem_carbonstate three times, since we do not currently use isotopes) + call SoilBiogeochemPrecisionControlInit( soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonstate_inst, & + soilbiogeochem_carbonstate_inst, soilbiogeochem_nitrogenstate_inst) + + + ! call FireMethodInit(bounds,paramfile) + + if (use_century_decomp) then + call init_decompcascade_bgc(bounds, soilbiogeochem_state_inst, & + soilstate_inst ) + else + call init_decompcascade_cn(bounds, soilbiogeochem_state_inst) + end if + + ! initialize custom type used to pass Catchment information to nested CLM fire types + + call cn2clm_inst%Init (bounds) + + ! initialize radiation time + + call update_rad_dtime(.true.) + + end subroutine CN_init +end module CN_initMod + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/FireMethodType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/FireMethodType.F90 new file mode 100755 index 000000000..4c714a751 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/FireMethodType.F90 @@ -0,0 +1,233 @@ +module FireMethodType + + !--------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abstract base class for functions to implement fire model and fire data for + ! both FATES and BGC. + ! + ! Created by Erik Kluzek, following Bill Sack's implementation of polymorphism + ! !USES: + implicit none + private + ! + ! !PUBLIC TYPES: + public :: fire_method_type + + type, abstract :: fire_method_type + contains + + ! Initialize the fire datasets + procedure(FireInit_interface) , public, deferred :: FireInit + + ! Read namelist for the fire datasets + procedure(FireReadNML_interface), public, deferred :: FireReadNML + + ! Read parameters for the fire datasets + procedure(CNFireReadParams_interface), public, deferred :: CNFireReadParams + + ! Interpolate the fire datasets + ! procedure(FireInterp_interface) , public, deferred :: FireInterp + + ! Figure out the fire area + procedure(CNFireArea_interface) , public, deferred :: CNFireArea + + ! Figure out the fire fluxes + procedure(CNFireFluxes_interface) , public, deferred :: CNFireFluxes + + end type fire_method_type + + abstract interface + + ! Note: The following code is adapted based on what Bill Sacks has done for soil water retention curve + ! polymorphism. Therefore, I also keep some suggestions he gave there. + ! + ! - Make the interfaces contain all possible inputs that are needed by any + ! implementation; each implementation will then ignore the inputs it doesn't need. + ! + ! - For inputs that are needed only by particular implementations - and particularly + ! for inputs that are constant in time + ! pass these into the constructor, and save pointers to these inputs as components + ! of the child type that needs them. Then they aren't needed as inputs to the + ! individual routines, allowing the interfaces for these routines to remain more + ! consistent between different implementations. + ! + !--------------------------------------------------------------------------- + subroutine FireInit_interface(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize Fire datasets + ! + ! USES + use decompMod , only : bounds_type + import :: fire_method_type + ! !ARGUMENTS: + class(fire_method_type) :: this + type(bounds_type), intent(in) :: bounds + ! character(len=*), intent(in) :: NLFilename + !----------------------------------------------------------------------- + + end subroutine FireInit_interface + + subroutine FireReadNML_interface(this, NLFilename ) + ! + ! !DESCRIPTION: + ! Read general fire namelist + ! + ! USES + import :: fire_method_type + ! !ARGUMENTS: + class(fire_method_type) :: this + character(len=*), intent(in) :: NLFilename + !----------------------------------------------------------------------- + + end subroutine FireReadNML_interface + +! subroutine FireInterp_interface(this, bounds) +! ! +! ! !DESCRIPTION: +! ! Interpolate Fire datasets +! ! +! ! USES +! use decompMod , only : bounds_type +! import :: fire_method_type +! ! !ARGUMENTS: +! class(fire_method_type) :: this +! type(bounds_type), intent(in) :: bounds +! !----------------------------------------------------------------------- +! +! end subroutine FireInterp_interface + + !----------------------------------------------------------------------- + subroutine CNFireReadParams_interface( this, ncid ) + ! + ! Read in the constant parameters from the input NetCDF parameter file + ! !USES: + use ncdio_pio , only: file_desc_t + import :: fire_method_type + ! + ! !ARGUMENTS: + implicit none + class(fire_method_type) :: this + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + !-------------------------------------------------------------------- + + end subroutine CNFireReadParams_interface + + !----------------------------------------------------------------------- + subroutine CNFireArea_interface (this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_exposedvegp, filter_exposedvegp, num_noexposedvegp, filter_noexposedvegp, & + atm2lnd_inst, energyflux_inst, saturated_excess_runoff_inst, & + waterdiagnosticbulk_inst, wateratm2lndbulk_inst, & + waterstatebulk_inst, soilstate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, totlitc_col, decomp_cpools_vr_col, t_soi17cm_col) + ! + ! !DESCRIPTION: + ! Computes column-level burned area + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use atm2lndType , only : atm2lnd_type + use EnergyFluxType , only : energyflux_type + use SaturatedExcessRunoffMod , only : saturated_excess_runoff_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use SoilStateType , only : soilstate_type + ! use SoilWaterRetentionCurveMod , only : soil_water_retention_curve_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + import :: fire_method_type + ! + ! !ARGUMENTS: + class(fire_method_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + integer , intent(in) :: num_noexposedvegp ! number of points in filter_noexposedvegp + integer , intent(in) :: filter_noexposedvegp(:) ! patch filter where frac_veg_nosno is 0 + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(energyflux_type) , intent(in) :: energyflux_inst + type(saturated_excess_runoff_type) , intent(in) :: saturated_excess_runoff_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(wateratm2lndbulk_type) , intent(in) :: wateratm2lndbulk_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + !class(soil_water_retention_curve_type), intent(in) :: soil_water_retention_curve + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + real(r8) , intent(in) :: totlitc_col(bounds%begc:) + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,1:,1:) + real(r8) , intent(in) :: t_soi17cm_col(bounds%begc:) + !----------------------------------------------------------------------- + end subroutine CNFireArea_interface + + !----------------------------------------------------------------------- + subroutine CNFireFluxes_interface (this, bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + num_actfirec, filter_actfirec, num_actfirep, filter_actfirep, & + dgvs_inst, cnveg_state_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, & + leaf_prof_patch, froot_prof_patch, croot_prof_patch, stem_prof_patch, & + totsomc_col, decomp_cpools_vr_col, decomp_npools_vr_col, somc_fire_col) + ! + ! !DESCRIPTION: + ! Fire effects routine for coupled carbon-nitrogen code (CN). + ! Relies primarily on estimate of fractional area burned, from FireArea(). + ! + ! Total fire carbon emissions (g C/m2 land area/yr) + ! =avg(COL_FIRE_CLOSS)*seconds_per_year + avg(SOMC_FIRE)*seconds_per_year + + ! avg(LF_CONV_CFLUX)*seconds_per_year*min(1.0,avg(LFC2)*seconds_per_year)*0.8 + ! where avg means the temporal average in a year + ! seconds_per_year is the number of seconds in a year. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use CNDVType , only : dgvs_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use SoilbiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + import :: fire_method_type + ! + ! !ARGUMENTS: + class(fire_method_type) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(out) :: num_actfirep ! number of active patches on fire in filter + integer , intent(out) :: filter_actfirep(:) ! filter for soil patches + integer , intent(out) :: num_actfirec ! number of active columns on fire in filter + integer , intent(out) :: filter_actfirec(:) ! filter for soil columns + type(dgvs_type) , intent(inout) :: dgvs_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + real(r8) , intent(in) :: leaf_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: froot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: croot_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: stem_prof_patch(bounds%begp:,1:) + real(r8) , intent(in) :: totsomc_col(bounds%begc:) ! (gC/m2) total soil organic matter C + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,1:,1:) ! (gC/m3) VR decomp. (litter, cwd, soil) + real(r8) , intent(in) :: decomp_npools_vr_col(bounds%begc:,1:,1:) ! (gC/m3) VR decomp. (litter, cwd, soil) + real(r8) , intent(out) :: somc_fire_col(bounds%begc:) ! (gC/m2/s) fire C emissions due to peat burning + !----------------------------------------------------------------------- + end subroutine CNFireFluxes_interface + + !----------------------------------------------------------------------- + + end interface + +end module FireMethodType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionCLM45defaultMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionCLM45defaultMod.F90 new file mode 100755 index 000000000..ba0e1a111 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionCLM45defaultMod.F90 @@ -0,0 +1,1171 @@ +module NutrientCompetitionCLM45defaultMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! DESCRIPTION + ! module contains different subroutines to do soil nutrient competition dynamics + ! + ! created by Jinyun Tang, Sep 8, 2014 + ! modified by Mariana Vertenstein, Nov 15, 2014 + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use NutrientCompetitionMethodMod, only : nutrient_competition_method_type + use NutrientCompetitionMethodMod, only : params_inst + ! use CNVegMatrixMod , only : matrix_update_phn + !use clm_varctl , only : iulog + ! + implicit none + private + ! + ! !PUBLIC TYPES: + public :: nutrient_competition_clm45default_type + ! + type, extends(nutrient_competition_method_type) :: nutrient_competition_clm45default_type + private + contains + ! public methocs + procedure, public :: init ! Initialize the class + procedure, public :: calc_plant_nutrient_competition ! calculate nutrient yield rate from competition + procedure, public :: calc_plant_nutrient_demand ! calculate plant nutrient demand + ! + ! private methods + procedure, private:: calc_plant_cn_alloc + procedure, private:: calc_plant_nitrogen_demand + end type nutrient_competition_clm45default_type + ! + interface nutrient_competition_clm45default_type + ! initialize a new nutrient_competition_clm45default_type object + ! module procedure constructor + end interface nutrient_competition_clm45default_type + ! + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ +! type(nutrient_competition_clm45default_type) function constructor() +! ! +! ! !DESCRIPTION: +! ! Creates an object of type nutrient_competition_clm45default_type. +! ! For now, this is simply a place-holder. +! +! end function constructor + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize the class (currently empty for this version) + ! + class(nutrient_competition_clm45default_type) :: this + type(bounds_type), intent(in) :: bounds + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine calc_plant_nutrient_competition (this, & + bounds, num_soilp, filter_soilp, & + cnveg_state_inst, crop_inst, canopystate_inst, cnveg_carbonstate_inst, & + cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_nitrogenstate_inst, & + aroot, arepr, fpg_col) + ! + ! !USES: + use CNVegStateType , only : cnveg_state_type + use CropType , only : crop_type + use CanopyStateType , only : canopystate_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType, only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemNitrogenStateType, only : soilbiogeochem_nitrogenstate_type + use CNSharedParamsMod , only : use_fun + ! + ! !ARGUMENTS: + class(nutrient_competition_clm45default_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type), intent(in) :: soilbiogeochem_nitrogenstate_inst + real(r8) , intent(in) :: aroot(bounds%begp:) + real(r8) , intent(in) :: arepr(bounds%begp:) + real(r8) , intent(in) :: fpg_col(bounds%begc:) + + call this%calc_plant_cn_alloc (bounds, num_soilp, filter_soilp, & + cnveg_state_inst, crop_inst, canopystate_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, c13_cnveg_carbonflux_inst, & + c14_cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, & + aroot=aroot(bounds%begp:bounds%endp), & + arepr=arepr(bounds%begp:bounds%endp), & + fpg_col=fpg_col(bounds%begc:bounds%endc)) + + end subroutine calc_plant_nutrient_competition + + !----------------------------------------------------------------------- + subroutine calc_plant_cn_alloc (this, bounds, num_soilp, filter_soilp, & + cnveg_state_inst, crop_inst, canopystate_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, c13_cnveg_carbonflux_inst, & + c14_cnveg_carbonflux_inst, cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst, & + aroot, arepr, fpg_col) + ! + ! !USES: + use pftconMod , only : pftcon, npcropmin + use clm_varctl , only : use_c13, use_c14, use_matrixcn + use CNVegStateType , only : cnveg_state_type + use CropType , only : crop_type + use CanopyStateType , only : canopystate_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use CNVegNitrogenStateType, only : cnveg_nitrogenstate_type + use CNSharedParamsMod , only : use_fun + use shr_infnan_mod , only : shr_infnan_isnan +!index for matrixcn + use clm_varpar , only : ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,& + igrain,igrain_st,igrain_xf,iretransn,ioutc,ioutn + + ! + ! !ARGUMENTS: + class(nutrient_competition_clm45default_type), intent(in) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + real(r8) , intent(in) :: aroot(bounds%begp:) + real(r8) , intent(in) :: arepr(bounds%begp:) + real(r8) , intent(in) :: fpg_col(bounds%begc:) + ! + ! !LOCAL VARIABLES: + integer :: c,p,l,j ! indices + integer :: fp ! lake filter patch index + real(r8):: f1,f2,f3,f4,g1,g2 ! allocation parameters + real(r8):: cnl,cnfr,cnlw,cndw ! C:N ratios for leaf, fine root, and wood + real(r8):: fcur ! fraction of current psn displayed as growth + real(r8):: gresp_storage ! temporary variable for growth resp to storage + real(r8):: nlc ! temporary variable for total new leaf carbon allocation + real(r8):: f5 ! grain allocation parameter + real(r8):: cng ! C:N ratio for grain (= cnlw for now; slevis) + real(r8):: fsmn(bounds%begp:bounds%endp) ! A emperate variable for adjusting FUN uptakes + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(aroot) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(arepr) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(fpg_col) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + fpg => fpg_col , & ! Input: [real(r8) (:) ] fraction of potential gpp (no units) + + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + froot_leaf => pftcon%froot_leaf , & ! Input: allocation parameter: new fine root C per new leaf C (gC/gC) + croot_stem => pftcon%croot_stem , & ! Input: allocation parameter: new coarse root C per new stem C (gC/gC) + stem_leaf => pftcon%stem_leaf , & ! Input: allocation parameter: new stem c per new leaf C (gC/gC) + flivewd => pftcon%flivewd , & ! Input: allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: fine root C:N (gC/gN) + livewdcn => pftcon%livewdcn , & ! Input: live wood (phloem and ray parenchyma) C:N (gC/gN) + deadwdcn => pftcon%deadwdcn , & ! Input: dead wood (xylem and heartwood) C:N (gC/gN) + fcur2 => pftcon%fcur , & ! Input: allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage + graincn => pftcon%graincn , & ! Input: grain C:N (gC/gN) + grperc => pftcon%grperc , & ! Input: growth respiration parameter + grpnow => pftcon%grpnow , & ! Input: growth respiration parameter + + croplive => crop_inst%croplive_patch , & ! Input: [logical (:) ] flag, true if planted, not harvested + + peaklai => cnveg_state_inst%peaklai_patch , & ! Input: [integer (:) ] 1: max allowed lai; 0: not at max + aleaf => cnveg_state_inst%aleaf_patch , & ! Output: [real(r8) (:) ] leaf allocation coefficient + astem => cnveg_state_inst%astem_patch , & ! Output: [real(r8) (:) ] stem allocation coefficient + c_allometry => cnveg_state_inst%c_allometry_patch , & ! Output: [real(r8) (:) ] C allocation index (DIM) + n_allometry => cnveg_state_inst%n_allometry_patch , & ! Output: [real(r8) (:) ] N allocation index (DIM) + downreg => cnveg_state_inst%downreg_patch , & ! Output: [real(r8) (:) ] fractional reduction in GPP due to N limitation (DIM) + + annsum_npp => cnveg_carbonflux_inst%annsum_npp_patch , & ! Input: [real(r8) (:) ] annual sum of NPP, for wood allocation + gpp => cnveg_carbonflux_inst%gpp_before_downreg_patch , & ! Output: [real(r8) (:) ] GPP flux before downregulation (gC/m2/s) + availc => cnveg_carbonflux_inst%availc_patch , & ! Output: [real(r8) (:) ] C flux available for allocation (gC/m2/s) + excess_cflux => cnveg_carbonflux_inst%excess_cflux_patch , & ! Output: [real(r8) (:) ] C flux not allocated due to downregulation (gC/m2/s) + plant_calloc => cnveg_carbonflux_inst%plant_calloc_patch , & ! Output: [real(r8) (:) ] total allocated C flux (gC/m2/s) + psnsun_to_cpool => cnveg_carbonflux_inst%psnsun_to_cpool_patch , & ! Output: [real(r8) (:) ] + psnshade_to_cpool => cnveg_carbonflux_inst%psnshade_to_cpool_patch , & ! Output: [real(r8) (:) ] + cpool_to_leafc => cnveg_carbonflux_inst%cpool_to_leafc_patch , & ! Output: [real(r8) (:) ] + cpool_to_leafc_storage => cnveg_carbonflux_inst%cpool_to_leafc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_frootc => cnveg_carbonflux_inst%cpool_to_frootc_patch , & ! Output: [real(r8) (:) ] + cpool_to_frootc_storage => cnveg_carbonflux_inst%cpool_to_frootc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_livestemc => cnveg_carbonflux_inst%cpool_to_livestemc_patch , & ! Output: [real(r8) (:) ] + cpool_to_livestemc_storage => cnveg_carbonflux_inst%cpool_to_livestemc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_deadstemc => cnveg_carbonflux_inst%cpool_to_deadstemc_patch , & ! Output: [real(r8) (:) ] + cpool_to_deadstemc_storage => cnveg_carbonflux_inst%cpool_to_deadstemc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_livecrootc => cnveg_carbonflux_inst%cpool_to_livecrootc_patch , & ! Output: [real(r8) (:) ] + cpool_to_livecrootc_storage => cnveg_carbonflux_inst%cpool_to_livecrootc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_deadcrootc => cnveg_carbonflux_inst%cpool_to_deadcrootc_patch , & ! Output: [real(r8) (:) ] + cpool_to_deadcrootc_storage => cnveg_carbonflux_inst%cpool_to_deadcrootc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_gresp_storage => cnveg_carbonflux_inst%cpool_to_gresp_storage_patch , & ! Output: [real(r8) (:) ] allocation to growth respiration storage (gC/m2/s) + cpool_to_grainc => cnveg_carbonflux_inst%cpool_to_grainc_patch , & ! Output: [real(r8) (:) ] allocation to grain C (gC/m2/s) + cpool_to_grainc_storage => cnveg_carbonflux_inst%cpool_to_grainc_storage_patch , & ! Output: [real(r8) (:) ] allocation to grain C storage (gC/m2/s) + + plant_ndemand => cnveg_nitrogenflux_inst%plant_ndemand_patch , & ! Output: [real(r8) (:) ] N flux required to support initial GPP (gN/m2/s) + plant_nalloc => cnveg_nitrogenflux_inst%plant_nalloc_patch , & ! Output: [real(r8) (:) ] total allocated N flux (gN/m2/s) + npool_to_grainn => cnveg_nitrogenflux_inst%npool_to_grainn_patch , & ! Output: [real(r8) (:) ] allocation to grain N (gN/m2/s) + npool_to_grainn_storage => cnveg_nitrogenflux_inst%npool_to_grainn_storage_patch , & ! Output: [real(r8) (:) ] allocation to grain N storage (gN/m2/s) + retransn_to_npool => cnveg_nitrogenflux_inst%retransn_to_npool_patch , & ! Output: [real(r8) (:) ] deployment of retranslocated N (gN/m2/s) + sminn_to_npool => cnveg_nitrogenflux_inst%sminn_to_npool_patch , & ! Output: [real(r8) (:) ] deployment of soil mineral N uptake (gN/m2/s) + retransn => cnveg_nitrogenstate_inst%retransn_patch , & ! Input: [real(r8) (:) ] (gN/m2) plant pool of retranslocated N + npool_to_leafn => cnveg_nitrogenflux_inst%npool_to_leafn_patch , & ! Output: [real(r8) (:) ] allocation to leaf N (gN/m2/s) + npool_to_leafn_storage => cnveg_nitrogenflux_inst%npool_to_leafn_storage_patch , & ! Output: [real(r8) (:) ] allocation to leaf N storage (gN/m2/s) + npool_to_frootn => cnveg_nitrogenflux_inst%npool_to_frootn_patch , & ! Output: [real(r8) (:) ] allocation to fine root N (gN/m2/s) + npool_to_frootn_storage => cnveg_nitrogenflux_inst%npool_to_frootn_storage_patch , & ! Output: [real(r8) (:) ] allocation to fine root N storage (gN/m2/s) + npool_to_livestemn => cnveg_nitrogenflux_inst%npool_to_livestemn_patch , & ! Output: [real(r8) (:) ] + npool_to_livestemn_storage => cnveg_nitrogenflux_inst%npool_to_livestemn_storage_patch , & ! Output: [real(r8) (:) ] + npool_to_deadstemn => cnveg_nitrogenflux_inst%npool_to_deadstemn_patch , & ! Output: [real(r8) (:) ] + npool_to_deadstemn_storage => cnveg_nitrogenflux_inst%npool_to_deadstemn_storage_patch , & ! Output: [real(r8) (:) ] + npool_to_livecrootn => cnveg_nitrogenflux_inst%npool_to_livecrootn_patch , & ! Output: [real(r8) (:) ] + npool_to_livecrootn_storage => cnveg_nitrogenflux_inst%npool_to_livecrootn_storage_patch , & ! Output: [real(r8) (:) ] + npool_to_deadcrootn => cnveg_nitrogenflux_inst%npool_to_deadcrootn_patch , & ! Output: [real(r8) (:) ] + npool_to_deadcrootn_storage => cnveg_nitrogenflux_inst%npool_to_deadcrootn_storage_patch , & ! Output: [real(r8) (:) ] + Npassive => cnveg_nitrogenflux_inst%Npassive_patch , & ! Output: [real(r8) (:) ] Passive N uptake (gN/m2/s) + Nfix => cnveg_nitrogenflux_inst%Nfix_patch , & ! Output: [real(r8) (:) ] Symbiotic BNF (gN/m2/s) + Nactive => cnveg_nitrogenflux_inst%Nactive_patch , & ! Output: [real(r8) (:) ] Mycorrhizal N uptake (gN/m2/s) + Nnonmyc => cnveg_nitrogenflux_inst%Nnonmyc_patch , & ! Output: [real(r8) (:) ] Non-mycorrhizal N uptake (gN/m2/s) + Nam => cnveg_nitrogenflux_inst%Nam_patch , & ! Output: [real(r8) (:) ] AM uptake (gN/m2/s) + Necm => cnveg_nitrogenflux_inst%Necm_patch , & ! Output: [real(r8) (:) ] ECM uptake (gN/m2/s) + sminn_to_plant_fun => cnveg_nitrogenflux_inst%sminn_to_plant_fun_patch , & ! Output: [real(r8) (:) ] Total N uptake of FUN (gN/m2/s) + iretransn_to_ileaf => cnveg_nitrogenflux_inst%iretransn_to_ileaf_ph , & ! Input: [integer] Transfer index (from retranslocation pool to leaf pool) + iretransn_to_ileafst => cnveg_nitrogenflux_inst%iretransn_to_ileafst_ph , & ! Input: [integer] Transfer index (from retranslocation pool to leaf storage pool) + iretransn_to_ifroot => cnveg_nitrogenflux_inst%iretransn_to_ifroot_ph , & ! Input: [integer] Transfer index (from retranslocation pool to fine root pool) + iretransn_to_ifrootst => cnveg_nitrogenflux_inst%iretransn_to_ifrootst_ph , & ! Input: [integer] Transfer index (from retranslocation pool to fine root storage pool) + iretransn_to_ilivestem => cnveg_nitrogenflux_inst%iretransn_to_ilivestem_ph , & ! Input: [integer] Transfer index (from retranslocation pool to live stem pool) + iretransn_to_ilivestemst => cnveg_nitrogenflux_inst%iretransn_to_ilivestemst_ph , & ! Input: [integer] Transfer index (from retranslocation pool to live stem storage pool) + iretransn_to_ideadstem => cnveg_nitrogenflux_inst%iretransn_to_ideadstem_ph , & ! Input: [integer] Transfer index (from retranslocation pool to dead stem pool) + iretransn_to_ideadstemst => cnveg_nitrogenflux_inst%iretransn_to_ideadstemst_ph , & ! Input: [integer] Transfer index (from retranslocation pool to dead stem storage pool) + iretransn_to_ilivecroot => cnveg_nitrogenflux_inst%iretransn_to_ilivecroot_ph , & ! Input: [integer] Transfer index (from retranslocation pool to live coarse root pool) + iretransn_to_ilivecrootst => cnveg_nitrogenflux_inst%iretransn_to_ilivecrootst_ph , & ! Input: [integer] Transfer index (from retranslocation pool to live coarse root storage pool) + iretransn_to_ideadcroot => cnveg_nitrogenflux_inst%iretransn_to_ideadcroot_ph , & ! Input: [integer] Transfer index (from retranslocation pool to dead coarse root pool) + iretransn_to_ideadcrootst => cnveg_nitrogenflux_inst%iretransn_to_ideadcrootst_ph , & ! Input: [integer] Transfer index (from retranslocation pool to dead coarse root storage pool) + iretransn_to_igrain => cnveg_nitrogenflux_inst%iretransn_to_igrain_ph , & ! Input: [integer] Transfer index (from retranslocation pool to grain pool) + iretransn_to_igrainst => cnveg_nitrogenflux_inst%iretransn_to_igrainst_ph , & ! Input: [integer] Transfer index (from retranslocation pool to grain storage pool) + ileaf_to_iretransn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer] Transfer index (from leaf pool to retranslocation pools) + ifroot_to_iretransn => cnveg_nitrogenflux_inst%ifroot_to_iretransn_ph , & ! Input: [integer] Transfer index (from fine root pool to retranslocation pools) + ilivestem_to_iretransn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph & ! Input: [integer] Transfer index (from live stem pool to retranslocation pools) + ) + + ! patch loop to distribute the available N between the competing patches + ! on the basis of relative demand, and allocate C and N to new growth and storage + + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + + ! set some local allocation variables + f1 = froot_leaf(ivt(p)) + f2 = croot_stem(ivt(p)) + + ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, + ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) + ! There was an error in this formula in previous version, where the coefficient + ! was 0.004 instead of 0.0025. + ! This variable allocation is only for trees. Shrubs have a constant + ! allocation as specified in the pft-physiology file. The value is also used + ! as a trigger here: -1.0 means to use the dynamic allocation (trees). + if (stem_leaf(ivt(p)) == -1._r8) then + f3 = (2.7/(1.0+exp(-0.004*(annsum_npp(p) - 300.0)))) - 0.4 + else + f3 = stem_leaf(ivt(p)) + end if + + f4 = flivewd(ivt(p)) + g1 = grperc(ivt(p)) + g2 = grpnow(ivt(p)) + cnl = leafcn(ivt(p)) + cnfr = frootcn(ivt(p)) + cnlw = livewdcn(ivt(p)) + cndw = deadwdcn(ivt(p)) + fcur = fcur2(ivt(p)) + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + if (croplive(p).and.(.not.shr_infnan_isnan(aleaf(p)))) then + f1 = aroot(p) / aleaf(p) + f3 = astem(p) / aleaf(p) + f5 = arepr(p) / aleaf(p) + g1 = 0.25_r8 + else + f1 = 0._r8 + f3 = 0._r8 + f5 = 0._r8 + g1 = 0.25_r8 + end if + end if + + if(use_fun)then ! if we are using FUN, we get the N available from there. + sminn_to_npool(p) = sminn_to_plant_fun(p) + else ! no FUN. :( we get N available from the FPG calculation in soilbiogeochemistry competition. + sminn_to_npool(p) = plant_ndemand(p) * fpg(c) + end if + + plant_nalloc(p) = sminn_to_npool(p) + retransn_to_npool(p) + plant_calloc(p) = plant_nalloc(p) * (c_allometry(p)/n_allometry(p)) + if (use_matrixcn)then + associate( & + matrix_Cinput => cnveg_carbonflux_inst%matrix_Cinput_patch , & ! Output: [real(r8) (:) ] C input of matrix (gC/m2/s) + matrix_Ninput => cnveg_nitrogenflux_inst%matrix_Ninput_patch & ! Output: [real(r8) (:) ] N input of matrix (gN/m2/s) + ) + matrix_Ninput(p) = sminn_to_npool(p)! + retransn_to_npool(p) + matrix_Cinput(p) = plant_nalloc(p) * (c_allometry(p)/n_allometry(p)) + end associate + end if + + + if(.not.use_fun)then !ORIGINAL CLM(CN) downregulation code. + excess_cflux(p) = availc(p) - plant_calloc(p) + ! reduce gpp fluxes due to N limitation + if (gpp(p) > 0.0_r8) then + downreg(p) = excess_cflux(p)/gpp(p) + + psnsun_to_cpool(p) = psnsun_to_cpool(p) *(1._r8 - downreg(p)) + psnshade_to_cpool(p) = psnshade_to_cpool(p)*(1._r8 - downreg(p)) + + if ( use_c13 ) then + c13_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) = & + c13_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) *(1._r8 - downreg(p)) + c13_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p) = & + c13_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p)*(1._r8 - downreg(p)) + end if + if ( use_c14 ) then + c14_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) = & + c14_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) *(1._r8 - downreg(p)) + c14_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p) = & + c14_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p)*(1._r8 - downreg(p)) + end if + end if + + end if !use_fun + + ! calculate the amount of new leaf C dictated by these allocation + ! decisions, and calculate the daily fluxes of C and N to current + ! growth and storage pools + + ! fcur is the proportion of this day's growth that is displayed now, + ! the remainder going into storage for display next year through the + ! transfer pools + + nlc = plant_calloc(p) / c_allometry(p) + + cpool_to_leafc(p) = nlc * fcur + cpool_to_leafc_storage(p) = nlc * (1._r8 - fcur) + cpool_to_frootc(p) = nlc * f1 * fcur + cpool_to_frootc_storage(p) = nlc * f1 * (1._r8 - fcur) + if (woody(ivt(p)) == 1._r8) then + cpool_to_livestemc(p) = nlc * f3 * f4 * fcur + cpool_to_livestemc_storage(p) = nlc * f3 * f4 * (1._r8 - fcur) + cpool_to_deadstemc(p) = nlc * f3 * (1._r8 - f4) * fcur + cpool_to_deadstemc_storage(p) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_livecrootc(p) = nlc * f2 * f3 * f4 * fcur + cpool_to_livecrootc_storage(p) = nlc * f2 * f3 * f4 * (1._r8 - fcur) + cpool_to_deadcrootc(p) = nlc * f2 * f3 * (1._r8 - f4) * fcur + cpool_to_deadcrootc_storage(p) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cpool_to_livestemc(p) = nlc * f3 * f4 * fcur + cpool_to_livestemc_storage(p) = nlc * f3 * f4 * (1._r8 - fcur) + cpool_to_deadstemc(p) = nlc * f3 * (1._r8 - f4) * fcur + cpool_to_deadstemc_storage(p) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_livecrootc(p) = nlc * f2 * f3 * f4 * fcur + cpool_to_livecrootc_storage(p) = nlc * f2 * f3 * f4 * (1._r8 - fcur) + cpool_to_deadcrootc(p) = nlc * f2 * f3 * (1._r8 - f4) * fcur + cpool_to_deadcrootc_storage(p) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_grainc(p) = nlc * f5 * fcur + cpool_to_grainc_storage(p) = nlc * f5 * (1._r8 -fcur) + end if + + ! corresponding N fluxes + npool_to_leafn(p) = (nlc / cnl) * fcur + npool_to_leafn_storage(p) = (nlc / cnl) * (1._r8 - fcur) + npool_to_frootn(p) = (nlc * f1 / cnfr) * fcur + npool_to_frootn_storage(p) = (nlc * f1 / cnfr) * (1._r8 - fcur) + if (woody(ivt(p)) == 1._r8) then + npool_to_livestemn(p) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cng = graincn(ivt(p)) + npool_to_livestemn(p) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_grainn(p) = (nlc * f5 / cng) * fcur + npool_to_grainn_storage(p) = (nlc * f5 / cng) * (1._r8 -fcur) + end if + if (use_matrixcn) then + associate( & + matrix_alloc => cnveg_carbonflux_inst%matrix_alloc_patch , & ! Output: [real(r8) (:,:) ] B-matrix for carbon allocation + matrix_nalloc => cnveg_nitrogenflux_inst%matrix_nalloc_patch & ! Output: [real(r8) (:,:) ] B-matrix for nitrogen allocation + ) + matrix_alloc(p,ileaf) = (1.0_r8) / c_allometry(p) * fcur + matrix_alloc(p,ileaf_st) = (1.0_r8) / c_allometry(p) * (1._r8 - fcur) + matrix_alloc(p,ifroot) = (1.0_r8) / c_allometry(p) * f1 * fcur + matrix_alloc(p,ifroot_st) = (1.0_r8) / c_allometry(p) * f1 * (1._r8 - fcur) + + matrix_nalloc(p,ileaf) = ((1.0_r8/cnl) / n_allometry(p)) * fcur + matrix_nalloc(p,ileaf_st) = ((1.0_r8/cnl) / n_allometry(p))* (1._r8 - fcur) + matrix_nalloc(p,ifroot) = ((f1/cnfr) / n_allometry(p)) * fcur + matrix_nalloc(p,ifroot_st) = ((f1/cnfr) / n_allometry(p)) * (1._r8 - fcur) + if (woody(ivt(p)) == 1._r8) then + matrix_alloc(p,ilivestem) = (1.0_r8) / c_allometry(p) * f3 * f4 * fcur + matrix_alloc(p,ilivestem_st) = (1.0_r8) / c_allometry(p) * f3 * f4 * (1._r8 - fcur) + matrix_alloc(p,ideadstem) = (1.0_r8) / c_allometry(p) * f3 * (1._r8 - f4) * fcur + matrix_alloc(p,ideadstem_st) = (1.0_r8) / c_allometry(p) * f3 * (1._r8 - f4) * (1._r8 - fcur) + matrix_alloc(p,ilivecroot) = (1.0_r8) / c_allometry(p) * f2 * f3 * f4 * fcur + matrix_alloc(p,ilivecroot_st) = (1.0_r8) / c_allometry(p) * f2 * f3 * f4 * (1._r8 - fcur) + matrix_alloc(p,ideadcroot) = (1.0_r8) / c_allometry(p) * f2 * f3 * (1._r8 - f4) * fcur + matrix_alloc(p,ideadcroot_st) = (1.0_r8) / c_allometry(p) * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + + matrix_nalloc(p,ilivestem) = (f3*f4/cnlw) / n_allometry(p) * fcur + matrix_nalloc(p,ilivestem_st) = (f3*f4/cnlw) / n_allometry(p) * (1._r8 - fcur) + matrix_nalloc(p,ideadstem) = (f3 * (1._r8 - f4)/cndw) / n_allometry(p) * fcur + matrix_nalloc(p,ideadstem_st) = (f3 * (1._r8 - f4)/cndw) / n_allometry(p) * (1._r8 - fcur) + matrix_nalloc(p,ilivecroot) = (f2 * f3 * f4/cnlw) / n_allometry(p) * fcur + matrix_nalloc(p,ilivecroot_st) = (f2 * f3 * f4 /cnlw) / n_allometry(p) * (1._r8 - fcur) + matrix_nalloc(p,ideadcroot) = (f2 * f3 * (1._r8 - f4)/cndw) / n_allometry(p) * fcur + matrix_nalloc(p,ideadcroot_st) = (f2 * f3 * (1._r8 - f4)/cndw) / n_allometry(p) *(1._r8 - fcur) + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + matrix_alloc(p,ilivestem) = (1.0_r8) / c_allometry(p) * f3 * f4 * fcur + matrix_alloc(p,ilivestem_st) = (1.0_r8) / c_allometry(p) * f3 * f4 * (1._r8 - fcur) + matrix_alloc(p,ideadstem) = (1.0_r8) / c_allometry(p) * f3 * (1._r8 - f4) * fcur + matrix_alloc(p,ideadstem_st) = (1.0_r8) / c_allometry(p) * f3 * (1._r8 - f4) * (1._r8 - fcur) + matrix_alloc(p,ilivecroot) = (1.0_r8) / c_allometry(p) * f2 * f3 * f4 * fcur + matrix_alloc(p,ilivecroot_st) = (1.0_r8) / c_allometry(p) * f2 * f3 * f4 * (1._r8 - fcur) + matrix_alloc(p,ideadcroot) = (1.0_r8) / c_allometry(p) * f2 * f3 * (1._r8 - f4) * fcur + matrix_alloc(p,ideadcroot_st) = (1.0_r8) / c_allometry(p) * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + matrix_alloc(p,igrain) = (1.0_r8) / c_allometry(p) * f5 * fcur + matrix_alloc(p,igrain_st) = (1.0_r8) / c_allometry(p) * f5 * (1._r8 - fcur) + + matrix_nalloc(p,ilivestem) = (f3*f4/cnlw) / n_allometry(p) * fcur + matrix_nalloc(p,ilivestem_st) = (f3*f4/cnlw) / n_allometry(p) * (1._r8 - fcur) + matrix_nalloc(p,ideadstem) = (f3 * (1._r8 - f4)/cndw) / n_allometry(p) * fcur + matrix_nalloc(p,ideadstem_st) = (f3 * (1._r8 - f4)/cndw) / n_allometry(p) * (1._r8 - fcur) + matrix_nalloc(p,ilivecroot) = (f2 * f3 * f4/cnlw) / n_allometry(p) * fcur + matrix_nalloc(p,ilivecroot_st) = (f2 * f3 * f4 /cnlw) / n_allometry(p) * (1._r8 - fcur) + matrix_nalloc(p,ideadcroot) = (f2 * f3 * (1._r8 - f4)/cndw) / n_allometry(p) * fcur + matrix_nalloc(p,ideadcroot_st) = (f2 * f3 * (1._r8 - f4)/cndw) / n_allometry(p) * (1._r8 - fcur) + matrix_nalloc(p,igrain) = (f5 / cng) / n_allometry(p) * fcur + matrix_nalloc(p,igrain_st) = (f5 / cng) / n_allometry(p) *(1._r8 - fcur) + end if + end associate + end if !end use_matrixcn + + ! Calculate the amount of carbon that needs to go into growth + ! respiration storage to satisfy all of the storage growth demands. + ! Allows for the fraction of growth respiration that is released at the + ! time of fixation, versus the remaining fraction that is stored for + ! release at the time of display. Note that all the growth respiration + ! fluxes that get released on a given timestep are calculated in growth_resp(), + ! but that the storage of C for growth resp during display of transferred + ! growth is assigned here. + + gresp_storage = cpool_to_leafc_storage(p) + cpool_to_frootc_storage(p) + if (woody(ivt(p)) == 1._r8) then + gresp_storage = gresp_storage + cpool_to_livestemc_storage(p) + gresp_storage = gresp_storage + cpool_to_deadstemc_storage(p) + + gresp_storage = gresp_storage + cpool_to_livecrootc_storage(p) + gresp_storage = gresp_storage + cpool_to_deadcrootc_storage(p) + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + gresp_storage = gresp_storage + cpool_to_livestemc_storage(p) + gresp_storage = gresp_storage + cpool_to_grainc_storage(p) + end if + cpool_to_gresp_storage(p) = gresp_storage * g1 * (1._r8 - g2) + + if(use_matrixcn)then + associate( & + matrix_Cinput => cnveg_carbonflux_inst%matrix_Cinput_patch & ! Output: [real(r8) (:) ] C input of matrix (gC/m2/s) + ) + matrix_Cinput(p) = plant_calloc(p) + if(use_c13 .and. psnsun_to_cpool(p)+psnshade_to_cpool(p).ne. 0.)then + associate( & + matrix_C13input => cnveg_carbonflux_inst%matrix_C13input_patch & ! C13 input of matrix + ) + matrix_C13input(p) = plant_calloc(p) * & + ((c13_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p)+ c13_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p))/ & + (psnsun_to_cpool(p)+psnshade_to_cpool(p))) + end associate + end if + if(use_c14 .and. psnsun_to_cpool(p)+psnshade_to_cpool(p).ne. 0.)then + associate( & + matrix_C14input => cnveg_carbonflux_inst%matrix_C14input_patch & ! C14 input of matrix + ) + matrix_C14input(p) = plant_calloc(p) * & + ((c14_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p)+ c14_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p))/ & + (psnsun_to_cpool(p)+psnshade_to_cpool(p))) + end associate + end if + if(retransn(p) .ne. 0)then + associate( & + matrix_nphtransfer => cnveg_nitrogenflux_inst%matrix_nphtransfer_patch, & ! Output: [real(r8) (:,:,:) ] A-matrix_phenology for nitrogen + matrix_nalloc => cnveg_nitrogenflux_inst%matrix_nalloc_patch & ! Output: [real(r8) (:,:) ] B-matrix for nitrogen allocation + ) + matrix_nphtransfer(p,iretransn_to_ileaf) = matrix_nphtransfer(p,iretransn_to_ileaf) & + + matrix_nalloc(p,ileaf ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ileafst) = matrix_nphtransfer(p,iretransn_to_ileafst) & + + matrix_nalloc(p,ileaf_st ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ifroot) = matrix_nphtransfer(p,iretransn_to_ifroot) & + + matrix_nalloc(p,ifroot ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ifrootst) = matrix_nphtransfer(p,iretransn_to_ifrootst) & + + matrix_nalloc(p,ifroot_st) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ilivestem) = matrix_nphtransfer(p,iretransn_to_ilivestem) & + + matrix_nalloc(p,ilivestem ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ilivestemst) = matrix_nphtransfer(p,iretransn_to_ilivestemst) & + + matrix_nalloc(p,ilivestem_st ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ideadstem) = matrix_nphtransfer(p,iretransn_to_ideadstem) & + + matrix_nalloc(p,ideadstem ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ideadstemst) = matrix_nphtransfer(p,iretransn_to_ideadstemst) & + + matrix_nalloc(p,ideadstem_st ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ilivecroot) = matrix_nphtransfer(p,iretransn_to_ilivecroot) & + + matrix_nalloc(p,ilivecroot ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ilivecrootst) = matrix_nphtransfer(p,iretransn_to_ilivecrootst) & + + matrix_nalloc(p,ilivecroot_st) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ideadcroot) = matrix_nphtransfer(p,iretransn_to_ideadcrootst) & + + matrix_nalloc(p,ideadcroot ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_ideadcrootst) = matrix_nphtransfer(p,iretransn_to_ideadcrootst) & + + matrix_nalloc(p,ideadcroot_st) * retransn_to_npool(p) / retransn(p) + if(ivt(p) >= npcropmin)then + matrix_nphtransfer(p,iretransn_to_igrain) = matrix_nphtransfer(p,iretransn_to_igrain) & + + matrix_nalloc(p,igrain ) * retransn_to_npool(p) / retransn(p) + matrix_nphtransfer(p,iretransn_to_igrainst) = matrix_nphtransfer(p,iretransn_to_igrainst) & + + matrix_nalloc(p,igrain_st ) * retransn_to_npool(p) / retransn(p) + end if + end associate + end if + end associate + end if !end use_matrixcn + end do ! end patch loop + + end associate + + end subroutine calc_plant_cn_alloc + + !----------------------------------------------------------------------- + subroutine calc_plant_nutrient_demand(this, bounds, num_soilp, filter_soilp,& + photosyns_inst, crop_inst, canopystate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenstate_inst, & + energyflux_inst, & + aroot, arepr) + ! + ! !USES: + use CanopyStateType , only : canopystate_type + use PhotosynthesisMod , only : photosyns_type + use CropType , only : crop_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemCarbonFluxType, only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType, only : soilbiogeochem_nitrogenstate_type + use EnergyFluxType , only : energyflux_type + use CNSharedParamsMod , only : use_fun + ! + ! !ARGUMENTS: + class(nutrient_competition_clm45default_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(photosyns_type) , intent(in) :: photosyns_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenstate_type), intent(in) :: soilbiogeochem_nitrogenstate_inst + type(energyflux_type) , intent(in) :: energyflux_inst + real(r8) , intent(out) :: aroot(bounds%begp:) + real(r8) , intent(out) :: arepr(bounds%begp:) + !----------------------------------------------------------------------- + + call this%calc_plant_nitrogen_demand(bounds, num_soilp, filter_soilp, & + photosyns_inst, crop_inst, canopystate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + aroot=aroot(bounds%begp:bounds%endp), & + arepr=arepr(bounds%begp:bounds%endp)) + + end subroutine calc_plant_nutrient_demand + + !----------------------------------------------------------------------- + subroutine calc_plant_nitrogen_demand(this, bounds, num_soilp, filter_soilp, & + photosyns_inst, crop_inst, canopystate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + aroot, arepr) + ! + ! !USES: + use pftconMod , only : npcropmin, pftcon + use pftconMod , only : ntmp_soybean, nirrig_tmp_soybean + use pftconMod , only : ntrp_soybean, nirrig_trp_soybean + use clm_varcon , only : secspday + use clm_varctl , only : use_c13, use_c14, use_matrixcn + use clm_time_manager , only : get_step_size_real + use CanopyStateType , only : canopystate_type + use PhotosynthesisMod , only : photosyns_type + use CropType , only : crop_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use CNSharedParamsMod , only : use_fun + use clm_varpar , only : ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,& + igrain,igrain_st,igrain_xf,iretransn,ioutc,ioutn + ! + ! !ARGUMENTS: + class(nutrient_competition_clm45default_type), intent(in) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(photosyns_type) , intent(in) :: photosyns_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + real(r8) , intent(out) :: aroot(bounds%begp:) + real(r8) , intent(out) :: arepr(bounds%begp:) + ! + ! !LOCAL VARIABLES: + integer :: c,p,l,j ! indices + integer :: fp ! lake filter patch index + real(r8):: mr ! maintenance respiration (gC/m2/s) + real(r8):: f1,f2,f3,f4,g1,g2 ! allocation parameters + real(r8):: cnl,cnfr,cnlw,cndw ! C:N ratios for leaf, fine root, and wood + real(r8):: curmr, curmr_ratio ! xsmrpool temporary variables + real(r8):: f5 ! grain allocation parameter + real(r8):: cng ! C:N ratio for grain (= cnlw for now; slevis) + real(r8):: fleaf ! fraction allocated to leaf + real(r8):: t1 ! temporary variable + real(r8):: dt ! model time step + real(r8):: dayscrecover ! number of days to recover negative cpool + + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(aroot) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(arepr) == (/bounds%endp/)), sourcefile, __LINE__) + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + froot_leaf => pftcon%froot_leaf , & ! Input: allocation parameter: new fine root C per new leaf C (gC/gC) + croot_stem => pftcon%croot_stem , & ! Input: allocation parameter: new coarse root C per new stem C (gC/gC) + stem_leaf => pftcon%stem_leaf , & ! Input: allocation parameter: new stem c per new leaf C (gC/gC) + flivewd => pftcon%flivewd , & ! Input: allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: fine root C:N (gC/gN) + livewdcn => pftcon%livewdcn , & ! Input: live wood (phloem and ray parenchyma) C:N (gC/gN) + deadwdcn => pftcon%deadwdcn , & ! Input: dead wood (xylem and heartwood) C:N (gC/gN) + graincn => pftcon%graincn , & ! Input: grain C:N (gC/gN) + fleafcn => pftcon%fleafcn , & ! Input: leaf c:n during organ fill + ffrootcn => pftcon%ffrootcn , & ! Input: froot c:n during organ fill + fstemcn => pftcon%fstemcn , & ! Input: stem c:n during organ fill + bfact => pftcon%bfact , & ! Input: parameter used below + aleaff => pftcon%aleaff , & ! Input: parameter used below + arootf => pftcon%arootf , & ! Input: parameter used below + astemf => pftcon%astemf , & ! Input: parameter used below + arooti => pftcon%arooti , & ! Input: parameter used below + fleafi => pftcon%fleafi , & ! Input: parameter used below + allconsl => pftcon%allconsl , & ! Input: parameter used below + allconss => pftcon%allconss , & ! Input: parameter used below + grperc => pftcon%grperc , & ! Input: parameter used below + grpnow => pftcon%grpnow , & ! Input: parameter used below + declfact => pftcon%declfact , & ! Input: + season_decid => pftcon%season_decid , & ! Input: binary flag for seasonal-deciduous leaf habit (0 or 1) + stress_decid => pftcon%stress_decid , & ! Input: binary flag for stress-deciduous leaf habit (0 or 1) + psnsun => photosyns_inst%psnsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) + psnsha => photosyns_inst%psnsha_patch , & ! Input: [real(r8) (:) ] shaded leaf-level photosynthesis (umol CO2 /m**2/ s) + c13_psnsun => photosyns_inst%c13_psnsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) + c13_psnsha => photosyns_inst%c13_psnsha_patch , & ! Input: [real(r8) (:) ] shaded leaf-level photosynthesis (umol CO2 /m**2/ s) + c14_psnsun => photosyns_inst%c14_psnsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) + c14_psnsha => photosyns_inst%c14_psnsha_patch , & ! Input: [real(r8) (:) ] shaded leaf-level photosynthesis (umol CO2 /m**2/ s) + + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit projected leaf area index + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded projected leaf area index + + hui => crop_inst%gddplant_patch , & ! Input: [real(r8) (:) ] =gdd since planting (gddplant) + leafout => crop_inst%gddtsoi_patch , & ! Input: [real(r8) (:) ] =gdd from top soil layer temperature + croplive => crop_inst%croplive_patch , & ! Input: [logical (:) ] flag, true if planted, not harvested + + gddmaturity => cnveg_state_inst%gddmaturity_patch , & ! Input: [real(r8) (:) ] gdd needed to harvest + huileaf => cnveg_state_inst%huileaf_patch , & ! Input: [real(r8) (:) ] heat unit index needed from planting to leaf emergence + huigrain => cnveg_state_inst%huigrain_patch , & ! Input: [real(r8) (:) ] same to reach vegetative maturity + peaklai => cnveg_state_inst%peaklai_patch , & ! Input: [integer (:) ] 1: max allowed lai; 0: not at max + aleafi => cnveg_state_inst%aleafi_patch , & ! Output: [real(r8) (:) ] saved allocation coefficient from phase 2 + astemi => cnveg_state_inst%astemi_patch , & ! Output: [real(r8) (:) ] saved allocation coefficient from phase 2 + aleaf => cnveg_state_inst%aleaf_patch , & ! Output: [real(r8) (:) ] leaf allocation coefficient + astem => cnveg_state_inst%astem_patch , & ! Output: [real(r8) (:) ] stem allocation coefficient + grain_flag => cnveg_state_inst%grain_flag_patch , & ! Output: [real(r8) (:) ] 1: grain fill stage; 0: not + c_allometry => cnveg_state_inst%c_allometry_patch , & ! Output: [real(r8) (:) ] C allocation index (DIM) + n_allometry => cnveg_state_inst%n_allometry_patch , & ! Output: [real(r8) (:) ] N allocation index (DIM) + tempsum_potential_gpp => cnveg_state_inst%tempsum_potential_gpp_patch , & ! Output: [real(r8) (:) ] temporary annual sum of potential GPP + tempmax_retransn => cnveg_state_inst%tempmax_retransn_patch , & ! Output: [real(r8) (:) ] temporary annual max of retranslocated N pool (gN/m2) + annsum_potential_gpp => cnveg_state_inst%annsum_potential_gpp_patch , & ! Output: [real(r8) (:) ] annual sum of potential GPP + annmax_retransn => cnveg_state_inst%annmax_retransn_patch , & ! Output: [real(r8) (:) ] annual max of retranslocated N pool + + xsmrpool => cnveg_carbonstate_inst%xsmrpool_patch , & ! Input: [real(r8) (:) ] (gC/m2) temporary photosynthate C pool + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) (:) ] + + retransn => cnveg_nitrogenstate_inst%retransn_patch , & ! Input: [real(r8) (:) ] (gN/m2) plant pool of retranslocated N + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) livestem N + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N + + annsum_npp => cnveg_carbonflux_inst%annsum_npp_patch , & ! Input: [real(r8) (:) ] annual sum of NPP, for wood allocation + leaf_mr => cnveg_carbonflux_inst%leaf_mr_patch , & ! Input: [real(r8) (:) ] + froot_mr => cnveg_carbonflux_inst%froot_mr_patch , & ! Input: [real(r8) (:) ] + livestem_mr => cnveg_carbonflux_inst%livestem_mr_patch , & ! Input: [real(r8) (:) ] + livecroot_mr => cnveg_carbonflux_inst%livecroot_mr_patch , & ! Input: [real(r8) (:) ] + grain_mr => cnveg_carbonflux_inst%grain_mr_patch , & ! Input: [real(r8) (:) ] + gpp => cnveg_carbonflux_inst%gpp_before_downreg_patch , & ! Output: [real(r8) (:) ] GPP flux before downregulation (gC/m2/s) + availc => cnveg_carbonflux_inst%availc_patch , & ! Output: [real(r8) (:) ] C flux available for allocation (gC/m2/s) + xsmrpool_recover => cnveg_carbonflux_inst%xsmrpool_recover_patch , & ! Output: [real(r8) (:) ] C flux assigned to recovery of negative cpool (gC/m2/s) + psnsun_to_cpool => cnveg_carbonflux_inst%psnsun_to_cpool_patch , & ! Output: [real(r8) (:) ] + psnshade_to_cpool => cnveg_carbonflux_inst%psnshade_to_cpool_patch , & ! Output: [real(r8) (:) ] + leaf_curmr => cnveg_carbonflux_inst%leaf_curmr_patch , & ! Output: [real(r8) (:) ] + froot_curmr => cnveg_carbonflux_inst%froot_curmr_patch , & ! Output: [real(r8) (:) ] + livestem_curmr => cnveg_carbonflux_inst%livestem_curmr_patch , & ! Output: [real(r8) (:) ] + livecroot_curmr => cnveg_carbonflux_inst%livecroot_curmr_patch , & ! Output: [real(r8) (:) ] + grain_curmr => cnveg_carbonflux_inst%grain_curmr_patch , & ! Output: [real(r8) (:) ] + leaf_xsmr => cnveg_carbonflux_inst%leaf_xsmr_patch , & ! Output: [real(r8) (:) ] + froot_xsmr => cnveg_carbonflux_inst%froot_xsmr_patch , & ! Output: [real(r8) (:) ] + livestem_xsmr => cnveg_carbonflux_inst%livestem_xsmr_patch , & ! Output: [real(r8) (:) ] + livecroot_xsmr => cnveg_carbonflux_inst%livecroot_xsmr_patch , & ! Output: [real(r8) (:) ] + grain_xsmr => cnveg_carbonflux_inst%grain_xsmr_patch , & ! Output: [real(r8) (:) ] + cpool_to_xsmrpool => cnveg_carbonflux_inst%cpool_to_xsmrpool_patch , & ! Output: [real(r8) (:) ] + + plant_ndemand => cnveg_nitrogenflux_inst%plant_ndemand_patch , & ! Output: [real(r8) (:) ] N flux required to support initial GPP (gN/m2/s) + avail_retransn => cnveg_nitrogenflux_inst%avail_retransn_patch , & ! Output: [real(r8) (:) ] N flux available from retranslocation pool (gN/m2/s) + retransn_to_npool => cnveg_nitrogenflux_inst%retransn_to_npool_patch , & ! Output: [real(r8) (:) ] deployment of retranslocated N (gN/m2/s) + sminn_to_npool => cnveg_nitrogenflux_inst%sminn_to_npool_patch , & ! Output: [real(r8) (:) ] deployment of soil mineral N uptake (gN/m2/s) + leafn_to_retransn => cnveg_nitrogenflux_inst%leafn_to_retransn_patch , & ! Output: [real(r8) (:) ] + frootn_to_retransn => cnveg_nitrogenflux_inst%frootn_to_retransn_patch , & ! Output: [real(r8) (:) ] + livestemn_to_retransn => cnveg_nitrogenflux_inst%livestemn_to_retransn_patch,& ! Output: [real(r8) (:) ] + ileaf_to_iretransn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Input: [integer] Index of phenology related N transfer from leaf pool to retranslocation pools + ifroot_to_iretransn => cnveg_nitrogenflux_inst%ifroot_to_iretransn_ph , & ! Input: [integer] Index of phenology related N transfer from fine root pool to retranslocation pools + ilivestem_to_iretransn=> cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph & ! Input: [integer] Index of phenology related N transfer from live stem pool to retranslocation pools + ) + + ! set time steps + dt = get_step_size_real() + + ! set number of days to recover negative cpool + dayscrecover = params_inst%dayscrecover + + ! loop over patches to assess the total plant N demand + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + ! get the time step total gross photosynthesis + ! this is coming from the canopy fluxes code, and is the + ! gpp that is used to control stomatal conductance. + ! For the nitrogen downregulation code, this is assumed + ! to be the potential gpp, and the actual gpp will be + ! reduced due to N limitation. + + ! Convert psn from umol/m2/s -> gC/m2/s + + ! The input psn (psnsun and psnsha) are expressed per unit LAI + ! in the sunlit and shaded canopy, respectively. These need to be + ! scaled by laisun and laisha to get the total gpp for allocation + + ! Note that no associate statement is used for the isotope carbon fluxes below + ! since they are not always allocated AND nag compiler will complain if you try to + ! to have an associate statement with unallocated memory + + psnsun_to_cpool(p) = psnsun(p) * laisun(p) * 12.011e-6_r8 + psnshade_to_cpool(p) = psnsha(p) * laisha(p) * 12.011e-6_r8 + + if ( use_c13 ) then + c13_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) = c13_psnsun(p) * laisun(p) * 12.011e-6_r8 + c13_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p) = c13_psnsha(p) * laisha(p) * 12.011e-6_r8 + endif + + if ( use_c14 ) then + c14_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) = c14_psnsun(p) * laisun(p) * 12.011e-6_r8 + c14_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p) = c14_psnsha(p) * laisha(p) * 12.011e-6_r8 + endif + + gpp(p) = psnsun_to_cpool(p) + psnshade_to_cpool(p) + + ! get the time step total maintenance respiration + ! These fluxes should already be in gC/m2/s + + mr = leaf_mr(p) + froot_mr(p) + if (woody(ivt(p)) == 1.0_r8) then + mr = mr + livestem_mr(p) + livecroot_mr(p) + else if (ivt(p) >= npcropmin) then + if (croplive(p)) mr = mr + livestem_mr(p) + grain_mr(p) + end if + + ! carbon flux available for allocation + availc(p) = gpp(p) - mr + + ! new code added for isotope calculations, 7/1/05, PET + ! If mr > gpp, then some mr comes from gpp, the rest comes from + ! cpool (xsmr) + if (mr > 0._r8 .and. availc(p) < 0._r8) then + curmr = gpp(p) + curmr_ratio = curmr / mr + else + curmr_ratio = 1._r8 + end if + leaf_curmr(p) = leaf_mr(p) * curmr_ratio + leaf_xsmr(p) = leaf_mr(p) - leaf_curmr(p) + froot_curmr(p) = froot_mr(p) * curmr_ratio + froot_xsmr(p) = froot_mr(p) - froot_curmr(p) + livestem_curmr(p) = livestem_mr(p) * curmr_ratio + livestem_xsmr(p) = livestem_mr(p) - livestem_curmr(p) + livecroot_curmr(p) = livecroot_mr(p) * curmr_ratio + livecroot_xsmr(p) = livecroot_mr(p) - livecroot_curmr(p) + grain_curmr(p) = grain_mr(p) * curmr_ratio + grain_xsmr(p) = grain_mr(p) - grain_curmr(p) + + ! no allocation when available c is negative + availc(p) = max(availc(p),0.0_r8) + + ! test for an xsmrpool deficit + if (xsmrpool(p) < 0.0_r8) then + ! Running a deficit in the xsmrpool, so the first priority is to let + ! some availc from this timestep accumulate in xsmrpool. + ! Determine rate of recovery for xsmrpool deficit + + xsmrpool_recover(p) = -xsmrpool(p)/(dayscrecover*secspday) + if (xsmrpool_recover(p) < availc(p)) then + ! available carbon reduced by amount for xsmrpool recovery + availc(p) = availc(p) - xsmrpool_recover(p) + else + ! all of the available carbon goes to xsmrpool recovery + xsmrpool_recover(p) = availc(p) + availc(p) = 0.0_r8 + end if + cpool_to_xsmrpool(p) = xsmrpool_recover(p) + end if + + f1 = froot_leaf(ivt(p)) + f2 = croot_stem(ivt(p)) + + ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, + ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) + ! This variable allocation is only for trees. Shrubs have a constant + ! allocation as specified in the pft-physiologfy file. The value is also used + ! as a trigger here: -1.0 means to use the dynamic allocation (trees). + + if (stem_leaf(ivt(p)) == -1._r8) then + f3 = (2.7/(1.0+exp(-0.004*(annsum_npp(p) - 300.0)))) - 0.4 + else + f3 = stem_leaf(ivt(p)) + end if + + f4 = flivewd(ivt(p)) + g1 = grperc(ivt(p)) + g2 = grpnow(ivt(p)) + cnl = leafcn(ivt(p)) + cnfr = frootcn(ivt(p)) + cnlw = livewdcn(ivt(p)) + cndw = deadwdcn(ivt(p)) + + ! calculate f1 to f5 for prog crops following AgroIBIS subr phenocrop + + f5 = 0._r8 ! continued intializations from above + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + + if (croplive(p)) then + ! same phases appear in subroutine CropPhenology + + ! Phase 1 completed: + ! ================== + ! if hui is less than the number of gdd needed for filling of grain + ! leaf emergence also has to have taken place for lai changes to occur + ! and carbon assimilation + ! Next phase: leaf emergence to start of leaf decline + + if (leafout(p) >= huileaf(p) .and. hui(p) < huigrain(p)) then + + ! allocation rules for crops based on maturity and linear decrease + ! of amount allocated to roots over course of the growing season + + if (peaklai(p) == 1) then ! lai at maximum allowed + arepr(p) = 0._r8 + aleaf(p) = 1.e-5_r8 + astem(p) = 0._r8 + aroot(p) = 1._r8 - arepr(p) - aleaf(p) - astem(p) + else + arepr(p) = 0._r8 + aroot(p) = max(0._r8, min(1._r8, arooti(ivt(p)) - & + (arooti(ivt(p)) - arootf(ivt(p))) * & + min(1._r8, hui(p)/gddmaturity(p)))) + fleaf = fleafi(ivt(p)) * (exp(-bfact(ivt(p))) - & + exp(-bfact(ivt(p))*hui(p)/huigrain(p))) / & + (exp(-bfact(ivt(p)))-1) ! fraction alloc to leaf (from J Norman alloc curve) + aleaf(p) = max(1.e-5_r8, (1._r8 - aroot(p)) * fleaf) + astem(p) = 1._r8 - arepr(p) - aleaf(p) - aroot(p) + end if + + ! AgroIBIS included here an immediate adjustment to aleaf & astem if the + ! predicted lai from the above allocation coefficients exceeded laimx. + ! We have decided to live with lais slightly higher than laimx by + ! enforcing the cap in the following tstep through the peaklai logic above. + + astemi(p) = astem(p) ! save for use by equations after shift + aleafi(p) = aleaf(p) ! to reproductive phenology stage begins + grain_flag(p) = 0._r8 ! setting to 0 while in phase 2 + + ! Phase 2 completed: + ! ================== + ! shift allocation either when enough gdd are accumulated or maximum number + ! of days has elapsed since planting + + else if (hui(p) >= huigrain(p)) then + + aroot(p) = max(0._r8, min(1._r8, arooti(ivt(p)) - & + (arooti(ivt(p)) - arootf(ivt(p))) * min(1._r8, hui(p)/gddmaturity(p)))) + if (astemi(p) > astemf(ivt(p))) then + astem(p) = max(0._r8, max(astemf(ivt(p)), astem(p) * & + (1._r8 - min((hui(p)- & + huigrain(p))/((gddmaturity(p)*declfact(ivt(p)))- & + huigrain(p)),1._r8)**allconss(ivt(p)) ))) + end if + if (aleafi(p) > aleaff(ivt(p))) then + aleaf(p) = max(1.e-5_r8, max(aleaff(ivt(p)), aleaf(p) * & + (1._r8 - min((hui(p)- & + huigrain(p))/((gddmaturity(p)*declfact(ivt(p)))- & + huigrain(p)),1._r8)**allconsl(ivt(p)) ))) + end if + + !Beth's retranslocation of leafn, stemn, rootn to organ + !Filter excess plant N to retransn pool for organ N + !Only do one time then hold grain_flag till onset next season + + ! slevis: Will astem ever = astemf exactly? + ! Beth's response: ...looks like astem can equal astemf under the right circumstances. + !It might be worth a rewrite to capture what I was trying to do, but the retranslocation for + !corn and wheat begins at the beginning of the grain fill stage, but for soybean I was holding it + !until after the leaf and stem decline were complete. Looking at how astem is calculated, once the + !stem decline is near complete, astem should (usually) be set to astemf. The reason for holding off + !on soybean is that the retranslocation scheme begins at the beginning of the grain phase, when the + !leaf and stem are still growing, but declining. Since carbon is still getting allocated and now + !there is more nitrogen available, the nitrogen can be diverted from grain. For corn and wheat + !the impact was probably enough to boost productivity, but for soybean the nitrogen was better off + !fulfilling the grain fill. It seems that if the peak lai is reached for soybean though that this + !would be bypassed altogether, not the intended outcome. I checked several of my output files and + !they all seemed to be going through the retranslocation loop for soybean - good news. + + if (astem(p) == astemf(ivt(p)) .or. & + (ivt(p) /= ntmp_soybean .and. ivt(p) /= nirrig_tmp_soybean .and.& + ivt(p) /= ntrp_soybean .and. ivt(p) /= nirrig_trp_soybean)) then + if (grain_flag(p) == 0._r8)then + if(.not.use_fun) then + t1 = 1 / dt + leafn_to_retransn(p) = t1 * ((leafc(p) / leafcn(ivt(p))) - (leafc(p) / & + fleafcn(ivt(p)))) + livestemn_to_retransn(p) = t1 * ((livestemc(p) / livewdcn(ivt(p))) - (livestemc(p) / & + fstemcn(ivt(p)))) + frootn_to_retransn(p) = 0._r8 + if (ffrootcn(ivt(p)) > 0._r8) then + frootn_to_retransn(p) = t1 * ((frootc(p) / frootcn(ivt(p))) - (frootc(p) / & + ffrootcn(ivt(p)))) + end if + else !leafn retrans flux is handled in phenology + frootn_to_retransn(p) = 0._r8 + livestemn_to_retransn(p)=0.0_r8 + end if !fun + grain_flag(p) = 1._r8 + if(use_matrixcn)then +! if(leafn(p) .ne. 0._r8)then +! leafn_to_retransn(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iretransn,leafn_to_retransn(p) / leafn(p),dt,cnveg_nitrogenflux_inst,.True.,.False.) +! end if +! if(frootn(p) .ne. 0._r8)then +! frootn_to_retransn(p) = frootn(p) * matrix_update_phn(p,ifroot_to_iretransn,frootn_to_retransn(p) / frootn(p),dt,cnveg_nitrogenflux_inst,.True.,.False.) +! end if +! if(livestemn(p) .ne. 0._r8)then +! livestemn_to_retransn(p) = livestemn(p) * matrix_update_phn(p,ilivestem_to_iretransn,livestemn_to_retransn(p) / livestemn(p),dt,cnveg_nitrogenflux_inst,.True.,.False.) +! end if + end if + end if + end if + + arepr(p) = 1._r8 - aroot(p) - astem(p) - aleaf(p) + + else ! pre emergence + aleaf(p) = 1.e-5_r8 ! allocation coefficients should be irrelevant + astem(p) = 0._r8 ! because crops have no live carbon pools; + aroot(p) = 0._r8 ! this applies to this "else" and to the "else" + arepr(p) = 0._r8 ! a few lines down + end if + + f1 = aroot(p) / aleaf(p) + f3 = astem(p) / aleaf(p) + f5 = arepr(p) / aleaf(p) + g1 = 0.25_r8 + + else ! .not croplive + f1 = 0._r8 + f3 = 0._r8 + f5 = 0._r8 + g1 = 0.25_r8 + end if + end if + + ! based on available C, use constant allometric relationships to + ! determine N requirements + + !RF. I removed the growth respiration from this, because it is used to calculate + !plantCN for N uptake AND c_allometry for allocation. If we add gresp to the + !allometry calculation then we allocate too much carbon since gresp is not allocated here. + if(.not.use_fun)then + if (woody(ivt(p)) == 1.0_r8) then + c_allometry(p) = (1._r8+g1)*(1._r8+f1+f3*(1._r8+f2)) + n_allometry(p) = 1._r8/cnl + f1/cnfr + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + else if (ivt(p) >= npcropmin) then ! skip generic crops + cng = graincn(ivt(p)) + c_allometry(p) = (1._r8+g1)*(1._r8+f1+f5+f3*(1._r8+f2)) + n_allometry(p) = 1._r8/cnl + f1/cnfr + f5/cng + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + else + c_allometry(p) = 1._r8+g1+f1+f1*g1 + n_allometry(p) = 1._r8/cnl + f1/cnfr + end if + else !no FUN. + if (woody(ivt(p)) == 1.0_r8) then + c_allometry(p) = (1._r8)*(1._r8+f1+f3*(1._r8+f2)) + n_allometry(p) = 1._r8/cnl + f1/cnfr + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + else if (ivt(p) >= npcropmin) then ! skip generic crops + cng = graincn(ivt(p)) + c_allometry(p) = (1._r8)*(1._r8+f1+f5+f3*(1._r8+f2)) + n_allometry(p) = 1._r8/cnl + f1/cnfr + f5/cng + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + else + c_allometry(p) = 1._r8+f1 + n_allometry(p) = 1._r8/cnl + f1/cnfr + end if + end if !use_fun + + plant_ndemand(p) = availc(p)*(n_allometry(p)/c_allometry(p)) + + ! retranslocated N deployment depends on seasonal cycle of potential GPP + ! (requires one year run to accumulate demand) + + tempsum_potential_gpp(p) = tempsum_potential_gpp(p) + gpp(p) + + ! Adding the following line to carry max retransn info to CN Annual Update + tempmax_retransn(p) = max(tempmax_retransn(p),retransn(p)) + + ! Beth's code: crops pull from retransn pool only during grain fill; + ! retransn pool has N from leaves, stems, and roots for + ! retranslocation + + if(.not.use_fun)then + + if (ivt(p) >= npcropmin .and. grain_flag(p) == 1._r8) then + avail_retransn(p) = plant_ndemand(p) + else if (ivt(p) < npcropmin .and. annsum_potential_gpp(p) > 0._r8) then + avail_retransn(p) = (annmax_retransn(p)/2._r8)*(gpp(p)/annsum_potential_gpp(p))/dt + else + avail_retransn(p) = 0.0_r8 + end if + + ! make sure available retrans N doesn't exceed storage + avail_retransn(p) = min(avail_retransn(p), retransn(p)/dt) + + ! modify plant N demand according to the availability of + ! retranslocated N + ! take from retransn pool at most the flux required to meet + ! plant ndemand + + if (plant_ndemand(p) > avail_retransn(p)) then + retransn_to_npool(p) = avail_retransn(p) + else + retransn_to_npool(p) = plant_ndemand(p) + end if + + if ( .not. use_fun ) then + plant_ndemand(p) = plant_ndemand(p) - retransn_to_npool(p) + else + if (season_decid(ivt(p)) == 1._r8.or.stress_decid(ivt(p))==1._r8) then + plant_ndemand(p) = plant_ndemand(p) - retransn_to_npool(p) + end if + end if + + end if !use_fun + + end do ! end patch loop + + end associate + + end subroutine calc_plant_nitrogen_demand + +end module NutrientCompetitionCLM45defaultMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionFactoryMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionFactoryMod.F90 new file mode 100755 index 000000000..99daa738f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionFactoryMod.F90 @@ -0,0 +1,87 @@ +module NutrientCompetitionFactoryMod + + !--------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Factory to create an instance of nutrient_competition_method_type. This module figures + ! out the particular type to return. + ! + ! !USES: + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog + + implicit none + save + private + ! + ! !PUBLIC ROUTINES: + public :: create_nutrient_competition_method ! create an object of class nutrient_competition_method_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + function create_nutrient_competition_method(bounds) result(nutrient_competition_method) + ! + ! !DESCRIPTION: + ! Create and return an object of nutrient_competition_method_type. The particular type + ! is determined based on a namelist parameter. + ! + ! !USES: + use shr_kind_mod , only : SHR_KIND_CL + use NutrientCompetitionMethodMod , only : nutrient_competition_method_type + use NutrientCompetitionCLM45defaultMod, only : nutrient_competition_clm45default_type + use NutrientCompetitionFlexibleCNMod , only : nutrient_competition_FlexibleCN_type + use decompMod , only : bounds_type + + ! FIXME(bja, 2015-06) need to pass method control in as a parameter + ! instead of relying on a global! + use clm_varctl, only : use_flexibleCN + + ! + ! !ARGUMENTS: + class(nutrient_competition_method_type), allocatable :: nutrient_competition_method ! function result + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + ! For now, hard-code the method. Eventually this will be set from namelist, either by + ! this routine (appropriate if the 'method' is in its own namelist group), or do the + ! namelist read outside this module and pass the method in as a parameter (appropriate + ! if the 'method' is part of a larger namelist group). + character(len=SHR_KIND_CL) :: method + + character(len=*), parameter :: subname = 'create_nutrient_competition_method' + !----------------------------------------------------------------------- + + ! FIXME(bja, 2015-06) flexible_cn may need to be + ! merged with other nitrogen code, so a more robust method of + ! selecting the competition method will depend on how the science + ! is merged. + method = "clm45default" + if (use_flexibleCN) then + method = "flexible_cn" + end if + + select case (trim(method)) + + case ("clm45default") + allocate(nutrient_competition_method, & + source=nutrient_competition_clm45default_type()) + + case ("flexible_cn") + allocate(nutrient_competition_method, & + source=nutrient_competition_FlexibleCN_type()) + + case default + write(iulog,*) subname//' ERROR: unknown method: ', method + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + call nutrient_competition_method%Init(bounds) + + end function create_nutrient_competition_method + +end module NutrientCompetitionFactoryMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionFlexibleCNMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionFlexibleCNMod.F90 new file mode 100755 index 000000000..668cd9672 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionFlexibleCNMod.F90 @@ -0,0 +1,1993 @@ +module NutrientCompetitionFlexibleCNMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! DESCRIPTION + ! module contains different subroutines to do soil nutrient competition dynamics + ! + ! FIXME(bja, 2015-08) This module was copied from + ! NutrientCompetitionCLM45default then flexible cn modifications + ! were added for the clm50 nitrogen science changes (r120). There is + ! a significant amount of duplicate code between the two + ! modules. They need to be reexamined and the common code pulled out + ! into a common base class. + ! + ! created by Jinyun Tang, Sep 8, 2014 + ! modified by Mariana Vertenstein, Nov 15, 2014 + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use nanMod , only : nan + use decompMod , only : bounds_type + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use NutrientCompetitionMethodMod, only : nutrient_competition_method_type + use NutrientCompetitionMethodMod, only : params_inst + use clm_varctl , only : iulog, use_matrixcn + use clm_varcon , only : spval + ! + implicit none + private + ! + ! !PUBLIC TYPES: + public :: nutrient_competition_FlexibleCN_type + ! + type, extends(nutrient_competition_method_type) :: nutrient_competition_FlexibleCN_type + private + real(r8), pointer :: actual_leafcn(:) ! leaf CN ratio used by flexible CN + real(r8), pointer :: actual_storage_leafcn(:) ! storage leaf CN ratio used by flexible CN + contains + ! public methocs + procedure, public :: Init ! Initialization + procedure, public :: calc_plant_nutrient_competition ! calculate nutrient yield rate from competition + procedure, public :: calc_plant_nutrient_demand ! calculate plant nutrient demand + ! + ! private methods + procedure, private :: InitAllocate + !procedure, private :: InitHistory + procedure, private :: calc_plant_cn_alloc + procedure, private :: calc_plant_nitrogen_demand + end type nutrient_competition_FlexibleCN_type + ! + interface nutrient_competition_FlexibleCN_type + ! initialize a new nutrient_competition_FlexibleCN_type object + module procedure constructor + end interface nutrient_competition_FlexibleCN_type + ! + + logical,parameter :: matrixcheck_ph = .True. + logical,parameter :: acc_ph = .False. + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + type(nutrient_competition_FlexibleCN_type) function constructor() + ! + ! !DESCRIPTION: + ! Creates an object of type nutrient_competition_FlexibleCN_type. + ! For now, this is simply a place-holder. + end function constructor + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize the class + ! + class(nutrient_competition_FlexibleCN_type) :: this + type(bounds_type), intent(in) :: bounds + + call this%InitAllocate(bounds) + ! call this%InitHistory(bounds) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Allocate memory for the class data + ! + ! !USES: + !use shr_infnan_mod , only : nan => shr_infnan_nan + ! !ARGUMENTS: + class(nutrient_competition_FlexibleCN_type) :: this + type(bounds_type), intent(in) :: bounds + + allocate(this%actual_leafcn(bounds%begp:bounds%endp)) ; this%actual_leafcn(:) = nan + allocate(this%actual_storage_leafcn(bounds%begp:bounds%endp)) ; this%actual_storage_leafcn(:) = nan + + + this%actual_leafcn(bounds%begp:bounds%endp) = spval + this%actual_storage_leafcn(bounds%begp:bounds%endp) = spval + + end subroutine InitAllocate + + !------------------------------------------------------------------------ +! subroutine InitHistory(this, bounds) +! ! +! ! !DESCRIPTION: +! ! Send data to history file +! ! +! ! !USES: +! use histFileMod , only : hist_addfld1d +! use clm_varcon , only : spval +! ! +! ! !ARGUMENTS: +! class(nutrient_competition_FlexibleCN_type), intent(in) :: this +! type(bounds_type), intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! integer :: begp, endp +! !------------------------------------------------------------------------ +! +! begp = bounds%begp; endp= bounds%endp +! +! this%actual_leafcn(begp:endp) = spval +! call hist_addfld1d (fname='LEAFCN', units='gC/gN', & +! avgflag='A', long_name='Leaf CN ratio used for flexible CN', & +! ptr_patch=this%actual_leafcn ) +! this%actual_storage_leafcn(begp:endp) = spval +! call hist_addfld1d (fname='LEAFCN_STORAGE', units='gC/gN', & +! avgflag='A', long_name='Storage Leaf CN ratio used for flexible CN', & +! ptr_patch=this%actual_storage_leafcn, default='inactive') +! +! end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine calc_plant_nutrient_competition (this, & + bounds, num_soilp, filter_soilp, & + cnveg_state_inst, crop_inst, canopystate_inst, cnveg_carbonstate_inst, & + cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_nitrogenstate_inst, & + aroot, arepr, fpg_col) + ! + ! !USES: + use CNVegStateType , only : cnveg_state_type + use CropType , only : crop_type + use CanopyStateType , only : canopystate_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemNitrogenStateType, only : soilbiogeochem_nitrogenstate_type + ! + ! !ARGUMENTS: + class(nutrient_competition_FlexibleCN_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type), intent(in) :: soilbiogeochem_nitrogenstate_inst + real(r8), intent(in) :: aroot (bounds%begp:) + real(r8), intent(in) :: arepr (bounds%begp:) + real(r8), intent(in) :: fpg_col (bounds%begc:) + + call this%calc_plant_cn_alloc(bounds, num_soilp, filter_soilp, & + cnveg_state_inst, crop_inst, canopystate_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, c13_cnveg_carbonflux_inst, & + c14_cnveg_carbonflux_inst, cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_nitrogenstate_inst, & + aroot=aroot(bounds%begp:bounds%endp), & + arepr=arepr(bounds%begp:bounds%endp), & + fpg_col=fpg_col(bounds%begc:bounds%endc)) + + end subroutine calc_plant_nutrient_competition + +!----------------------------------------------------------------------- + subroutine calc_plant_cn_alloc(this, bounds, num_soilp, filter_soilp, & + cnveg_state_inst, crop_inst, canopystate_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, c13_cnveg_carbonflux_inst, & + c14_cnveg_carbonflux_inst, cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_nitrogenstate_inst, & + aroot, arepr, fpg_col) + ! + ! !USES: + use pftconMod , only : pftcon, npcropmin + use clm_varctl , only : use_c13, use_c14, carbon_resp_opt,use_matrixcn + use clm_varctl , only : downreg_opt + use clm_varctl , only : CN_residual_opt + use clm_varctl , only : CN_partition_opt + use clm_time_manager , only : get_step_size_real + use CNVegStateType , only : cnveg_state_type + use CropType , only : crop_type + use CanopyStateType , only : canopystate_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use CNSharedParamsMod , only : use_fun + use CNPrecisionControlMod , only : n_min + use clm_varcon , only : spval + !index for matrixcn + use clm_varpar , only : ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,& + igrain,igrain_st,igrain_xf,iretransn,ioutc,ioutn,nvegnpool + ! use CNVegMatrixMod , only : matrix_update_phn + + ! + ! !ARGUMENTS: + class(nutrient_competition_FlexibleCN_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(soilbiogeochem_nitrogenstate_type), intent(in) :: soilbiogeochem_nitrogenstate_inst + real(r8) , intent(in) :: aroot(bounds%begp:) + real(r8) , intent(in) :: arepr(bounds%begp:) + real(r8) , intent(in) :: fpg_col(bounds%begc:) + ! + ! !LOCAL VARIABLES: + integer :: c,p ! indices + integer :: fp ! lake filter patch index + real(r8) :: f1,f2,f3,f4,g1,g2 ! allocation parameters + real(r8) :: cnl,cnfr,cnlw,cndw ! C:N ratios for leaf, fine root, and wood + real(r8) :: fcur ! fraction of current psn displayed as growth + real(r8) :: gresp_storage ! temporary variable for growth resp to storage + real(r8) :: matrix_nalloc_total ! temporary variable + real(r8) :: nlc ! temporary variable for total new leaf carbon allocation + real(r8) :: f5 ! grain allocation parameter + real(r8) :: cng ! C:N ratio for grain (= cnlw for now; slevis) + real(r8) :: dt ! model time step + real(r8):: fsmn(bounds%begp:bounds%endp) ! A emperate variable for adjusting FUN uptakes + + real(r8):: frootcn_storage_actual + real(r8):: frootcn_actual + real(r8):: livestemcn_storage_actual + real(r8):: livestemcn_actual + real(r8):: livecrootcn_storage_actual + real(r8):: livecrootcn_actual + real(r8):: leafcn_max + real(r8):: frootcn_max + real(r8):: livewdcn_max + real(r8):: frac_resp + real(r8):: npool_to_veg + real(r8):: cpool_to_veg + real(r8) :: npool_to_leafn_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_leafn_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_leafn_storage_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_leafn_storage_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_frootn_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_frootn_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_frootn_storage_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_frootn_storage_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_livestemn_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_livestemn_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_livestemn_storage_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_livestemn_storage_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_livecrootn_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_livecrootn_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_livecrootn_storage_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_livecrootn_storage_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_deadstemn_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_deadstemn_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_deadstemn_storage_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_deadstemn_storage_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_deadcrootn_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_deadcrootn_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_deadcrootn_storage_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_deadcrootn_storage_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_grainn_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_grainn_supply (bounds%begp:bounds%endp) + real(r8) :: npool_to_grainn_storage_demand (bounds%begp:bounds%endp) + real(r8) :: npool_to_grainn_storage_supply (bounds%begp:bounds%endp) + real(r8) :: total_plant_Ndemand (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_leafn (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_leafn_storage (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_frootn (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_frootn_storage (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_livestemn (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_livestemn_storage (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_deadstemn (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_deadstemn_storage (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_livecrootn (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_livecrootn_storage (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_deadcrootn (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_deadcrootn_storage (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_grainn (bounds%begp:bounds%endp) + real(r8) :: frNdemand_npool_to_grainn_storage (bounds%begp:bounds%endp) + real(r8) :: tmp + + ! ----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(aroot) == (/bounds%endp/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(arepr) == (/bounds%endp/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(fpg_col) == (/bounds%endc/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(this%actual_storage_leafcn) >= (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((lbound(this%actual_storage_leafcn) <= (/bounds%begp/)), sourcefile, __LINE__) + + associate( & + fpg => fpg_col , & ! Input: [real(r8) (:) ] fraction of potential gpp (no units) + + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + froot_leaf => pftcon%froot_leaf , & ! Input: allocation parameter: new fine root C per new leaf C (gC/gC) + croot_stem => pftcon%croot_stem , & ! Input: allocation parameter: new coarse root C per new stem C (gC/gC) + stem_leaf => pftcon%stem_leaf , & ! Input: allocation parameter: new stem c per new leaf C (gC/gC) + flivewd => pftcon%flivewd , & ! Input: allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: fine root C:N (gC/gN) + livewdcn => pftcon%livewdcn , & ! Input: live wood (phloem and ray parenchyma) C:N (gC/gN) + deadwdcn => pftcon%deadwdcn , & ! Input: dead wood (xylem and heartwood) C:N (gC/gN) + fcur2 => pftcon%fcur , & ! Input: allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage + graincn => pftcon%graincn , & ! Input: grain C:N (gC/gN) + grperc => pftcon%grperc , & ! Input: growth respiration parameter + grpnow => pftcon%grpnow , & ! Input: growth respiration parameter + evergreen => pftcon%evergreen , & ! Input: binary flag for evergreen leaf habit (0 or 1) + + croplive => crop_inst%croplive_patch , & ! Input: [logical (:) ] flag, true if planted, not harvested + + peaklai => cnveg_state_inst%peaklai_patch , & ! Input: [integer (:) ] 1: max allowed lai; 0: not at max + aleaf => cnveg_state_inst%aleaf_patch , & ! Output: [real(r8) (:) ] leaf allocation coefficient + astem => cnveg_state_inst%astem_patch , & ! Output: [real(r8) (:) ] stem allocation coefficient + c_allometry => cnveg_state_inst%c_allometry_patch , & ! Output: [real(r8) (:) ] C allocation index (DIM) + n_allometry => cnveg_state_inst%n_allometry_patch , & ! Output: [real(r8) (:) ] N allocation index (DIM) + downreg => cnveg_state_inst%downreg_patch , & ! Output: [real(r8) (:) ] fractional reduction in GPP due to N limitation (DIM) + + annsum_npp => cnveg_carbonflux_inst%annsum_npp_patch , & ! Input: [real(r8) (:) ] annual sum of NPP, for wood allocation + gpp => cnveg_carbonflux_inst%gpp_before_downreg_patch , & ! Output: [real(r8) (:) ] GPP flux before downregulation (gC/m2/s) + availc => cnveg_carbonflux_inst%availc_patch , & ! Output: [real(r8) (:) ] C flux available for allocation (gC/m2/s) + excess_cflux => cnveg_carbonflux_inst%excess_cflux_patch , & ! Output: [real(r8) (:) ] C flux not allocated due to downregulation (gC/m2/s) + plant_calloc => cnveg_carbonflux_inst%plant_calloc_patch , & ! Output: [real(r8) (:) ] total allocated C flux (gC/m2/s) + npp_growth => cnveg_carbonflux_inst%npp_growth_patch , & ! output: [real(r8) (:) ] c for growth in fun. g/m2/s + cpool_to_resp => cnveg_carbonflux_inst%cpool_to_resp_patch , & ! output: [real(r8) (:) ] + cpool_to_leafc_resp => cnveg_carbonflux_inst%cpool_to_leafc_resp_patch , & ! Output: [real(r8) (:) ] + cpool_to_leafc_storage_resp => cnveg_carbonflux_inst%cpool_to_leafc_storage_resp_patch , & ! Output: [real(r8) (:) ] + cpool_to_frootc_resp => cnveg_carbonflux_inst%cpool_to_frootc_resp_patch , & ! Output: [real(r8) (:) ] + cpool_to_frootc_storage_resp => cnveg_carbonflux_inst%cpool_to_frootc_storage_resp_patch , & ! Output: [real(r8) (:) ] + cpool_to_livecrootc_resp => cnveg_carbonflux_inst%cpool_to_livecrootc_resp_patch , & ! Output: [real(r8) (:) ] + cpool_to_livecrootc_storage_resp => cnveg_carbonflux_inst%cpool_to_livecrootc_storage_resp_patch , & ! Output: [real(r8) (:) ] + cpool_to_livestemc_resp => cnveg_carbonflux_inst%cpool_to_livestemc_resp_patch , & ! Output: [real(r8) (:) ] + cpool_to_livestemc_storage_resp => cnveg_carbonflux_inst%cpool_to_livestemc_storage_resp_patch , & ! Output: [real(r8) (:) ] + psnsun_to_cpool => cnveg_carbonflux_inst%psnsun_to_cpool_patch , & ! Output: [real(r8) (:) ] + psnshade_to_cpool => cnveg_carbonflux_inst%psnshade_to_cpool_patch , & ! Output: [real(r8) (:) ] + cpool_to_leafc => cnveg_carbonflux_inst%cpool_to_leafc_patch , & ! Output: [real(r8) (:) ] + cpool_to_leafc_storage => cnveg_carbonflux_inst%cpool_to_leafc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_frootc => cnveg_carbonflux_inst%cpool_to_frootc_patch , & ! Output: [real(r8) (:) ] + cpool_to_frootc_storage => cnveg_carbonflux_inst%cpool_to_frootc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_livestemc => cnveg_carbonflux_inst%cpool_to_livestemc_patch , & ! Output: [real(r8) (:) ] + cpool_to_livestemc_storage => cnveg_carbonflux_inst%cpool_to_livestemc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_deadstemc => cnveg_carbonflux_inst%cpool_to_deadstemc_patch , & ! Output: [real(r8) (:) ] + cpool_to_deadstemc_storage => cnveg_carbonflux_inst%cpool_to_deadstemc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_livecrootc => cnveg_carbonflux_inst%cpool_to_livecrootc_patch , & ! Output: [real(r8) (:) ] + cpool_to_livecrootc_storage => cnveg_carbonflux_inst%cpool_to_livecrootc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_deadcrootc => cnveg_carbonflux_inst%cpool_to_deadcrootc_patch , & ! Output: [real(r8) (:) ] + cpool_to_deadcrootc_storage => cnveg_carbonflux_inst%cpool_to_deadcrootc_storage_patch , & ! Output: [real(r8) (:) ] + cpool_to_gresp_storage => cnveg_carbonflux_inst%cpool_to_gresp_storage_patch , & ! Output: [real(r8) (:) ] allocation to growth respiration storage (gC/m2/s) + cpool_to_grainc => cnveg_carbonflux_inst%cpool_to_grainc_patch , & ! Output: [real(r8) (:) ] allocation to grain C (gC/m2/s) + cpool_to_grainc_storage => cnveg_carbonflux_inst%cpool_to_grainc_storage_patch , & ! Output: [real(r8) (:) ] allocation to grain C storage (gC/m2/s) + + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit projected leaf area index + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded projected leaf area index + smin_no3_vr => soilbiogeochem_nitrogenstate_inst%smin_no3_vr_col , & ! Output: [real(r8) (:,:) ] (gN/m3) soil mineral NO3 + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N + leafn_storage => cnveg_nitrogenstate_inst%leafn_storage_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N + npool => cnveg_nitrogenstate_inst%npool_patch , & ! Input: [real(r8) (:) ] (gN/m2) temporary plant N pool + plant_ndemand => cnveg_nitrogenflux_inst%plant_ndemand_patch , & ! Output: [real(r8) (:) ] N flux required to support initial GPP (gN/m2/s) + plant_nalloc => cnveg_nitrogenflux_inst%plant_nalloc_patch , & ! Output: [real(r8) (:) ] total allocated N flux (gN/m2/s) + npool_to_grainn => cnveg_nitrogenflux_inst%npool_to_grainn_patch , & ! Output: [real(r8) (:) ] allocation to grain N (gN/m2/s) + npool_to_grainn_storage => cnveg_nitrogenflux_inst%npool_to_grainn_storage_patch , & ! Output: [real(r8) (:) ] allocation to grain N storage (gN/m2/s) + retransn_to_npool => cnveg_nitrogenflux_inst%retransn_to_npool_patch , & ! Output: [real(r8) (:) ] deployment of retranslocated N (gN/m2/s) + retransn => cnveg_nitrogenstate_inst%retransn_patch , & ! Input: [real(r8) (:) ] (gN/m2) plant pool of retranslocated N + sminn_to_npool => cnveg_nitrogenflux_inst%sminn_to_npool_patch , & ! Output: [real(r8) (:) ] deployment of soil mineral N uptake (gN/m2/s) + npool_to_leafn => cnveg_nitrogenflux_inst%npool_to_leafn_patch , & ! Output: [real(r8) (:) ] allocation to leaf N (gN/m2/s) + npool_to_leafn_storage => cnveg_nitrogenflux_inst%npool_to_leafn_storage_patch , & ! Output: [real(r8) (:) ] allocation to leaf N storage (gN/m2/s) + npool_to_frootn => cnveg_nitrogenflux_inst%npool_to_frootn_patch , & ! Output: [real(r8) (:) ] allocation to fine root N (gN/m2/s) + npool_to_frootn_storage => cnveg_nitrogenflux_inst%npool_to_frootn_storage_patch , & ! Output: [real(r8) (:) ] allocation to fine root N storage (gN/m2/s) + npool_to_livestemn => cnveg_nitrogenflux_inst%npool_to_livestemn_patch , & ! Output: [real(r8) (:) ] + npool_to_livestemn_storage => cnveg_nitrogenflux_inst%npool_to_livestemn_storage_patch , & ! Output: [real(r8) (:) ] + npool_to_deadstemn => cnveg_nitrogenflux_inst%npool_to_deadstemn_patch , & ! Output: [real(r8) (:) ] + npool_to_deadstemn_storage => cnveg_nitrogenflux_inst%npool_to_deadstemn_storage_patch , & ! Output: [real(r8) (:) ] + npool_to_livecrootn => cnveg_nitrogenflux_inst%npool_to_livecrootn_patch , & ! Output: [real(r8) (:) ] + npool_to_livecrootn_storage => cnveg_nitrogenflux_inst%npool_to_livecrootn_storage_patch , & ! Output: [real(r8) (:) ] + npool_to_deadcrootn => cnveg_nitrogenflux_inst%npool_to_deadcrootn_patch , & ! Output: [real(r8) (:) ] + npool_to_deadcrootn_storage => cnveg_nitrogenflux_inst%npool_to_deadcrootn_storage_patch , & ! Output: [real(r8) (:) ] + Npassive => cnveg_nitrogenflux_inst%Npassive_patch , & ! Output: [real(r8) (:) ] Passive N uptake (gN/m2/s) + Nfix => cnveg_nitrogenflux_inst%Nfix_patch , & ! Output: [real(r8) (:) ] Symbiotic BNF (gN/m2/s) + Nactive => cnveg_nitrogenflux_inst%Nactive_patch , & ! Output: [real(r8) (:) ] Mycorrhizal N uptake (gN/m2/s) + Nnonmyc => cnveg_nitrogenflux_inst%Nnonmyc_patch , & ! Output: [real(r8) (:) ] Non-mycorrhizal N uptake (gN/m2/s) + Nam => cnveg_nitrogenflux_inst%Nam_patch , & ! Output: [real(r8) (:) ] AM uptake (gN/m2/s) + Necm => cnveg_nitrogenflux_inst%Necm_patch , & ! Output: [real(r8) (:) ] ECM uptake (gN/m2/s) + sminn_to_plant_fun => cnveg_nitrogenflux_inst%sminn_to_plant_fun_patch , & ! Output: [real(r8) (:) ] Total soil N uptake of FUN (gN/m2/s) + + iretransn_to_ileaf => cnveg_nitrogenflux_inst%iretransn_to_ileaf_ph , & ! Transfer index (from retranslocation pool to leaf pool) + iretransn_to_ileafst => cnveg_nitrogenflux_inst%iretransn_to_ileafst_ph , & ! Transfer index (from retranslocation pool to leaf storage pool) + iretransn_to_ifroot => cnveg_nitrogenflux_inst%iretransn_to_ifroot_ph , & ! Transfer index (from retranslocation pool to fine root pool) + iretransn_to_ifrootst => cnveg_nitrogenflux_inst%iretransn_to_ifrootst_ph , & ! Transfer index (from retranslocation pool to fine root storage pool) + iretransn_to_ilivestem => cnveg_nitrogenflux_inst%iretransn_to_ilivestem_ph , & ! Transfer index (from retranslocation pool to live stem pool) + iretransn_to_ilivestemst => cnveg_nitrogenflux_inst%iretransn_to_ilivestemst_ph , & ! Transfer index (from retranslocation pool to live stem storage pool) + iretransn_to_ideadstem => cnveg_nitrogenflux_inst%iretransn_to_ideadstem_ph , & ! Transfer index (from retranslocation pool to dead stem pool) + iretransn_to_ideadstemst => cnveg_nitrogenflux_inst%iretransn_to_ideadstemst_ph , & ! Transfer index (from retranslocation pool to dead stem storage pool) + iretransn_to_ilivecroot => cnveg_nitrogenflux_inst%iretransn_to_ilivecroot_ph , & ! Transfer index (from retranslocation pool to live coarse root pool) + iretransn_to_ilivecrootst => cnveg_nitrogenflux_inst%iretransn_to_ilivecrootst_ph , & ! Transfer index (from retranslocation pool to live coarse root storage pool) + iretransn_to_ideadcroot => cnveg_nitrogenflux_inst%iretransn_to_ideadcroot_ph , & ! Transfer index (from retranslocation pool to dead coarse root pool) + iretransn_to_ideadcrootst => cnveg_nitrogenflux_inst%iretransn_to_ideadcrootst_ph , & ! Transfer index (from retranslocation pool to dead coarse root storage pool) + iretransn_to_igrain => cnveg_nitrogenflux_inst%iretransn_to_igrain_ph , & ! Transfer index (from retranslocation pool to grain pool) + iretransn_to_igrainst => cnveg_nitrogenflux_inst%iretransn_to_igrainst_ph , & ! Transfer index (from retranslocation pool to grain storage pool) + iretransn_to_iout => cnveg_nitrogenflux_inst%iretransn_to_iout_ph , & ! Transfer index (from retranslocation pool to external) + ileaf_to_iretransn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & ! Transfer index (from leaf pool to retranslocation pools) + ifroot_to_iretransn => cnveg_nitrogenflux_inst%ifroot_to_iretransn_ph , & ! Transfer index (from fine root pool to retranslocation pools) + ilivestem_to_iretransn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph & ! Transfer index (from live stem pool to retranslocation pools) + ) + + ! set time steps + dt = get_step_size_real() + + ! patch loop to distribute the available N between the competing patches + ! on the basis of relative demand, and allocate C and N to new growth and storage + + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + ! set some local allocation variables + f1 = froot_leaf(ivt(p)) + f2 = croot_stem(ivt(p)) + + ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, + ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) + ! There was an error in this formula in previous version, where the coefficient + ! was 0.004 instead of 0.0025. + ! This variable allocation is only for trees. Shrubs have a constant + ! allocation as specified in the pft-physiology file. The value is also used + ! as a trigger here: -1.0 means to use the dynamic allocation (trees). + if (stem_leaf(ivt(p)) == -1._r8) then + f3 = (2.7/(1.0+exp(-0.004*(annsum_npp(p) - 300.0)))) - 0.4 + else + f3 = stem_leaf(ivt(p)) + end if + + f4 = flivewd(ivt(p)) + g1 = grperc(ivt(p)) + g2 = grpnow(ivt(p)) + cnl = leafcn(ivt(p)) + cnfr = frootcn(ivt(p)) + cnlw = livewdcn(ivt(p)) + cndw = deadwdcn(ivt(p)) + fcur = fcur2(ivt(p)) + + if (.not. downreg_opt) then + if (evergreen(ivt(p)) == 1._r8) then + fcur = 0.0_r8 + end if + end if + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + if (croplive(p)) then + f1 = aroot(p) / aleaf(p) + f3 = astem(p) / aleaf(p) + f5 = arepr(p) / aleaf(p) + g1 = 0.25_r8 + else + f1 = 0._r8 + f3 = 0._r8 + f5 = 0._r8 + g1 = 0.25_r8 + end if + end if + + ! increase fcur linearly with ndays_active, until fcur reaches 1.0 at + ! ndays_active = days/year. This prevents the continued storage of C and N. + ! turning off this correction (PET, 12/11/03), instead using bgtr in + ! phenology algorithm. + + if(use_fun)then ! if we are using FUN, we get the N available from there. + sminn_to_npool(p) = sminn_to_plant_fun(p) + else ! no FUN. :( we get N available from the FPG calculation in soilbiogeochemistry competition. + sminn_to_npool(p) = plant_ndemand(p) * fpg(c) + end if + + plant_nalloc(p) = sminn_to_npool(p) + retransn_to_npool(p) + if(use_matrixcn)then +! associate( & +! matrix_Ninput => cnveg_nitrogenflux_inst%matrix_Ninput_patch & ! N input of matrix +! ) +! matrix_Ninput(p) = sminn_to_npool(p)! + retransn_to_npool(p) +! end associate + end if + + if(.not.use_fun)then + if (downreg_opt) then + ! calculate the associated carbon allocation, and the excess + ! carbon flux that must be accounted for through downregulation + plant_calloc(p) = plant_nalloc(p) * (c_allometry(p)/n_allometry(p)) + excess_cflux(p) = availc(p) - plant_calloc(p) + + if(use_matrixcn)then +! associate( & +! matrix_Cinput => cnveg_carbonflux_inst%matrix_Cinput_patch & ! C input of matrix +! ) +! matrix_Cinput(p) = plant_nalloc(p) * (c_allometry(p)/n_allometry(p)) + ! end associate + end if + + ! reduce gpp fluxes due to N limitation + if (gpp(p) > 0.0_r8) then + downreg(p) = excess_cflux(p)/gpp(p) + + psnsun_to_cpool(p) = psnsun_to_cpool(p) *(1._r8 - downreg(p)) + psnshade_to_cpool(p) = psnshade_to_cpool(p)*(1._r8 - downreg(p)) + + if ( use_c13 ) then + c13_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) = & + c13_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) *(1._r8 - downreg(p)) + c13_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p) = & + c13_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p)*(1._r8 - downreg(p)) + endif + if ( use_c14 ) then + c14_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) = & + c14_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) *(1._r8 - downreg(p)) + c14_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p) = & + c14_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p)*(1._r8 - downreg(p)) + endif + end if + end if + end if + + + if(use_fun)then + plant_calloc(p) = npp_growth(p) + if(use_matrixcn)then + cnveg_carbonflux_inst%matrix_Cinput_patch(p) = npp_growth(p) + end if + else + if (.not. downreg_opt) then + plant_calloc(p) = availc(p) + if(use_matrixcn)then + cnveg_carbonflux_inst%matrix_Cinput_patch(p) = availc(p) + end if + end if + end if + + ! calculate the amount of new leaf C dictated by these allocation + ! decisions, and calculate the daily fluxes of C and N to current + ! growth and storage pools + + ! fcur is the proportion of this day's growth that is displayed now, + ! the remainder going into storage for display next year through the + ! transfer pools + + nlc = plant_calloc(p) / c_allometry(p) + cpool_to_leafc(p) = nlc * fcur + cpool_to_leafc_storage(p) = nlc * (1._r8 - fcur) + cpool_to_frootc(p) = nlc * f1 * fcur + cpool_to_frootc_storage(p) = nlc * f1 * (1._r8 - fcur) + if(use_matrixcn)then + cpool_to_veg = cpool_to_leafc(p) + cpool_to_leafc_storage(p) & + + cpool_to_frootc(p) + cpool_to_frootc_storage(p) + end if + if (woody(ivt(p)) == 1._r8) then + cpool_to_livestemc(p) = nlc * f3 * f4 * fcur + cpool_to_livestemc_storage(p) = nlc * f3 * f4 * (1._r8 - fcur) + cpool_to_deadstemc(p) = nlc * f3 * (1._r8 - f4) * fcur + cpool_to_deadstemc_storage(p) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_livecrootc(p) = nlc * f2 * f3 * f4 * fcur + cpool_to_livecrootc_storage(p) = nlc * f2 * f3 * f4 * (1._r8 - fcur) + cpool_to_deadcrootc(p) = nlc * f2 * f3 * (1._r8 - f4) * fcur + cpool_to_deadcrootc_storage(p) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + if(use_matrixcn)then + cpool_to_veg = cpool_to_veg & + + cpool_to_livestemc(p) + cpool_to_livestemc_storage(p) & + + cpool_to_deadstemc(p) + cpool_to_deadstemc_storage(p) & + + cpool_to_livecrootc(p) + cpool_to_livecrootc_storage(p) & + + cpool_to_deadcrootc(p) + cpool_to_deadcrootc_storage(p) + end if + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cpool_to_livestemc(p) = nlc * f3 * f4 * fcur + cpool_to_livestemc_storage(p) = nlc * f3 * f4 * (1._r8 - fcur) + cpool_to_deadstemc(p) = nlc * f3 * (1._r8 - f4) * fcur + cpool_to_deadstemc_storage(p) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_livecrootc(p) = nlc * f2 * f3 * f4 * fcur + cpool_to_livecrootc_storage(p) = nlc * f2 * f3 * f4 * (1._r8 - fcur) + cpool_to_deadcrootc(p) = nlc * f2 * f3 * (1._r8 - f4) * fcur + cpool_to_deadcrootc_storage(p) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_grainc(p) = nlc * f5 * fcur + cpool_to_grainc_storage(p) = nlc * f5 * (1._r8 -fcur) + if(use_matrixcn)then + cpool_to_veg = cpool_to_veg & + + cpool_to_livestemc(p) + cpool_to_livestemc_storage(p) & + + cpool_to_deadstemc(p) + cpool_to_deadstemc_storage(p) & + + cpool_to_livecrootc(p) + cpool_to_livecrootc_storage(p) & + + cpool_to_deadcrootc(p) + cpool_to_deadcrootc_storage(p) & + + cpool_to_grainc(p) + cpool_to_grainc_storage(p) + end if + end if + + if (use_matrixcn) then + associate( & + matrix_Cinput => cnveg_carbonflux_inst%matrix_Cinput_patch, & ! C input of matrix + matrix_alloc => cnveg_carbonflux_inst%matrix_alloc_patch & ! B-matrix for carbon allocation + ) + matrix_Cinput(p) = cpool_to_veg + if(cpool_to_veg .ne. 0)then + matrix_alloc(p,ileaf) = cpool_to_leafc(p) / cpool_to_veg + matrix_alloc(p,ileaf_st) = cpool_to_leafc_storage(p) / cpool_to_veg + matrix_alloc(p,ifroot) = cpool_to_frootc(p) / cpool_to_veg + matrix_alloc(p,ifroot_st) = cpool_to_frootc_storage(p) / cpool_to_veg + end if + + if (woody(ivt(p)) == 1._r8) then + if(cpool_to_veg .ne. 0)then + matrix_alloc(p,ilivestem) = cpool_to_livestemc(p) / cpool_to_veg + matrix_alloc(p,ilivestem_st) = cpool_to_livestemc_storage(p) / cpool_to_veg + matrix_alloc(p,ideadstem) = cpool_to_deadstemc(p) / cpool_to_veg + matrix_alloc(p,ideadstem_st) = cpool_to_deadstemc_storage(p) / cpool_to_veg + matrix_alloc(p,ilivecroot) = cpool_to_livecrootc(p) / cpool_to_veg + matrix_alloc(p,ilivecroot_st) = cpool_to_livecrootc_storage(p) / cpool_to_veg + matrix_alloc(p,ideadcroot) = cpool_to_deadcrootc(p) / cpool_to_veg + matrix_alloc(p,ideadcroot_st) = cpool_to_deadcrootc_storage(p) / cpool_to_veg + end if + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + if(cpool_to_veg .ne. 0)then + matrix_alloc(p,ilivestem) = cpool_to_livestemc(p) / cpool_to_veg + matrix_alloc(p,ilivestem_st) = cpool_to_livestemc_storage(p) / cpool_to_veg + matrix_alloc(p,ideadstem) = cpool_to_deadstemc(p) / cpool_to_veg + matrix_alloc(p,ideadstem_st) = cpool_to_deadstemc_storage(p) / cpool_to_veg + matrix_alloc(p,ilivecroot) = cpool_to_livecrootc(p) / cpool_to_veg + matrix_alloc(p,ilivecroot_st) = cpool_to_livecrootc_storage(p) / cpool_to_veg + matrix_alloc(p,ideadcroot) = cpool_to_deadcrootc(p) / cpool_to_veg + matrix_alloc(p,ideadcroot_st) = cpool_to_deadcrootc_storage(p) / cpool_to_veg + matrix_alloc(p,igrain) = cpool_to_grainc(p) / cpool_to_veg + matrix_alloc(p,igrain_st) = cpool_to_grainc_storage(p) / cpool_to_veg + end if + end if + end associate + end if !use_matrixcn + + if (downreg_opt) then + ! corresponding N fluxes + npool_to_leafn(p) = (nlc / cnl) * fcur + npool_to_leafn_storage(p) = (nlc / cnl) * (1._r8 - fcur) + npool_to_frootn(p) = (nlc * f1 / cnfr) * fcur + npool_to_frootn_storage(p) = (nlc * f1 / cnfr) * (1._r8 - fcur) + if (woody(ivt(p)) == 1._r8) then + npool_to_livestemn(p) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cng = graincn(ivt(p)) + npool_to_livestemn(p) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_grainn(p) = (nlc * f5 / cng) * fcur + npool_to_grainn_storage(p) = (nlc * f5 / cng) * (1._r8 -fcur) + end if + end if + + if (downreg_opt .eqv. .false. .AND. CN_partition_opt == 0) then + + ! N transfer depends on supply and demand + npool_to_frootn_demand(p) = (nlc * f1 / cnfr) * fcur + npool_to_frootn_supply(p) = npool(p)/dt * fcur + npool_to_frootn(p) = max(min(npool_to_frootn_supply(p),npool_to_frootn_demand(p)),0.0_r8) + + npool_to_frootn_storage_demand(p) = (nlc * f1 / cnfr) * (1._r8 - fcur) + npool_to_frootn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) + npool_to_frootn_storage(p) = max(min(npool_to_frootn_storage_supply(p),npool_to_frootn_storage_demand(p)),0.0_r8) + + npool_to_leafn_demand(p) = (nlc / cnl) * fcur + npool_to_leafn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) + npool_to_leafn(p) = max(min(npool_to_leafn_supply(p),npool_to_leafn_demand(p)),0.0_r8) + + npool_to_leafn_storage_demand(p) = (nlc / cnl) * (1._r8 - fcur) + npool_to_leafn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) + npool_to_leafn_storage(p) = max(min(npool_to_leafn_storage_supply(p),npool_to_leafn_storage_demand(p)),0.0_r8) + if (CN_residual_opt == 1) then + npool_to_leafn(p) = max(npool_to_leafn_supply(p),0.0_r8) + npool_to_leafn_storage(p) = max(npool_to_leafn_storage_supply(p),0.0_r8) + end if + + if (woody(ivt(p)) == 1._r8) then + npool_to_livestemn_demand(p) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) + npool_to_livestemn(p) = max(min(npool_to_livestemn_supply(p),npool_to_livestemn_demand(p)),0.0_r8) + + npool_to_livestemn_storage_demand(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_livestemn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) + npool_to_livestemn_storage(p) = max(min(npool_to_livestemn_storage_supply(p), & + npool_to_livestemn_storage_demand(p)),0.0_r8) + + npool_to_livecrootn_demand(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) + npool_to_livecrootn(p) = max(min(npool_to_livecrootn_supply(p),npool_to_livecrootn_demand(p)),0.0_r8) + + npool_to_livecrootn_storage_demand(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_livecrootn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) + npool_to_livecrootn_storage(p) = max(min(npool_to_livecrootn_storage_supply(p), & + npool_to_livecrootn_storage_demand(p)),0.0_r8) + + npool_to_deadstemn_demand(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) - & + npool_to_livecrootn(p) + npool_to_deadstemn(p) = max(min(npool_to_deadstemn_supply(p),npool_to_deadstemn_demand(p)),0.0_r8) + + npool_to_deadstemn_storage_demand(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_deadstemn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) - npool_to_livecrootn_storage(p) + npool_to_deadstemn_storage(p) = max(min(npool_to_deadstemn_storage_supply(p), & + npool_to_deadstemn_storage_demand(p)),0.0_r8) + + npool_to_deadcrootn_demand(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) - & + npool_to_livecrootn(p) - npool_to_deadstemn(p) + npool_to_deadcrootn(p) = max(min(npool_to_deadcrootn_supply(p),npool_to_deadcrootn_demand(p)),0.0_r8) + + npool_to_deadcrootn_storage_demand(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_deadcrootn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) - npool_to_livecrootn_storage(p) - npool_to_deadstemn_storage(p) + npool_to_deadcrootn_storage(p) = max(min(npool_to_deadcrootn_storage_supply(p), & + npool_to_deadcrootn_storage_demand(p)),0.0_r8) + + npool_to_leafn_demand(p) = (nlc / cnl) * fcur + npool_to_leafn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) - & + npool_to_livecrootn(p) - npool_to_deadstemn(p) - npool_to_deadcrootn(p) + npool_to_leafn(p) = max(min(npool_to_leafn_supply(p),npool_to_leafn_demand(p)),0.0_r8) + + npool_to_leafn_storage_demand(p) = (nlc / cnl) * (1._r8 - fcur) + npool_to_leafn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) - npool_to_livecrootn_storage(p) - npool_to_deadstemn_storage(p) - & + npool_to_deadcrootn_storage(p) + npool_to_leafn_storage(p) = max(min(npool_to_leafn_storage_supply(p),& + npool_to_leafn_storage_demand(p)),0.0_r8) + + if (CN_residual_opt == 1) then + npool_to_leafn(p) = max(npool_to_leafn_supply(p),0.0_r8) + npool_to_leafn_storage(p) = max(npool_to_leafn_storage_supply(p),0.0_r8) + end if + + end if + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + cng = graincn(ivt(p)) + npool_to_livestemn_demand(p) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) + npool_to_livestemn(p) = max(min(npool_to_livestemn_supply(p),npool_to_livestemn_demand(p)),0.0_r8) + + npool_to_livestemn_storage_demand(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_livestemn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) + npool_to_livestemn_storage(p) = max(min(npool_to_livestemn_storage_supply(p), & + npool_to_livestemn_storage_demand(p)),0.0_r8) + + npool_to_livecrootn_demand(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) + npool_to_livecrootn(p) = max(min(npool_to_livecrootn_supply(p),npool_to_livecrootn_demand(p)),0.0_r8) + + npool_to_livecrootn_storage_demand(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_livecrootn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) + npool_to_livecrootn_storage(p) = max(min(npool_to_livecrootn_storage_supply(p), & + npool_to_livecrootn_storage_demand(p)),0.0_r8) + + npool_to_deadstemn_demand(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) - & + npool_to_livecrootn(p) + npool_to_deadstemn(p) = max(min(npool_to_deadstemn_supply(p), npool_to_deadstemn_demand(p)), 0.0_r8) + + npool_to_deadstemn_storage_demand(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_deadstemn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) - npool_to_livecrootn_storage(p) + npool_to_deadstemn_storage(p) = max(min(npool_to_deadstemn_storage_supply(p), & + npool_to_deadstemn_storage_demand(p)),0.0_r8) + + npool_to_deadcrootn_demand(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) - & + npool_to_livecrootn(p) - npool_to_deadstemn(p) + npool_to_deadcrootn(p) = max(min(npool_to_deadcrootn_supply(p), npool_to_deadcrootn_demand(p)), 0.0_r8) + + npool_to_deadcrootn_storage_demand(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_deadcrootn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) - npool_to_livecrootn_storage(p) - npool_to_deadstemn_storage(p) + npool_to_deadcrootn_storage(p) = max(min(npool_to_deadcrootn_storage_supply(p), & + npool_to_deadcrootn_storage_demand(p)),0.0_r8) + + npool_to_grainn_demand(p) = (nlc * f5 / cng) * fcur + npool_to_grainn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) - & + npool_to_livecrootn(p) - npool_to_deadstemn(p) - npool_to_deadcrootn(p) + npool_to_grainn(p) = max(min(npool_to_grainn_supply(p), npool_to_grainn_demand(p)), 0.0_r8) + + npool_to_grainn_storage_demand(p) = (nlc * f5 / cng) * (1._r8 -fcur) + npool_to_grainn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) - npool_to_livecrootn_storage(p) - npool_to_deadstemn_storage(p) - & + npool_to_deadcrootn_storage(p) + npool_to_grainn_storage(p) = max(min(npool_to_grainn_storage_supply(p), npool_to_grainn_storage_demand(p)), & + 0.0_r8) + + npool_to_leafn_demand(p) = (nlc / cnl) * fcur + npool_to_leafn_supply(p) = npool(p)/dt * fcur - npool_to_frootn(p) - npool_to_livestemn(p) - & + npool_to_livecrootn(p) - npool_to_deadstemn(p) - npool_to_deadcrootn(p) - npool_to_grainn(p) + npool_to_leafn(p) = max(min(npool_to_leafn_supply(p), npool_to_leafn_demand(p)), 0.0_r8) + + npool_to_leafn_storage_demand(p) = (nlc / cnl) * (1._r8 - fcur) + npool_to_leafn_storage_supply(p) = npool(p)/dt * (1._r8 - fcur) - npool_to_frootn_storage(p) - & + npool_to_livestemn_storage(p) - npool_to_livecrootn_storage(p) & + - npool_to_deadstemn_storage(p) - npool_to_deadcrootn_storage(p) - npool_to_grainn_storage(p) + npool_to_leafn_storage(p) = max(min(npool_to_leafn_storage_supply(p), npool_to_leafn_storage_demand(p)), & + 0.0_r8) + + if (CN_residual_opt == 1) then + npool_to_leafn(p) = max(npool_to_leafn_supply(p),0.0_r8) + npool_to_leafn_storage(p) = max(npool_to_leafn_storage_supply(p),0.0_r8) + end if + + end if + + end if + + + ! Calculate the amount of carbon that needs to go into growth + ! respiration storage to satisfy all of the storage growth demands. + ! Allows for the fraction of growth respiration that is released at the + ! time of fixation, versus the remaining fraction that is stored for + ! release at the time of display. Note that all the growth respiration + ! fluxes that get released on a given timestep are calculated in growth_resp(), + ! but that the storage of C for growth resp during display of transferred + ! growth is assigned here. + + gresp_storage = cpool_to_leafc_storage(p) + cpool_to_frootc_storage(p) + if (woody(ivt(p)) == 1._r8) then + gresp_storage = gresp_storage + cpool_to_livestemc_storage(p) + gresp_storage = gresp_storage + cpool_to_deadstemc_storage(p) + + gresp_storage = gresp_storage + cpool_to_livecrootc_storage(p) + gresp_storage = gresp_storage + cpool_to_deadcrootc_storage(p) + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + gresp_storage = gresp_storage + cpool_to_livestemc_storage(p) + gresp_storage = gresp_storage + cpool_to_grainc_storage(p) + end if + cpool_to_gresp_storage(p) = gresp_storage * g1 * (1._r8 - g2) + + ! computing 1.) fractional N demand and 2.) N allocation after uptake for different plant parts + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (downreg_opt .eqv. .false. .AND. CN_partition_opt == 1) then + + ! computing nitrogen demand for different pools based on carbon allocated and CN ratio + npool_to_leafn_demand(p) = (nlc / cnl) * fcur + npool_to_leafn_storage_demand(p) = (nlc / cnl) * (1._r8 - fcur) + npool_to_frootn_demand(p) = (nlc * f1 / cnfr) * fcur + npool_to_frootn_storage_demand(p) = (nlc * f1 / cnfr) * (1._r8 - fcur) + if (woody(ivt(p)) == 1._r8) then + + npool_to_livestemn_demand(p) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage_demand(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn_demand(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage_demand(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn_demand(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage_demand(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn_demand(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage_demand(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + + cng = graincn(ivt(p)) + npool_to_livestemn_demand(p) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage_demand(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn_demand(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage_demand(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn_demand(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage_demand(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn_demand(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage_demand(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_grainn_demand(p) = (nlc * f5 / cng) * fcur + npool_to_grainn_storage_demand(p) = (nlc * f5 / cng) * (1._r8 -fcur) + end if + + + ! computing 1.) fractional N demand for different plant parts + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + total_plant_Ndemand(p) = npool_to_leafn_demand(p) + npool_to_leafn_storage_demand(p) + & + npool_to_frootn_demand(p) + npool_to_frootn_storage_demand(p) + + if (woody(ivt(p)) == 1._r8) then + + total_plant_Ndemand(p) = npool_to_leafn_demand(p) + npool_to_leafn_storage_demand(p) + & + npool_to_frootn_demand(p) + npool_to_frootn_storage_demand(p) + & + npool_to_livestemn_demand(p) + npool_to_livestemn_storage_demand(p) + npool_to_deadstemn_demand(p) + & + npool_to_deadstemn_storage_demand(p) + & + npool_to_livecrootn_demand(p) + npool_to_livecrootn_storage_demand(p) + npool_to_deadcrootn_demand(p) + & + npool_to_deadcrootn_storage_demand(p) + + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + + total_plant_Ndemand(p) = npool_to_leafn_demand(p) + npool_to_leafn_storage_demand(p) + & + npool_to_frootn_demand(p) + npool_to_frootn_storage_demand(p) + & + npool_to_livestemn_demand(p) + npool_to_livestemn_storage_demand(p) + npool_to_deadstemn_demand(p) + & + npool_to_deadstemn_storage_demand(p) + & + npool_to_livecrootn_demand(p) + npool_to_livecrootn_storage_demand(p) + npool_to_deadcrootn_demand(p) + & + npool_to_deadcrootn_storage_demand(p) + & + npool_to_grainn_demand(p) + npool_to_grainn_storage_demand(p) + + end if + + if (total_plant_Ndemand(p) == 0.0_r8) then ! removing division by zero + + frNdemand_npool_to_leafn(p) = 0.0_r8 + frNdemand_npool_to_leafn_storage(p) = 0.0_r8 + frNdemand_npool_to_frootn(p) = 0.0_r8 + frNdemand_npool_to_frootn_storage(p) = 0.0_r8 + if (woody(ivt(p)) == 1._r8) then + + frNdemand_npool_to_livestemn(p) = 0.0_r8 + frNdemand_npool_to_livestemn_storage(p) = 0.0_r8 + frNdemand_npool_to_deadstemn(p) = 0.0_r8 + frNdemand_npool_to_deadstemn_storage(p) = 0.0_r8 + frNdemand_npool_to_livecrootn(p) = 0.0_r8 + frNdemand_npool_to_livecrootn_storage(p) = 0.0_r8 + frNdemand_npool_to_deadcrootn(p) = 0.0_r8 + frNdemand_npool_to_deadcrootn_storage(p) = 0.0_r8 + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + + frNdemand_npool_to_livestemn(p) = 0.0_r8 + frNdemand_npool_to_livestemn_storage(p) = 0.0_r8 + frNdemand_npool_to_deadstemn(p) = 0.0_r8 + frNdemand_npool_to_deadstemn_storage(p) = 0.0_r8 + frNdemand_npool_to_livecrootn(p) = 0.0_r8 + frNdemand_npool_to_livecrootn_storage(p) = 0.0_r8 + frNdemand_npool_to_deadcrootn(p) = 0.0_r8 + frNdemand_npool_to_deadcrootn_storage(p) = 0.0_r8 + frNdemand_npool_to_grainn(p) = 0.0_r8 + frNdemand_npool_to_grainn_storage(p) = 0.0_r8 + end if + + else + + frNdemand_npool_to_leafn(p) = npool_to_leafn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_leafn_storage(p) = npool_to_leafn_storage_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_frootn(p) = npool_to_frootn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_frootn_storage(p) = npool_to_frootn_storage_demand(p) / total_plant_Ndemand(p) + if (woody(ivt(p)) == 1._r8) then + + frNdemand_npool_to_livestemn(p) = npool_to_livestemn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_livestemn_storage(p) = npool_to_livestemn_storage_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_deadstemn(p) = npool_to_deadstemn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_deadstemn_storage(p) = npool_to_deadstemn_storage_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_livecrootn(p) = npool_to_livecrootn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_livecrootn_storage(p) = npool_to_livecrootn_storage_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_deadcrootn(p) = npool_to_deadcrootn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_deadcrootn_storage(p) = npool_to_deadcrootn_storage_demand(p) / total_plant_Ndemand(p) + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + + frNdemand_npool_to_livestemn(p) = npool_to_livestemn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_livestemn_storage(p) = npool_to_livestemn_storage_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_deadstemn(p) = npool_to_deadstemn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_deadstemn_storage(p) = npool_to_deadstemn_storage_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_livecrootn(p) = npool_to_livecrootn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_livecrootn_storage(p) = npool_to_livecrootn_storage_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_deadcrootn(p) = npool_to_deadcrootn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_deadcrootn_storage(p) = npool_to_deadcrootn_storage_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_grainn(p) = npool_to_grainn_demand(p) / total_plant_Ndemand(p) + frNdemand_npool_to_grainn_storage(p) = npool_to_grainn_storage_demand(p) / total_plant_Ndemand(p) + end if + + end if + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + ! computing N allocation for different plant parts + ! allocating allocation to different plant parts in proportion to the fractional demand + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + npool_to_leafn(p) = frNdemand_npool_to_leafn(p) * npool(p) / dt + npool_to_leafn_storage(p) = frNdemand_npool_to_leafn_storage(p) * npool(p) / dt + npool_to_frootn(p) = frNdemand_npool_to_frootn(p) * npool(p) / dt + npool_to_frootn_storage(p) = frNdemand_npool_to_frootn_storage(p) * npool(p) / dt + if (woody(ivt(p)) == 1._r8) then + npool_to_livestemn(p) = frNdemand_npool_to_livestemn(p) * npool(p) / dt + npool_to_livestemn_storage(p) = frNdemand_npool_to_livestemn_storage(p) * npool(p) / dt + npool_to_deadstemn(p) = frNdemand_npool_to_deadstemn(p) * npool(p) / dt + npool_to_deadstemn_storage(p) = frNdemand_npool_to_deadstemn_storage(p) * npool(p) / dt + npool_to_livecrootn(p) = frNdemand_npool_to_livecrootn(p) * npool(p) / dt + npool_to_livecrootn_storage(p) = frNdemand_npool_to_livecrootn_storage(p) * npool(p) / dt + npool_to_deadcrootn(p) = frNdemand_npool_to_deadcrootn(p) * npool(p) / dt + npool_to_deadcrootn_storage(p) = frNdemand_npool_to_deadcrootn_storage(p) * npool(p) / dt + end if + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + npool_to_livestemn(p) = frNdemand_npool_to_livestemn(p) * npool(p) / dt + npool_to_livestemn_storage(p) = frNdemand_npool_to_livestemn_storage(p) * npool(p) / dt + npool_to_deadstemn(p) = frNdemand_npool_to_deadstemn(p) * npool(p) / dt + npool_to_deadstemn_storage(p) = frNdemand_npool_to_deadstemn_storage(p) * npool(p) / dt + npool_to_livecrootn(p) = frNdemand_npool_to_livecrootn(p) * npool(p) / dt + npool_to_livecrootn_storage(p) = frNdemand_npool_to_livecrootn_storage(p) * npool(p) / dt + npool_to_deadcrootn(p) = frNdemand_npool_to_deadcrootn(p) * npool(p) / dt + npool_to_deadcrootn_storage(p) = frNdemand_npool_to_deadcrootn_storage(p) * npool(p) / dt + npool_to_grainn(p) = frNdemand_npool_to_grainn(p) * npool(p) / dt + npool_to_grainn_storage(p) = frNdemand_npool_to_grainn_storage(p) * npool(p) / dt + end if + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + cpool_to_resp(p) = 0.0_r8 + cpool_to_leafc_resp(p) = 0.0_r8 + cpool_to_leafc_storage_resp(p) = 0.0_r8 + cpool_to_frootc_resp(p) = 0.0_r8 + cpool_to_frootc_storage_resp(p) = 0.0_r8 + cpool_to_livecrootc_resp(p) = 0.0_r8 + cpool_to_livecrootc_storage_resp(p) = 0.0_r8 + cpool_to_livestemc_resp(p) = 0.0_r8 + cpool_to_livestemc_storage_resp(p) = 0.0_r8 + + if ( laisun(p)+laisha(p) > 0.0_r8 ) then + if (cnveg_nitrogenstate_inst%leafn_storage_patch(p) == 0.0_r8 ) then + ! to avoid division by zero, and also to make actual_leafncn(p) a very large number if leafn(p) is zero + this%actual_storage_leafcn(p) = spval + else + ! leaf CN ratio + this%actual_storage_leafcn(p) = cnveg_carbonstate_inst%leafc_storage_patch(p) & + / cnveg_nitrogenstate_inst%leafn_storage_patch(p) + end if + end if + + if (carbon_resp_opt == 1 .AND. laisun(p)+laisha(p) > 0.0_r8) then + ! computing carbon to nitrogen ratio of different plant parts + + + if (cnveg_nitrogenstate_inst%frootn_storage_patch(p) == 0.0_r8) then + ! to avoid division by zero, and also to make frootcn_actual(p) a very large number if frootc(p) is zero + frootcn_actual = cnveg_carbonstate_inst%frootc_storage_patch(p) / n_min + else + ! fine root CN ratio + frootcn_actual = cnveg_carbonstate_inst%frootc_storage_patch(p) / cnveg_nitrogenstate_inst%frootn_storage_patch(p) + end if + + if (woody(ivt(p)) == 1._r8) then + + if (cnveg_nitrogenstate_inst%livestemn_storage_patch(p) == 0.0_r8) then + ! to avoid division by zero, and also to make livestemcn_actual(p) a very large number if livestemc(p) is zero + livestemcn_actual = cnveg_carbonstate_inst%livestemc_storage_patch(p) / n_min + else + ! live stem CN ratio + livestemcn_actual = cnveg_carbonstate_inst%livestemc_storage_patch(p) / & + cnveg_nitrogenstate_inst%livestemn_storage_patch(p) + end if + + if (cnveg_nitrogenstate_inst%livecrootn_storage_patch(p) == 0.0_r8) then + ! to avoid division by zero, and also to make livecrootcn_actual(p) a very large number if livecrootc(p) is zero + livecrootcn_actual = cnveg_carbonstate_inst%livecrootc_storage_patch(p) / n_min + else + ! live coarse root CN ratio + livecrootcn_actual = cnveg_carbonstate_inst%livecrootc_storage_patch(p) / & + cnveg_nitrogenstate_inst%livecrootn_storage_patch(p) + end if + end if + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + + if (cnveg_nitrogenstate_inst%livestemn_storage_patch(p) == 0.0_r8) then + ! to avoid division by zero, and also to make livestemcn_actual(p) a very large number if livestemc(p) is zero + livestemcn_actual = cnveg_carbonstate_inst%livestemc_storage_patch(p) / n_min + else + ! live stem CN ratio + livestemcn_actual = cnveg_carbonstate_inst%livestemc_storage_patch(p) / & + cnveg_nitrogenstate_inst%livestemn_storage_patch(p) + end if + + if (cnveg_nitrogenstate_inst%livecrootn_storage_patch(p) == 0.0_r8) then + ! to avoid division by zero, and also to make livecrootcn_actual(p) a very large number if livecrootc(p) is zero + livecrootcn_actual = cnveg_carbonstate_inst%livecrootc_storage_patch(p) / n_min + else + ! live coarse root CN ratio + livecrootcn_actual = cnveg_carbonstate_inst%livecrootc_storage_patch(p) / & + cnveg_nitrogenstate_inst%livecrootn_storage_patch(p) + end if + end if + + leafcn_max = leafcn(ivt(p)) + 15.0_r8 + frootcn_max = frootcn(ivt(p)) + 15.0_r8 + + ! Note that for high CN ratio stress the plant part does not retranslocate nitrogen as the plant part will need the N + ! if high leaf CN ratio (i.e., high leaf C compared to N) then turnover extra C + if (this%actual_storage_leafcn(p) > leafcn_max) then + + frac_resp = (this%actual_storage_leafcn(p) - leafcn_max) / 10.0_r8 + frac_resp = min(1.0_r8, max(0.0_r8, frac_resp)) + + cpool_to_leafc_resp(p) = frac_resp * cpool_to_leafc(p) + cpool_to_leafc_storage_resp(p) = frac_resp * cpool_to_leafc_storage(p) + !cpool_to_leafc(p) = cpool_to_leafc(p) - cpool_to_leafc_resp(p) + !cpool_to_leafc_storage(p) = cpool_to_leafc_storage(p) - cpool_to_leafc_storage_resp(p) + + end if + + ! if high fine root CN ratio (i.e., high fine root C compared to N) then turnover extra C + if (frootcn_actual > frootcn_max) then + + frac_resp = (frootcn_actual - frootcn_max) / 10.0_r8 + frac_resp = min(1.0_r8, max(0.0_r8, frac_resp)) + + cpool_to_frootc_resp(p) = frac_resp * cpool_to_frootc(p) + cpool_to_frootc_storage_resp(p) = frac_resp * cpool_to_frootc_storage(p) + + !cpool_to_frootc(p) = cpool_to_frootc(p) - cpool_to_frootc_resp(p) + !cpool_to_frootc_storage(p) = cpool_to_frootc_storage(p) - cpool_to_frootc_storage_resp(p) + + end if + + if (woody(ivt(p)) == 1._r8) then + + livewdcn_max = livewdcn(ivt(p)) + 15.0_r8 + + ! if high coarse root CN ratio (i.e., high coarse root C compared to N) then turnover extra C + if (livecrootcn_actual > livewdcn_max) then + + frac_resp = (livecrootcn_actual - livewdcn_max) / 10.0_r8 + frac_resp = min(1.0_r8, max(0.0_r8, frac_resp)) + + cpool_to_livecrootc_resp(p) = frac_resp * cpool_to_livecrootc(p) + cpool_to_livecrootc_storage_resp(p) = frac_resp * cpool_to_livecrootc_storage(p) + + !cpool_to_livecrootc(p) = cpool_to_livecrootc(p) - cpool_to_livecrootc_resp(p) + !cpool_to_livecrootc_storage(p) = cpool_to_livecrootc_storage(p) - cpool_to_livecrootc_storage_resp(p) + + end if + + ! if high stem CN ratio (i.e., high stem C compared to N) then turnover extra C + if (livestemcn_actual > livewdcn_max) then + + frac_resp = (livestemcn_actual - livewdcn_max) / 10.0_r8 + frac_resp = min(1.0_r8, max(0.0_r8, frac_resp)) + + cpool_to_livestemc_resp(p) = frac_resp * cpool_to_livestemc(p) + cpool_to_livestemc_storage_resp(p) = frac_resp * cpool_to_livestemc_storage(p) + + !cpool_to_livestemc(p) = cpool_to_livestemc(p) - cpool_to_livestemc_resp(p) + !cpool_to_livestemc_storage(p) = cpool_to_livestemc_storage(p) - cpool_to_livestemc_storage_resp(p) + + end if + + end if + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + + livewdcn_max = livewdcn(ivt(p)) + 15.0_r8 + + ! if high coarse root CN ratio (i.e., high coarse root C compared to N) then turnover extra C + if (livecrootcn_actual > livewdcn_max) then + + frac_resp = (livecrootcn_actual - livewdcn_max) / 10.0_r8 + frac_resp = min(1.0_r8, max(0.0_r8, frac_resp)) + + cpool_to_livecrootc_resp(p) = frac_resp * cpool_to_livecrootc(p) + cpool_to_livecrootc_storage_resp(p) = frac_resp * cpool_to_livecrootc_storage(p) + + !cpool_to_livecrootc(p) = cpool_to_livecrootc(p) - cpool_to_livecrootc_resp(p) + !cpool_to_livecrootc_storage(p) = cpool_to_livecrootc_storage(p) - cpool_to_livecrootc_storage_resp(p) + + end if + + ! if high stem CN ratio (i.e., high stem C compared to N) then turnover extra C + if (livestemcn_actual > livewdcn_max) then + + frac_resp = (livestemcn_actual - livewdcn_max) / 10.0_r8 + frac_resp = min(1.0_r8, max(0.0_r8, frac_resp)) + + cpool_to_livestemc_resp(p) = frac_resp * cpool_to_livestemc(p) + cpool_to_livestemc_storage_resp(p) = frac_resp * cpool_to_livestemc_storage(p) + + !cpool_to_livestemc(p) = cpool_to_livestemc(p) - cpool_to_livestemc_resp(p) + !cpool_to_livestemc_storage(p) = cpool_to_livestemc_storage(p) - cpool_to_livestemc_storage_resp(p) + + end if + + end if + + cpool_to_resp(p) = cpool_to_leafc_resp(p) + cpool_to_leafc_storage_resp(p) + cpool_to_frootc_resp(p) + & + cpool_to_frootc_storage_resp(p) + cpool_to_livecrootc_resp(p) + cpool_to_livecrootc_storage_resp(p) + & + cpool_to_livestemc_resp(p) + cpool_to_livestemc_storage_resp(p) + + if(use_matrixcn)then + cnveg_carbonflux_inst%matrix_Cinput_patch(p) = cnveg_carbonflux_inst%matrix_Cinput_patch(p) - cpool_to_resp(p) + end if + + end if ! end of if (carbon_resp_opt == 1 .AND. laisun(p)+laisha(p) > 0.0_r8) then + + !if (cnveg_nitrogenstate_inst%leafn_storage_patch(p) < n_min .or. laisun(p)+laisha(p) <= 0.0_r8) then + !! to make output on history missing value + !this%actual_storage_leafcn(p) = spval + !end if + + end if ! end of if (downreg_opt .eqv. .false. .AND. CN_partition_opt == 1) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if(use_matrixcn)then + associate( & + matrix_Ninput => cnveg_nitrogenflux_inst%matrix_Ninput_patch, & ! N input of matrix + matrix_nalloc => cnveg_nitrogenflux_inst%matrix_nalloc_patch & ! B-matrix for nitrogen allocation + ) + if(use_c13 .and. psnsun_to_cpool(p)+psnshade_to_cpool(p).ne. 0.)then + associate( & + matrix_C13input => cnveg_carbonflux_inst%matrix_C13input_patch & ! C13 input of matrix + ) + matrix_C13input(p) = plant_calloc(p) * & + ((c13_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p)+ c13_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p))/ & + (psnsun_to_cpool(p)+psnshade_to_cpool(p))) + end associate + end if + if(use_c14 .and. psnsun_to_cpool(p)+psnshade_to_cpool(p).ne. 0.)then + associate( & + matrix_C14input => cnveg_carbonflux_inst%matrix_C14input_patch & ! C14 input of matrix + ) + matrix_C14input(p) = plant_calloc(p) * & + ((c14_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p)+ c14_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p))/ & + (psnsun_to_cpool(p)+psnshade_to_cpool(p))) + end associate + end if + npool_to_veg = npool_to_leafn(p) + npool_to_leafn_storage(p) & + + npool_to_frootn(p) + npool_to_frootn_storage(p) & + + npool_to_livestemn(p) + npool_to_livestemn_storage(p) & + + npool_to_deadstemn(p) + npool_to_deadstemn_storage(p) & + + npool_to_livecrootn(p) + npool_to_livecrootn_storage(p) & + + npool_to_deadcrootn(p) + npool_to_deadcrootn_storage(p) + if (ivt(p) >= npcropmin)then + npool_to_veg = npool_to_veg + npool_to_grainn(p) + npool_to_grainn_storage(p) + end if + if(npool_to_veg .ne. 0)then + matrix_nalloc(p,ileaf ) = npool_to_leafn(p) / npool_to_veg + matrix_nalloc(p,ileaf_st ) = npool_to_leafn_storage(p) / npool_to_veg + matrix_nalloc(p,ifroot ) = npool_to_frootn(p) / npool_to_veg + matrix_nalloc(p,ifroot_st ) = npool_to_frootn_storage(p) / npool_to_veg + matrix_nalloc(p,ilivestem ) = npool_to_livestemn(p) / npool_to_veg + matrix_nalloc(p,ilivestem_st ) = npool_to_livestemn_storage(p) / npool_to_veg + matrix_nalloc(p,ideadstem ) = npool_to_deadstemn(p) / npool_to_veg + matrix_nalloc(p,ideadstem_st ) = npool_to_deadstemn_storage(p) / npool_to_veg + matrix_nalloc(p,ilivecroot ) = npool_to_livecrootn(p) / npool_to_veg + matrix_nalloc(p,ilivecroot_st ) = npool_to_livecrootn_storage(p) / npool_to_veg + matrix_nalloc(p,ideadcroot ) = npool_to_deadcrootn(p) / npool_to_veg + matrix_nalloc(p,ideadcroot_st ) = npool_to_deadcrootn_storage(p) / npool_to_veg + if (ivt(p) >= npcropmin)then + matrix_nalloc(p,igrain ) = npool_to_grainn(p) / npool_to_veg + matrix_nalloc(p,igrain_st ) = npool_to_grainn_storage(p) / npool_to_veg + end if + matrix_Ninput(p) = npool_to_veg - retransn_to_npool(p) + else + if(retransn(p) .ne. 0)then + ! retransn_to_npool(p) = retransn(p) * matrix_update_phn(p,iretransn_to_iout,retransn_to_npool(p)/retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) + end if + end if + + if(retransn(p) .ne. 0)then +! tmp = matrix_update_phn(p,iretransn_to_ileaf ,matrix_nalloc(p,ileaf ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ileafst ,matrix_nalloc(p,ileaf_st ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ifroot ,matrix_nalloc(p,ifroot ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ifrootst ,matrix_nalloc(p,ifroot_st ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ilivestem ,matrix_nalloc(p,ilivestem ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ilivestemst ,matrix_nalloc(p,ilivestem_st ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ideadstem ,matrix_nalloc(p,ideadstem ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ideadstemst ,matrix_nalloc(p,ideadstem_st ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ilivecroot ,matrix_nalloc(p,ilivecroot ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ilivecrootst ,matrix_nalloc(p,ilivecroot_st ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ideadcroot ,matrix_nalloc(p,ideadcroot ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_ideadcrootst ,matrix_nalloc(p,ideadcroot_st ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! if(ivt(p) >= npcropmin)then +! tmp = matrix_update_phn(p,iretransn_to_igrain ,matrix_nalloc(p,igrain ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) +! tmp = matrix_update_phn(p,iretransn_to_igrainst ,matrix_nalloc(p,igrain_st ) * retransn_to_npool(p) / retransn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,.True.) + ! end if + end if + end associate + end if !end use_matrixcn + end do ! end patch loop + + end associate + + end subroutine calc_plant_cn_alloc + +! ----------------------------------------------------------------------- + subroutine calc_plant_nutrient_demand(this, bounds, num_soilp, filter_soilp,& + photosyns_inst, crop_inst, canopystate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenstate_inst, & + energyflux_inst, & + aroot, arepr) + ! + ! !USES: + use CanopyStateType , only : canopystate_type + use PhotosynthesisMod , only : photosyns_type + use CropType , only : crop_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemCarbonFluxType, only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType, only : soilbiogeochem_nitrogenstate_type + use EnergyFluxType , only : energyflux_type ! + ! !ARGUMENTS: + class(nutrient_competition_FlexibleCN_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(photosyns_type) , intent(in) :: photosyns_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenstate_type), intent(in) :: soilbiogeochem_nitrogenstate_inst + type(energyflux_type) , intent(in) :: energyflux_inst + real(r8) , intent(out) :: aroot(bounds%begp:) + real(r8) , intent(out) :: arepr(bounds%begp:) + !----------------------------------------------------------------------- + + call this%calc_plant_nitrogen_demand(bounds, num_soilp, filter_soilp, & + photosyns_inst, crop_inst, canopystate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenstate_inst, & + energyflux_inst, & + aroot=aroot(bounds%begp:bounds%endp), & + arepr=arepr(bounds%begp:bounds%endp)) + + end subroutine calc_plant_nutrient_demand + + !----------------------------------------------------------------------- + subroutine calc_plant_nitrogen_demand(this, bounds, num_soilp, filter_soilp, & + photosyns_inst, crop_inst, canopystate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenstate_inst, & + energyflux_inst, & + aroot, arepr) + ! + ! !USES: + use pftconMod , only : npcropmin, pftcon + use pftconMod , only : ntmp_soybean, nirrig_tmp_soybean + use pftconMod , only : ntrp_soybean, nirrig_trp_soybean + use clm_varcon , only : secspday, dzsoi_decomp + use clm_varctl , only : use_c13, use_c14, use_matrixcn + use clm_varctl , only : nscalar_opt, plant_ndemand_opt, substrate_term_opt, temp_scalar_opt + use clm_varpar , only : nlevdecomp + use clm_time_manager , only : get_step_size_real + use CanopyStateType , only : canopystate_type + use PhotosynthesisMod , only : photosyns_type + use CropType , only : crop_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemCarbonFluxType, only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType, only : soilbiogeochem_nitrogenstate_type + use EnergyFluxType , only : energyflux_type ! + use CNSharedParamsMod , only : use_fun + use CNPrecisionControlMod , only : n_min + use clm_varcon , only : spval + use clm_varpar , only : ileaf,ileaf_st,ileaf_xf,ifroot,ifroot_st,ifroot_xf,& + ilivestem,ilivestem_st,ilivestem_xf,& + ideadstem,ideadstem_st,ideadstem_xf,& + ilivecroot,ilivecroot_st,ilivecroot_xf,& + ideadcroot,ideadcroot_st,ideadcroot_xf,& + igrain,igrain_st,igrain_xf,iretransn,ioutc,ioutn + ! use CNVegMatrixMod , only : matrix_update_phn + ! !ARGUMENTS: + class(nutrient_competition_FlexibleCN_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(photosyns_type) , intent(in) :: photosyns_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenstate_type), intent(in) :: soilbiogeochem_nitrogenstate_inst + type(energyflux_type) , intent(in) :: energyflux_inst + real(r8) , intent(out) :: aroot(bounds%begp:) + real(r8) , intent(out) :: arepr(bounds%begp:) + ! + ! !LOCAL VARIABLES: + integer :: c, p, j ! indices + integer :: fp ! lake filter patch index + real(r8) :: mr ! maintenance respiration (gC/m2/s) + real(r8) :: f1, f2, f3, f4, g1, g2 ! allocation parameters + real(r8) :: cnl, cnfr, cnlw, cndw ! C:N ratios for leaf, fine root, and wood + real(r8) :: curmr, curmr_ratio ! xsmrpool temporary variables + real(r8) :: f5 ! grain allocation parameter + real(r8) :: cng ! C:N ratio for grain (= cnlw for now; slevis) + real(r8) :: fleaf ! fraction allocated to leaf + real(r8) :: t1 ! temporary variable + real(r8) :: dt ! model time step + real(r8) :: dayscrecover ! number of days to recover negative cpool + real(r8) :: f_N (bounds%begp:bounds%endp) + real(r8) :: Kmin + real(r8) :: leafcn_max + real(r8) :: leafcn_min + real(r8) :: nscalar + real(r8) :: sminn_total + real(r8) :: substrate_term + real(r8) :: temp_scalar + real(r8) :: Vmax_N + real(r8) :: allocation_leaf (bounds%begp:bounds%endp) + real(r8) :: allocation_stem (bounds%begp:bounds%endp) + real(r8) :: allocation_froot (bounds%begp:bounds%endp) + real(r8) :: tmp + + ! ----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(aroot) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(arepr) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(this%actual_leafcn) >= (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((lbound(this%actual_leafcn) <= (/bounds%begp/)), sourcefile, __LINE__) + + associate( & + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + woody => pftcon%woody , & ! Input: binary flag for woody lifeform (1=woody, 0=not woody) + froot_leaf => pftcon%froot_leaf , & ! Input: allocation parameter: new fine root C per new leaf C (gC/gC) + croot_stem => pftcon%croot_stem , & ! Input: allocation parameter: new coarse root C per new stem C (gC/gC) + stem_leaf => pftcon%stem_leaf , & ! Input: allocation parameter: new stem c per new leaf C (gC/gC) + flivewd => pftcon%flivewd , & ! Input: allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + frootcn => pftcon%frootcn , & ! Input: fine root C:N (gC/gN) + livewdcn => pftcon%livewdcn , & ! Input: live wood (phloem and ray parenchyma) C:N (gC/gN) + deadwdcn => pftcon%deadwdcn , & ! Input: dead wood (xylem and heartwood) C:N (gC/gN) + graincn => pftcon%graincn , & ! Input: grain C:N (gC/gN) + fleafcn => pftcon%fleafcn , & ! Input: leaf c:n during organ fill + ffrootcn => pftcon%ffrootcn , & ! Input: froot c:n during organ fill + fstemcn => pftcon%fstemcn , & ! Input: stem c:n during organ fill + bfact => pftcon%bfact , & ! Input: parameter used below + aleaff => pftcon%aleaff , & ! Input: parameter used below + arootf => pftcon%arootf , & ! Input: parameter used below + astemf => pftcon%astemf , & ! Input: parameter used below + arooti => pftcon%arooti , & ! Input: parameter used below + fleafi => pftcon%fleafi , & ! Input: parameter used below + allconsl => pftcon%allconsl , & ! Input: parameter used below + allconss => pftcon%allconss , & ! Input: parameter used below + grperc => pftcon%grperc , & ! Input: parameter used below + grpnow => pftcon%grpnow , & ! Input: parameter used below + declfact => pftcon%declfact , & ! Input: + season_decid => pftcon%season_decid , & ! Input: binary flag for seasonal-deciduous leaf habit (0 or 1) + stress_decid => pftcon%stress_decid , & ! Input: binary flag for stress-deciduous leaf habit (0 or 1) + psnsun => photosyns_inst%psnsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) + psnsha => photosyns_inst%psnsha_patch , & ! Input: [real(r8) (:) ] shaded leaf-level photosynthesis (umol CO2 /m**2/ s) + c13_psnsun => photosyns_inst%c13_psnsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) + c13_psnsha => photosyns_inst%c13_psnsha_patch , & ! Input: [real(r8) (:) ] shaded leaf-level photosynthesis (umol CO2 /m**2/ s) + c14_psnsun => photosyns_inst%c14_psnsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) + c14_psnsha => photosyns_inst%c14_psnsha_patch , & ! Input: [real(r8) (:) ] shaded leaf-level photosynthesis (umol CO2 /m**2/ s) + + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit projected leaf area index + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded projected leaf area index + + hui => crop_inst%gddplant_patch , & ! Input: [real(r8) (:) ] =gdd since planting (gddplant) + leafout => crop_inst%gddtsoi_patch , & ! Input: [real(r8) (:) ] =gdd from top soil layer temperature + croplive => crop_inst%croplive_patch , & ! Input: [logical (:) ] flag, true if planted, not harvested + + gddmaturity => cnveg_state_inst%gddmaturity_patch , & ! Input: [real(r8) (:) ] gdd needed to harvest + huileaf => cnveg_state_inst%huileaf_patch , & ! Input: [real(r8) (:) ] heat unit index needed from planting to leaf emergence + huigrain => cnveg_state_inst%huigrain_patch , & ! Input: [real(r8) (:) ] same to reach vegetative maturity + peaklai => cnveg_state_inst%peaklai_patch , & ! Input: [integer (:) ] 1: max allowed lai; 0: not at max + aleafi => cnveg_state_inst%aleafi_patch , & ! Output: [real(r8) (:) ] saved allocation coefficient from phase 2 + astemi => cnveg_state_inst%astemi_patch , & ! Output: [real(r8) (:) ] saved allocation coefficient from phase 2 + aleaf => cnveg_state_inst%aleaf_patch , & ! Output: [real(r8) (:) ] leaf allocation coefficient + astem => cnveg_state_inst%astem_patch , & ! Output: [real(r8) (:) ] stem allocation coefficient + grain_flag => cnveg_state_inst%grain_flag_patch , & ! Output: [real(r8) (:) ] 1: grain fill stage; 0: not + c_allometry => cnveg_state_inst%c_allometry_patch , & ! Output: [real(r8) (:) ] C allocation index (DIM) + n_allometry => cnveg_state_inst%n_allometry_patch , & ! Output: [real(r8) (:) ] N allocation index (DIM) + tempsum_potential_gpp => cnveg_state_inst%tempsum_potential_gpp_patch , & ! Output: [real(r8) (:) ] temporary annual sum of potential GPP + tempmax_retransn => cnveg_state_inst%tempmax_retransn_patch , & ! Output: [real(r8) (:) ] temporary annual max of retranslocated N pool (gN/m2) + annsum_potential_gpp => cnveg_state_inst%annsum_potential_gpp_patch , & ! Output: [real(r8) (:) ] annual sum of potential GPP + annmax_retransn => cnveg_state_inst%annmax_retransn_patch , & ! Output: [real(r8) (:) ] annual max of retranslocated N pool + + xsmrpool => cnveg_carbonstate_inst%xsmrpool_patch , & ! Input: [real(r8) (:) ] (gC/m2) temporary photosynthate C pool + leafc => cnveg_carbonstate_inst%leafc_patch , & ! Input: [real(r8) (:) ] + frootc => cnveg_carbonstate_inst%frootc_patch , & ! Input: [real(r8) (:) ] + livestemc => cnveg_carbonstate_inst%livestemc_patch , & ! Input: [real(r8) (:) ] + livecrootc => cnveg_carbonstate_inst%livecrootc_patch , & ! Input: [real(r8) (:) ] + retransn => cnveg_nitrogenstate_inst%retransn_patch , & ! Input: [real(r8) (:) ] (gN/m2) plant pool of retranslocated N + + annsum_npp => cnveg_carbonflux_inst%annsum_npp_patch , & ! Input: [real(r8) (:) ] annual sum of NPP, for wood allocation + leaf_mr => cnveg_carbonflux_inst%leaf_mr_patch , & ! Input: [real(r8) (:) ] + froot_mr => cnveg_carbonflux_inst%froot_mr_patch , & ! Input: [real(r8) (:) ] + livestem_mr => cnveg_carbonflux_inst%livestem_mr_patch , & ! Input: [real(r8) (:) ] + livecroot_mr => cnveg_carbonflux_inst%livecroot_mr_patch , & ! Input: [real(r8) (:) ] + grain_mr => cnveg_carbonflux_inst%grain_mr_patch , & ! Input: [real(r8) (:) ] + gpp => cnveg_carbonflux_inst%gpp_before_downreg_patch , & ! Output: [real(r8) (:) ] GPP flux before downregulation (gC/m2/s) + availc => cnveg_carbonflux_inst%availc_patch , & ! Output: [real(r8) (:) ] C flux available for allocation (gC/m2/s) + xsmrpool_recover => cnveg_carbonflux_inst%xsmrpool_recover_patch , & ! Output: [real(r8) (:) ] C flux assigned to recovery of negative cpool (gC/m2/s) + psnsun_to_cpool => cnveg_carbonflux_inst%psnsun_to_cpool_patch , & ! Output: [real(r8) (:) ] + psnshade_to_cpool => cnveg_carbonflux_inst%psnshade_to_cpool_patch , & ! Output: [real(r8) (:) ] + leaf_curmr => cnveg_carbonflux_inst%leaf_curmr_patch , & ! Output: [real(r8) (:) ] + froot_curmr => cnveg_carbonflux_inst%froot_curmr_patch , & ! Output: [real(r8) (:) ] + livestem_curmr => cnveg_carbonflux_inst%livestem_curmr_patch , & ! Output: [real(r8) (:) ] + livecroot_curmr => cnveg_carbonflux_inst%livecroot_curmr_patch , & ! Output: [real(r8) (:) ] + grain_curmr => cnveg_carbonflux_inst%grain_curmr_patch , & ! Output: [real(r8) (:) ] + leaf_xsmr => cnveg_carbonflux_inst%leaf_xsmr_patch , & ! Output: [real(r8) (:) ] + froot_xsmr => cnveg_carbonflux_inst%froot_xsmr_patch , & ! Output: [real(r8) (:) ] + livestem_xsmr => cnveg_carbonflux_inst%livestem_xsmr_patch , & ! Output: [real(r8) (:) ] + livecroot_xsmr => cnveg_carbonflux_inst%livecroot_xsmr_patch , & ! Output: [real(r8) (:) ] + grain_xsmr => cnveg_carbonflux_inst%grain_xsmr_patch , & ! Output: [real(r8) (:) ] + cpool_to_xsmrpool => cnveg_carbonflux_inst%cpool_to_xsmrpool_patch , & ! Output: [real(r8) (:) ] + + leafn => cnveg_nitrogenstate_inst%leafn_patch , & ! Input: [real(r8) (:) ] (gN/m2) leaf N + plant_ndemand => cnveg_nitrogenflux_inst%plant_ndemand_patch , & ! Output: [real(r8) (:) ] N flux required to support initial GPP (gN/m2/s) + avail_retransn => cnveg_nitrogenflux_inst%avail_retransn_patch , & ! Output: [real(r8) (:) ] N flux available from retranslocation pool (gN/m2/s) + retransn_to_npool => cnveg_nitrogenflux_inst%retransn_to_npool_patch , & ! Output: [real(r8) (:) ] deployment of retranslocated N (gN/m2/s) + leafn_to_litter => cnveg_nitrogenflux_inst%leafn_to_litter_patch , & ! Output: [real(r8) (:) ] leaf N litterfall (gN/m2/s) + frootn_to_litter => cnveg_nitrogenflux_inst%frootn_to_litter_patch , & ! Output: [real(r8) (:) ] fine root N litterfall (gN/m2/s) + livestemn_to_litter => cnveg_nitrogenflux_inst%livestemn_to_litter_patch , & ! Input: [real(r8) (:) ] livestem N to litter (gN/m2/s) + sminn_to_npool => cnveg_nitrogenflux_inst%sminn_to_npool_patch , & ! Output: [real(r8) (:) ] deployment of soil mineral N uptake (gN/m2/s) + leafn_to_retransn => cnveg_nitrogenflux_inst%leafn_to_retransn_patch , & ! Output: [real(r8) (:) ] + frootn_to_retransn => cnveg_nitrogenflux_inst%frootn_to_retransn_patch , & ! Output: [real(r8) (:) ] + livestemn => cnveg_nitrogenstate_inst%livestemn_patch , & ! Input: [real(r8) (:) ] (gN/m2) livestem N + frootn => cnveg_nitrogenstate_inst%frootn_patch , & ! Input: [real(r8) (:) ] (gN/m2) fine root N + livestemn_to_retransn => cnveg_nitrogenflux_inst%livestemn_to_retransn_patch,& ! Output: [real(r8) (:) ] + sminn_vr => soilbiogeochem_nitrogenstate_inst%sminn_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral N + btran => energyflux_inst%btran_patch , & ! Input: [real(r8) (:) ] transpiration wetness factor (0 to 1) + t_scalar => soilbiogeochem_carbonflux_inst%t_scalar_col , & ! Input: [real(r8) (:,:) ] soil temperature scalar for decomp + ileaf_to_iretransn_phn => cnveg_nitrogenflux_inst%ileaf_to_iretransn_ph , & + ifroot_to_iretransn_phn => cnveg_nitrogenflux_inst%ifroot_to_iretransn_ph , & + ilivestem_to_iretransn_phn => cnveg_nitrogenflux_inst%ilivestem_to_iretransn_ph & + + ) + + ! set time steps + dt = get_step_size_real() + + ! set number of days to recover negative cpool + dayscrecover = params_inst%dayscrecover ! loop over patches to assess the total plant N demand + do fp = 1,num_soilp + p = filter_soilp(fp) + + ! get the time step total gross photosynthesis + ! this is coming from the canopy fluxes code, and is the + ! gpp that is used to control stomatal conductance. + ! For the nitrogen downregulation code, this is assumed + ! to be the potential gpp, and the actual gpp will be + ! reduced due to N limitation. + + ! Convert psn from umol/m2/s -> gC/m2/s + + ! The input psn (psnsun and psnsha) are expressed per unit LAI + ! in the sunlit and shaded canopy, respectively. These need to be + ! scaled by laisun and laisha to get the total gpp for allocation + + ! Note that no associate statement is used for the isotope carbon fluxes below + ! since they are not always allocated AND nag compiler will complain if you try to + ! to have an associate statement with unallocated memory + + psnsun_to_cpool(p) = psnsun(p) * laisun(p) * 12.011e-6_r8 + psnshade_to_cpool(p) = psnsha(p) * laisha(p) * 12.011e-6_r8 + + + if ( use_c13 ) then + c13_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) = c13_psnsun(p) * laisun(p) * 12.011e-6_r8 + c13_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p) = c13_psnsha(p) * laisha(p) * 12.011e-6_r8 + endif + + if ( use_c14 ) then + c14_cnveg_carbonflux_inst%psnsun_to_cpool_patch(p) = c14_psnsun(p) * laisun(p) * 12.011e-6_r8 + c14_cnveg_carbonflux_inst%psnshade_to_cpool_patch(p) = c14_psnsha(p) * laisha(p) * 12.011e-6_r8 + endif + + gpp(p) = psnsun_to_cpool(p) + psnshade_to_cpool(p) + + ! get the time step total maintenance respiration + ! These fluxes should already be in gC/m2/s + + mr = leaf_mr(p) + froot_mr(p) + if (woody(ivt(p)) == 1.0_r8) then + mr = mr + livestem_mr(p) + livecroot_mr(p) + else if (ivt(p) >= npcropmin) then + if (croplive(p)) mr = mr + livestem_mr(p) + grain_mr(p) + end if ! carbon flux available for allocation + if(mr <-1.e-15 .and. use_matrixcn)mr = 0 + availc(p) = gpp(p) - mr + + ! new code added for isotope calculations, 7/1/05, PET + ! If mr > gpp, then some mr comes from gpp, the rest comes from + ! cpool (xsmr) + if (mr > 0._r8 .and. availc(p) < 0._r8) then + curmr = gpp(p) + curmr_ratio = curmr / mr + else + curmr_ratio = 1._r8 + end if + leaf_curmr(p) = leaf_mr(p) * curmr_ratio + leaf_xsmr(p) = leaf_mr(p) - leaf_curmr(p) + froot_curmr(p) = froot_mr(p) * curmr_ratio + froot_xsmr(p) = froot_mr(p) - froot_curmr(p) + livestem_curmr(p) = livestem_mr(p) * curmr_ratio + livestem_xsmr(p) = livestem_mr(p) - livestem_curmr(p) + livecroot_curmr(p) = livecroot_mr(p) * curmr_ratio + livecroot_xsmr(p) = livecroot_mr(p) - livecroot_curmr(p) + grain_curmr(p) = grain_mr(p) * curmr_ratio + grain_xsmr(p) = grain_mr(p) - grain_curmr(p) + + ! no allocation when available c is negative + availc(p) = max(availc(p),0.0_r8) + + ! test for an xsmrpool deficit + if (xsmrpool(p) < 0.0_r8) then + ! Running a deficit in the xsmrpool, so the first priority is to let + ! some availc from this timestep accumulate in xsmrpool. + ! Determine rate of recovery for xsmrpool deficit + + xsmrpool_recover(p) = -xsmrpool(p)/(dayscrecover*secspday) + if (xsmrpool_recover(p) < availc(p)) then + ! available carbon reduced by amount for xsmrpool recovery + availc(p) = availc(p) - xsmrpool_recover(p) + else + ! all of the available carbon goes to xsmrpool recovery + xsmrpool_recover(p) = availc(p) + availc(p) = 0.0_r8 + end if + cpool_to_xsmrpool(p) = xsmrpool_recover(p) + end if + + f1 = froot_leaf(ivt(p)) + f2 = croot_stem(ivt(p)) + + ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, + ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) + ! This variable allocation is only for trees. Shrubs have a constant + ! allocation as specified in the pft-physiology file. The value is also used + ! as a trigger here: -1.0 means to use the dynamic allocation (trees). + + if (stem_leaf(ivt(p)) == -1._r8) then + f3 = (2.7/(1.0+exp(-0.004*(annsum_npp(p) - 300.0)))) - 0.4 + else + f3 = stem_leaf(ivt(p)) + end if + + f4 = flivewd(ivt(p)) + g1 = grperc(ivt(p)) + g2 = grpnow(ivt(p)) + cnl = leafcn(ivt(p)) + cnfr = frootcn(ivt(p)) + cnlw = livewdcn(ivt(p)) + cndw = deadwdcn(ivt(p)) + + + ! calculate f1 to f5 for prog crops following AgroIBIS subr phenocrop + + f5 = 0._r8 ! continued intializations from above + + if (ivt(p) >= npcropmin) then ! skip 2 generic crops + + if (croplive(p)) then + ! same phases appear in subroutine CropPhenology + + ! Phase 1 completed: + ! ================== + ! if hui is less than the number of gdd needed for filling of grain + ! leaf emergence also has to have taken place for lai changes to occur + ! and carbon assimilation + ! Next phase: leaf emergence to start of leaf decline + + if (leafout(p) >= huileaf(p) .and. hui(p) < huigrain(p)) then + + ! allocation rules for crops based on maturity and linear decrease + ! of amount allocated to roots over course of the growing season + + if (peaklai(p) == 1) then ! lai at maximum allowed + arepr(p) = 0._r8 + aleaf(p) = 1.e-5_r8 + astem(p) = 0._r8 + aroot(p) = 1._r8 - arepr(p) - aleaf(p) - astem(p) + else + arepr(p) = 0._r8 + aroot(p) = max(0._r8, min(1._r8, arooti(ivt(p)) - & + (arooti(ivt(p)) - arootf(ivt(p))) * & + min(1._r8, hui(p)/gddmaturity(p)))) + fleaf = fleafi(ivt(p)) * (exp(-bfact(ivt(p))) - & + exp(-bfact(ivt(p))*hui(p)/huigrain(p))) / & + (exp(-bfact(ivt(p)))-1) ! fraction alloc to leaf (from J Norman alloc curve) + aleaf(p) = max(1.e-5_r8, (1._r8 - aroot(p)) * fleaf) + astem(p) = 1._r8 - arepr(p) - aleaf(p) - aroot(p) + end if + + ! AgroIBIS included here an immediate adjustment to aleaf & astem if the + ! predicted lai from the above allocation coefficients exceeded laimx. + ! We have decided to live with lais slightly higher than laimx by + ! enforcing the cap in the following tstep through the peaklai logic above. + + astemi(p) = astem(p) ! save for use by equations after shift + aleafi(p) = aleaf(p) ! to reproductive phenology stage begins + grain_flag(p) = 0._r8 ! setting to 0 while in phase 2 + + ! Phase 2 completed: + ! ================== + ! shift allocation either when enough gdd are accumulated or maximum number + ! of days has elapsed since planting + + else if (hui(p) >= huigrain(p)) then + + aroot(p) = max(0._r8, min(1._r8, arooti(ivt(p)) - & + (arooti(ivt(p)) - arootf(ivt(p))) * min(1._r8, hui(p)/gddmaturity(p)))) + if (astemi(p) > astemf(ivt(p))) then + astem(p) = max(0._r8, max(astemf(ivt(p)), astem(p) * & + (1._r8 - min((hui(p)- & + huigrain(p))/((gddmaturity(p)*declfact(ivt(p)))- & + huigrain(p)),1._r8)**allconss(ivt(p)) ))) + end if + if (peaklai(p) == 1) then + aleaf(p) = 1.e-5_r8 + else if (aleafi(p) > aleaff(ivt(p))) then + aleaf(p) = max(1.e-5_r8, max(aleaff(ivt(p)), aleaf(p) * & + (1._r8 - min((hui(p)- & + huigrain(p))/((gddmaturity(p)*declfact(ivt(p)))- & + huigrain(p)),1._r8)**allconsl(ivt(p)) ))) + end if + + !Beth's retranslocation of leafn, stemn, rootn to organ + !Filter excess plant N to retransn pool for organ N + !Only do one time then hold grain_flag till onset next season + + ! slevis: Will astem ever = astemf exactly? + ! Beth's response: ...looks like astem can equal astemf under the right circumstances. + !It might be worth a rewrite to capture what I was trying to do, but the retranslocation for + !corn and wheat begins at the beginning of the grain fill stage, but for soybean I was holding it + !until after the leaf and stem decline were complete. Looking at how astem is calculated, once the + !stem decline is near complete, astem should (usually) be set to astemf. The reason for holding off + !on soybean is that the retranslocation scheme begins at the beginning of the grain phase, when the + !leaf and stem are still growing, but declining. Since carbon is still getting allocated and now + !there is more nitrogen available, the nitrogen can be diverted from grain. For corn and wheat + !the impact was probably enough to boost productivity, but for soybean the nitrogen was better off + !fulfilling the grain fill. It seems that if the peak lai is reached for soybean though that this + !would be bypassed altogether, not the intended outcome. I checked several of my output files and + !they all seemed to be going through the retranslocation loop for soybean - good news. + + if (astem(p) == astemf(ivt(p)) .or. & + (ivt(p) /= ntmp_soybean .and. ivt(p) /= nirrig_tmp_soybean .and.& + ivt(p) /= ntrp_soybean .and. ivt(p) /= nirrig_trp_soybean)) then + if (grain_flag(p) == 0._r8) then + t1 = 1 / dt + leafn_to_retransn(p) = t1 * max(leafn(p)- (leafc(p) / fleafcn(ivt(p))),0._r8) + livestemn_to_retransn(p) = t1 * max(livestemn(p) - (livestemc(p) / fstemcn(ivt(p))),0._r8) + frootn_to_retransn(p) = 0._r8 + if (ffrootcn(ivt(p)) > 0._r8) then + frootn_to_retransn(p) = t1 * max(frootn(p) - (frootc(p) / ffrootcn(ivt(p))),0._r8) + end if + grain_flag(p) = 1._r8 + if(use_matrixcn)then +! if(leafn(p) .ne. 0._r8)then +! leafn_to_retransn(p) = leafn(p) * matrix_update_phn(p,ileaf_to_iretransn_phn,leafn_to_retransn(p) / leafn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if +! if(frootn(p) .ne. 0._r8)then +! frootn_to_retransn(p) = frootn(p) * matrix_update_phn(p,ifroot_to_iretransn_phn,frootn_to_retransn(p) / frootn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) +! end if +! if(livestemn(p) .ne. 0._r8)then +! livestemn_to_retransn(p) = livestemn(p) * matrix_update_phn(p,ilivestem_to_iretransn_phn,livestemn_to_retransn(p) / livestemn(p),dt,cnveg_nitrogenflux_inst,matrixcheck_ph,acc_ph) + ! end if + end if + + end if + end if + + arepr(p) = 1._r8 - aroot(p) - astem(p) - aleaf(p) + + else ! pre emergence + aleaf(p) = 1.e-5_r8 ! allocation coefficients should be irrelevant + astem(p) = 0._r8 ! because crops have no live carbon pools; + aroot(p) = 0._r8 ! this applies to this "else" and to the "else" + arepr(p) = 0._r8 ! a few lines down + end if + + f1 = aroot(p) / aleaf(p) + f3 = astem(p) / aleaf(p) + f5 = arepr(p) / aleaf(p) + g1 = 0.25_r8 + + else ! .not croplive + f1 = 0._r8 + f3 = 0._r8 + f5 = 0._r8 + g1 = 0.25_r8 + end if + end if + + ! based on available C, use constant allometric relationships to + ! determine N requirements + if(use_fun)then ! In FUN, growth respiration is not part of the allometry calculation. + if (woody(ivt(p)) == 1.0_r8) then + c_allometry(p) = (1._r8)*(1._r8+f1+f3*(1._r8+f2)) + n_allometry(p) = 1._r8/cnl + f1/cnfr + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + else if (ivt(p) >= npcropmin) then ! skip generic crops + cng = graincn(ivt(p)) + c_allometry(p) = (1._r8)*(1._r8+f1+f5+f3*(1._r8+f2)) + n_allometry(p) = 1._r8/cnl + f1/cnfr + f5/cng + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + else + c_allometry(p) = 1._r8+f1 + n_allometry(p) = 1._r8/cnl + f1/cnfr + end if + else !no FUN. + if (woody(ivt(p)) == 1.0_r8) then + c_allometry(p) = (1._r8+g1)*(1._r8+f1+f3*(1._r8+f2)) + n_allometry(p) = 1._r8/cnl + f1/cnfr + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + else if (ivt(p) >= npcropmin) then ! skip generic crops + cng = graincn(ivt(p)) + c_allometry(p) = (1._r8+g1)*(1._r8+f1+f5+f3*(1._r8+f2)) + n_allometry(p) = 1._r8/cnl + f1/cnfr + f5/cng + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + else + c_allometry(p) = 1._r8+g1+f1+f1*g1 + n_allometry(p) = 1._r8/cnl + f1/cnfr + end if + end if !FUN + + ! when we have "if (leafn(p) == 0.0_r8)" below then we + ! have floating overflow (out of floating point range) + ! error in "actual_leafcn(p) = leafc(p) / leafn(p)" + if (leafn(p) < n_min ) then + ! to avoid division by zero, and to set leafcn to missing value for history files + this%actual_leafcn(p) = spval + else + ! leaf CN ratio + this%actual_leafcn(p) = leafc(p) / leafn(p) + end if + + + if (nscalar_opt) then + + leafcn_min = leafcn(ivt(p)) - 10.0_r8 + leafcn_max = leafcn(ivt(p)) + 10.0_r8 + + this%actual_leafcn(p) = max( this%actual_leafcn(p), leafcn_min-0.0001_r8 ) + this%actual_leafcn(p) = min( this%actual_leafcn(p), leafcn_max ) + + nscalar = (this%actual_leafcn(p) - leafcn_min ) / (leafcn_max - leafcn_min) ! Nitrogen scaler factor + nscalar = min( max(0.0_r8, nscalar), 1.0_r8 ) + else ! if (nscalar_opt == .false.) then + nscalar = 1.0_r8 + end if + + + if (substrate_term_opt) then + c = patch%column(p) + sminn_total = 0.0_r8 + do j = 1, nlevdecomp + sminn_total = sminn_total + sminn_vr(c,j) * dzsoi_decomp(j) + end do + Kmin = 1.0_r8 + substrate_term = sminn_total / (sminn_total + Kmin) + else ! if (substrate_term_opt == .false) then + substrate_term = 1.0_r8 + end if + + if (.not. temp_scalar_opt) then + temp_scalar = 1.0_r8 + else !(temp_scalar_opt == .true.) then + c = patch%column(p) + temp_scalar=t_scalar(c,1) + temp_scalar = min( max(0.0_r8, temp_scalar), 1.0_r8 ) + end if + + if(use_fun)then ! in FUN, plant_ndemand is just used as a maximum draw on soil N pools. + plant_ndemand(p) = availc(p)*(n_allometry(p)/c_allometry(p)) + else !FUN + if (plant_ndemand_opt == 0) then + plant_ndemand(p) = availc(p)*(n_allometry(p)/c_allometry(p)) + else if (plant_ndemand_opt == 1) then + plant_ndemand(p) = availc(p)*(n_allometry(p)/c_allometry(p)) * substrate_term + else if (plant_ndemand_opt == 2) then ! N uptake happens at day time only + + if (gpp(p) > 0.0_r8) then + Vmax_N = 2.7E-8_r8 + plant_ndemand(p) = Vmax_N * frootc(p) * substrate_term * temp_scalar * nscalar + else + plant_ndemand(p) = 0.0_r8 + end if + else if (plant_ndemand_opt == 3) then ! N uptake happens at day and night time + + if (laisun(p)+laisha(p) > 0.0_r8) then + Vmax_N = 2.7E-8_r8 + plant_ndemand(p) = Vmax_N * frootc(p) * substrate_term * temp_scalar * nscalar + else + plant_ndemand(p) = 0.0_r8 + end if + + if (this%actual_leafcn(p) < leafcn_min )then + plant_ndemand(p) = 0.0_r8 + end if + + end if + end if !FUN + !if (leafn(p) < n_min ) then + !! to set leafcn to missing value for history files + !this%actual_leafcn(p) = spval + !end if + + ! retranslocated N deployment depends on seasonal cycle of potential GPP + ! (requires one year run to accumulate demand) + + tempsum_potential_gpp(p) = tempsum_potential_gpp(p) + gpp(p) + + ! Adding the following line to carry max retransn info to CN Annual Update + tempmax_retransn(p) = max(tempmax_retransn(p),retransn(p)) + + ! Beth's code: crops pull from retransn pool only during grain fill; + ! retransn pool has N from leaves, stems, and roots for + ! retranslocation + + if (ivt(p) >= npcropmin .and. grain_flag(p) == 1._r8) then + avail_retransn(p) = plant_ndemand(p) + else if (ivt(p) < npcropmin .and. annsum_potential_gpp(p) > 0._r8) then + avail_retransn(p) = (annmax_retransn(p)/2._r8)*(gpp(p)/annsum_potential_gpp(p))/dt + else + avail_retransn(p) = 0.0_r8 + end if + + ! make sure available retrans N doesn't exceed storage + avail_retransn(p) = min(avail_retransn(p), retransn(p)/dt) + + ! modify plant N demand according to the availability of + ! retranslocated N + ! take from retransn pool at most the flux required to meet + ! plant ndemand + + if (plant_ndemand(p) > avail_retransn(p)) then + retransn_to_npool(p) = avail_retransn(p) + else + retransn_to_npool(p) = plant_ndemand(p) + end if + + if ( .not. use_fun ) then + plant_ndemand(p) = plant_ndemand(p) - retransn_to_npool(p) + end if + + end do ! end patch loop + + end associate + + end subroutine calc_plant_nitrogen_demand + +end module NutrientCompetitionFlexibleCNMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionMethodMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionMethodMod.F90 new file mode 100755 index 000000000..56ebcc4f6 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionMethodMod.F90 @@ -0,0 +1,202 @@ +module NutrientCompetitionMethodMod + + !--------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abstract base class for functions to calculate nutrient competition + ! + ! Created by Jinyun Tang, following Bill Sack's implementation of polymorphism + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + implicit none + private + ! + ! !PUBLIC TYPES: + public :: nutrient_competition_method_type + + type, abstract :: nutrient_competition_method_type + private + contains + + ! initialization + procedure(init_interface), public, deferred :: init + + ! Read in parameters + procedure, public :: readParams + + ! compute plant nutrient demand + procedure(calc_plant_nutrient_demand_interface), public, deferred :: calc_plant_nutrient_demand + + ! compute the nutrient yield for different components + procedure(calc_plant_nutrient_competition_interface), public, deferred :: calc_plant_nutrient_competition + + end type nutrient_competition_method_type + + type, public :: params_type + real(r8) :: dayscrecover ! number of days to recover negative cpool + end type params_type + ! + type(params_type), public, protected :: params_inst ! params_inst is populated in readParamsMod + + abstract interface + + ! Note: The following code is adapted based on what Bill Scaks has done for soil water retention curve + ! polymorphism. Therefore, I also keep some suggestions he gave there. + ! + ! - Make the interfaces contain all possible inputs that are needed by any + ! implementation; each implementation will then ignore the inputs it doesn't need. + ! + ! - For inputs that are needed only by particular implementations - and particularly + ! for inputs that are constant in time + ! pass these into the constructor, and save pointers to these inputs as components + ! of the child type that needs them. Then they aren't needed as inputs to the + ! individual routines, allowing the interfaces for these routines to remain more + ! consistent between different implementations. + ! + !--------------------------------------------------------------------------- + subroutine init_interface(this, bounds) + ! !DESCRIPTION: + ! read in kinetic parameters that are needed for doing nutrient competition + ! + ! !USES: + use decompMod , only : bounds_type + import :: nutrient_competition_method_type + ! + ! !ARGUMENTS: + class(nutrient_competition_method_type) :: this + type(bounds_type) , intent(in) :: bounds + + end subroutine init_interface + + !--------------------------------------------------------------------------- + subroutine calc_plant_nutrient_demand_interface (this, bounds, num_soilp, filter_soilp, & + photosyns_inst, crop_inst, canopystate_inst, & + cnveg_state_inst, cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenstate_inst, & + energyflux_inst, & + aroot, arepr) + ! + ! DESCRIPTION + ! calculate nutrient yield after considering competition between different components + ! + ! USES + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use PhotosynthesisMod , only : photosyns_type + use CropType , only : crop_type + use CanopyStateType , only : canopystate_type + use CNVegStateType , only : cnveg_state_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemCarbonFluxType, only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType, only : soilbiogeochem_nitrogenstate_type + use EnergyFluxType , only : energyflux_type + import :: nutrient_competition_method_type + ! + ! !ARGUMENTS: + class(nutrient_competition_method_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(photosyns_type) , intent(in) :: photosyns_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_carbonflux_type), intent(in) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenstate_type), intent(in) :: soilbiogeochem_nitrogenstate_inst + type(energyflux_type) , intent(in) :: energyflux_inst + real(r8) , intent(out) :: aroot(bounds%begp:) + real(r8) , intent(out) :: arepr(bounds%begp:) + + end subroutine calc_plant_nutrient_demand_interface + + !----------------------------------------------------------------------- + subroutine calc_plant_nutrient_competition_interface (this, & + bounds, num_soilp, filter_soilp, & + cnveg_state_inst, crop_inst, canopystate_inst, & + cnveg_carbonstate_inst, cnveg_carbonflux_inst, & + c13_cnveg_carbonflux_inst, c14_cnveg_carbonflux_inst, & + cnveg_nitrogenstate_inst, cnveg_nitrogenflux_inst, & + soilbiogeochem_nitrogenstate_inst, & + aroot, arepr, fpg_col) + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use CNVegStateType , only : cnveg_state_type + use CropType , only : crop_type + use CanopyStateType , only : canopystate_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegNitrogenStateType, only : cnveg_nitrogenstate_type + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use SoilBiogeochemNitrogenStateType, only : soilbiogeochem_nitrogenstate_type + import :: nutrient_competition_method_type + ! + ! !ARGUMENTS: + class(nutrient_competition_method_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(cnveg_state_type) , intent(inout) :: cnveg_state_inst + type(crop_type) , intent(in) :: crop_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_carbonflux_type) , intent(inout) :: cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c13_cnveg_carbonflux_inst + type(cnveg_carbonflux_type) , intent(inout) :: c14_cnveg_carbonflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cnveg_nitrogenflux_type) , intent(inout) :: cnveg_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type), intent(in) :: soilbiogeochem_nitrogenstate_inst + real(r8) , intent(in) :: aroot(bounds%begp:) + real(r8) , intent(in) :: arepr(bounds%begp:) + real(r8) , intent(in) :: fpg_col(bounds%begc:) + + end subroutine calc_plant_nutrient_competition_interface + + end interface + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + subroutine readParams (this, ncid ) + ! + ! !USES: + use shr_log_mod , only : errMsg => shr_log_errMsg + use ncdio_pio , only : file_desc_t,ncd_io + use abortutils , only : endrun + ! + ! !ARGUMENTS: + class(nutrient_competition_method_type), intent(in) :: this + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNAllocParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in parameter + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + ! read in parameters + + tString='dayscrecover' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%dayscrecover=tempr + + end subroutine readParams + +end module NutrientCompetitionMethodMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/PhotosynthesisMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/PhotosynthesisMod.F90 new file mode 100755 index 000000000..fbcfae073 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/PhotosynthesisMod.F90 @@ -0,0 +1,3778 @@ +module PhotosynthesisMod + +#include "MAPL_Generic.h" +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !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 shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use nanMod , only : nan + use abortutils , only : endrun + use clm_varctl , only : use_c13, use_c14, use_cn, use_cndv, use_fates, use_luna, use_hydrstress + use clm_varctl , only : iulog + use clm_varpar , only : nlevcan, nvegwcs, mxpft + use clm_varpar , only : numpft, NUM_VEG, NUM_ZON, VAR_COL, VAR_PFT + use clm_varcon , only : namep, spval, isecspday + use decompMod , only : bounds_type + use QuadraticMod , only : quadratic + use pftconMod , only : pftcon + use atm2lndType , only : atm2lnd_type + use CanopyStateType , only : canopystate_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use WaterFluxBulkType , only : waterfluxbulk_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use SolarAbsorbedType , only : solarabs_type + use SurfaceAlbedoType , only : surfalb_type + use OzoneBaseMod , only : ozone_base_type + use LandunitType , only : lun + use PatchType , only : patch + use GridcellType , only : grc + use MAPL_ExceptionHandling + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: PhotosynthesisTotal ! Determine of total photosynthesis + ! For plant hydraulics approach + public :: PhotosynthesisHydraulicStress ! Leaf stomatal resistance and leaf photosynthesis + ! Simultaneous solution of sunlit/shaded per Pierre + ! Gentine/Daniel Kennedy plant hydraulic stress method + public :: plc ! Return value of vulnerability curve at x + + ! !PRIVATE MEMBER FUNCTIONS: + private :: hybrid ! hybrid solver for ci + private :: ci_func ! ci function + private :: brent ! brent solver for root of a single variable function + private :: ft ! photosynthesis temperature response + private :: fth ! photosynthesis temperature inhibition + private :: fth25 ! scaling factor for photosynthesis temperature inhibition + ! For plant hydraulics approach + private :: hybrid_PHS ! hybrid solver for ci + private :: ci_func_PHS ! ci function + private :: brent_PHS ! brent solver for root of a single variable function + private :: calcstress ! compute the root water stress + private :: getvegwp ! calculate vegetation water potential (sun, sha, xylem, root) + private :: getqflx ! calculate sunlit and shaded transpiration + private :: spacF ! flux divergence across each vegetation segment + private :: spacA ! the inverse Jacobian matrix relating delta(vegwp) to f, d(vegwp)=A*f + private :: d1plc ! compute 1st deriv of conductance attenuation for each segment + + ! !PRIVATE DATA: + integer, parameter, private :: leafresp_mtd_ryan1991 = 1 ! Ryan 1991 method for lmr25top + integer, parameter, private :: leafresp_mtd_atkin2015 = 2 ! Atkin 2015 method for lmr25top + integer, parameter, private :: sun=1 ! index for sunlit + integer, parameter, private :: sha=2 ! index for shaded + integer, parameter, private :: xyl=3 ! index for xylem + integer, parameter, private :: root=4 ! index for root + integer, parameter, private :: veg=0 ! index for vegetation + integer, parameter, private :: soil=1 ! index for soil + integer, parameter, private :: stomatalcond_mtd_bb1987 = 1 ! Ball-Berry 1987 method for photosynthesis + integer, parameter, private :: stomatalcond_mtd_medlyn2011 = 2 ! Medlyn 2011 method for photosynthesis + ! !PUBLIC VARIABLES: + + type :: photo_params_type + real(r8) :: act25 ! Rubisco activity at 25 C (umol CO2/gRubisco/s) + real(r8) :: fnr ! Mass ratio of total Rubisco molecular mass to nitrogen in Rubisco (gRubisco/gN in Rubisco) + real(r8) :: cp25_yr2000 ! CO2 compensation point at 25°C at present day O2 (mol/mol) + real(r8) :: kc25_coef ! Michaelis-Menten const. at 25°C for CO2 (unitless) + real(r8) :: ko25_coef ! Michaelis-Menten const. at 25°C for O2 (unitless) + real(r8) :: fnps ! Fraction of light absorbed by non-photosynthetic pigment (unitless) + real(r8) :: theta_psii ! Empirical curvature parameter for electron transport rate (unitless) + real(r8) :: theta_ip ! Empirical curvature parameter for ap photosynthesis co-limitation (unitless) + 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) :: lmrse ! Entropy term for lmr (J/mol/K) + real(r8) :: tpu25ratio ! Ratio of tpu25top to vcmax25top (unitless) + real(r8) :: kp25ratio ! Ratio of kp25top to vcmax25top (unitless) + real(r8) :: vcmaxse_sf ! Scale factor for vcmaxse (unitless) + real(r8) :: jmaxse_sf ! Scale factor for jmaxse (unitless) + real(r8) :: tpuse_sf ! Scale factor for tpuse (unitless) + real(r8) :: jmax25top_sf ! Scale factor for jmax25top (unitless) + real(r8), allocatable, public :: krmax (:) + real(r8), allocatable, private :: kmax (:,:) + real(r8), allocatable, private :: psi50 (:,:) + real(r8), allocatable, private :: ck (:,:) + real(r8), allocatable, private :: lmr_intercept_atkin(:) + real(r8), allocatable, private :: theta_cj (:) ! Empirical curvature parameter for ac, aj photosynthesis co-limitation (unitless) + contains + procedure, private :: allocParams + end type photo_params_type + ! + type(photo_params_type), public, protected :: params_inst ! params_inst is populated in readParamsMod + + type, public :: photosyns_type + + logical , pointer, private :: c3flag_patch (:) ! patch true if C3 and false if C4 + ! Plant hydraulic stress specific variables + real(r8), pointer, private :: ac_phs_patch (:,:,:) ! patch Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: aj_phs_patch (:,:,:) ! patch RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: ap_phs_patch (:,:,:) ! patch product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: ag_phs_patch (:,:,:) ! patch co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: an_sun_patch (:,:) ! patch sunlit net leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: an_sha_patch (:,:) ! patch shaded net leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: vcmax_z_phs_patch (:,:,:) ! patch maximum rate of carboxylation (umol co2/m**2/s) + real(r8), pointer, private :: kp_z_phs_patch (:,:,:) ! patch initial slope of CO2 response curve (C4 plants) + real(r8), pointer, private :: tpu_z_phs_patch (:,:,:) ! patch triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), pointer, public :: gs_mol_sun_patch (:,:) ! patch sunlit leaf stomatal conductance (umol H2O/m**2/s) + real(r8), pointer, public :: gs_mol_sha_patch (:,:) ! patch shaded leaf stomatal conductance (umol H2O/m**2/s) + real(r8), pointer, private :: gs_mol_sun_ln_patch (:,:) ! patch sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + real(r8), pointer, private :: gs_mol_sha_ln_patch (:,:) ! patch shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + real(r8), pointer, private :: ac_patch (:,:) ! patch Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: aj_patch (:,:) ! patch RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: ap_patch (:,:) ! patch product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: ag_patch (:,:) ! patch co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: an_patch (:,:) ! patch net leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: vcmax_z_patch (:,:) ! patch maximum rate of carboxylation (umol co2/m**2/s) + real(r8), pointer, private :: cp_patch (:) ! patch CO2 compensation point (Pa) + real(r8), pointer, private :: kc_patch (:) ! patch Michaelis-Menten constant for CO2 (Pa) + real(r8), pointer, private :: ko_patch (:) ! patch Michaelis-Menten constant for O2 (Pa) + real(r8), pointer, private :: qe_patch (:) ! patch quantum efficiency, used only for C4 (mol CO2 / mol photons) + real(r8), pointer, private :: tpu_z_patch (:,:) ! patch triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), pointer, private :: kp_z_patch (:,:) ! patch initial slope of CO2 response curve (C4 plants) + real(r8), pointer, private :: bbb_patch (:) ! patch Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), pointer, private :: mbb_patch (:) ! patch Ball-Berry slope of conductance-photosynthesis relationship + real(r8), pointer, private :: gs_mol_patch (:,:) ! patch leaf stomatal conductance (umol H2O/m**2/s) + real(r8), pointer, private :: gb_mol_patch (:) ! patch leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), pointer, private :: rh_leaf_patch (:) ! patch fractional humidity at leaf surface (dimensionless) + real(r8), pointer, private :: vpd_can_patch (:) ! patch canopy vapor pressure deficit (kPa) + real(r8), pointer, private :: alphapsnsun_patch (:) ! patch sunlit 13c fractionation ([]) + real(r8), pointer, private :: alphapsnsha_patch (:) ! patch shaded 13c fractionation ([]) + + real(r8), pointer, public :: rc13_canair_patch (:) ! patch C13O2/C12O2 in canopy air + real(r8), pointer, public :: rc13_psnsun_patch (:) ! patch C13O2/C12O2 in sunlit canopy psn flux + real(r8), pointer, public :: rc13_psnsha_patch (:) ! patch C13O2/C12O2 in shaded canopy psn flux + + real(r8), pointer, public :: psnsun_patch (:) ! patch sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, public :: psnsha_patch (:) ! patch shaded leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, public :: c13_psnsun_patch (:) ! patch c13 sunlit leaf photosynthesis (umol 13CO2/m**2/s) + real(r8), pointer, public :: c13_psnsha_patch (:) ! patch c13 shaded leaf photosynthesis (umol 13CO2/m**2/s) + real(r8), pointer, public :: c14_psnsun_patch (:) ! patch c14 sunlit leaf photosynthesis (umol 14CO2/m**2/s) + real(r8), pointer, public :: c14_psnsha_patch (:) ! patch c14 shaded leaf photosynthesis (umol 14CO2/m**2/s) + + real(r8), pointer, private :: psnsun_z_patch (:,:) ! patch canopy layer: sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsha_z_patch (:,:) ! patch canopy layer: shaded leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsun_wc_patch (:) ! patch Rubsico-limited sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsha_wc_patch (:) ! patch Rubsico-limited shaded leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsun_wj_patch (:) ! patch RuBP-limited sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsha_wj_patch (:) ! patch RuBP-limited shaded leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsun_wp_patch (:) ! patch product-limited sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsha_wp_patch (:) ! patch product-limited shaded leaf photosynthesis (umol CO2/m**2/s) + + real(r8), pointer, public :: fpsn_patch (:) ! patch photosynthesis (umol CO2/m**2 ground/s) + real(r8), pointer, private :: fpsn_wc_patch (:) ! patch Rubisco-limited photosynthesis (umol CO2/m**2 ground/s) + real(r8), pointer, private :: fpsn_wj_patch (:) ! patch RuBP-limited photosynthesis (umol CO2/m**2 ground/s) + real(r8), pointer, private :: fpsn_wp_patch (:) ! patch product-limited photosynthesis (umol CO2/m**2 ground/s) + + real(r8), pointer, public :: lnca_patch (:) ! top leaf layer leaf N concentration (gN leaf/m^2) + + real(r8), pointer, public :: lmrsun_patch (:) ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), pointer, public :: lmrsha_patch (:) ! patch shaded leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), pointer, private :: lmrsun_z_patch (:,:) ! patch canopy layer: sunlit leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), pointer, private :: lmrsha_z_patch (:,:) ! patch canopy layer: shaded leaf maintenance respiration rate (umol CO2/m**2/s) + + real(r8), pointer, public :: cisun_z_patch (:,:) ! patch intracellular sunlit leaf CO2 (Pa) + real(r8), pointer, public :: cisha_z_patch (:,:) ! patch intracellular shaded leaf CO2 (Pa) + + real(r8), pointer, private :: rssun_z_patch (:,:) ! patch canopy layer: sunlit leaf stomatal resistance (s/m) + real(r8), pointer, private :: rssha_z_patch (:,:) ! patch canopy layer: shaded leaf stomatal resistance (s/m) + real(r8), pointer, public :: rssun_patch (:) ! patch sunlit stomatal resistance (s/m) + real(r8), pointer, public :: rssha_patch (:) ! patch shaded stomatal resistance (s/m) + real(r8), pointer, public :: luvcmax25top_patch (:) ! vcmax25 ! (umol/m2/s) + real(r8), pointer, public :: lujmax25top_patch (:) ! vcmax25 (umol/m2/s) + real(r8), pointer, public :: lutpu25top_patch (:) ! vcmax25 (umol/m2/s) +!! + + + ! 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 + real(r8), pointer, public :: vcmx25_z_last_valid_patch (:,:) ! patch leaf Vc,max25 at the end of the growing season for the previous year + real(r8), pointer, public :: jmx25_z_last_valid_patch (:,:) ! patch leaf Jmax25 at the end of the growing season for the previous year + real(r8), pointer, public :: pnlc_z_patch (:,:) ! patch proportion of leaf nitrogen allocated for light capture for canopy layer + real(r8), pointer, public :: enzs_z_patch (:,:) ! enzyme decay status 1.0-fully active; 0-all decayed during stress + real(r8), pointer, public :: fpsn24_patch (:) ! 24 hour mean patch photosynthesis (umol CO2/m**2 ground/day) + + ! Logical switches for different options + logical, public :: rootstem_acc ! Respiratory acclimation for roots and stems + logical, private :: light_inhibit ! If light should inhibit respiration + integer, private :: leafresp_method ! leaf maintencence respiration at 25C for canopy top method to use + integer, private :: stomatalcond_mtd ! Stomatal conduction method type + logical, private :: modifyphoto_and_lmr_forcrop ! Modify photosynthesis and LMR for crop + contains + + ! Public procedures + procedure, public :: Init + procedure, public :: ReadParams + procedure, public :: ReadNML + procedure, public :: TimeStepInit + + end type photosyns_type + type(photosyns_type), public, target, save :: photosyns_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this,bounds,nch,ityp,fveg,cncol,cnpft,cn5_cold_start,rc) + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: nch ! number of Catchment tiles + integer, dimension(nch,num_veg,num_zon), intent(in) :: ityp ! PFT index + real, dimension(nch,num_veg,num_zon), intent(in) :: fveg ! PFT fraction + real, dimension(nch,num_zon,var_col), intent(in) :: cncol ! column-level restart variable array + real, dimension(nch,num_zon,num_veg,var_pft), intent(in) :: cnpft ! pft-level (patch-level) restart variable array + logical, optional, intent(in) :: cn5_cold_start + class(photosyns_type) :: this + integer, optional, intent(out) :: rc + + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: np, nc, nz, p, nv + logical :: cold_start = .false. + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + ! check whether a cn5_cold_start option was set and change cold_start accordingly + if (present(cn5_cold_start) .and. (cn5_cold_start.eqv..true.)) then + cold_start = .true. + end if + + ! jkolassa: if cold_start is false, check that both CNCOL and CNPFT have the expected size for CNCLM50, else abort + if ((cold_start.eqv..false.) .and. ((size(cncol,3).ne.var_col) .or. & + (size(cnpft,4).ne.var_pft))) then + _ASSERT(.FALSE.,'option CNCLM50_cold_start = .FALSE. requires a CNCLM50 restart file') + end if + + + allocate(this%c3flag_patch (begp:endp)) ; this%c3flag_patch (:) =.false. + allocate(this%ac_phs_patch (begp:endp,2,1:nlevcan)) ; this%ac_phs_patch (:,:,:) = nan + allocate(this%aj_phs_patch (begp:endp,2,1:nlevcan)) ; this%aj_phs_patch (:,:,:) = nan + allocate(this%ap_phs_patch (begp:endp,2,1:nlevcan)) ; this%ap_phs_patch (:,:,:) = nan + allocate(this%ag_phs_patch (begp:endp,2,1:nlevcan)) ; this%ag_phs_patch (:,:,:) = nan + allocate(this%an_sun_patch (begp:endp,1:nlevcan)) ; this%an_sun_patch (:,:) = nan + allocate(this%an_sha_patch (begp:endp,1:nlevcan)) ; this%an_sha_patch (:,:) = nan + allocate(this%vcmax_z_phs_patch (begp:endp,2,1:nlevcan)) ; this%vcmax_z_phs_patch (:,:,:) = nan + allocate(this%tpu_z_phs_patch (begp:endp,2,1:nlevcan)) ; this%tpu_z_phs_patch (:,:,:) = nan + allocate(this%kp_z_phs_patch (begp:endp,2,1:nlevcan)) ; this%kp_z_phs_patch (:,:,:) = nan + allocate(this%gs_mol_sun_patch (begp:endp,1:nlevcan)) ; this%gs_mol_sun_patch (:,:) = nan + allocate(this%gs_mol_sha_patch (begp:endp,1:nlevcan)) ; this%gs_mol_sha_patch (:,:) = nan + allocate(this%gs_mol_sun_ln_patch (begp:endp,1:nlevcan)) ; this%gs_mol_sun_ln_patch (:,:) = nan + allocate(this%gs_mol_sha_ln_patch (begp:endp,1:nlevcan)) ; this%gs_mol_sha_ln_patch (:,:) = nan + allocate(this%ac_patch (begp:endp,1:nlevcan)) ; this%ac_patch (:,:) = nan + allocate(this%aj_patch (begp:endp,1:nlevcan)) ; this%aj_patch (:,:) = nan + allocate(this%ap_patch (begp:endp,1:nlevcan)) ; this%ap_patch (:,:) = nan + allocate(this%ag_patch (begp:endp,1:nlevcan)) ; this%ag_patch (:,:) = nan + allocate(this%an_patch (begp:endp,1:nlevcan)) ; this%an_patch (:,:) = nan + allocate(this%vcmax_z_patch (begp:endp,1:nlevcan)) ; this%vcmax_z_patch (:,:) = nan + allocate(this%tpu_z_patch (begp:endp,1:nlevcan)) ; this%tpu_z_patch (:,:) = nan + allocate(this%kp_z_patch (begp:endp,1:nlevcan)) ; this%kp_z_patch (:,:) = nan + allocate(this%gs_mol_patch (begp:endp,1:nlevcan)) ; this%gs_mol_patch (:,:) = nan + allocate(this%cp_patch (begp:endp)) ; this%cp_patch (:) = nan + allocate(this%kc_patch (begp:endp)) ; this%kc_patch (:) = nan + allocate(this%ko_patch (begp:endp)) ; this%ko_patch (:) = nan + allocate(this%qe_patch (begp:endp)) ; this%qe_patch (:) = nan + allocate(this%bbb_patch (begp:endp)) ; this%bbb_patch (:) = nan + allocate(this%mbb_patch (begp:endp)) ; this%mbb_patch (:) = nan + allocate(this%gb_mol_patch (begp:endp)) ; this%gb_mol_patch (:) = nan + allocate(this%rh_leaf_patch (begp:endp)) ; this%rh_leaf_patch (:) = nan + allocate(this%vpd_can_patch (begp:endp)) ; this%vpd_can_patch (:) = nan + allocate(this%psnsun_patch (begp:endp)) ; this%psnsun_patch (:) = nan + allocate(this%psnsha_patch (begp:endp)) ; this%psnsha_patch (:) = nan + allocate(this%c13_psnsun_patch (begp:endp)) ; this%c13_psnsun_patch (:) = nan + allocate(this%c13_psnsha_patch (begp:endp)) ; this%c13_psnsha_patch (:) = nan + allocate(this%c14_psnsun_patch (begp:endp)) ; this%c14_psnsun_patch (:) = nan + allocate(this%c14_psnsha_patch (begp:endp)) ; this%c14_psnsha_patch (:) = nan + + allocate(this%psnsun_z_patch (begp:endp,1:nlevcan)) ; this%psnsun_z_patch (:,:) = nan + allocate(this%psnsha_z_patch (begp:endp,1:nlevcan)) ; this%psnsha_z_patch (:,:) = nan + allocate(this%psnsun_wc_patch (begp:endp)) ; this%psnsun_wc_patch (:) = nan + allocate(this%psnsha_wc_patch (begp:endp)) ; this%psnsha_wc_patch (:) = nan + allocate(this%psnsun_wj_patch (begp:endp)) ; this%psnsun_wj_patch (:) = nan + allocate(this%psnsha_wj_patch (begp:endp)) ; this%psnsha_wj_patch (:) = nan + allocate(this%psnsun_wp_patch (begp:endp)) ; this%psnsun_wp_patch (:) = nan + allocate(this%psnsha_wp_patch (begp:endp)) ; this%psnsha_wp_patch (:) = nan + allocate(this%fpsn_patch (begp:endp)) ; this%fpsn_patch (:) = nan + allocate(this%fpsn_wc_patch (begp:endp)) ; this%fpsn_wc_patch (:) = nan + allocate(this%fpsn_wj_patch (begp:endp)) ; this%fpsn_wj_patch (:) = nan + allocate(this%fpsn_wp_patch (begp:endp)) ; this%fpsn_wp_patch (:) = nan + + allocate(this%lnca_patch (begp:endp)) ; this%lnca_patch (:) = nan + + allocate(this%lmrsun_z_patch (begp:endp,1:nlevcan)) ; this%lmrsun_z_patch (:,:) = nan + allocate(this%lmrsha_z_patch (begp:endp,1:nlevcan)) ; this%lmrsha_z_patch (:,:) = nan + allocate(this%lmrsun_patch (begp:endp)) ; this%lmrsun_patch (:) = nan + allocate(this%lmrsha_patch (begp:endp)) ; this%lmrsha_patch (:) = nan + + allocate(this%alphapsnsun_patch (begp:endp)) ; this%alphapsnsun_patch (:) = nan + allocate(this%alphapsnsha_patch (begp:endp)) ; this%alphapsnsha_patch (:) = nan + allocate(this%rc13_canair_patch (begp:endp)) ; this%rc13_canair_patch (:) = nan + allocate(this%rc13_psnsun_patch (begp:endp)) ; this%rc13_psnsun_patch (:) = nan + allocate(this%rc13_psnsha_patch (begp:endp)) ; this%rc13_psnsha_patch (:) = nan + + allocate(this%cisun_z_patch (begp:endp,1:nlevcan)) ; this%cisun_z_patch (:,:) = nan + allocate(this%cisha_z_patch (begp:endp,1:nlevcan)) ; this%cisha_z_patch (:,:) = nan + + allocate(this%rssun_z_patch (begp:endp,1:nlevcan)) ; this%rssun_z_patch (:,:) = nan + allocate(this%rssha_z_patch (begp:endp,1:nlevcan)) ; this%rssha_z_patch (:,:) = nan + allocate(this%rssun_patch (begp:endp)) ; this%rssun_patch (:) = nan + allocate(this%rssha_patch (begp:endp)) ; this%rssha_patch (:) = nan + allocate(this%luvcmax25top_patch(begp:endp)) ; this%luvcmax25top_patch(:) = nan + allocate(this%lujmax25top_patch (begp:endp)) ; this%lujmax25top_patch(:) = nan + allocate(this%lutpu25top_patch (begp:endp)) ; this%lutpu25top_patch(:) = nan +!! +! allocate(this%psncanopy_patch (begp:endp)) ; this%psncanopy_patch (:) = nan +! allocate(this%lmrcanopy_patch (begp:endp)) ; this%lmrcanopy_patch (:) = nan + if(use_luna)then + ! NOTE(bja, 2015-09) because these variables are only allocated + ! when luna is turned on, they can not be placed into associate + ! statements. + allocate(this%vcmx25_z_patch (begp:endp,1:nlevcan)) ; this%vcmx25_z_patch (:,:) = 30._r8 + allocate(this%jmx25_z_patch (begp:endp,1:nlevcan)) ; this%jmx25_z_patch (:,:) = 60._r8 + allocate(this%vcmx25_z_last_valid_patch (begp:endp,1:nlevcan)) ; this%vcmx25_z_last_valid_patch (:,:) = 30._r8 + allocate(this%jmx25_z_last_valid_patch (begp:endp,1:nlevcan)) ; this%jmx25_z_last_valid_patch (:,:) = 60._r8 + allocate(this%pnlc_z_patch (begp:endp,1:nlevcan)) ; this%pnlc_z_patch (:,:) = 0.01_r8 + allocate(this%fpsn24_patch (begp:endp)) ; this%fpsn24_patch (:) = nan + allocate(this%enzs_z_patch (begp:endp,1:nlevcan)) ; this%enzs_z_patch (:,:) = 1._r8 + endif + +! this%rootstem_acc = .false. ! jkolassa, Jun 2022: Default for CTSM5.1 +! +! this%light_inhibit = .true. ! jkolassa, Feb 2022: This is the default value for CTSM5.1; we could in the future control this through resource files +! +! this%leafresp_method = 2 ! jkolassa, Feb 2022: Default for CTSM5.1 if use_cn is true (2 corresponds to Atkin et al., 2015) +! +! this%stomatalcond_mtd = 2 ! jkolassa, Feb 2022: Default for CTSM5.1, corresponds to Medlyn et al., 2011 +! +! this%modifyphoto_and_lmr_forcrop = .true. ! jkolassa, Feb 2022: Default for CLM50 and up + + ! initialize types from restart file or through cold start values + + np = 0 + do nc = 1,nch ! catchment tile loop + do nz = 1,num_zon ! CN zone loop + do p = 0,numpft ! PFT index loop + np = np + 1 + do nv = 1,num_veg ! defined veg loop + if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then + if (cold_start) then + this%alphapsnsun_patch(np) = spval + this%alphapsnsha_patch(np) = spval + else if (cold_start.eqv..false.) then + this%alphapsnsun_patch(np) = cnpft(nc,nz,nv, 76) + this%alphapsnsha_patch(np) = cnpft(nc,nz,nv, 77) + end if + end if ! ityp =p + end do !nv + end do ! p + end do ! nz + end do ! nc + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine allocParams ( this ) + ! + implicit none + + ! !ARGUMENTS: + class(photo_params_type) :: this + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'allocParams' + !----------------------------------------------------------------------- + + ! allocate parameters + + allocate( this%krmax (0:mxpft) ) ; this%krmax(:) = nan + allocate( this%theta_cj (0:mxpft) ) ; this%theta_cj(:) = nan + allocate( this%kmax (0:mxpft,nvegwcs) ) ; this%kmax(:,:) = nan + allocate( this%psi50 (0:mxpft,nvegwcs) ) ; this%psi50(:,:) = nan + allocate( this%ck (0:mxpft,nvegwcs) ) ; this%ck(:,:) = nan + + if ( use_hydrstress .and. nvegwcs /= 4 )then + call endrun(msg='Error:: the Plant Hydraulics Stress methodology is for the spacA function is hardcoded for nvegwcs==4' & + //errMsg(__FILE__, __LINE__)) + end if + + end subroutine allocParams + + !----------------------------------------------------------------------- + subroutine readParams ( this, ncid ) + ! + ! !USES: + use ncdio_pio , only : file_desc_t,ncd_io + use paramUtilMod, only: readNcdioScalar + implicit none + + ! !ARGUMENTS: + class(photosyns_type) :: this + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'readParams' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: temp1d(0:mxpft) ! temporary to read in parameter + real(r8) :: temp2d(0:mxpft,nvegwcs) ! temporary to read in parameter + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + ! read in parameters + + + call params_inst%allocParams() + + tString = "krmax" + call ncd_io(varname=trim(tString),data=temp1d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%krmax=temp1d + tString = "lmr_intercept_atkin" + call ncd_io(varname=trim(tString),data=temp1d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%lmr_intercept_atkin=temp1d + tString = "theta_cj" + call ncd_io(varname=trim(tString),data=temp1d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%theta_cj=temp1d + tString = "kmax" + call ncd_io(varname=trim(tString),data=temp2d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%kmax=temp2d + tString = "psi50" + call ncd_io(varname=trim(tString),data=temp2d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%psi50=temp2d + tString = "ck" + call ncd_io(varname=trim(tString),data=temp2d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%ck=temp2d + + ! read in the scalar parameters + + ! Michaelis-Menten constant at 25°C for O2 (unitless) + call readNcdioScalar(ncid, 'ko25_coef', subname, params_inst%ko25_coef) + ! Michaelis-Menten constant at 25°C for CO2 (unitless) + call readNcdioScalar(ncid, 'kc25_coef', subname, params_inst%kc25_coef) + ! CO2 compensation point at 25°C at present day O2 levels + call readNcdioScalar(ncid, 'cp25_yr2000', subname, params_inst%cp25_yr2000) + ! Rubisco activity at 25 C (umol CO2/gRubisco/s) + call readNcdioScalar(ncid, 'act25', subname, params_inst%act25) + ! Mass ratio of total Rubisco molecular mass to nitrogen in Rubisco (gRubisco/gN(Rubisco)) + call readNcdioScalar(ncid, 'fnr', subname, params_inst%fnr) + ! Fraction of light absorbed by non-photosynthetic pigment (unitless) + call readNcdioScalar(ncid, 'fnps', subname, params_inst%fnps) + ! Empirical curvature parameter for electron transport rate (unitless) + call readNcdioScalar(ncid, 'theta_psii', subname, params_inst%theta_psii) + ! Empirical curvature parameter for ap photosynthesis co-limitation (unitless) + call readNcdioScalar(ncid, 'theta_ip', subname, params_inst%theta_ip) + ! Activation energy for vcmax (J/mol) + call readNcdioScalar(ncid, 'vcmaxha', subname, params_inst%vcmaxha) + ! Activation energy for jmax (J/mol) + call readNcdioScalar(ncid, 'jmaxha', subname, params_inst%jmaxha) + ! Activation energy for tpu (J/mol) + call readNcdioScalar(ncid, 'tpuha', subname, params_inst%tpuha) + ! Activation energy for lmr (J/mol) + call readNcdioScalar(ncid, 'lmrha', subname, params_inst%lmrha) + ! Activation energy for kc (J/mol) + call readNcdioScalar(ncid, 'kcha', subname, params_inst%kcha) + ! Activation energy for ko (J/mol) + call readNcdioScalar(ncid, 'koha', subname, params_inst%koha) + ! Activation energy for cp (J/mol) + call readNcdioScalar(ncid, 'cpha', subname, params_inst%cpha) + ! Deactivation energy for vcmax (J/mol) + call readNcdioScalar(ncid, 'vcmaxhd', subname, params_inst%vcmaxhd) + ! Deactivation energy for jmax (J/mol) + call readNcdioScalar(ncid, 'jmaxhd', subname, params_inst%jmaxhd) + ! Deactivation energy for tpu (J/mol) + call readNcdioScalar(ncid, 'tpuhd', subname, params_inst%tpuhd) + ! Deactivation energy for lmr (J/mol) + call readNcdioScalar(ncid, 'lmrhd', subname, params_inst%lmrhd) + ! Entropy term for lmr (J/mol/K) + call readNcdioScalar(ncid, 'lmrse', subname, params_inst%lmrse) + ! Ratio of tpu25top to vcmax25top (unitless) + call readNcdioScalar(ncid, 'tpu25ratio', subname, params_inst%tpu25ratio) + ! Ratio of kp25top to vcmax25top (unitless) + call readNcdioScalar(ncid, 'kp25ratio', subname, params_inst%kp25ratio) + ! Scale factor for vcmaxse (unitless) + call readNcdioScalar(ncid, 'vcmaxse_sf', subname, params_inst%vcmaxse_sf) + ! Scale factor for jmaxse (unitless) + call readNcdioScalar(ncid, 'jmaxse_sf', subname, params_inst%jmaxse_sf) + ! Scale factor for tpuse (unitless) + call readNcdioScalar(ncid, 'tpuse_sf', subname, params_inst%tpuse_sf) + ! Scale factor for jmax25top (unitless) + call readNcdioScalar(ncid, 'jmax25top_sf', subname, params_inst%jmax25top_sf) + + end subroutine readParams + + + !------------------------------------------------------------------------ + subroutine ReadNML(this, NLFilename) + ! + ! !DESCRIPTION: + ! Read the namelist for Photosynthesis + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + character(len=*), intent(IN) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'Photosyn::ReadNML' + character(len=*), parameter :: nmlname = 'photosyns_inparm' + logical :: rootstem_acc = .false. ! Respiratory acclimation for roots and stems + logical :: light_inhibit = .false. ! If light should inhibit respiration + integer :: leafresp_method = leafresp_mtd_ryan1991 ! leaf maintencence respiration at 25C for canopy top method to use + logical :: modifyphoto_and_lmr_forcrop = .false. ! Modify photosynthesis and LMR for crop + character(len=50) :: stomatalcond_method = 'Ball-Berry1987' ! Photosynthesis method string + !----------------------------------------------------------------------- + + namelist /photosyns_inparm/ leafresp_method, light_inhibit, & + rootstem_acc, stomatalcond_method, modifyphoto_and_lmr_forcrop + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=photosyns_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + this%rootstem_acc = rootstem_acc + this%leafresp_method = leafresp_method + this%light_inhibit = light_inhibit + this%modifyphoto_and_lmr_forcrop = modifyphoto_and_lmr_forcrop + if ( trim(stomatalcond_method) == 'Ball-Berry1987' ) then + this%stomatalcond_mtd = stomatalcond_mtd_bb1987 + else if ( trim(stomatalcond_method) == 'Medlyn2011' ) then + this%stomatalcond_mtd = stomatalcond_mtd_medlyn2011 + else + call endrun(msg="ERROR bad value for stomtalcond_method in "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + end if + + call shr_mpi_bcast (this%rootstem_acc , mpicom) + call shr_mpi_bcast (this%leafresp_method, mpicom) + call shr_mpi_bcast (this%light_inhibit , mpicom) + call shr_mpi_bcast (this%stomatalcond_mtd, mpicom) + call shr_mpi_bcast (this%modifyphoto_and_lmr_forcrop, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=photosyns_inparm) + write(iulog,*) ' ' + end if + + end subroutine ReadNML + + !------------------------------------------------------------------------ +! subroutine Restart(this, bounds, ncid, flag) +! ! +! ! !USES: +! use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_double, ncd_int, ncd_inqvdlen +! use restUtilMod +! ! +! ! !ARGUMENTS: +! class(photosyns_type) :: this +! type(bounds_type), intent(in) :: bounds +! type(file_desc_t), intent(inout) :: ncid ! netcdf id +! character(len=*) , intent(in) :: flag ! 'read' or 'write' +! ! +! ! !LOCAL VARIABLES: +! integer :: j,c ! indices +! logical :: readvar ! determine if variable is on initial file +! !----------------------------------------------------------------------- +! +! if ( use_c13 ) then +! call restartvar(ncid=ncid, flag=flag, varname='rc13_canair', xtype=ncd_double, & +! dim1name='pft', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=this%rc13_canair_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='rc13_psnsun', xtype=ncd_double, & +! dim1name='pft', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=this%rc13_psnsun_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='rc13_psnsha', xtype=ncd_double, & +! dim1name='pft', long_name='', units='', & +! interpinic_flag='interp', readvar=readvar, data=this%rc13_psnsha_patch) +! endif +! +! call restartvar(ncid=ncid, flag=flag, varname='GSSUN', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='sunlit leaf stomatal conductance', units='umol H20/m2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%gs_mol_sun_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='GSSHA', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='shaded leaf stomatal conductance', units='umol H20/m2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%gs_mol_sha_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='GSSUNLN', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon', & +! units='umol H20/m2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%gs_mol_sun_ln_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='GSSHALN', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon', & +! units='umol H20/m2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%gs_mol_sha_ln_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='lnca', xtype=ncd_double, & +! dim1name='pft', long_name='leaf N concentration', units='gN leaf/m^2', & +! interpinic_flag='interp', readvar=readvar, data=this%lnca_patch) +! +! if(use_luna) then +! call restartvar(ncid=ncid, flag=flag, varname='vcmx25_z', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='Maximum carboxylation rate at 25 Celcius for canopy layers', units='umol CO2/m**2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%vcmx25_z_patch) +! call restartvar(ncid=ncid, flag=flag, varname='jmx25_z', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='Maximum rate of electron transport at 25 Celcius for canopy layers', units='umol electrons/m**2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%jmx25_z_patch) +! call restartvar(ncid=ncid, flag=flag, varname='vcmx25_z_last_valid_patch:vcmx_prevyr', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='avg carboxylation rate at 25 celsius for canopy layers', units='umol CO2/m**2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%vcmx25_z_last_valid_patch) +! call restartvar(ncid=ncid, flag=flag, varname='jmx25_z_last_valid_patch:jmx_prevyr', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='avg rate of electron transport at 25 Celcius for canopy layers', units='umol electrons/m**2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%jmx25_z_last_valid_patch) +! call restartvar(ncid=ncid, flag=flag, varname='pnlc_z', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='proportion of leaf nitrogen allocated for light capture', units='unitless', & +! interpinic_flag='interp', readvar=readvar, data=this%pnlc_z_patch ) +! call restartvar(ncid=ncid, flag=flag, varname='enzs_z', xtype=ncd_double, & +! dim1name='pft', dim2name='levcan', switchdim=.true., & +! long_name='enzyme decay status during stress: 1.0-fully active; 0.0-all decayed', units='unitless', & +! interpinic_flag='interp', readvar=readvar, data=this%enzs_z_patch ) +! call restartvar(ncid=ncid, flag=flag, varname='gpp24', xtype=ncd_double, & +! dim1name='pft', long_name='accumulative gross primary production', units='umol CO2/m**2 ground/day', & +! interpinic_flag='interp', readvar=readvar, data=this%fpsn24_patch) +! endif +! call restartvar(ncid=ncid, flag=flag, varname='vcmx25t', xtype=ncd_double, & +! dim1name='pft', long_name='canopy profile of vcmax25', & +! units='umol/m2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%luvcmax25top_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='jmx25t', xtype=ncd_double, & +! dim1name='pft', long_name='canopy profile of jmax', & +! units='umol/m2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%lujmax25top_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='tpu25t', xtype=ncd_double, & +! dim1name='pft', long_name='canopy profile of tpu', & +! units='umol/m2/s', & +! interpinic_flag='interp', readvar=readvar, data=this%lutpu25top_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='VPD_CAN', xtype=ncd_double, & +! dim1name='pft', long_name='canopy vapor pressure deficit', & +! units='kPa', & +! interpinic_flag='interp', readvar=readvar, data=this%vpd_can_patch) +! +! +! +! end subroutine Restart + + !------------------------------------------------------------------------------ + subroutine TimeStepInit (this, bounds) + ! + ! Time step initialization + ! + ! !USES: + use landunit_varcon, only : istsoil, istcrop, istice_mec, istwet + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p,l ! indices + !----------------------------------------------------------------------- + + do p = bounds%begp, bounds%endp + l = patch%landunit(p) + if (.not. lun%lakpoi(l)) then + this%psnsun_patch(p) = 0._r8 + this%psnsun_wc_patch(p) = 0._r8 + this%psnsun_wj_patch(p) = 0._r8 + this%psnsun_wp_patch(p) = 0._r8 + + this%psnsha_patch(p) = 0._r8 + this%psnsha_wc_patch(p) = 0._r8 + this%psnsha_wj_patch(p) = 0._r8 + this%psnsha_wp_patch(p) = 0._r8 + + this%fpsn_patch(p) = 0._r8 + this%fpsn_wc_patch(p) = 0._r8 + this%fpsn_wj_patch(p) = 0._r8 + this%fpsn_wp_patch(p) = 0._r8 + + if ( use_c13 ) then + this%alphapsnsun_patch(p) = 0._r8 + this%alphapsnsha_patch(p) = 0._r8 + this%c13_psnsun_patch(p) = 0._r8 + this%c13_psnsha_patch(p) = 0._r8 + endif + if ( use_c14 ) then + this%c14_psnsun_patch(p) = 0._r8 + this%c14_psnsha_patch(p) = 0._r8 + endif + end if + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop & + .or. lun%itype(l) == istice_mec & + .or. lun%itype(l) == istwet) then + if (use_c13) then + this%rc13_canair_patch(p) = 0._r8 + this%rc13_psnsun_patch(p) = 0._r8 + this%rc13_psnsha_patch(p) = 0._r8 + end if + end if + end do + + end subroutine TimeStepInit + + !------------------------------------------------------------------------------ + + !------------------------------------------------------------------------------ + subroutine PhotosynthesisTotal (fn, filterp, & + atm2lnd_inst, canopystate_inst, photosyns_inst) + ! + ! Determine total photosynthesis + ! + ! !ARGUMENTS: + integer , intent(in) :: fn ! size of pft filter + integer , intent(in) :: filterp(fn) ! patch filter + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + ! + ! !LOCAL VARIABLES: + integer :: f,fp,p,l,g ! indices + + ! real(r8) :: rc14_atm(nsectors_c14), rc13_atm + integer :: sector_c14 + !----------------------------------------------------------------------- + + associate( & + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + + psnsun => photosyns_inst%psnsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf photosynthesis (umol CO2 /m**2/ s) + psnsha => photosyns_inst%psnsha_patch , & ! Input: [real(r8) (:) ] shaded leaf photosynthesis (umol CO2 /m**2/ s) + rc13_canair => photosyns_inst%rc13_canair_patch , & ! Output: [real(r8) (:) ] C13O2/C12O2 in canopy air + rc13_psnsun => photosyns_inst%rc13_psnsun_patch , & ! Output: [real(r8) (:) ] C13O2/C12O2 in sunlit canopy psn flux + rc13_psnsha => photosyns_inst%rc13_psnsha_patch , & ! Output: [real(r8) (:) ] C13O2/C12O2 in shaded canopy psn flux + alphapsnsun => photosyns_inst%alphapsnsun_patch , & ! Output: [real(r8) (:) ] fractionation factor in sunlit canopy psn flux + alphapsnsha => photosyns_inst%alphapsnsha_patch , & ! Output: [real(r8) (:) ] fractionation factor in shaded canopy psn flux + psnsun_wc => photosyns_inst%psnsun_wc_patch , & ! Output: [real(r8) (:) ] Rubsico-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) + psnsun_wj => photosyns_inst%psnsun_wj_patch , & ! Output: [real(r8) (:) ] RuBP-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) + psnsun_wp => photosyns_inst%psnsun_wp_patch , & ! Output: [real(r8) (:) ] product-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) + psnsha_wc => photosyns_inst%psnsha_wc_patch , & ! Output: [real(r8) (:) ] Rubsico-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) + psnsha_wj => photosyns_inst%psnsha_wj_patch , & ! Output: [real(r8) (:) ] RuBP-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) + psnsha_wp => photosyns_inst%psnsha_wp_patch , & ! Output: [real(r8) (:) ] product-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) + c13_psnsun => photosyns_inst%c13_psnsun_patch , & ! Output: [real(r8) (:) ] sunlit leaf photosynthesis (umol 13CO2 /m**2/ s) + c13_psnsha => photosyns_inst%c13_psnsha_patch , & ! Output: [real(r8) (:) ] shaded leaf photosynthesis (umol 13CO2 /m**2/ s) + c14_psnsun => photosyns_inst%c14_psnsun_patch , & ! Output: [real(r8) (:) ] sunlit leaf photosynthesis (umol 14CO2 /m**2/ s) + c14_psnsha => photosyns_inst%c14_psnsha_patch , & ! Output: [real(r8) (:) ] shaded leaf photosynthesis (umol 14CO2 /m**2/ s) + fpsn => photosyns_inst%fpsn_patch , & ! Output: [real(r8) (:) ] photosynthesis (umol CO2 /m**2 /s) + fpsn_wc => photosyns_inst%fpsn_wc_patch , & ! Output: [real(r8) (:) ] Rubisco-limited photosynthesis (umol CO2 /m**2 /s) + fpsn_wj => photosyns_inst%fpsn_wj_patch , & ! Output: [real(r8) (:) ] RuBP-limited photosynthesis (umol CO2 /m**2 /s) + fpsn_wp => photosyns_inst%fpsn_wp_patch & ! Output: [real(r8) (:) ] product-limited photosynthesis (umol CO2 /m**2 /s) + ) + + + do f = 1, fn + p = filterp(f) + g = patch%gridcell(p) + + if (.not. use_fates) then + fpsn(p) = psnsun(p) *laisun(p) + psnsha(p) *laisha(p) + fpsn_wc(p) = psnsun_wc(p)*laisun(p) + psnsha_wc(p)*laisha(p) + fpsn_wj(p) = psnsun_wj(p)*laisun(p) + psnsha_wj(p)*laisha(p) + fpsn_wp(p) = psnsun_wp(p)*laisun(p) + psnsha_wp(p)*laisha(p) + end if + end do + + end associate + + end subroutine PhotosynthesisTotal + + + !------------------------------------------------------------------------------- + subroutine hybrid(x0, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z,& + rh_can, gs_mol,iter, & + atm2lnd_inst, photosyns_inst) + ! + !! DESCRIPTION: + ! use a hybrid solver to find the root of equation + ! f(x) = x- h(x), + !we want to find x, s.t. f(x) = 0. + !the hybrid approach combines the strength of the newton secant approach (find the solution domain) + !and the bisection approach implemented with the Brent's method to guarrantee convergence. + + ! + !! REVISION HISTORY: + !Dec 14/2012: created by Jinyun Tang + ! + !!USES: + ! + !! ARGUMENTS: + implicit none + real(r8), intent(inout) :: x0 !initial guess and final value of the solution + real(r8), intent(in) :: lmr_z ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: par_z ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8), intent(in) :: rh_can ! canopy air relative humidity + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8), intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + integer, intent(in) :: p, iv, c ! pft, c3/c4, and column index + real(r8), intent(out) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + integer, intent(out) :: iter !number of iterations used, for record only + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type), intent(inout) :: photosyns_inst + ! + !! LOCAL VARIABLES + real(r8) :: a, b + real(r8) :: fa, fb + real(r8) :: x1, f0, f1 + real(r8) :: x, dx + real(r8), parameter :: eps = 1.e-2_r8 !relative accuracy + real(r8), parameter :: eps1= 1.e-4_r8 + integer, parameter :: itmax = 40 !maximum number of iterations + real(r8) :: tol,minx,minf + + call ci_func(x0, f0, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + + if(f0 == 0._r8)return + + minx=x0 + minf=f0 + x1 = x0 * 0.99_r8 + + call ci_func(x1,f1, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + + if(f1==0._r8)then + x0 = x1 + return + endif + if(f1itmax)then + !in case of failing to converge within itmax iterations + !stop at the minimum function + !this happens because of some other issues besides the stomatal conductance calculation + !and it happens usually in very dry places and more likely with c4 plants. + + call ci_func(minx,f1, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + + exit + endif + enddo + + end subroutine hybrid + + !------------------------------------------------------------------------------ + subroutine brent(x, x1,x2,f1, f2, tol, ip, iv, ic, gb_mol, je, cair, oair,& + lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + ! + !!DESCRIPTION: + !Use Brent's method to find the root of a single variable function ci_func, which is known to exist between x1 and x2. + !The found root will be updated until its accuracy is tol. + + !!REVISION HISTORY: + !Dec 14/2012: Jinyun Tang, modified from numerical recipes in F90 by press et al. 1188-1189 + ! + !!ARGUMENTS: + real(r8), intent(out) :: x ! indepedent variable of the single value function ci_func(x) + real(r8), intent(in) :: x1, x2, f1, f2 ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(in) :: tol ! the error tolerance + real(r8), intent(in) :: lmr_z ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: par_z ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8), intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8), intent(in) :: rh_can ! inside canopy relative humidity + integer, intent(in) :: ip, iv, ic ! pft, c3/c4, and column index + real(r8), intent(out) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type), intent(inout) :: photosyns_inst + ! + !!LOCAL VARIABLES: + integer, parameter :: itmax=20 !maximum number of iterations + real(r8), parameter :: eps=1.e-2_r8 !relative error tolerance + integer :: iter + real(r8) :: a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm + !------------------------------------------------------------------------------ + + a=x1 + b=x2 + fa=f1 + fb=f2 + if((fa > 0._r8 .and. fb > 0._r8).or.(fa < 0._r8 .and. fb < 0._r8))then + write(iulog,*) 'root must be bracketed for brent' + call endrun(msg=errmsg(sourcefile, __LINE__)) + endif + c=b + fc=fb + iter = 0 + do + if(iter==itmax)exit + iter=iter+1 + if((fb > 0._r8 .and. fc > 0._r8) .or. (fb < 0._r8 .and. fc < 0._r8))then + c=a !Rename a, b, c and adjust bounding interval d. + fc=fa + d=b-a + e=d + endif + if( abs(fc) < abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + endif + tol1=2._r8*eps*abs(b)+0.5_r8*tol !Convergence check. + xm=0.5_r8*(c-b) + if(abs(xm) <= tol1 .or. fb == 0.)then + x=b + return + endif + if(abs(e) >= tol1 .and. abs(fa) > abs(fb)) then + s=fb/fa !Attempt inverse quadratic interpolation. + if(a == c) then + p=2._r8*xm*s + q=1._r8-s + else + q=fa/fc + r=fb/fc + p=s*(2._r8*xm*q*(q-r)-(b-a)*(r-1._r8)) + q=(q-1._r8)*(r-1._r8)*(s-1._r8) + endif + if(p > 0._r8) q=-q !Check whether in bounds. + p=abs(p) + if(2._r8*p < min(3._r8*xm*q-abs(tol1*q),abs(e*q))) then + e=d !Accept interpolation. + d=p/q + else + d=xm !Interpolation failed, use bisection. + e=d + endif + else !Bounds decreasing too slowly, use bisection. + d=xm + e=d + endif + a=b !Move last best guess to a. + fa=fb + if(abs(d) > tol1) then !Evaluate new trial root. + b=b+d + else + b=b+sign(tol1,xm) + endif + + call ci_func(b, fb, ip, iv, ic, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + + if(fb==0._r8)exit + + enddo + + if(iter==itmax)write(iulog,*) 'brent exceeding maximum iterations', b, fb + x=b + + return + end subroutine brent + + !------------------------------------------------------------------------------- + function ft(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! + !!USES + use clm_varcon , only : rgas, tfrz + ! + ! !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 ft + + !------------------------------------------------------------------------------- + function fth(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! + use clm_varcon , only : rgas, tfrz + ! + ! !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 + + !------------------------------------------------------------------------------- + function fth25(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! + !!USES + use clm_varcon , only : rgas, tfrz + ! + ! !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 + + !------------------------------------------------------------------------------ + subroutine ci_func(ci, fval, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z,& + rh_can, gs_mol, atm2lnd_inst, photosyns_inst) + ! + !! DESCRIPTION: + ! evaluate the function + ! f(ci)=ci - (ca - (1.37rb+1.65rs))*patm*an + ! + ! remark: I am attempting to maintain the original code structure, also + ! considering one may be interested to output relevant variables for the + ! photosynthesis model, I have decided to add these relevant variables to + ! the relevant data types. + ! + !!ARGUMENTS: + real(r8) , intent(in) :: ci ! intracellular leaf CO2 (Pa) + real(r8) , intent(in) :: lmr_z ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8) , intent(in) :: par_z ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) , intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8) , intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8) , intent(in) :: rh_can ! canopy air realtive humidity + integer , intent(in) :: p, iv, c ! pft, vegetation type and column indexes + real(r8) , intent(out) :: fval ! return function of the value f(ci) + real(r8) , intent(out) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + ! + !local variables + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: cs ! CO2 partial pressure at leaf surface (Pa) + + real(r8) :: aquad, bquad, cquad ! terms for quadratic equations + real(r8) :: r1, r2 ! roots of quadratic equation + !------------------------------------------------------------------------------ + + associate(& + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Output: [real(r8) (:) ] atmospheric pressure (Pa) + c3flag => photosyns_inst%c3flag_patch , & ! Output: [logical (:) ] true if C3 and false if C4 + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + ac => photosyns_inst%ac_patch , & ! Output: [real(r8) (:,:) ] Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + aj => photosyns_inst%aj_patch , & ! Output: [real(r8) (:,:) ] RuBP-limited gross photosynthesis (umol CO2/m**2/s) + ap => photosyns_inst%ap_patch , & ! Output: [real(r8) (:,:) ] product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + ag => photosyns_inst%ag_patch , & ! Output: [real(r8) (:,:) ] co-limited gross leaf photosynthesis (umol CO2/m**2/s) + an => photosyns_inst%an_patch , & ! Output: [real(r8) (:,:) ] net leaf photosynthesis (umol CO2/m**2/s) + vcmax_z => photosyns_inst%vcmax_z_patch , & ! Input: [real(r8) (:,:) ] maximum rate of carboxylation (umol co2/m**2/s) + cp => photosyns_inst%cp_patch , & ! Output: [real(r8) (:) ] CO2 compensation point (Pa) + kc => photosyns_inst%kc_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for CO2 (Pa) + ko => photosyns_inst%ko_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for O2 (Pa) + qe => photosyns_inst%qe_patch , & ! Output: [real(r8) (:) ] quantum efficiency, used only for C4 (mol CO2 / mol photons) + tpu_z => photosyns_inst%tpu_z_patch , & ! Output: [real(r8) (:,:) ] triose phosphate utilization rate (umol CO2/m**2/s) + kp_z => photosyns_inst%kp_z_patch , & ! Output: [real(r8) (:,:) ] initial slope of CO2 response curve (C4 plants) + bbb => photosyns_inst%bbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + mbb => photosyns_inst%mbb_patch & ! Output: [real(r8) (:) ] Ball-Berry slope of conductance-photosynthesis relationship + ) + + if (c3flag(p)) then + ! C3: Rubisco-limited photosynthesis + ac(p,iv) = vcmax_z(p,iv) * max(ci-cp(p), 0._r8) / (ci+kc(p)*(1._r8+oair/ko(p))) + + ! C3: RuBP-limited photosynthesis + aj(p,iv) = je * max(ci-cp(p), 0._r8) / (4._r8*ci+8._r8*cp(p)) + + ! C3: Product-limited photosynthesis + ap(p,iv) = 3._r8 * tpu_z(p,iv) + + else + + ! C4: Rubisco-limited photosynthesis + ac(p,iv) = vcmax_z(p,iv) + + ! C4: RuBP-limited photosynthesis + aj(p,iv) = qe(p) * par_z * 4.6_r8 + + ! C4: PEP carboxylase-limited (CO2-limited) + ap(p,iv) = kp_z(p,iv) * max(ci, 0._r8) / forc_pbot(c) + + end if + + ! Gross photosynthesis. First co-limit ac and aj. Then co-limit ap + + aquad = params_inst%theta_cj(ivt(p)) + bquad = -(ac(p,iv) + aj(p,iv)) + cquad = ac(p,iv) * aj(p,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = params_inst%theta_ip + bquad = -(ai + ap(p,iv)) + cquad = ai * ap(p,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ag(p,iv) = max(0._r8,min(r1,r2)) + + ! Net photosynthesis. Exit iteration if an < 0 + + an(p,iv) = ag(p,iv) - lmr_z + if (an(p,iv) < 0._r8) then + fval = 0._r8 + return + endif + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = bbb + + cs = cair - 1.4_r8/gb_mol * an(p,iv) * forc_pbot(c) + cs = max(cs,1.e-06_r8) + aquad = cs + bquad = cs*(gb_mol - bbb(p)) - mbb(p)*an(p,iv)*forc_pbot(c) + cquad = -gb_mol*(cs*bbb(p) + mbb(p)*an(p,iv)*forc_pbot(c)*rh_can) + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + ! Derive new estimate for ci + + fval =ci - cair + an(p,iv) * forc_pbot(c) * (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + + end associate + + end subroutine ci_func + + !------------------------------------------------------------------------------ + subroutine PhotosynthesisHydraulicStress ( bounds, fn, filterp, & + esat_tv, eair, oair, cair, rb, bsun, bsha, btran, dayl_factor, leafn, & + qsatl, qaf, & + atm2lnd_inst, temperature_inst, soilstate_inst, waterdiagnosticbulk_inst, & + surfalb_inst, solarabs_inst, canopystate_inst, ozone_inst, & + photosyns_inst, waterfluxbulk_inst, froot_carbon, croot_carbon) + ! + ! !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 + ! Here, sunlit and shaded photosynthesis and stomatal conductance are solved + ! simultaneously per Pierre Gentine/Daniel Kennedy plant hydraulic stress + ! method + ! + ! !USES: + use clm_varcon , only : rgas, tfrz, rpi, spval + use GridcellType , only : grc + use clm_time_manager , only : get_step_size_real, is_near_local_noon + use clm_varctl , only : cnallocate_carbon_only + use clm_varctl , only : lnc_opt, reduce_dayl_factor, vcmax_opt + use clm_varpar , only : nlevsoi + use pftconMod , only : nbrdlf_dcd_tmp_shrub, npcropmin + use ColumnType , only : col + use shr_infnan_mod , only : shr_infnan_isnan + + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: fn ! size of pft filter + integer , intent(in) :: filterp(fn) ! patch filter + real(r8) , intent(in) :: esat_tv( bounds%begp: ) ! saturation vapor pressure at t_veg (Pa) [pft] + real(r8) , intent(in) :: eair( bounds%begp: ) ! vapor pressure of canopy air (Pa) [pft] + real(r8) , intent(in) :: oair( bounds%begp: ) ! Atmospheric O2 partial pressure (Pa) [pft] + real(r8) , intent(in) :: cair( bounds%begp: ) ! Atmospheric CO2 partial pressure (Pa) [pft] + real(r8) , intent(in) :: rb( bounds%begp: ) ! boundary layer resistance (s/m) [pft] + real(r8) , intent(in) :: dayl_factor( bounds%begp: ) ! scalar (0-1) for daylength + real(r8) , intent(in) :: qsatl ( bounds%begp: ) ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ( bounds%begp: ) ! humidity of canopy air [kg/kg] + real(r8) , intent(in) :: leafn( bounds%begp: ) ! leaf N (gN/m2) + real(r8) , intent(out) :: bsun( bounds%begp: ) ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(out) :: bsha( bounds%begp: ) ! shaded canopy transpiration wetness factor (0 to 1) + real(r8) , intent(out) :: btran( bounds%begp: ) ! transpiration wetness factor (0 to 1) [pft] + real(r8) , intent(in) :: froot_carbon( bounds%begp: ) ! fine root carbon (gC/m2) [pft] + real(r8) , intent(in) :: croot_carbon( bounds%begp: ) ! live coarse root carbon (gC/m2) [pft] + + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(temperature_type) , intent(in) :: temperature_inst + type(surfalb_type) , intent(in) :: surfalb_inst + type(solarabs_type) , intent(in) :: solarabs_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(inout) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + class(ozone_base_type) , intent(in) :: ozone_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + ! + ! !LOCAL VARIABLES: + ! + ! Leaf photosynthesis parameters + real(r8) :: jmax_z(bounds%begp:bounds%endp,2,nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) + real(r8) :: bbbopt(bounds%begp:bounds%endp) ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + real(r8) :: kn(bounds%begp:bounds%endp) ! leaf nitrogen decay coefficient + real(r8) :: vcmax25top ! canopy top: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25top ! canopy top: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25top ! canopy top: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25top ! canopy top: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25top ! canopy top: initial slope of CO2 response curve (C4 plants) at 25C + + real(r8) :: vcmax25_sun ! sunlit leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: vcmax25_sha ! shaded leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25_sun ! sunlit leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: jmax25_sha ! shaded leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25_sun ! sunlit leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: tpu25_sha ! shaded leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25_sun ! sunlit leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25_sha ! shaded leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25_sun ! sunlit leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + real(r8) :: kp25_sha ! shaded 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) :: 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) :: 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) + + ! Other + integer :: f,p,c,iv ! indices + real(r8) :: cf ! s m**2/umol -> s/m + real(r8) :: rsmax0 ! maximum stomatal resistance [s/m] + real(r8) :: gb ! leaf boundary layer conductance (m/s) + real(r8) :: cs_sun ! CO2 partial pressure at sunlit leaf surface (Pa) + real(r8) :: cs_sha ! CO2 partial pressure at shaded leaf surface (Pa) + 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) :: ft ! photosynthesis temperature response (statement function) + real(r8) :: fth ! photosynthesis temperature inhibition (statement function) + real(r8) :: fth25 ! ccaling factor for photosynthesis temperature inhibition (statement function) + 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) :: scaleFactor ! 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_sun ! sunlit leaf electron transport rate (umol electrons/m**2/s) + real(r8) :: je_sha ! shaded leaf 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) + integer :: iter1 ! number of iterations used, for record only + integer :: iter2 ! number of iterations used, for record only + real(r8) :: nscaler ! leaf nitrogen scaling coefficient + real(r8) :: nscaler_sun ! sunlit leaf nitrogen scaling coefficient + real(r8) :: nscaler_sha ! shaded leaf nitrogen scaling coefficient + + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + + real(r8) :: psn_wc_z_sun(bounds%begp:bounds%endp,nlevcan) ! Rubisco-limited contribution to sunlit psn_z (umol CO2/m**2/s) + real(r8) :: psn_wj_z_sun(bounds%begp:bounds%endp,nlevcan) ! RuBP-limited contribution to sunlit psn_z (umol CO2/m**2/s) + real(r8) :: psn_wp_z_sun(bounds%begp:bounds%endp,nlevcan) ! product-limited contribution to sunlit psn_z (umol CO2/m**2/s) + real(r8) :: psn_wc_z_sha(bounds%begp:bounds%endp,nlevcan) ! Rubisco-limited contribution to shaded psn_z (umol CO2/m**2/s) + real(r8) :: psn_wj_z_sha(bounds%begp:bounds%endp,nlevcan) ! RuBP-limited contribution to shaded psn_z (umol CO2/m**2/s) + real(r8) :: psn_wp_z_sha(bounds%begp:bounds%endp,nlevcan) ! product-limited contribution to shaded psn_z (umol CO2/m**2/s) + real(r8) :: rh_leaf_sun(bounds%begp:bounds%endp) ! fractional humidity at sunlit leaf surface (dimensionless) + real(r8) :: rh_leaf_sha(bounds%begp:bounds%endp) ! fractional humidity at shaded leaf surface (dimensionless) + + real(r8) :: psncan_sun ! canopy sum of sunlit psn_z + real(r8) :: psncan_wc_sun ! canopy sum of sunlit psn_wc_z + real(r8) :: psncan_wj_sun ! canopy sum of sunlit psn_wj_z + real(r8) :: psncan_wp_sun ! canopy sum of sunlit psn_wp_z + real(r8) :: lmrcan_sun ! canopy sum of sunlit lmr_z + real(r8) :: gscan_sun ! canopy sum of sunlit leaf conductance + real(r8) :: laican_sun ! canopy sum of sunlit lai_z + real(r8) :: psncan_sha ! canopy sum of shaded psn_z + real(r8) :: psncan_wc_sha ! canopy sum of shaded psn_wc_z + real(r8) :: psncan_wj_sha ! canopy sum of shaded psn_wj_z + real(r8) :: psncan_wp_sha ! canopy sum of shaded psn_wp_z + real(r8) :: lmrcan_sha ! canopy sum of shaded lmr_z + real(r8) :: gscan_sha ! canopy sum of shaded leaf conductance + real(r8) :: laican_sha ! canopy sum of shaded lai_z + real(r8) :: laican ! canopy sum of lai_z + real(r8) :: rh_can ! canopy air relative humidity + + real(r8) , pointer :: lai_z_sun (:,:) ! leaf area index for canopy layer, sunlit + real(r8) , pointer :: par_z_sun (:,:) ! par absorbed per unit lai for canopy layer, sunlit (w/m**2) + real(r8) , pointer :: vcmaxcint_sun (:) ! leaf to canopy scaling coefficient, sunlit + real(r8) , pointer :: alphapsn_sun (:) ! 13C fractionation factor for PSN, sunlit () + real(r8) , pointer :: psn_sun (:) ! foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wc_sun (:) ! Rubisco-limited foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wj_sun (:) ! RuBP-limited foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wp_sun (:) ! product-limited foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_z_sun (:,:) ! canopy layer: foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: lmr_sun (:) ! leaf maintenance respiration rate, sunlit (umol CO2/m**2/s) + real(r8) , pointer :: lmr_z_sun (:,:) ! canopy layer: leaf maintenance respiration rate, sunlit (umol CO2/m**2/s) + real(r8) , pointer :: rs_sun (:) ! leaf stomatal resistance, sunlit (s/m) + real(r8) , pointer :: rs_z_sun (:,:) ! canopy layer: leaf stomatal resistance, sunlit (s/m) + real(r8) , pointer :: ci_z_sun (:,:) ! intracellular leaf CO2, sunlit (Pa) + real(r8) , pointer :: o3coefv_sun (:) ! o3 coefficient used in photo calculation, sunlit + real(r8) , pointer :: o3coefg_sun (:) ! o3 coefficient used in rs calculation, sunlit + real(r8) , pointer :: lai_z_sha (:,:) ! leaf area index for canopy layer, shaded + real(r8) , pointer :: par_z_sha (:,:) ! par absorbed per unit lai for canopy layer, shaded (w/m**2) + real(r8) , pointer :: vcmaxcint_sha (:) ! leaf to canopy scaling coefficient, shaded + real(r8) , pointer :: alphapsn_sha (:) ! 13C fractionation factor for PSN, shaded () + real(r8) , pointer :: psn_sha (:) ! foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wc_sha (:) ! Rubisco-limited foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wj_sha (:) ! RuBP-limited foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wp_sha (:) ! product-limited foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_z_sha (:,:) ! canopy layer: foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: lmr_sha (:) ! leaf maintenance respiration rate, shaded (umol CO2/m**2/s) + real(r8) , pointer :: lmr_z_sha (:,:) ! canopy layer: leaf maintenance respiration rate, shaded (umol CO2/m**2/s) + real(r8) , pointer :: rs_sha (:) ! leaf stomatal resistance, shaded (s/m) + real(r8) , pointer :: rs_z_sha (:,:) ! canopy layer: leaf stomatal resistance, shaded (s/m) + real(r8) , pointer :: ci_z_sha (:,:) ! intracellular leaf CO2, shaded (Pa) + real(r8) , pointer :: o3coefv_sha (:) ! o3 coefficient used in photo calculation, shaded + real(r8) , pointer :: o3coefg_sha (:) ! o3 coefficient used in rs calculation, shaded + real(r8) :: sum_nscaler + real(r8) :: total_lai + integer :: nptreemax + real(r8) :: dtime ! land model time step (sec) + integer :: j,g ! index + real(r8) :: rs_resis ! combined soil-root resistance [s] + real(r8) :: r_soil ! root spacing [m] + real(r8) :: root_biomass_density ! root biomass density [g/m3] + real(r8) :: root_cross_sec_area ! root cross sectional area [m2] + real(r8) :: root_length_density ! root length density [m/m3] + real(r8) :: froot_average_length ! average coarse root length [m] + real(r8) :: croot_average_length ! average coarse root length [m] + real(r8) :: soil_conductance ! soil to root hydraulic conductance [1/s] + real(r8) :: root_conductance ! root hydraulic conductance [1/s] + real(r8) :: rai(nlevsoi) ! root area index [m2/m2] + real(r8) :: fs(nlevsoi) ! root conductance scale factor (reduction in conductance due to decreasing (more negative) root water potential) + real(r8) :: gsminsun ! Minimum stomatal conductance sunlit + real(r8) :: gsminsha ! Minimum stomatal conductance shaded + real(r8) :: gs_slope_sun ! Slope stomatal conductance sunlit + real(r8) :: gs_slope_sha ! Slope stomatal conductance shaded + real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] + real(r8), parameter :: c_to_b = 2.0_r8 !(g biomass /g C) +!Note that root density is for dry biomass not carbon. CLM provides root biomass as carbon. The conversion is 0.5 g C / g biomass + + !------------------------------------------------------------------------------ + + ! Temperature and soil water response functions + + ft(tl,ha) = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + fth(tl,hd,se,scaleFactor) = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + fth25(hd,se) = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + ! Enforce expected array sizes + + SHR_ASSERT_ALL_FL((ubound(esat_tv) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(eair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(oair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(cair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(rb) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(bsun) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(bsha) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(btran) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dayl_factor) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(qsatl) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(qaf) == (/bounds%endp/)), sourcefile, __LINE__) + + associate( & + k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] soil-root interface conductance (mm/s) + hk_l => soilstate_inst%hk_l_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity (mm/s) + hksat => soilstate_inst%hksat_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity at saturation (mm H2O /s) + smp => soilstate_inst%smp_l_col , & ! Input: [real(r8) (:,:) ] soil matrix potential [mm] + + froot_leaf => pftcon%froot_leaf , & ! fine root to leaf ratio + root_conductance_patch => soilstate_inst%root_conductance_patch , & ! Output: [real(r8) (:,:)] root conductance + soil_conductance_patch => soilstate_inst%soil_conductance_patch , & ! Output: [real(r8) (:,:)] soil conductance + rootfr => soilstate_inst%rootfr_patch , & ! Input: [real(r8) (:,:)] + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) + z => col%z , & ! Input: [real(r8) (:,:) ] layer depth (m) + root_radius => pftcon%root_radius , & ! Input: 0.29e-03_r8 !(m) + root_density => pftcon%root_density , & ! Input: 0.31e06_r8 !(g biomass / m3 root) + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + c3psn => pftcon%c3psn , & ! Input: photosynthetic pathway: 0. = c4, 1. = c3 + crop => pftcon%crop , & ! Input: crop or not (0 =not crop and 1 = crop) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + flnr => pftcon%flnr , & ! Input: fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) + fnitr => pftcon%fnitr , & ! Input: foliage nitrogen limitation factor (-) + slatop => pftcon%slatop , & ! Input: specific leaf area at top of canopy, projected area basis [m^2/gC] + dsladlai => pftcon%dsladlai , & ! Input: change in sla per unit lai + i_vcad => pftcon%i_vcad , & ! Input: [real(r8) (:) ] + s_vcad => pftcon%s_vcad , & ! Input: [real(r8) (:) ] + i_flnr => pftcon%i_flnr , & ! Input: [real(r8) (:) ] + s_flnr => pftcon%s_flnr , & ! Input: [real(r8) (:) ] + mbbopt => pftcon%mbbopt , & + medlynintercept=> pftcon%medlynintercept , & ! Input: [real(r8) (:) ] Intercept for Medlyn stomatal conductance model method + medlynslope=> pftcon%medlynslope , & ! Input: [real(r8) (:) ] Slope for Medlyn stomatal conductance model method + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + t_veg => temperature_inst%t_veg_patch , & ! Input: [real(r8) (:) ] vegetation temperature (Kelvin) + t10 => temperature_inst%t_a10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of the 2 m temperature (K) + tgcm => temperature_inst%thm_patch , & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] pft number of canopy layers, above snow for radiative transfer + tlai_z => surfalb_inst%tlai_z_patch , & ! Input: [real(r8) (:,:) ] pft total leaf area index for canopy layer + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8)(:) ] one-sided leaf area index, no burying by snow + c3flag => photosyns_inst%c3flag_patch , & ! Output: [logical (:) ] true if C3 and false if C4 + ac => photosyns_inst%ac_phs_patch , & ! Output: [real(r8) (:,:,:) ] Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + aj => photosyns_inst%aj_phs_patch , & ! Output: [real(r8) (:,:,:) ] RuBP-limited gross photosynthesis (umol CO2/m**2/s) + ap => photosyns_inst%ap_phs_patch , & ! Output: [real(r8) (:,:,:) ] product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + ag => photosyns_inst%ag_phs_patch , & ! Output: [real(r8) (:,:,:) ] co-limited gross leaf photosynthesis (umol CO2/m**2/s) + vcmax_z => photosyns_inst%vcmax_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] maximum rate of carboxylation (umol co2/m**2/s) + luvcmax25top => photosyns_inst%luvcmax25top_patch , & ! Output: [real(r8) (:) ] maximum rate of carboxylation (umol co2/m**2/s) + lujmax25top => photosyns_inst%lujmax25top_patch , & ! Output: [real(r8) (:) ] maximum rate of carboxylation (umol co2/m**2/s) + lutpu25top => photosyns_inst%lutpu25top_patch , & ! Output: [real(r8) (:) ] maximum rate of carboxylation (umol co2/m**2/s) +!!! + tpu_z => photosyns_inst%tpu_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] triose phosphate utilization rate (umol CO2/m**2/s) + kp_z => photosyns_inst%kp_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] initial slope of CO2 response curve (C4 plants) + gb_mol => photosyns_inst%gb_mol_patch , & ! Output: [real(r8) (:) ] leaf boundary layer conductance (umol H2O/m**2/s) + cp => photosyns_inst%cp_patch , & ! Output: [real(r8) (:) ] CO2 compensation point (Pa) + kc => photosyns_inst%kc_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for CO2 (Pa) + ko => photosyns_inst%ko_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for O2 (Pa) + qe => photosyns_inst%qe_patch , & ! Output: [real(r8) (:) ] quantum efficiency, used only for C4 (mol CO2 / mol photons) + bbb => photosyns_inst%bbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + mbb => photosyns_inst%mbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry slope of conductance-photosynthesis relationship + rh_leaf => photosyns_inst%rh_leaf_patch , & ! Output: [real(r8) (:) ] fractional humidity at leaf surface (dimensionless) + vpd_can => photosyns_inst%vpd_can_patch , & ! Output: [real(r8) (:) ] canopy vapor pressure deficit (kPa) + lnc => photosyns_inst%lnca_patch , & ! Output: [real(r8) (:) ] top leaf layer leaf N concentration (gN leaf/m^2) + light_inhibit=> photosyns_inst%light_inhibit , & ! Input: [logical ] flag if light should inhibit respiration + leafresp_method=> photosyns_inst%leafresp_method , & ! Input: [integer ] method type to use for leaf-maint.-respiration at 25C canopy top + stomatalcond_mtd=> photosyns_inst%stomatalcond_mtd , & ! Input: [integer ] method type to use for stomatal conductance + modifyphoto_and_lmr_forcrop=> photosyns_inst%modifyphoto_and_lmr_forcrop, & ! Input: [logical ] modifyphoto_and_lmr_forcrop + leaf_mr_vcm => canopystate_inst%leaf_mr_vcm , & ! Input: [real(r8) ] scalar constant of leaf respiration with Vcmax + vegwp => canopystate_inst%vegwp_patch , & ! Input/Output: [real(r8) (:,:) ] vegetation water matric potential (mm) + an_sun => photosyns_inst%an_sun_patch , & ! Output: [real(r8) (:,:) ] net sunlit leaf photosynthesis (umol CO2/m**2/s) + an_sha => photosyns_inst%an_sha_patch , & ! Output: [real(r8) (:,:) ] net shaded leaf photosynthesis (umol CO2/m**2/s) + gs_mol_sun => photosyns_inst%gs_mol_sun_patch , & ! Output: [real(r8) (:,:) ] sunlit leaf stomatal conductance (umol H2O/m**2/s) + gs_mol_sha => photosyns_inst%gs_mol_sha_patch , & ! Output: [real(r8) (:,:) ] shaded leaf stomatal conductance (umol H2O/m**2/s) + gs_mol_sun_ln => photosyns_inst%gs_mol_sun_ln_patch , & ! Output: [real(r8) (:,:) ] sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + gs_mol_sha_ln => photosyns_inst%gs_mol_sha_ln_patch & ! Output: [real(r8) (:,:) ] shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + ) + + par_z_sun => solarabs_inst%parsun_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + lai_z_sun => canopystate_inst%laisun_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + vcmaxcint_sun => surfalb_inst%vcmaxcintsun_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + alphapsn_sun => photosyns_inst%alphapsnsun_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () + o3coefv_sun => ozone_inst%o3coefvsun_patch ! Input: [real(r8) (:) ] O3 coefficient used in photosynthesis calculation + o3coefg_sun => ozone_inst%o3coefgsun_patch ! Input: [real(r8) (:) ] O3 coefficient used in rs calculation + ci_z_sun => photosyns_inst%cisun_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + rs_sun => photosyns_inst%rssun_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + rs_z_sun => photosyns_inst%rssun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + lmr_sun => photosyns_inst%lmrsun_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + lmr_z_sun => photosyns_inst%lmrsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + psn_sun => photosyns_inst%psnsun_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_z_sun => photosyns_inst%psnsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wc_sun => photosyns_inst%psnsun_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wj_sun => photosyns_inst%psnsun_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wp_sun => photosyns_inst%psnsun_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + par_z_sha => solarabs_inst%parsha_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + lai_z_sha => canopystate_inst%laisha_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + vcmaxcint_sha => surfalb_inst%vcmaxcintsha_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + alphapsn_sha => photosyns_inst%alphapsnsha_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () + o3coefv_sha => ozone_inst%o3coefvsha_patch ! Input: [real(r8) (:) ] O3 coefficient used in photosynthesis calculation + o3coefg_sha => ozone_inst%o3coefgsha_patch ! Input: [real(r8) (:) ] O3 coefficient used in rs calculation + ci_z_sha => photosyns_inst%cisha_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + rs_sha => photosyns_inst%rssha_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + rs_z_sha => photosyns_inst%rssha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + lmr_sha => photosyns_inst%lmrsha_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + lmr_z_sha => photosyns_inst%lmrsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + psn_sha => photosyns_inst%psnsha_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_z_sha => photosyns_inst%psnsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wc_sha => photosyns_inst%psnsha_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wj_sha => photosyns_inst%psnsha_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wp_sha => photosyns_inst%psnsha_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + !==============================================================================! + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + !==============================================================================! + + ! Determine seconds off current time step + + dtime = get_step_size_real() + + ! 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 + + lmrc = fth25 (params_inst%lmrhd, params_inst%lmrse) + +! calculate root-soil interface conductance + do f = 1, fn + p = filterp(f) + c = patch%column(p) + + do j = 1,nlevsoi + +! calculate conversion from conductivity to conductance + root_biomass_density = c_to_b * froot_carbon(p) * rootfr(p,j) / dz(c,j) +! ensure minimum root biomass (using 1gC/m2) + root_biomass_density = max(c_to_b*1._r8,root_biomass_density) + + ! Root length density: m root per m3 soil + root_cross_sec_area = rpi*root_radius(ivt(p))**2 + root_length_density = root_biomass_density / (root_density(ivt(p)) * root_cross_sec_area) + + ! Root-area index (RAI) + rai(j) = (tsai(p)+tlai(p)) * froot_leaf(ivt(p)) * rootfr(p,j) + +! fix coarse root_average_length to specified length + croot_average_length = croot_lateral_length + +! calculate r_soil using Gardner/spa equation (Bonan, GMD, 2014) + r_soil = sqrt(1./(rpi*root_length_density)) + + ! length scale approach + soil_conductance = min(hksat(c,j),hk_l(c,j))/(1.e3*r_soil) + +! use vegetation plc function to adjust root conductance + fs(j)= plc(smp(c,j),p,c,root,veg) + +! krmax is root conductance per area per length + root_conductance = (fs(j)*rai(j)*params_inst%krmax(ivt(p)))/(croot_average_length + z(c,j)) + + soil_conductance = max(soil_conductance, 1.e-16_r8) + root_conductance = max(root_conductance, 1.e-16_r8) + + root_conductance_patch(p,j) = root_conductance + soil_conductance_patch(p,j) = soil_conductance + +! sum resistances in soil and root + rs_resis = 1._r8/soil_conductance + 1._r8/root_conductance + +! conductance is inverse resistance +! explicitly set conductance to zero for top soil layer + if(rai(j)*rootfr(p,j) > 0._r8 .and. j > 1) then + k_soil_root(p,j) = 1._r8/rs_resis + else + !k_soil_root(p,j) = 0. + k_soil_root(p,j) = 1._r8/rs_resis + endif + + end do + enddo + + ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + + ! C3 or C4 photosynthesis logical variable + + if (nint(c3psn(patch%itype(p))) == 1) then + c3flag(p) = .true. + else if (nint(c3psn(patch%itype(p))) == 0) then + c3flag(p) = .false. + end if + + ! C3 and C4 dependent parameters + + if (c3flag(p)) then + qe(p) = 0._r8 + bbbopt(p) = 10000._r8 + else + qe(p) = 0.05_r8 + bbbopt(p) = 40000._r8 + end if + + if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + ! Soil water stress applied to Ball-Berry parameters later in ci_func_PHS + bbb(p) = bbbopt(p) + mbb(p) = mbbopt(patch%itype(p)) + end if + ! kc, ko, cp, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! + ! kc25_coef = 404.9e-6 mol/mol + ! ko25_coef = 278.4e-3 mol/mol + ! cp25_yr2000 = 42.75e-6 mol/mol + ! + ! Derive sco from cp and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! cp to account for variation in O2 using cp = 0.5 O2 / sco + ! + + kc25 = params_inst%kc25_coef * forc_pbot(c) + ko25 = params_inst%ko25_coef * forc_pbot(c) + sco = 0.5_r8 * 0.209_r8 / params_inst%cp25_yr2000 + cp25 = 0.5_r8 * oair(p) / sco + + kc(p) = kc25 * ft(t_veg(p), params_inst%kcha) + ko(p) = ko25 * ft(t_veg(p), params_inst%koha) + cp(p) = cp25 * ft(t_veg(p), params_inst%cpha) + + 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 + + do f = 1, fn + p = filterp(f) + + if (lnc_opt .eqv. .false.) then + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + lnc(p) = 1._r8 / (slatop(patch%itype(p)) * leafcn(patch%itype(p))) + end if + + ! Using the actual nitrogen allocated to the leaf after + ! uptake rather than fixing leaf nitrogen based on SLA and CN + ! ratio + if (lnc_opt .eqv. .true.) then + ! nlevcan and nrad(p) look like the same variable ?? check this later + sum_nscaler = 0.0_r8 + laican = 0.0_r8 + total_lai = 0.0_r8 + + do iv = 1, nrad(p) + + if (iv == 1) then + laican = 0.5_r8 * tlai_z(p,iv) + total_lai = tlai_z(p,iv) + else + laican = laican + 0.5_r8 * (tlai_z(p,iv-1)+tlai_z(p,iv)) + total_lai = total_lai + tlai_z(p,iv) + end if + + ! Scale for leaf nitrogen profile. If multi-layer code, use explicit + ! profile. If sun/shade big leaf code, use canopy integrated factor. + if (nlevcan == 1) then + nscaler = 1.0_r8 + else if (nlevcan > 1) then + nscaler = exp(-kn(p) * laican) + end if + + sum_nscaler = sum_nscaler + nscaler + + end do + + if (tlai(p) > 0.0_r8 .AND. sum_nscaler > 0.0_r8) then + ! dividing by LAI to convert total leaf nitrogen + ! from m2 ground to m2 leaf; dividing by sum_nscaler to + ! convert total leaf N to leaf N at canopy top + lnc(p) = leafn(p) / (tlai(p) * sum_nscaler) + else + lnc(p) = 0.0_r8 + end if + + end if + lnc(p) = min(lnc(p),10._r8) + + ! reduce_dayl_factor .eqv. .false. + if (reduce_dayl_factor .eqv. .true.) then + if (dayl_factor(p) > 0.25_r8) then + ! dayl_factor(p) = 1.0_r8 + end if + end if + + + ! Default + if (vcmax_opt == 0) then + ! vcmax25 at canopy top, as in CN but using lnc at top of the canopy + vcmax25top = lnc(p) * flnr(patch%itype(p)) * params_inst%fnr * params_inst%act25 * dayl_factor(p) + if (.not. use_cn) then + vcmax25top = vcmax25top * fnitr(patch%itype(p)) + else + if ( CNAllocate_Carbon_only() ) vcmax25top = vcmax25top * fnitr(patch%itype(p)) + end if + else if (vcmax_opt == 3) then + vcmax25top = ( i_vcad(patch%itype(p)) + s_vcad(patch%itype(p)) * lnc(p) ) * dayl_factor(p) + else if (vcmax_opt == 4) then + nptreemax = 9 ! is this number correct? check later + if (patch%itype(p) >= nptreemax) then ! if not tree + ! for shrubs and herbs + vcmax25top = lnc(p) * ( i_flnr(patch%itype(p)) + s_flnr(patch%itype(p)) * lnc(p) ) * params_inst%fnr * params_inst%act25 * & + dayl_factor(p) + else + ! if tree + vcmax25top = lnc(p) * ( i_flnr(patch%itype(p)) * exp(s_flnr(patch%itype(p)) * lnc(p)) ) * params_inst%fnr * params_inst%act25 * & + dayl_factor(p) + ! for trees + end if + end if + + ! 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. + + jmax25top = ((2.59_r8 - 0.035_r8*min(max((t10(p)-tfrz),11._r8),35._r8)) * vcmax25top) * & + params_inst%jmax25top_sf + tpu25top = params_inst%tpu25ratio * vcmax25top + kp25top = params_inst%kp25ratio * vcmax25top + luvcmax25top(p) = vcmax25top + lujmax25top(p) = jmax25top + lutpu25top(p)=tpu25top + + ! 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 + ! But not used as defined here if using sun/shade big leaf code. Instead, + ! will use canopy integrated scaling factors from SurfaceAlbedo. + + if (dayl_factor(p) .eq. 0._r8) then + kn(p) = 0._r8 + else + kn(p) = exp(0.00963_r8 * vcmax25top/dayl_factor(p) - 2.43_r8) + end if + + if (use_cn) then + if ( leafresp_method == leafresp_mtd_ryan1991 ) then + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + ! + ! Base rate for maintenance respiration is from: + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! + ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 + ! + ! 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 = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top = lmr25top * lnc(p) / 12.e-06_r8 + + else if ( leafresp_method == leafresp_mtd_atkin2015 ) then + !using new form for respiration base rate from Atkin + !communication. + if ( lnc(p) > 0.0_r8 ) then + lmr25top = params_inst%lmr_intercept_atkin(ivt(p)) + (lnc(p) * 0.2061_r8) - (0.0402_r8 * (t10(p)-tfrz)) + else + lmr25top = 0.0_r8 + end if + end if + + else + ! Leaf maintenance respiration in proportion to vcmax25top + + if (c3flag(p)) then + lmr25top = vcmax25top * leaf_mr_vcm + else + lmr25top = vcmax25top * 0.025_r8 + end if + end if + + ! Loop through canopy layers (above snow). Respiration needs to be + ! calculated every timestep. Others are calculated only if daytime + + laican = 0._r8 + do iv = 1, nrad(p) + + ! Cumulative lai at middle of layer + + if (iv == 1) then + laican = 0.5_r8 * tlai_z(p,iv) + else + laican = laican + 0.5_r8 * (tlai_z(p,iv-1)+tlai_z(p,iv)) + end if + + ! Scale for leaf nitrogen profile. If multi-layer code, use explicit + ! profile. If sun/shade big leaf code, use canopy integrated factor. + + if (nlevcan == 1) then + nscaler_sun = vcmaxcint_sun(p) + nscaler_sha = vcmaxcint_sha(p) + else if (nlevcan > 1) then + nscaler_sun = exp(-kn(p) * laican) + nscaler_sha = exp(-kn(p) * laican) + end if + + ! Maintenance respiration + + lmr25_sun = lmr25top * nscaler_sun + lmr25_sha = lmr25top * nscaler_sha + + if(use_luna.and.c3flag(p).and.crop(patch%itype(p))== 0)then + if(.not.use_cn)then ! If CN is on, use leaf N to predict respiration (above). Otherwise, use Vcmax term from LUNA. RF + lmr25_sun = leaf_mr_vcm * photosyns_inst%vcmx25_z_patch(p,iv) + lmr25_sha = leaf_mr_vcm * photosyns_inst%vcmx25_z_patch(p,iv) + endif + endif + + if (c3flag(p)) then + lmr_z_sun(p,iv) = lmr25_sun * ft(t_veg(p), params_inst%lmrha) * fth(t_veg(p), params_inst%lmrhd, & + params_inst%lmrse, lmrc) + lmr_z_sha(p,iv) = lmr25_sha * ft(t_veg(p), params_inst%lmrha) * fth(t_veg(p), params_inst%lmrhd, & + params_inst%lmrse, lmrc) + else + lmr_z_sun(p,iv) = lmr25_sun * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + lmr_z_sun(p,iv) = lmr_z_sun(p,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) + lmr_z_sha(p,iv) = lmr25_sha * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + lmr_z_sha(p,iv) = lmr_z_sha(p,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) + end if + + ! Reduce lmr w/ low lai + lmr_z_sun(p,iv) = lmr_z_sun(p,iv)*min((0.2_r8*exp(3.218_r8*tlai_z(p,iv))),1._r8) + lmr_z_sha(p,iv) = lmr_z_sha(p,iv)*min((0.2_r8*exp(3.218_r8*tlai_z(p,iv))),1._r8) + + if (par_z_sun(p,iv) <= 0._r8) then ! night time + + vcmax_z(p,sun,iv) = 0._r8 + jmax_z(p,sun,iv) = 0._r8 + tpu_z(p,sun,iv) = 0._r8 + kp_z(p,sun,iv) = 0._r8 + + vcmax_z(p,sha,iv) = 0._r8 + jmax_z(p,sha,iv) = 0._r8 + tpu_z(p,sha,iv) = 0._r8 + kp_z(p,sha,iv) = 0._r8 + + if ( use_c13 ) then + alphapsn_sun(p) = 1._r8 + alphapsn_sha(p) = 1._r8 + end if + + else ! day time + + if(use_luna.and.c3flag(p).and.crop(patch%itype(p))== 0)then + vcmax25_sun = photosyns_inst%vcmx25_z_patch(p,iv) + vcmax25_sha = photosyns_inst%vcmx25_z_patch(p,iv) + jmax25_sun = photosyns_inst%jmx25_z_patch(p,iv) + jmax25_sha = photosyns_inst%jmx25_z_patch(p,iv) + tpu25_sun = params_inst%tpu25ratio * vcmax25_sun + tpu25_sha = params_inst%tpu25ratio * vcmax25_sha + if(surfalb_inst%vcmaxcintsun_patch(p).gt.0._r8.and.nlevcan==1) then + vcmax25_sha = vcmax25_sun * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + jmax25_sha = jmax25_sun * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + tpu25_sha = tpu25_sun * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + end if + else + vcmax25_sun = vcmax25top * nscaler_sun + jmax25_sun = jmax25top * nscaler_sun + tpu25_sun = tpu25top * nscaler_sun + vcmax25_sha = vcmax25top * nscaler_sha + jmax25_sha = jmax25top * nscaler_sha + tpu25_sha = tpu25top * nscaler_sha + endif + kp25_sun = kp25top * nscaler_sun + kp25_sha = kp25top * nscaler_sha + + ! Adjust for temperature + ! Acclimation is done for Kattge + vcmaxse = (668.39_r8 - 1.07_r8 * min(max((t10(p)-tfrz),11._r8),35._r8)) * params_inst%vcmaxse_sf + jmaxse = (659.70_r8 - 0.75_r8 * min(max((t10(p)-tfrz),11._r8),35._r8)) * params_inst%jmaxse_sf + ! These values are used for Leuning + !vcmaxse = 486.0_r8 + !jmaxse = 495.0_r8 + tpuse = (668.39_r8 - 1.07_r8 * min(max((t10(p)-tfrz),11._r8),35._r8)) * params_inst%tpuse_sf + vcmaxc = fth25 (params_inst%vcmaxhd, vcmaxse) + jmaxc = fth25 (params_inst%jmaxhd, jmaxse) + tpuc = fth25 (params_inst%tpuhd, tpuse) + vcmax_z(p,sun,iv) = vcmax25_sun * ft(t_veg(p), params_inst%vcmaxha) * fth(t_veg(p), & + params_inst%vcmaxhd, vcmaxse, vcmaxc) + jmax_z(p,sun,iv) = jmax25_sun * ft(t_veg(p), params_inst%jmaxha) * fth(t_veg(p), & + params_inst%jmaxhd, jmaxse, jmaxc) + tpu_z(p,sun,iv) = tpu25_sun * ft(t_veg(p), params_inst%tpuha) * fth(t_veg(p), & + params_inst%tpuhd, tpuse, tpuc) + vcmax_z(p,sha,iv) = vcmax25_sha * ft(t_veg(p), params_inst%vcmaxha) * fth(t_veg(p), & + params_inst%vcmaxhd, vcmaxse, vcmaxc) + jmax_z(p,sha,iv) = jmax25_sha * ft(t_veg(p), params_inst%jmaxha) * fth(t_veg(p), & + params_inst%jmaxhd, jmaxse, jmaxc) + tpu_z(p,sha,iv) = tpu25_sha * ft(t_veg(p), params_inst%tpuha) * fth(t_veg(p), & + params_inst%tpuhd, tpuse, tpuc) + + if (.not. c3flag(p)) then + vcmax_z(p,sun,iv) = vcmax25_sun * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + vcmax_z(p,sun,iv) = vcmax_z(p,sun,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg(p)) )) + vcmax_z(p,sun,iv) = vcmax_z(p,sun,iv) / (1._r8 + exp( 0.3_r8*(t_veg(p)-(tfrz+40._r8)) )) + vcmax_z(p,sha,iv) = vcmax25_sha * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + vcmax_z(p,sha,iv) = vcmax_z(p,sha,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg(p)) )) + vcmax_z(p,sha,iv) = vcmax_z(p,sha,iv) / (1._r8 + exp( 0.3_r8*(t_veg(p)-(tfrz+40._r8)) )) + end if + + kp_z(p,sun,iv) = kp25_sun * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + kp_z(p,sha,iv) = kp25_sha * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + + end if + + ! Change to add in light inhibition of respiration. 0.67 from Lloyd et al. 2010, & Metcalfe et al. 2012 + ! Also pers. comm from Peter Reich (Nov 2015). Might potentially be updated pending findings of Atkin et al. (in prep) + ! review of light inhibition database. + if ( light_inhibit .and. par_z_sun(p,1) > 0._r8) then ! are the lights on? + lmr_z_sun(p,iv) = lmr_z_sun(p,iv) * 0.67_r8 ! inhibit respiration accordingly. + end if + if ( light_inhibit .and. par_z_sha(p,1) > 0._r8) then ! are the lights on? + lmr_z_sha(p,iv) = lmr_z_sha(p,iv) * 0.67_r8 ! inhibit respiration accordingly. + end if + + end do ! canopy layer loop + end do ! patch loop + + !==============================================================================! + ! Leaf-level photosynthesis and stomatal conductance + !==============================================================================! + + rsmax0 = 2.e4_r8 + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) + + ! Leaf boundary layer conductance, umol/m**2/s + + cf = forc_pbot(c)/(rgas*1.e-3_r8*tgcm(p))*1.e06_r8 + gb = 1._r8/rb(p) + gb_mol(p) = gb * cf + + ! Loop through canopy layers (above snow). Only do calculations if daytime + + do iv = 1, nrad(p) + + if (par_z_sun(p,iv) <= 0._r8) then ! night time + + !zqz temporary signal for night time + vegwp(p,sun)=1._r8 + + if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + gsminsun = bbb(p) + gsminsha = bbb(p) + else if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + gsminsun = medlynintercept(patch%itype(p)) + gsminsha = medlynintercept(patch%itype(p)) + else + gsminsun = nan + gsminsha = nan + end if + call calcstress(p,c,vegwp(p,:),bsun(p),bsha(p),gb_mol(p),gsminsun, gsminsha, & + qsatl(p),qaf(p), atm2lnd_inst,canopystate_inst,waterdiagnosticbulk_inst, & + soilstate_inst,temperature_inst, waterfluxbulk_inst) + + ac(p,sun,iv) = 0._r8 + aj(p,sun,iv) = 0._r8 + ap(p,sun,iv) = 0._r8 + ag(p,sun,iv) = 0._r8 + if(crop(patch%itype(p))== 0 .or. .not. modifyphoto_and_lmr_forcrop) then + an_sun(p,iv) = ag(p,sun,iv) - bsun(p) * lmr_z_sun(p,iv) + else + an_sun(p,iv) = ag(p,sun,iv) - lmr_z_sun(p,iv) + endif + psn_z_sun(p,iv) = 0._r8 + psn_wc_z_sun(p,iv) = 0._r8 + psn_wj_z_sun(p,iv) = 0._r8 + psn_wp_z_sun(p,iv) = 0._r8 + rs_z_sun(p,iv) = min(rsmax0, 1._r8/(max( bsun(p)*gsminsun, 1._r8 )) * cf) + ci_z_sun(p,iv) = 0._r8 + rh_leaf_sun(p) = 0._r8 + + ac(p,sha,iv) = 0._r8 + aj(p,sha,iv) = 0._r8 + ap(p,sha,iv) = 0._r8 + ag(p,sha,iv) = 0._r8 + if(crop(patch%itype(p))== 0 .or. .not. modifyphoto_and_lmr_forcrop) then + an_sha(p,iv) = ag(p,sha,iv) - bsha(p) * lmr_z_sha(p,iv) + else + an_sha(p,iv) = ag(p,sha,iv) - lmr_z_sha(p,iv) + endif + psn_z_sha(p,iv) = 0._r8 + psn_wc_z_sha(p,iv) = 0._r8 + psn_wj_z_sha(p,iv) = 0._r8 + psn_wp_z_sha(p,iv) = 0._r8 + rs_z_sha(p,iv) = min(rsmax0, 1._r8/(max( bsha(p)*gsminsha, 1._r8 )) * cf) + ci_z_sha(p,iv) = 0._r8 + rh_leaf_sha(p) = 0._r8 + + else ! day time + + !now the constraint is no longer needed, Jinyun Tang + ceair = min( eair(p), esat_tv(p) ) + if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + rh_can = ceair / esat_tv(p) + else if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + ! Put some constraints on RH in the canopy when Medlyn stomatal conductance is being used + rh_can = max((esat_tv(p) - ceair), 50._r8) * 0.001_r8 + vpd_can(p) = rh_can + end if + + ! Electron transport rate for C3 plants. Convert par from W/m2 to + ! umol photons/m**2/s using the factor 4.6 + + ! sun + qabs = 0.5_r8 * (1._r8 - params_inst%fnps) * par_z_sun(p,iv) * 4.6_r8 + aquad = params_inst%theta_psii + bquad = -(qabs + jmax_z(p,sun,iv)) + cquad = qabs * jmax_z(p,sun,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + je_sun = min(r1,r2) + + ! sha + qabs = 0.5_r8 * (1._r8 - params_inst%fnps) * par_z_sha(p,iv) * 4.6_r8 + aquad = params_inst%theta_psii + bquad = -(qabs + jmax_z(p,sha,iv)) + cquad = qabs * jmax_z(p,sha,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + je_sha = min(r1,r2) + + ! Iterative loop for ci beginning with initial guess + + if (c3flag(p)) then + ci_z_sun(p,iv) = 0.7_r8 * cair(p) + ci_z_sha(p,iv) = 0.7_r8 * cair(p) + else + ci_z_sun(p,iv) = 0.4_r8 * cair(p) + ci_z_sha(p,iv) = 0.4_r8 * cair(p) + end if + + !find ci and stomatal conductance + call hybrid_PHS(ci_z_sun(p,iv), ci_z_sha(p,iv), p, iv, c, g, gb_mol(p), bsun(p),bsha(p), je_sun, & + je_sha, cair(p), oair(p), lmr_z_sun(p,iv), lmr_z_sha(p,iv), & + par_z_sun(p,iv), par_z_sha(p,iv), rh_can, gs_mol_sun(p,iv), gs_mol_sha(p,iv), & + qsatl(p), qaf(p), iter1, iter2, atm2lnd_inst, photosyns_inst, & + canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst, waterfluxbulk_inst) + if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + gsminsun = medlynintercept(patch%itype(p)) + gsminsha = medlynintercept(patch%itype(p)) + gs_slope_sun = medlynslope(patch%itype(p)) + gs_slope_sha = medlynslope(patch%itype(p)) + else if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + gsminsun = bbb(p) + gsminsha = bbb(p) + gs_slope_sun = mbb(p) + gs_slope_sha = mbb(p) + end if + + ! End of ci iteration. Check for an < 0, in which case gs_mol = bbb + + if (an_sun(p,iv) < 0._r8) gs_mol_sun(p,iv) = max( bsun(p)*gsminsun, 1._r8 ) + if (an_sha(p,iv) < 0._r8) gs_mol_sha(p,iv) = max( bsha(p)*gsminsha, 1._r8 ) + ! Use time period 1 hour before and 1 hour after local noon inclusive (11AM-1PM) + if ( is_near_local_noon( grc%londeg(g), deltasec=3600 ) )then + gs_mol_sun_ln(p,iv) = gs_mol_sun(p,iv) + gs_mol_sha_ln(p,iv) = gs_mol_sha(p,iv) + else + gs_mol_sun_ln(p,iv) = spval + gs_mol_sha_ln(p,iv) = spval + end if + + ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) + + cs_sun = cair(p) - 1.4_r8/gb_mol(p) * an_sun(p,iv) * forc_pbot(c) + cs_sun = max(cs_sun,1.e-06_r8) + ci_z_sun(p,iv) = cair(p) - an_sun(p,iv) * forc_pbot(c) * & + (1.4_r8*gs_mol_sun(p,iv)+1.6_r8*gb_mol(p)) / & + (gb_mol(p)*gs_mol_sun(p,iv)) + + ! Trap for values of ci_z_sun less than 1.e-06. This is needed for + ! Megan (which can crash with negative values) + ci_z_sun(p,iv) = max( ci_z_sun(p,iv), 1.e-06_r8 ) + + cs_sha = cair(p) - 1.4_r8/gb_mol(p) * an_sha(p,iv) * forc_pbot(c) + cs_sha = max(cs_sha,1.e-06_r8) + ci_z_sha(p,iv) = cair(p) - an_sha(p,iv) * forc_pbot(c) * & + (1.4_r8*gs_mol_sha(p,iv)+1.6_r8*gb_mol(p)) / & + (gb_mol(p)*gs_mol_sha(p,iv)) + + ! Trap for values of ci_z_sha less than 1.e-06. This is needed for + ! Megan (which can crash with negative values) + ci_z_sha(p,iv) = max( ci_z_sha(p,iv), 1.e-06_r8 ) + + ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) + + gs = gs_mol_sun(p,iv) / cf + rs_z_sun(p,iv) = min(1._r8/gs, rsmax0) + rs_z_sun(p,iv) = rs_z_sun(p,iv) / o3coefg_sun(p) + gs = gs_mol_sha(p,iv) / cf + rs_z_sha(p,iv) = min(1._r8/gs, rsmax0) + rs_z_sha(p,iv) = rs_z_sha(p,iv) / o3coefg_sha(p) + + ! Photosynthesis. Save rate-limiting photosynthesis + + psn_z_sun(p,iv) = ag(p,sun,iv) + psn_z_sun(p,iv) = psn_z_sun(p,iv) * o3coefv_sun(p) + + psn_wc_z_sun(p,iv) = 0._r8 + psn_wj_z_sun(p,iv) = 0._r8 + psn_wp_z_sun(p,iv) = 0._r8 + + if (ac(p,sun,iv) <= aj(p,sun,iv) .and. ac(p,sun,iv) <= ap(p,sun,iv)) then + psn_wc_z_sun(p,iv) = psn_z_sun(p,iv) + else if (aj(p,sun,iv) < ac(p,sun,iv) .and. aj(p,sun,iv) <= ap(p,sun,iv)) then + psn_wj_z_sun(p,iv) = psn_z_sun(p,iv) + else if (ap(p,sun,iv) < ac(p,sun,iv) .and. ap(p,sun,iv) < aj(p,sun,iv)) then + psn_wp_z_sun(p,iv) = psn_z_sun(p,iv) + end if + + psn_z_sha(p,iv) = ag(p,sha,iv) + psn_z_sha(p,iv) = psn_z_sha(p,iv) * o3coefv_sha(p) + + psn_wc_z_sha(p,iv) = 0._r8 + psn_wj_z_sha(p,iv) = 0._r8 + psn_wp_z_sha(p,iv) = 0._r8 + + if (ac(p,sha,iv) <= aj(p,sha,iv) .and. ac(p,sha,iv) <= ap(p,sha,iv)) then + psn_wc_z_sha(p,iv) = psn_z_sha(p,iv) + else if (aj(p,sha,iv) < ac(p,sha,iv) .and. aj(p,sha,iv) <= ap(p,sha,iv)) then + psn_wj_z_sha(p,iv) = psn_z_sha(p,iv) + else if (ap(p,sha,iv) < ac(p,sha,iv) .and. ap(p,sha,iv) < aj(p,sha,iv)) then + psn_wp_z_sha(p,iv) = psn_z_sha(p,iv) + end if + + ! Make sure iterative solution is correct + + if (gs_mol_sun(p,iv) < 0._r8 .or. gs_mol_sha(p,iv) < 0._r8) then + write (iulog,*)'Negative stomatal conductance:' + write (iulog,*)'p,iv,gs_mol_sun,gs_mol_sha= ',p,iv,gs_mol_sun(p,iv),gs_mol_sha(p,iv) + call endrun(decomp_index=p, clmlevel=namep, msg=errmsg(sourcefile, __LINE__)) + end if + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b + + hs = (gb_mol(p)*ceair + gs_mol_sun(p,iv)*esat_tv(p)) / ((gb_mol(p)+gs_mol_sun(p,iv))*esat_tv(p)) + rh_leaf_sun(p) = hs + gs_mol_err = gs_slope_sun*max(an_sun(p,iv), 0._r8)*hs/cs_sun*forc_pbot(c) + max( bsun(p)*gsminsun, 1._r8 ) + + if (abs(gs_mol_sun(p,iv)-gs_mol_err) > 1.e-01_r8 .and. (stomatalcond_mtd == stomatalcond_mtd_bb1987) ) then + write (iulog,*) 'Ball-Berry error check - sunlit stomatal conductance error:' + write (iulog,*) gs_mol_sun(p,iv), gs_mol_err + end if + + hs = (gb_mol(p)*ceair + gs_mol_sha(p,iv)*esat_tv(p)) / ((gb_mol(p)+gs_mol_sha(p,iv))*esat_tv(p)) + rh_leaf_sha(p) = hs + gs_mol_err = gs_slope_sha*max(an_sha(p,iv), 0._r8)*hs/cs_sha*forc_pbot(c) + max( bsha(p)*gsminsha, 1._r8) + + if (abs(gs_mol_sha(p,iv)-gs_mol_err) > 1.e-01_r8 .and. (stomatalcond_mtd == stomatalcond_mtd_bb1987) ) then + write (iulog,*) 'Ball-Berry error check - shaded stomatal conductance error:' + write (iulog,*) gs_mol_sha(p,iv), gs_mol_err + end if + + end if ! night or day if branch + end do ! canopy layer loop + end do ! patch loop + + !==============================================================================! + ! Canopy photosynthesis and stomatal conductance + !==============================================================================! + + ! Sum canopy layer fluxes and then derive effective leaf-level fluxes (per + ! unit leaf area), which are used in other parts of the model. Here, laican + ! sums to either laisun or laisha. + + do f = 1, fn + p = filterp(f) + + psncan_sun = 0._r8 + psncan_wc_sun = 0._r8 + psncan_wj_sun = 0._r8 + psncan_wp_sun = 0._r8 + lmrcan_sun = 0._r8 + gscan_sun = 0._r8 + laican_sun = 0._r8 + do iv = 1, nrad(p) + psncan_sun = psncan_sun + psn_z_sun(p,iv) * lai_z_sun(p,iv) + psncan_wc_sun = psncan_wc_sun + psn_wc_z_sun(p,iv) * lai_z_sun(p,iv) + psncan_wj_sun = psncan_wj_sun + psn_wj_z_sun(p,iv) * lai_z_sun(p,iv) + psncan_wp_sun = psncan_wp_sun + psn_wp_z_sun(p,iv) * lai_z_sun(p,iv) + if(crop(patch%itype(p))== 0 .and. modifyphoto_and_lmr_forcrop) then + lmrcan_sun = lmrcan_sun + lmr_z_sun(p,iv) * lai_z_sun(p,iv) * bsun(p) + else + lmrcan_sun = lmrcan_sun + lmr_z_sun(p,iv) * lai_z_sun(p,iv) + endif + gscan_sun = gscan_sun + lai_z_sun(p,iv) / (rb(p)+rs_z_sun(p,iv)) + laican_sun = laican_sun + lai_z_sun(p,iv) + end do + if (laican_sun > 0._r8) then + psn_sun(p) = psncan_sun / laican_sun + psn_wc_sun(p) = psncan_wc_sun / laican_sun + psn_wj_sun(p) = psncan_wj_sun / laican_sun + psn_wp_sun(p) = psncan_wp_sun / laican_sun + lmr_sun(p) = lmrcan_sun / laican_sun + rs_sun(p) = laican_sun / gscan_sun - rb(p) + else + psn_sun(p) = 0._r8 + psn_wc_sun(p) = 0._r8 + psn_wj_sun(p) = 0._r8 + psn_wp_sun(p) = 0._r8 + lmr_sun(p) = 0._r8 + rs_sun(p) = 0._r8 + end if + psncan_sha = 0._r8 + psncan_wc_sha = 0._r8 + psncan_wj_sha = 0._r8 + psncan_wp_sha = 0._r8 + lmrcan_sha = 0._r8 + gscan_sha = 0._r8 + laican_sha = 0._r8 + do iv = 1, nrad(p) + psncan_sha = psncan_sha + psn_z_sha(p,iv) * lai_z_sha(p,iv) + psncan_wc_sha = psncan_wc_sha + psn_wc_z_sha(p,iv) * lai_z_sha(p,iv) + psncan_wj_sha = psncan_wj_sha + psn_wj_z_sha(p,iv) * lai_z_sha(p,iv) + psncan_wp_sha = psncan_wp_sha + psn_wp_z_sha(p,iv) * lai_z_sha(p,iv) + if(crop(patch%itype(p))== 0 .and. modifyphoto_and_lmr_forcrop) then + lmrcan_sha = lmrcan_sha + lmr_z_sha(p,iv) * lai_z_sha(p,iv) * bsha(p) + else + lmrcan_sha = lmrcan_sha + lmr_z_sha(p,iv) * lai_z_sha(p,iv) + endif + gscan_sha = gscan_sha + lai_z_sha(p,iv) / (rb(p)+rs_z_sha(p,iv)) + laican_sha = laican_sha + lai_z_sha(p,iv) + end do + if (laican_sha > 0._r8) then + psn_sha(p) = psncan_sha / laican_sha + psn_wc_sha(p) = psncan_wc_sha / laican_sha + psn_wj_sha(p) = psncan_wj_sha / laican_sha + psn_wp_sha(p) = psncan_wp_sha / laican_sha + lmr_sha(p) = lmrcan_sha / laican_sha + rs_sha(p) = laican_sha / gscan_sha - rb(p) + else + psn_sha(p) = 0._r8 + psn_wc_sha(p) = 0._r8 + psn_wj_sha(p) = 0._r8 + psn_wp_sha(p) = 0._r8 + lmr_sha(p) = 0._r8 + rs_sha(p) = 0._r8 + end if + + if ( laican_sha+laican_sun > 0._r8 ) then + btran(p) = bsun(p) * (laican_sun / (laican_sun + laican_sha)) + & + bsha(p) * (laican_sha / (laican_sun + laican_sha)) + else + ! In this case, bsun and bsha should have the same value and btran + ! can be set to either bsun or bsha. + btran(p) = bsun(p) + end if + + end do + + end associate + + end subroutine PhotosynthesisHydraulicStress + !------------------------------------------------------------------------------ + + !-------------------------------------------------------------------------------- + subroutine hybrid_PHS(x0sun, x0sha, p, iv, c, g, gb_mol, bsun, bsha, jesun, jesha, & + cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + gs_mol_sun, gs_mol_sha, qsatl, qaf, iter1, iter2, atm2lnd_inst, photosyns_inst, & + canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst, waterfluxbulk_inst) + ! + !! DESCRIPTION: + !use a hybrid solver to find the root of the ci_func equation for sunlit and shaded leaves + ! f(x) = x- h(x) + !we want to find x, s.t. f(x) = 0. + !outside loop iterates for bsun/bsha, which are functions of stomatal conductance + !the hybrid approach combines the strength of the newton secant approach (find the solution domain) + !and the bisection approach implemented with the Brent's method to guarantee convergence. + ! + !! REVISION HISTORY: + ! + ! + !!USES: + use clm_time_manager , only : is_near_local_noon + ! + !! ARGUMENTS: + implicit none + real(r8), intent(inout) :: x0sun,x0sha ! initial guess and final value of the solution for cisun/cisha + integer , intent(in) :: p ! pft index + integer , intent(in) :: iv ! radiation canopy layer index + integer , intent(in) :: c ! column index + integer , intent(in) :: g ! gridcell index + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(out) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8), intent(out) :: bsha ! shaded canopy transpiration wetness factor (0 to 1) + real(r8), intent(in) :: jesun ! sunlit leaf electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: jesha ! shaded leaf electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8), intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8), intent(in) :: lmr_z_sun ! sunlit canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: lmr_z_sha ! shaded canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: par_z_sun ! par absorbed per unit lai for sunlit canopy layer (w/m**2) + real(r8), intent(in) :: par_z_sha ! par absorbed per unit lai for shaded canopy layer (w/m**2) + real(r8), intent(in) :: rh_can ! canopy air relative humidity + real(r8), intent(out) :: gs_mol_sun ! sunlit leaf stomatal conductance (umol H2O/m**2/s) + real(r8), intent(out) :: gs_mol_sha ! shaded leaf stomatal conductance (umol H2O/m**2/s) + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + integer, intent(out) :: iter1 ! number of iterations used to find appropriate bsun/bsha + integer, intent(out) :: iter2 ! number of iterations used to find cisun/cisha + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(inout) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + ! + !! LOCAL VARIABLES + real(r8) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8) :: gs0sun ! unstressed sunlit stomatal conductance + real(r8) :: gs0sha ! unstressed shaded stomatal conductance + logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs + real(r8) :: soilflux ! total soil column transpiration [mm/s] + real(r8) :: x1sun ! second guess for cisun + real(r8) :: f0sun ! error of cifunc(x0sun) + real(r8) :: f1sun ! error of cifunc(x1sun) + real(r8) :: xsun ! open variable for brent to return cisun solution + real(r8) :: dxsun ! delta cisun from iter_i to iter_i+1 + real(r8) :: x1sha ! second guess for cisha + real(r8) :: f0sha ! error of cifunc(x0sha) + real(r8) :: f1sha ! error of cifunc(x1sha) + real(r8) :: xsha ! open variable for brent to return cisha solution + real(r8) :: dxsha ! delta cisha from iter_i to iter_i+1 + real(r8) :: b0sun ! bsun from previous iter + real(r8) :: b0sha ! bsha from previous iter + real(r8) :: dbsun ! delta(bsun) from iter_i to iter_i+1 + real(r8) :: dbsha ! delta(bsun) from iter_i to iter_i+1 + logical :: bflag ! signals to call calcstress to recalc bsun/bsha (or not) + real(r8) :: tolsun ! error tolerance for cisun solution [Pa] + real(r8) :: tolsha ! error tolerance for cisun solution [Pa] + real(r8) :: minf ! storage spot for best cisun/cisha solution + real(r8) :: minxsun ! cisun associated with minf + real(r8) :: minxsha ! cisha associated with minf + real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution + real(r8), parameter :: eps = 1.e-2_r8 ! relative accuracy + real(r8), parameter :: eps1= 1.e-4_r8 ! absolute accuracy threshold for fsun/fsha + integer , parameter :: itmax = 3 ! maximum number of iterations zqz (increase later) + !------------------------------------------------------------------------------ + + associate( & + qflx_tran_veg => waterfluxbulk_inst%qflx_tran_veg_patch , & ! Input: [real(r8) (:) ] vegetation transpiration (mm H2O/s) (+ = to atm) + vegwp => canopystate_inst%vegwp_patch ,& ! Input/Output: [real(r8) (:,:) ] vegetation water matric potential (mm) + vegwp_ln => canopystate_inst%vegwp_ln_patch & ! Output: [real(r8) (:,:) ] vegetation water matric potential (mm) at local noon + ) + + + x1sun = x0sun + x1sha = x0sha + bflag = .false. + b0sun = -1._r8 + b0sha = -1._r8 + gs0sun = 0._r8 ! Initialize to zero as good form, not used on first itteration below because of bflag + gs0sha = 0._r8 ! Initialize to zero as good form, not used on first itteration below because of bflag + bsun = 1._r8 + bsha = 1._r8 + iter1 = 0 + + do !outer loop updates bsun/bsha and makes two ci_func calls for interpolation + x=vegwp(p,:) + iter1=iter1+1 + iter2=0 + x0sun=max(0.1_r8,x1sun) !need to make sure x0 .neq. x1 + x1sun=0.99_r8*x1sun + x0sha=max(0.1_r8,x1sha) + x1sha=0.99_r8*x1sha + tolsun = abs(x1sun) * eps + tolsha = abs(x1sha) * eps + + ! this ci_func_PHS call updates bsun/bsha (except on first iter) + call ci_func_PHS(x,x0sun, x0sha, f0sun, f0sha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + ! update bsun/bsha convergence vars + dbsun=b0sun-bsun + dbsha=b0sha-bsha + b0sun=bsun + b0sha=bsha + bflag=.false. + + ! this ci_func_PHS call creates second point for ci interpolation + call ci_func_PHS(x,x1sun, x1sha, f1sun, f1sha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + do !inner loop finds ci + if ( (abs(f0sun) < eps1) .and. (abs(f0sha) < eps1) ) then + x1sun=x0sun + x1sha=x0sha + exit + endif + if ( (abs(f1sun) < eps1) .and. (abs(f1sha) < eps1) ) then + exit + endif + iter2=iter2+1 + + if ( (f1sun - f0sun) == 0._r8) then + !makes next x1sun the midpt between current x1 & x0 + dxsun = 0.5_r8*(x1sun+x0sun)-x1sun + else + dxsun=-f1sun*(x1sun-x0sun)/(f1sun-f0sun) + end if + if ( (f1sha - f0sha) == 0._r8) then + dxsha = 0.5_r8*(x1sha+x0sha)-x1sha + else + dxsha=-f1sha*(x1sha-x0sha)/(f1sha-f0sha) + end if + x0sun=x1sun + x1sun=x1sun+dxsun + x0sha=x1sha + x1sha=x1sha+dxsha + + call ci_func_PHS(x,x1sun, x1sha, f1sun, f1sha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + if ( (abs(dxsun) < tolsun ) .and. (abs(dxsha) itmax) then + x1sun=minxsun + x1sha=minxsha + call ci_func_PHS(x,x1sun, x1sha, f1sun, f1sha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + exit + endif + + enddo + + !update unstressed stomatal conductance + if (bsun>0.01_r8) then + gs0sun=gs_mol_sun/bsun + endif + if (bsha>0.01_r8) then + gs0sha=gs_mol_sha/bsha + endif + + bflag=.true. + + if ( (abs(dbsun) < toldb) .and. (abs(dbsha) < toldb) ) then + exit + endif + + if (iter1 > itmax) then + exit + endif + + enddo + x0sun=x1sun + x0sha=x1sha + + !set vegwp for the final gs_mol solution + call getvegwp(p, c, x, gb_mol, gs_mol_sun, gs_mol_sha, qsatl, qaf, soilflux, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst) + vegwp(p,:)=x + + !write out local noon vwp (within +/- 1hr) + if ( is_near_local_noon( grc%londeg(g), deltasec=3600 ) )then + vegwp_ln(p,:) = vegwp(p,:) + else + vegwp_ln(p,:) = spval + end if + + if (soilflux<0._r8) soilflux = 0._r8 + qflx_tran_veg(p) = soilflux + + end associate + + end subroutine hybrid_PHS + !-------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------ + subroutine brent_PHS(xsun, x1sun, x2sun, f1sun, f2sun, xsha, x1sha, x2sha, f1sha, f2sha, & + tol, ip, iv, ic, gb_mol, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha,& + rh_can, gs_mol_sun, gs_mol_sha, bsun, bsha, qsatl, qaf, atm2lnd_inst, photosyns_inst, & + canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst, waterfluxbulk_inst) + !------------------------------------------------------------------------------ + implicit none + ! + !!DESCRIPTION: + !Use Brent's method to find the root of a single variable function ci_func, which is known to exist between x1 and x2. + !The found root will be updated until its accuracy is tol. Performed for cisun and cisha. + ! + !!REVISION HISTORY: + ! + !!ARGUMENTS: + real(r8), intent(out) :: xsun ! independent variable of the single value function ci_func(x) + real(r8), intent(in) :: x1sun, x2sun ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(in) :: f1sun, f2sun ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(out) :: xsha ! independent variable of the single value function ci_func(x) + real(r8), intent(in) :: x1sha, x2sha ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(in) :: f1sha, f2sha ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(in) :: tol ! the error tolerance + integer , intent(in) :: ip, iv, ic ! pft, c3/c4, and column index + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: jesun,jesha ! electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8), intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8), intent(in) :: lmr_z_sun, lmr_z_sha ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: par_z_sun, par_z_sha ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8), intent(in) :: rh_can ! inside canopy relative humidity + real(r8), intent(out) :: gs_mol_sun ! sunlit leaf stomatal conductance (umol H2O/m**2/s) + real(r8), intent(out) :: gs_mol_sha ! shaded leaf stomatal conductance (umol H2O/m**2/s) + real(r8), intent(inout) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8), intent(inout) :: bsha ! shaded canopy transpiration wetness factor (0 to 1) + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(inout) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + !------------------------------------------------------------------------------ + ! !LOCAL VARIABLES: + real(r8) :: gs0sun ! sunlit leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs0sha ! shaded leaf stomatal conductance (umol H2O/m**2/s) + integer :: phase ! sun==1, sha==2 + integer , parameter :: nphs = 2 ! number of phases for sun/shade + integer , parameter :: itmax = 20 ! maximum number of iterations + real(r8), parameter :: eps = 1.e-4_r8 ! relative error tolerance + integer :: iter ! + real(r8) :: a(nphs),b(nphs),c(nphs),d(nphs),e(nphs),fa(nphs),fb(nphs),fc(nphs) + real(r8) :: p(nphs),q(nphs),r(nphs),s(nphs),tol1(nphs),xm(nphs) + real(r8) :: x(nvegwcs) !dummy variable passed to cifunc + logical , parameter :: bflag = .false. !indicates the cifunc should not call calcstress + !------------------------------------------------------------------------------ + + a(:)=(/x1sun,x1sha/) + b(:)=(/x2sun,x2sha/) + fa(:)=(/f1sun,f1sha/) + fb(:)=(/f2sun,f2sha/) + + do phase=1, nphs + if ( (fa(phase) > 0._r8 .and. fb(phase) > 0._r8) .or. (fa(phase) < 0._r8 .and. fb(phase) < 0._r8) ) then + write(iulog,*) 'root must be bracketed for brent' + call endrun(msg=errmsg(sourcefile, __LINE__)) + endif + enddo + + c=b + fc=fb + iter = 0 + do + if( iter == itmax ) exit + iter=iter+1 + + do phase=1, nphs + if( (fb(phase) > 0._r8 .and. fc(phase) > 0._r8) .or. (fb(phase) < 0._r8 .and. fc(phase) < 0._r8)) then + c(phase)=a(phase) !Rename a, b, c and adjust bounding interval d. + fc(phase)=fa(phase) + d(phase)=b(phase)-a(phase) + e(phase)=d(phase) + endif + if( abs(fc(phase)) < abs(fb(phase)) ) then + a(phase)=b(phase) + b(phase)=c(phase) + c(phase)=a(phase) + fa(phase)=fb(phase) + fb(phase)=fc(phase) + fc(phase)=fa(phase) + endif + enddo + tol1=2._r8*eps*abs(b)+0.5_r8*tol !Convergence check. + xm=0.5_r8*(c-b) + + if( abs(xm(sun)) <= tol1(sun) .or. fb(sun) == 0._r8 ) then + if( abs(xm(sha)) <= tol1(sha) .or. fb(sha) == 0._r8 ) then + xsun=b(sun) + xsha=b(sha) + return + endif + endif + + do phase=1, nphs + if( abs(e(phase)) >= tol1(phase) .and. abs(fa(phase)) > abs(fb(phase)) ) then + s(phase)=fb(phase)/fa(phase) !Attempt inverse quadratic interpolation. + if(a(phase) == c(phase)) then + p(phase)=2._r8*xm(phase)*s(phase) + q(phase)=1._r8-s(phase) + else + q(phase)=fa(phase)/fc(phase) + r(phase)=fb(phase)/fc(phase) + p(phase)=s(phase)*(2._r8*xm(phase)*q(phase)*(q(phase)-r(phase))-(b(phase)-a(phase))*(r(phase)-1._r8)) + q(phase)=(q(phase)-1._r8)*(r(phase)-1._r8)*(s(phase)-1._r8) + endif + if( p(phase) > 0._r8 ) q(phase)=-q(phase) !Check whether in bounds. + p(phase)=abs(p(phase)) + if( 2._r8*p(phase) < min(3._r8*xm(phase)*q(phase)-abs(tol1(phase)*q(phase)),abs(e(phase)*q(phase))) ) then + e(phase)=d(phase) !Accept interpolation. + d(phase)=p(phase)/q(phase) + else + d(phase)=xm(phase) !Interpolation failed, use bisection. + e(phase)=d(phase) + endif + else !Bounds decreasing too slowly, use bisection. + d(phase)=xm(phase) + e(phase)=d(phase) + endif + a(phase)=b(phase) !Move last best guess to a. + fa(phase)=fb(phase) + if( abs(d(phase)) > tol1(phase) ) then !Evaluate new trial root. + b(phase)=b(phase)+d(phase) + else + b(phase)=b(phase)+sign(tol1(phase),xm(phase)) + endif + enddo + + gs0sun = gs_mol_sun + gs0sha = gs_mol_sha + call ci_func_PHS(x,b(sun), b(sha), fb(sun), fb(sha), ip, iv, ic, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha, & + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + if( (fb(sun) == 0._r8) .and. (fb(sha) == 0._r8) ) exit + enddo + if( iter == itmax) write(iulog,*) 'brent exceeding maximum iterations', b, fb + xsun=b(sun) + xsha=b(sha) + + return + + end subroutine brent_PHS + !-------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------ + subroutine ci_func_PHS(x,cisun, cisha, fvalsun, fvalsha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + !------------------------------------------------------------------------------ + ! + ! !DESCRIPTION: + ! evaluate the function + ! f(ci)=ci - (ca - (1.37rb+1.65rs))*patm*an for sunlit and shaded leaves + ! + ! !REVISION HISTORY: + ! + ! + ! !USES: + use clm_varpar , only : nlevsoi + implicit none + ! + ! !ARGUMENTS: + real(r8) , intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8) , intent(in) :: cisun,cisha ! intracellular leaf CO2 (Pa) + real(r8) , intent(out) :: fvalsun,fvalsha ! return function of the value f(ci) + integer , intent(in) :: p,c,iv ! pft, column, and radiation indexes + real(r8) , intent(inout) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(inout) :: bsha ! shaded canopy transpiration wetness factor (0 to 1) + logical , intent(in) :: bflag ! signals to call calcstress to recalc bsun/bsha (or not) + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gs0sun,gs0sha ! local gs_mol copies + real(r8) , intent(inout) :: gs_mol_sun,gs_mol_sha !leaf stomatal conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: jesun, jesha ! electron transport rate (umol electrons/m**2/s) + real(r8) , intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8) , intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8) , intent(in) :: lmr_z_sun, lmr_z_sha ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8) , intent(in) :: par_z_sun, par_z_sha ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8) , intent(in) :: rh_can ! canopy air relative humidity + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + + ! !LOCAL VARIABLES: + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: cs_sun,cs_sha ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: aquad, bquad, cquad ! terms for quadratic equations + real(r8) :: r1, r2 ! roots of quadratic equation + real(r8) :: term ! intermediate in Medlyn stomatal model + ! + !------------------------------------------------------------------------------ + + associate( & + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + c3flag => photosyns_inst%c3flag_patch , & ! Input: [logical (:) ] true if C3 and false if C4 + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + medlynslope=> pftcon%medlynslope , & ! Input: [real(r8) (:) ] Slope for Medlyn stomatal conductance model method + medlynintercept=> pftcon%medlynintercept , & ! Input: [real(r8) (:) ] Intercept for Medlyn stomatal conductance model method + stomatalcond_mtd=> photosyns_inst%stomatalcond_mtd , & ! Input: [integer ] method type to use for stomatal conductance.GC.fnlprmsn15_r22845 + ac => photosyns_inst%ac_phs_patch , & ! Output: [real(r8) (:,:,:) ] Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + aj => photosyns_inst%aj_phs_patch , & ! Output: [real(r8) (:,:,:) ] RuBP-limited gross photosynthesis (umol CO2/m**2/s) + ap => photosyns_inst%ap_phs_patch , & ! Output: [real(r8) (:,:,:) ] product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + ag => photosyns_inst%ag_phs_patch , & ! Output: [real(r8) (:,:,:) ] co-limited gross leaf photosynthesis (umol CO2/m**2/s) + vcmax_z => photosyns_inst%vcmax_z_phs_patch , & ! Input: [real(r8) (:,:,:) ] maximum rate of carboxylation (umol co2/m**2/s) + cp => photosyns_inst%cp_patch , & ! Output: [real(r8) (:) ] CO2 compensation point (Pa) + kc => photosyns_inst%kc_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for CO2 (Pa) + ko => photosyns_inst%ko_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for O2 (Pa) + qe => photosyns_inst%qe_patch , & ! Output: [real(r8) (:) ] quantum efficiency, used only for C4 (mol CO2 / mol photons) + tpu_z => photosyns_inst%tpu_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] triose phosphate utilization rate (umol CO2/m**2/s) + kp_z => photosyns_inst%kp_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] initial slope of CO2 response curve (C4 plants) + bbb => photosyns_inst%bbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + mbb => photosyns_inst%mbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry slope of conductance-photosynthesis relationship + an_sun => photosyns_inst%an_sun_patch , & ! Output: [real(r8) (:,:) ] net sunlit leaf photosynthesis (umol CO2/m**2/s) + an_sha => photosyns_inst%an_sha_patch & ! Output: [real(r8) (:,:) ] net shaded leaf photosynthesis (umol CO2/m**2/s) + ) + + !------------------------------------------------------------------------------ + + if (bflag) then !zqz what if bsun==0 ... doesn't break... but follow up + + call calcstress(p,c,x,bsun,bsha,gb_mol,gs0sun,gs0sha,qsatl,qaf, & + atm2lnd_inst,canopystate_inst,waterdiagnosticbulk_inst,soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + endif + + if (c3flag(p)) then + ! C3: Rubisco-limited photosynthesis + ac(p,sun,iv) = bsun * vcmax_z(p,sun,iv) * max(cisun-cp(p), 0._r8) / (cisun+kc(p)*(1._r8+oair/ko(p))) + ac(p,sha,iv) = bsha * vcmax_z(p,sha,iv) * max(cisha-cp(p), 0._r8) / (cisha+kc(p)*(1._r8+oair/ko(p))) + + ! C3: RuBP-limited photosynthesis + aj(p,sun,iv) = jesun * max(cisun-cp(p), 0._r8) / (4._r8*cisun+8._r8*cp(p)) + aj(p,sha,iv) = jesha * max(cisha-cp(p), 0._r8) / (4._r8*cisha+8._r8*cp(p)) + + ! C3: Product-limited photosynthesis + ap(p,sun,iv) = 3._r8 * tpu_z(p,sun,iv) + ap(p,sha,iv) = 3._r8 * tpu_z(p,sha,iv) + + else + ! C4: Rubisco-limited photosynthesis + ac(p,sun,iv) = bsun * vcmax_z(p,sun,iv) + ac(p,sha,iv) = bsha * vcmax_z(p,sha,iv) + + ! C4: RuBP-limited photosynthesis + aj(p,sun,iv) = qe(p) * par_z_sun * 4.6_r8 + aj(p,sha,iv) = qe(p) * par_z_sha * 4.6_r8 + + ! C4: PEP carboxylase-limited (CO2-limited) + ap(p,sun,iv) = kp_z(p,sun,iv) * max(cisun, 0._r8) / forc_pbot(c) + ap(p,sha,iv) = kp_z(p,sha,iv) * max(cisha, 0._r8) / forc_pbot(c) + + end if + + ! Gross photosynthesis. First co-limit ac and aj. Then co-limit ap + + ! Sunlit + aquad = params_inst%theta_cj(ivt(p)) + bquad = -(ac(p,sun,iv) + aj(p,sun,iv)) + cquad = ac(p,sun,iv) * aj(p,sun,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = params_inst%theta_ip + bquad = -(ai + ap(p,sun,iv)) + cquad = ai * ap(p,sun,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ag(p,sun,iv) = max(0._r8,min(r1,r2)) + + ! Shaded + aquad = params_inst%theta_cj(ivt(p)) + bquad = -(ac(p,sha,iv) + aj(p,sha,iv)) + cquad = ac(p,sha,iv) * aj(p,sha,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = params_inst%theta_ip + bquad = -(ai + ap(p,sha,iv)) + cquad = ai * ap(p,sha,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ag(p,sha,iv) = max(0._r8,min(r1,r2)) + + ! Net photosynthesis. Exit iteration if an < 0 + an_sun(p,iv) = ag(p,sun,iv) - bsun * lmr_z_sun + an_sha(p,iv) = ag(p,sha,iv) - bsha * lmr_z_sha + + if (an_sun(p,iv) < 0._r8) then + if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + gs_mol_sun = medlynintercept(patch%itype(p)) + else if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + gs_mol_sun = bbb(p) + else + gs_mol_sun = nan + end if + gs_mol_sun = max( bsun*gs_mol_sun, 1._r8) + fvalsun = 0._r8 ! really tho? zqz + endif + if (an_sha(p,iv) < 0._r8) then + if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + gs_mol_sha = medlynintercept(patch%itype(p)) + else if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + gs_mol_sha = bbb(p) + else + gs_mol_sha = nan + end if + gs_mol_sha = max( bsha*gs_mol_sha, 1._r8) + fvalsha = 0._r8 + endif + if ((an_sun(p,iv) < 0._r8) .AND. (an_sha(p,iv) < 0._r8)) then + return + endif + + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = bbb + + ! Sunlit + if (an_sun(p,iv) >= 0._r8) then + cs_sun = cair - 1.4_r8/gb_mol * an_sun(p,iv) * forc_pbot(c) + cs_sun = max(cs_sun,10.e-06_r8) + end if + + if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + if (an_sun(p,iv) >= 0._r8) then + term = 1.6_r8 * an_sun(p,iv) / (cs_sun / forc_pbot(c) * 1.e06_r8) + aquad = 1.0_r8 + bquad = -(2.0 * (medlynintercept(patch%itype(p))*1.e-06_r8 + term) + (medlynslope(patch%itype(p)) * term)**2 / & + (gb_mol*1.e-06_r8 * rh_can)) + cquad = medlynintercept(patch%itype(p))*medlynintercept(patch%itype(p))*1.e-12_r8 + & + (2.0*medlynintercept(patch%itype(p))*1.e-06_r8 + term * & + (1.0 - medlynslope(patch%itype(p))* medlynslope(patch%itype(p)) / rh_can)) * term + + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol_sun = max(r1,r2) * 1.e06_r8 + end if + + ! Shaded + if (an_sha(p,iv) >= 0._r8) then + cs_sha = cair - 1.4_r8/gb_mol * an_sha(p,iv) * forc_pbot(c) + cs_sha = max(cs_sha,10.e-06_r8) + + term = 1.6_r8 * an_sha(p,iv) / (cs_sha / forc_pbot(c) * 1.e06_r8) + aquad = 1.0_r8 + bquad = -(2.0 * (medlynintercept(patch%itype(p))*1.e-06_r8 + term) + (medlynslope(patch%itype(p)) * term)**2 / & + (gb_mol*1.e-06_r8 * rh_can)) + cquad = medlynintercept(patch%itype(p))*medlynintercept(patch%itype(p))*1.e-12_r8 + & + (2.0*medlynintercept(patch%itype(p))*1.e-06_r8 + term * (1.0 - medlynslope(patch%itype(p))* & + medlynslope(patch%itype(p)) / rh_can)) * term + + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol_sha = max(r1,r2)* 1.e06_r8 + end if + else if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + if (an_sun(p,iv) >= 0._r8) then + aquad = cs_sun + bquad = cs_sun*(gb_mol - max(bsun*bbb(p),1._r8)) - mbb(p)*an_sun(p,iv)*forc_pbot(c) + cquad = -gb_mol*(cs_sun*max(bsun*bbb(p),1._r8) + mbb(p)*an_sun(p,iv)*forc_pbot(c)*rh_can) + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol_sun = max(r1,r2) + end if + + ! Shaded + if (an_sha(p,iv) >= 0._r8) then + cs_sha = cair - 1.4_r8/gb_mol * an_sha(p,iv) * forc_pbot(c) + cs_sha = max(cs_sha,10.e-06_r8) + + aquad = cs_sha + bquad = cs_sha*(gb_mol - max(bsha*bbb(p),1._r8)) - mbb(p)*an_sha(p,iv)*forc_pbot(c) + cquad = -gb_mol*(cs_sha*max(bsha*bbb(p),1._r8) + mbb(p)*an_sha(p,iv)*forc_pbot(c)*rh_can) + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol_sha = max(r1,r2) + end if + end if + + ! Derive new estimate for cisun,cisha + if (an_sun(p,iv) >= 0._r8) then + if (gs_mol_sun > 0._r8) then + fvalsun =cisun - cair + an_sun(p,iv) * forc_pbot(c) * (1.4_r8*gs_mol_sun+1.6_r8*gb_mol) / (gb_mol*gs_mol_sun) + else + fvalsun =cisun - cair + endif + endif + if (an_sha(p,iv) >= 0._r8) then + if (gs_mol_sha > 0._r8) then + fvalsha =cisha - cair + an_sha(p,iv) * forc_pbot(c) * (1.4_r8*gs_mol_sha+1.6_r8*gb_mol) / (gb_mol*gs_mol_sha) + else + fvalsha =cisha - cair + endif + endif + end associate + end subroutine ci_func_PHS + !-------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------ + subroutine calcstress(p,c,x,bsun,bsha,gb_mol,gs_mol_sun,gs_mol_sha,qsatl,qaf, & + atm2lnd_inst,canopystate_inst,waterdiagnosticbulk_inst,soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + ! + ! DESCRIPTIONS + ! compute the transpiration stress using a plant hydraulics approach + ! calls spacF, spacA, and getvegwp + ! + ! USES + use clm_varpar , only : nlevsoi + use clm_varcon , only : rgas + use clm_time_manager , only : get_local_time + !! + ! !ARGUMENTS: + integer , intent(in) :: p ! pft index + integer , intent(in) :: c ! column index + real(r8) , intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8) , intent(out) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(out) :: bsha ! shaded sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gs_mol_sun ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gs_mol_sha ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=A*f + real(r8) :: f(nvegwcs) ! flux divergence (mm/s) + real(r8) :: dx(nvegwcs) ! change in vegwp from one iter to the next [mm] + real(r8) :: efpot ! potential latent energy flux [kg/m2/s] + real(r8) :: rppdry_sun ! fraction of potential evaporation through transp - sunlit [-] + real(r8) :: rppdry_sha ! fraction of potential evaporation through transp - shaded [-] + real(r8) :: qflx_sun ! [kg/m2/s] + real(r8) :: qflx_sha ! [kg/m2/s] + real(r8) :: gs0sun,gs0sha ! local gs_mol copies + real(r8) :: qsun,qsha ! attenuated transpiration fluxes + integer :: j ! index + integer :: g ! gridcell index + real(r8) :: cf ! s m**2/umol -> s/m + integer :: iter ! newton's method iteration number + logical :: flag ! signal that matrix was not invertible + logical :: night ! signal to store vegwp within this routine, b/c it is night-time and full suite won't be called + integer, parameter :: itmax=50 ! exit newton's method if iters>itmax + real(r8), parameter :: tolf=1.e-6,toldx=1.e-9 !tolerances for a satisfactory solution + logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs + real(r8) :: soilflux ! total soil column transpiration [mm/s] + real(r8), parameter :: tol_lai=.001_r8 ! minimum lai where transpiration is calc'd + !------------------------------------------------------------------------------ + + associate( & + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + fdry => waterdiagnosticbulk_inst%fdry_patch , & ! Input: [real(r8) (:) ] fraction of foliage that is green and dry [-] + forc_rho => atm2lnd_inst%forc_rho_downscaled_col , & ! Input: [real(r8) (:) ] density (kg/m**3) + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + tgcm => temperature_inst%thm_patch , & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) + bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" + qflx_tran_veg => waterfluxbulk_inst%qflx_tran_veg_patch , & ! Input: [real(r8) (:) ] vegetation transpiration (mm H2O/s) (+ = to atm) + vegwp_pd => canopystate_inst%vegwp_pd_patch , & ! Output: [real(r8) (:,:) ] vegetation water matric potential (mm) predawn + sucsat => soilstate_inst%sucsat_col & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) + ) + + !temporary flag for night time vegwp(sun)>0 + if (x(sun)>0._r8) then + night=.TRUE. + x(sun)=x(sha) + else + night=.FALSE. + endif + + !copy to avoid rewriting gs_mol_sun + gs0sun=gs_mol_sun + gs0sha=gs_mol_sha + + !compute transpiration demand + havegs=.true. + call getqflx(p,c,gb_mol,gs0sun,gs0sha,qflx_sun,qflx_sha,qsatl,qaf,havegs, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, temperature_inst) + + if ((laisun(p)>tol_lai .or. laisha(p)>tol_lai).and.& + (qflx_sun>0._r8 .or. qflx_sha>0._r8))then + + !newton's method solves for matching fluxes through the spac + iter=0 + do + + iter=iter+1 + + call spacF(p,c,x,f,qflx_sun,qflx_sha, & + atm2lnd_inst,canopystate_inst,soilstate_inst,temperature_inst,waterfluxbulk_inst) + + if ( sqrt(sum(f*f)) < tolf*(qflx_sun+qflx_sha) ) then !fluxes balanced -> exit + flag = .false. + exit + end if + if ( iter>itmax ) then !exceeds max iters -> exit + flag = .false. + exit + end if + + call spacA(p,c,x,A,qflx_sun,qflx_sha,flag, & + atm2lnd_inst,canopystate_inst,soilstate_inst,temperature_inst,waterfluxbulk_inst) + + if (flag) then + ! cannot invert the matrix, solve for x algebraically assuming no flux + exit + end if + + if (laisun(p)>tol_lai.and.laisha(p)>tol_lai)then + dx = matmul(A,f) + else + !reduces to 3x3 system + !in this case, dx is not always [sun,sha,xyl,root] + !sun and sha flip depending on which is lai==0 + dx(sun)=0._r8 + dx(sha:root)=matmul(A(sha:root,sha:root),f(sha:root)) + endif + + + if ( maxval(abs(dx)) > 50000._r8) then + dx = 50000._r8 * dx / maxval(abs(dx)) !rescale step to max of 50000 + end if + + + if (laisun(p)>tol_lai.and.laisha(p)>tol_lai)then + x=x+dx + elseif (laisha(p)>tol_lai) then + x=x+dx + x(sun)=x(xyl) ! psi_sun = psi_xyl because laisun==0 + else + x(xyl:root)=x(xyl:root)+dx(xyl:root) + x(sun)=x(sun)+dx(sha) ! implementation ugly bit, chose to flip dx(sun) and dx(sha) for laisha==0 case + x(sha)=x(xyl) ! psi_sha = psi_xyl because laisha==0 + + endif + + + if ( sqrt(sum(dx*dx)) < toldx) then + !step in vegwp small -> exit + exit + end if + + ! this is a catch to force spac gradient to atmosphere + if ( x(xyl) > x(root) ) x(xyl) = x(root) + if ( x(sun) > x(xyl) ) x(sun) = x(xyl) + if ( x(sha) > x(xyl) ) x(sha) = x(xyl) + + end do + + else + ! both qflxsun and qflxsha==0 + flag=.true. + end if + + if (flag) then + ! solve algebraically + call getvegwp(p, c, x, gb_mol, gs0sun, gs0sha, qsatl, qaf, soilflux, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst) + bsun = plc(x(sun),p,c,sun,veg) + bsha = plc(x(sha),p,c,sha,veg) + else + ! compute attenuated flux + qsun=qflx_sun*plc(x(sun),p,c,sun,veg) + qsha=qflx_sha*plc(x(sha),p,c,sha,veg) + + ! retrieve stressed stomatal conductance + havegs=.FALSE. + call getqflx(p,c,gb_mol,gs0sun,gs0sha,qsun,qsha,qsatl,qaf,havegs, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, temperature_inst) + + ! compute water stress + ! .. generally -> B= gs_stressed / gs_unstressed + ! .. when gs=0 -> B= plc( x ) + if (qflx_sun>0._r8) then + bsun = gs0sun/gs_mol_sun + else + bsun = plc(x(sun),p,c,sun,veg) + endif + if (qflx_sha>0._r8) then + bsha = gs0sha/gs_mol_sha + else + bsha = plc(x(sha),p,c,sha,veg) + endif + endif + if ( bsun < 0.01_r8 ) bsun = 0._r8 + if ( bsha < 0.01_r8 ) bsha = 0._r8 + + !zqz is this the best place to do this? + ! was looking like qflx_tran_veg/vegwp was not being set at night time + ! set vegwp for the final gs_mol solution + if (night) then + gs0sun=bsun*gs_mol_sun + gs0sha=bsha*gs_mol_sha + call getvegwp(p, c, x, gb_mol, gs0sun, gs0sha, qsatl, qaf, soilflux, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst) + if (soilflux<0._r8) soilflux = 0._r8 + qflx_tran_veg(p) = soilflux + endif + + !save predawn vegwp + g = patch%gridcell(p) + if (night .and. get_local_time(grc%londeg(g))<(isecspday/2)) then + vegwp_pd(p,:) = x + else + vegwp_pd(p,:) = spval + end if + + + end associate + + end subroutine calcstress + + !------------------------------------------------------------------------------ + + !------------------------------------------------------------------------------ + subroutine spacA(p,c,x,invA,qflx_sun,qflx_sha,flag, & + atm2lnd_inst,canopystate_inst,soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + ! + ! DESCRIPTION + ! Returns invA, the inverse matrix relating delta(vegwp) to f + ! d(vegwp)=invA*f + ! evaluated at vegwp(p) + ! + ! The methodology is currently hardcoded for linear algebra assuming the + ! number of vegetation segments is four. Thus the matrix A and it's inverse + ! invA are both 4x4 matrices. A more general method could be done using for + ! example a LINPACK linear algebra solver. + ! + ! USES + use clm_varpar , only : nlevsoi + use clm_varcon , only : rgas + ! + ! !ARGUMENTS: + integer , intent(in) :: p ! pft index + integer , intent(in) :: c ! column index + real(r8) , intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] + real(r8) , intent(out) :: invA(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=invA*f + real(r8) , intent(in) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + logical , intent(out) :: flag ! tells calling function that the matrix is not invertible + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: fsto1 ! sunlit transpiration reduction function [-] + real(r8) :: fsto2 ! shaded transpiration reduction function [-] + real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) :: dfsto1 ! 1st derivative of fsto1 w.r.t. change in vegwp + real(r8) :: dfsto2 ! 1st derivative of fsto2 w.r.t. change in vegwp + real(r8) :: dfx ! 1st derivative of fx w.r.t. change in vegwp + real(r8) :: dfr ! 1st derivative of fr w.r.t. change in vegwp + real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating vegwp to flux divergence f=A*d(vegwp) + real(r8) :: leading ! inverse of determiniant + real(r8) :: determ ! determinant of matrix + real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) :: invfactor ! + real(r8), parameter :: tol_lai=.001_r8 ! minimum lai where transpiration is calc'd + integer :: j ! index + !------------------------------------------------------------------------------ +#ifndef NDEBUG + ! Only execute this code if DEBUG=TRUE + if ( nvegwcs /= 4 )then + call endrun(msg='Error:: this function is hardcoded for 4x4 matrices with nvegwcs==4'//errMsg(__FILE__, __LINE__)) + end if +#endif + + associate( & + k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] soil-root interface conductance (mm/s) + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + htop => canopystate_inst%htop_patch , & ! Input: [real(r8) (:) ] patch canopy top (m) + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + ivt => patch%itype & ! Input: [integer (:) ] patch vegetation type + ) + + ! initialize all elements to zero + A = 0._r8 + invA = 0._r8 + + grav1 = htop(p)*1000._r8 + + !compute conductance attentuation for each segment + fsto1= plc(x(sun),p,c,sun,veg) + fsto2= plc(x(sha),p,c,sha,veg) + fx= plc(x(xyl),p,c,xyl,veg) + fr= plc(x(root),p,c,root,veg) + + !compute 1st deriv of conductance attenuation for each segment + dfsto1= d1plc(x(sun),p,c,sun,veg) + dfsto2= d1plc(x(sha),p,c,sha,veg) + dfx= d1plc(x(xyl),p,c,xyl,veg) + dfr= d1plc(x(root),p,c,root,veg) + + !A - f=A*d(vegwp) + A(1,1)= - laisun(p) * params_inst%kmax(ivt(p),sun) * fx& + - qflx_sun * dfsto1 + A(1,3)= laisun(p) * params_inst%kmax(ivt(p),sun) * dfx * (x(xyl)-x(sun))& + + laisun(p) * params_inst%kmax(ivt(p),sun) * fx + A(2,2)= - laisha(p) * params_inst%kmax(ivt(p),sha) * fx& + - qflx_sha * dfsto2 + A(2,3)= laisha(p) * params_inst%kmax(ivt(p),sha) * dfx * (x(xyl)-x(sha))& + + laisha(p) * params_inst%kmax(ivt(p),sha) * fx + A(3,1)= laisun(p) * params_inst%kmax(ivt(p),sun) * fx + A(3,2)= laisha(p) * params_inst%kmax(ivt(p),sha) * fx + A(3,3)= - laisun(p) * params_inst%kmax(ivt(p),sun) * dfx * (x(xyl)-x(sun))& + - laisun(p) * params_inst%kmax(ivt(p),sun) * fx& + - laisha(p) * params_inst%kmax(ivt(p),sha) * dfx * (x(xyl)-x(sha))& + - laisha(p) * params_inst%kmax(ivt(p),sha) * fx& + - tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr + A(3,4)= tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * dfr * (x(root)-x(xyl)-grav1)& + + tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr + A(4,3)= tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr + A(4,4)= - tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr& + - tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * dfr * (x(root)-x(xyl)-grav1)& + - sum(k_soil_root(p,1:nlevsoi)) + + invfactor=1._r8 + A=invfactor*A + + !matrix inversion + if (laisun(p)>tol_lai .and. laisha(p)>tol_lai) then + ! general case + + determ=A(4,4)*A(2,2)*A(3,3)*A(1,1) - A(4,4)*A(2,2)*A(3,1)*A(1,3)& + - A(4,4)*A(3,2)*A(2,3)*A(1,1) - A(4,3)*A(1,1)*A(2,2)*A(3,4) + if ( abs(determ) <= 1.e-50_r8 ) then + flag = .true. !tells calling function that the matrix is not invertible + return + else + flag = .false. + end if + + leading = 1._r8/determ + + !algebraic inversion of the matrix + invA(1,1)=leading*A(4,4)*A(2,2)*A(3,3) - leading*A(4,4)*A(3,2)*A(2,3) - leading*A(4,3)*A(2,2)*A(3,4) + invA(2,1)=leading*A(2,3)*A(4,4)*A(3,1) + invA(3,1)=-leading*A(4,4)*A(2,2)*A(3,1) + invA(4,1)=leading*A(4,3)*A(2,2)*A(3,1) + invA(1,2)=leading*A(1,3)*A(4,4)*A(3,2) + invA(2,2)=leading*A(4,4)*A(3,3)*A(1,1)-leading*A(4,4)*A(3,1)*A(1,3)-leading*A(4,3)*A(1,1)*A(3,4) + invA(3,2)=-leading*A(1,1)*A(4,4)*A(3,2) + invA(4,2)=leading*A(4,3)*A(1,1)*A(3,2) + invA(1,3)=-leading*A(1,3)*A(2,2)*A(4,4) + invA(2,3)=-leading*A(2,3)*A(1,1)*A(4,4) + invA(3,3)=leading*A(2,2)*A(1,1)*A(4,4) + invA(4,3)=-leading*A(4,3)*A(1,1)*A(2,2) + invA(1,4)=leading*A(1,3)*A(3,4)*A(2,2) + invA(2,4)=leading*A(2,3)*A(3,4)*A(1,1) + invA(3,4)=-leading*A(3,4)*A(1,1)*A(2,2) + invA(4,4)=leading*A(2,2)*A(3,3)*A(1,1)-leading*A(2,2)*A(3,1)*A(1,3)-leading*A(3,2)*A(2,3)*A(1,1) + invA=invfactor*invA !undo inversion scaling + else + ! if laisun or laisha ==0 invert the corresponding 3x3 matrix + ! if both are zero, this routine is not called + if (laisha(p)<=tol_lai) then + ! shift nonzero matrix values so that both 3x3 cases can be inverted with the same code + A(2,2)=A(1,1) + A(3,2)=A(3,1) + A(2,3)=A(1,3) + endif + determ=A(2,2)*A(3,3)*A(4,4)-A(3,4)*A(2,2)*A(4,3)-A(2,3)*A(3,2)*A(4,4) + if ( abs(determ) <= 1.e-50_r8 ) then + flag = .true. !tells calling function that the matrix is not invertible + return + else + flag = .false. + end if + + !algebraic inversion of the 3x3 matrix stored in A(2:4,2:4) + invA(2,2)=A(3,3)*A(4,4)-A(3,4)*A(4,3) + invA(2,3)=-A(2,3)*A(4,4) + invA(2,4)=A(3,4)*A(2,3) + invA(3,2)=-A(3,2)*A(4,4) + invA(3,3)=A(2,2)*A(4,4) + invA(3,4)=-A(3,4)*A(2,2) + invA(4,2)=A(3,2)*A(4,3) + invA(4,3)=-A(2,2)*A(4,3) + invA(4,4)=A(2,2)*A(3,3)-A(2,3)*A(3,2) + invA=1._r8/determ*invA + + endif + + end associate + + end subroutine spacA + + !-------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------ + subroutine spacF(p,c,x,f,qflx_sun,qflx_sha, & + atm2lnd_inst,canopystate_inst,soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + ! + ! DESCRIPTION + ! Returns f, the flux divergence across each vegetation segment + ! calculated for vegwp(p,:) as passed in via x + ! + ! USES + use clm_varpar , only : nlevsoi + use clm_varcon , only : rgas + use ColumnType , only : col + ! + ! !ARGUMENTS: + integer , intent(in) :: p ! pft index + integer , intent(in) :: c ! column index + real(r8) , intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] + real(r8) , intent(out) :: f(nvegwcs) ! water flux divergence [mm/s] + real(r8) , intent(in) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: fsto1 ! sunlit transpiration reduction function [-] + real(r8) :: fsto2 ! shaded transpiration reduction function [-] + real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) :: grav2(nlevsoi) ! soil layer gravitational potential relative to surface (mm H2O) + real(r8) :: temp ! used to copy f(sun) to f(sha) for special case + real(r8), parameter :: tol_lai=.001_r8 ! needs to be the same as in calcstress and spacA (poor form, refactor)< + integer :: j ! index + !------------------------------------------------------------------------------ + + associate( & + k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] soil-root interface conductance (mm/s) + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + htop => canopystate_inst%htop_patch , & ! Input: [real(r8) (:) ] patch canopy top (m) + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + smp => soilstate_inst%smp_l_col , & ! Input: [real(r8) (:,:) ] soil matrix potential [mm] + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + z => col%z & ! Input: [real(r8) (:,:) ] layer node depth (m) + ) + + grav1 = htop(p) * 1000._r8 + grav2(1:nlevsoi) = z(c,1:nlevsoi) * 1000._r8 + + fsto1= plc(x(sun),p,c,sun,veg) + fsto2= plc(x(sha),p,c,sha,veg) + fx= plc(x(xyl),p,c,xyl,veg) + fr= plc(x(root),p,c,root,veg) + + !compute flux divergence across each plant segment + f(sun)= qflx_sun * fsto1 - laisun(p) * params_inst%kmax(ivt(p),sun) * fx * (x(xyl)-x(sun)) + f(sha)= qflx_sha * fsto2 - laisha(p) * params_inst%kmax(ivt(p),sha) * fx * (x(xyl)-x(sha)) + f(xyl)= laisun(p) * params_inst%kmax(ivt(p),sun) * fx * (x(xyl)-x(sun))& + + laisha(p) * params_inst%kmax(ivt(p),sha) * fx * (x(xyl)-x(sha)) & + - tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr * (x(root)-x(xyl)-grav1) + f(root)= tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr * (x(root)-x(xyl)-grav1) & + + sum( k_soil_root(p,1:nlevsoi) * (x(root)+grav2(1:nlevsoi)) ) & + - sum( k_soil_root(p,1:nlevsoi) * smp(c,1:nlevsoi) ) + + if (laisha(p)qflx or qflx->gs + !---------------------------------------------------------------------- + associate( & + k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] soil-root interface conductance (mm/s) + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + htop => canopystate_inst%htop_patch , & ! Input: [real(r8) (:) ] patch canopy top (m) + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + smp => soilstate_inst%smp_l_col , & ! Input: [real(r8) (:,:) ] soil matrix potential [mm] + rootfr => soilstate_inst%rootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer + bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + hk_l => soilstate_inst%hk_l_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity (mm/s) + hksat => soilstate_inst%hksat_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity at saturation (mm H2O /s) + sucsat => soilstate_inst%sucsat_col , & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) + z => col%z & ! Input: [real(r8) (:,:) ] layer node depth (m) + ) + + grav1 = 1000._r8 *htop(p) + grav2(1:nlevsoi) = 1000._r8 * z(c,1:nlevsoi) + + !compute transpiration demand + havegs=.true. + call getqflx(p,c,gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,havegs, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, temperature_inst) + + !calculate root water potential + if ( abs(sum(k_soil_root(p,1:nlevsoi))) == 0._r8 ) then + x(root) = sum(smp(c,1:nlevsoi) - grav2)/nlevsoi + else + x(root) = (sum(k_soil_root(p,1:nlevsoi)*(smp(c,1:nlevsoi)-grav2))-qflx_sun-qflx_sha) & + /sum(k_soil_root(p,1:nlevsoi)) + endif + + !calculate xylem water potential + fr = plc(x(root),p,c,root,veg) + if ( (tsai(p) > 0._r8) .and. (fr > 0._r8) ) then + x(xyl) = x(root) - grav1 - (qflx_sun+qflx_sha)/(fr*params_inst%kmax(ivt(p),root)/htop(p)*tsai(p))!removed htop conversion + else + x(xyl) = x(root) - grav1 + endif + + !calculate sun/sha leaf water potential + fx = plc(x(xyl),p,c,xyl,veg) + if ( (laisha(p) > 0._r8) .and. (fx > 0._r8) ) then + x(sha) = x(xyl) - (qflx_sha/(fx*params_inst%kmax(ivt(p),xyl)*laisha(p))) + else + x(sha) = x(xyl) + endif + if ( (laisun(p) > 0._r8) .and. (fx > 0._r8) ) then + x(sun) = x(xyl) - (qflx_sun/(fx*params_inst%kmax(ivt(p),xyl)*laisun(p))) + else + x(sun) = x(xyl) + endif + + !calculate soil flux + soilflux = 0._r8 + do j = 1,nlevsoi + soilflux = soilflux + k_soil_root(p,j)*(smp(c,j)-x(root)-grav2(j)) + enddo + + end associate + + end subroutine getvegwp + + !-------------------------------------------------------------------------------- + subroutine getqflx(p,c,gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,havegs, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, temperature_inst) + ! !DESCRIPTION: + ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL + ! !USES: + ! + use clm_varcon , only : rgas + implicit none + ! + ! !ARGUMENTS: + integer , intent(in) :: p ! pft index + integer , intent(in) :: c ! column index + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (umol H2O/m**2/s) + real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (umol H2O/m**2/s) + real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + logical , intent(in) :: havegs ! signals direction of calculation gs->qflx or qflx->gs + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(temperature_type) , intent(in) :: temperature_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: efpot ! potential latent energy flux [kg/m2/s] + real(r8) :: rppdry_sun ! fraction of potential evaporation through transp - sunlit [-] + real(r8) :: rppdry_sha ! fraction of potential evaporation through transp - shaded [-] + real(r8) :: cf ! s m**2/umol -> s/m + !---------------------------------------------------------------------- + + associate( & + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow + fdry => waterdiagnosticbulk_inst%fdry_patch , & ! Input: [real(r8) (:) ] fraction of foliage that is green and dry [-] + forc_rho => atm2lnd_inst%forc_rho_downscaled_col , & ! Input: [real(r8) (:) ] density (kg/m**3) + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + tgcm => temperature_inst%thm_patch & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) + ) + + + cf = forc_pbot(c)/(rgas*1.e-3_r8*tgcm(p))*1.e6_r8 ! gb->gbmol conversion factor + wtl = (elai(p)+esai(p))*gb_mol + efpot = forc_rho(c)*wtl*(qsatl-qaf) + if (havegs) then + + if ( (efpot > 0._r8) .and. (elai(p) > 0._r8) ) then + if ( gs_mol_sun > 0._r8 ) then + rppdry_sun = fdry(p)/gb_mol*(laisun(p)/(1._r8/gb_mol+1._r8/gs_mol_sun))/elai(p) + qflx_sun = efpot*rppdry_sun/cf + else + qflx_sun = 0._r8 + end if + if ( gs_mol_sha > 0._r8 ) then + rppdry_sha = fdry(p)/gb_mol*(laisha(p)/(1._r8/gb_mol+1._r8/gs_mol_sha))/elai(p) + qflx_sha = efpot*rppdry_sha/cf + else + qflx_sha = 0._r8 + end if + else + qflx_sun = 0._r8 + qflx_sha = 0._r8 + end if + + else + if (qflx_sun > 0._r8) then + gs_mol_sun=gb_mol*qflx_sun*cf*elai(p)/(efpot*fdry(p)*laisun(p)-qflx_sun*cf*elai(p)) + else + gs_mol_sun=0._r8 + endif + if (qflx_sha > 0._r8) then + gs_mol_sha=gb_mol*qflx_sha*cf*elai(p)/(efpot*fdry(p)*laisha(p)-qflx_sha*cf*elai(p)) + else + gs_mol_sha=0._r8 + endif + + endif + + end associate + + end subroutine getqflx + + !-------------------------------------------------------------------------------- + function plc(x,p,c,level,plc_method) + ! !DESCRIPTION + ! Return value of vulnerability curve at x + ! + ! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input + integer , intent(in) :: p ! index for pft + integer , intent(in) :: c ! index for column + integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) + integer , intent(in) :: plc_method ! + real(r8) :: plc ! attenuated conductance [0:1] 0=no flow + ! + ! !PARAMETERS + integer , parameter :: vegetation_weibull=0 ! case number + !------------------------------------------------------------------------------ + associate( & + ivt => patch%itype & ! Input: [integer (:) ] patch vegetation type + ) + + select case (plc_method) + !possible to add other methods later + case (vegetation_weibull) + plc=2._r8**(-((x/params_inst%psi50(ivt(p),level))**params_inst%ck(ivt(p),level))) + if ( plc < 0.005_r8) plc = 0._r8 + case default + print *,'must choose plc method' + end select + + end associate + + end function plc + !-------------------------------------------------------------------------------- + + !-------------------------------------------------------------------------------- + function d1plc(x,p,c,level,plc_method) + ! !DESCRIPTION + ! Return 1st derivative of vulnerability curve at x + ! + ! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input + integer , intent(in) :: p ! index for pft + integer , intent(in) :: c ! index for column + integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) + integer , intent(in) :: plc_method ! 0 for vegetation, 1 for soil + real(r8) :: d1plc ! first deriv of plc curve at x + ! + ! !PARAMETERS + integer , parameter :: vegetation_weibull=0 ! case number + !------------------------------------------------------------------------------ + associate( & + ivt => patch%itype & ! Input: [integer (:) ] patch vegetation type + ) + + select case (plc_method) + !possible to add other methods later + case (vegetation_weibull) + d1plc= -params_inst%ck(ivt(p),level) * log(2._r8) * (2._r8**(-(x/params_inst%psi50(ivt(p),level)) & + **params_inst%ck(ivt(p),level))) & + * ((x/params_inst%psi50(ivt(p),level))**params_inst%ck(ivt(p),level)) / x + case default + print *,'must choose plc method' + end select + + end associate + + end function d1plc + +end module PhotosynthesisMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/QSatMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/QSatMod.F90 new file mode 100755 index 000000000..9a17ce700 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/QSatMod.F90 @@ -0,0 +1,129 @@ +module QSatMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Computes saturation mixing ratio and the change in saturation + ! + ! !PUBLIC TYPES: + use shr_kind_mod , only: r8 => shr_kind_r8 + implicit none + save + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: QSat + !----------------------------------------------------------------------- + + ! For water vapor (temperature range 0C-100C) + real(r8), parameter :: a0 = 6.11213476_r8 + real(r8), parameter :: a1 = 0.444007856_r8 + real(r8), parameter :: a2 = 0.143064234e-01_r8 + real(r8), parameter :: a3 = 0.264461437e-03_r8 + real(r8), parameter :: a4 = 0.305903558e-05_r8 + real(r8), parameter :: a5 = 0.196237241e-07_r8 + real(r8), parameter :: a6 = 0.892344772e-10_r8 + real(r8), parameter :: a7 = -0.373208410e-12_r8 + real(r8), parameter :: a8 = 0.209339997e-15_r8 + ! For derivative:water vapor + real(r8), parameter :: b0 = 0.444017302_r8 + real(r8), parameter :: b1 = 0.286064092e-01_r8 + real(r8), parameter :: b2 = 0.794683137e-03_r8 + real(r8), parameter :: b3 = 0.121211669e-04_r8 + real(r8), parameter :: b4 = 0.103354611e-06_r8 + real(r8), parameter :: b5 = 0.404125005e-09_r8 + real(r8), parameter :: b6 = -0.788037859e-12_r8 + real(r8), parameter :: b7 = -0.114596802e-13_r8 + real(r8), parameter :: b8 = 0.381294516e-16_r8 + ! For ice (temperature range -75C-0C) + real(r8), parameter :: c0 = 6.11123516_r8 + real(r8), parameter :: c1 = 0.503109514_r8 + real(r8), parameter :: c2 = 0.188369801e-01_r8 + real(r8), parameter :: c3 = 0.420547422e-03_r8 + real(r8), parameter :: c4 = 0.614396778e-05_r8 + real(r8), parameter :: c5 = 0.602780717e-07_r8 + real(r8), parameter :: c6 = 0.387940929e-09_r8 + real(r8), parameter :: c7 = 0.149436277e-11_r8 + real(r8), parameter :: c8 = 0.262655803e-14_r8 + ! For derivative:ice + real(r8), parameter :: d0 = 0.503277922_r8 + real(r8), parameter :: d1 = 0.377289173e-01_r8 + real(r8), parameter :: d2 = 0.126801703e-02_r8 + real(r8), parameter :: d3 = 0.249468427e-04_r8 + real(r8), parameter :: d4 = 0.313703411e-06_r8 + real(r8), parameter :: d5 = 0.257180651e-08_r8 + real(r8), parameter :: d6 = 0.133268878e-10_r8 + real(r8), parameter :: d7 = 0.394116744e-13_r8 + real(r8), parameter :: d8 = 0.498070196e-16_r8 + +contains + + !----------------------------------------------------------------------- + subroutine QSat (T, p, qs, es, qsdT, esdT) + ! + ! !DESCRIPTION: + ! Computes saturation mixing ratio and (optionally) the change in saturation mixing + ! ratio with respect to temperature. Mixing ratio and specific humidity are + ! approximately equal and can be treated as the same. + ! Reference: Polynomial approximations from: + ! Piotr J. Flatau, et al.,1992: Polynomial fits to saturation + ! vapor pressure. Journal of Applied Meteorology, 31, 1507-1513. + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use shr_const_mod, only: SHR_CONST_TKFRZ + ! + ! !ARGUMENTS: + implicit none + real(r8), intent(in) :: T ! temperature (K) + real(r8), intent(in) :: p ! surface atmospheric pressure (pa) + real(r8), intent(out) :: qs ! humidity (kg/kg) + real(r8), intent(out), optional :: es ! vapor pressure (pa) + real(r8), intent(out), optional :: qsdT ! d(qs)/d(T) + real(r8), intent(out), optional :: esdT ! d(es)/d(T) + ! + ! !LOCAL VARIABLES: + real(r8) :: es_local ! local version of es (in case es is not present) + real(r8) :: esdT_local ! local version of esdT (in case esdT is not present) + real(r8) :: td,vp,vp1,vp2 + !----------------------------------------------------------------------- + + td = min(100.0_r8, max(-75.0_r8, T - SHR_CONST_TKFRZ)) + + if (td >= 0.0_r8) then + es_local = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & + + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + else + es_local = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & + + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + endif + + es_local = es_local * 100._r8 ! pa + vp = 1.0_r8 / (p - 0.378_r8*es_local) + vp1 = 0.622_r8 * vp + qs = es_local * vp1 ! kg/kg + if (present(es)) then + es = es_local + end if + + if (present(qsdT) .or. present(esdT)) then + if (td >= 0.0_r8) then + esdT_local = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & + + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) + else + esdT_local = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & + + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) + end if + + esdT_local = esdT_local * 100._r8 ! pa/K + vp2 = vp1 * vp + if (present(qsdT)) then + qsdT = esdT_local * vp2 * p ! 1 / K + end if + if (present(esdT)) then + esdT = esdT_local + end if + end if + + end subroutine QSat + +end module QSatMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/RootBiophysMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/RootBiophysMod.F90 new file mode 100755 index 000000000..8c910b694 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/RootBiophysMod.F90 @@ -0,0 +1,327 @@ +module RootBiophysMod + +#include "shr_assert.h" + + !-------------------------------------------------------------------------------------- + ! DESCRIPTION: + ! module contains subroutine for root biophysics + ! + ! HISTORY + ! created by Jinyun Tang, Mar 1st, 2014 + implicit none + private + ! + public :: init_vegrootfr + public :: init_rootprof + + integer, private, parameter :: zeng_2001_root = 0 !the zeng 2001 root profile function + integer, private, parameter :: jackson_1996_root = 1 !the jackson 1996 root profile function + integer, private, parameter :: koven_exp_root = 2 !the koven exponential root profile function + + integer, public :: rooting_profile_method_water !select the type of rooting profile parameterization for water + integer, public :: rooting_profile_method_carbon !select the type of rooting profile parameterization for carbon + integer, public :: rooting_profile_varindex_water !select the variant number of rooting profile parameterization for water + integer, public :: rooting_profile_varindex_carbon !select the variant number of rooting profile parameterization for carbon + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + !-------------------------------------------------------------------------------------- + +contains + + !-------------------------------------------------------------------------------------- + subroutine init_rootprof(NLFilename) + ! + !DESCRIPTION + ! initialize methods for root profile calculation + + ! !USES: + use abortutils , only : endrun + use fileutils , only : getavu, relavu, opnfil + use spmdMod , only : mpicom, masterproc + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + use shr_nl_mod , only : shr_nl_find_group_name + + ! !ARGUMENTS: + !------------------------------------------------------------------------------ + implicit none + character(len=*), intent(in) :: NLFilename + + integer :: unitn ! unit for namelist file + integer :: ierr ! namelist i/o error flag + character(*), parameter :: subName = "('init_rootprof')" + + !----------------------------------------------------------------------- + +! MUST agree with name in namelist and read statement + namelist /rooting_profile_inparm/ rooting_profile_method_water, rooting_profile_method_carbon, & + rooting_profile_varindex_water, rooting_profile_varindex_carbon + + ! Default values for namelist + + rooting_profile_method_water = zeng_2001_root + rooting_profile_method_carbon = zeng_2001_root + rooting_profile_varindex_water = 1 + rooting_profile_varindex_carbon = 2 + + ! Read rooting_profile namelist + if (masterproc) then + unitn = getavu() + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, 'rooting_profile_inparm', status=ierr) + if (ierr == 0) then + read(unitn, rooting_profile_inparm,iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading rooting_profile namelist') + end if + else + call endrun(subname // ':: ERROR finding rooting_profile namelist') + end if + call relavu( unitn ) + + endif + + call shr_mpi_bcast(rooting_profile_method_water, mpicom) + call shr_mpi_bcast(rooting_profile_method_carbon, mpicom) + call shr_mpi_bcast(rooting_profile_varindex_water, mpicom) + call shr_mpi_bcast(rooting_profile_varindex_carbon, mpicom) + + if (masterproc) then + + write(iulog,*) ' ' + write(iulog,*) 'rooting_profile settings:' + write(iulog,*) ' rooting_profile_method_water = ',rooting_profile_method_water + if ( rooting_profile_method_water == jackson_1996_root )then + write(iulog,*) ' (rooting_profile_varindex_water = ',rooting_profile_varindex_water, ')' + end if + write(iulog,*) ' rooting_profile_method_carbon = ',rooting_profile_method_carbon + if ( rooting_profile_method_carbon == jackson_1996_root )then + write(iulog,*) ' (rooting_profile_varindex_carbon = ',rooting_profile_varindex_carbon, ')' + end if + + endif + + end subroutine init_rootprof + + !-------------------------------------------------------------------------------------- + subroutine init_vegrootfr(bounds, nlevsoi, nlevgrnd, rootfr, water_carbon) + ! + !DESCRIPTION + !initialize plant root profiles + ! + ! USES + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun + use ColumnType , only : col + use PatchType , only : patch + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds ! bounds + integer, intent(in) :: nlevsoi ! number of hydactive layers + integer, intent(in) :: nlevgrnd ! number of soil layers + real(r8), intent(out):: rootfr(bounds%begp: , 1: ) ! root fraction by layer + character(len=*), intent(in) :: water_carbon ! roots for water or carbon + + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'init_vegrootfr' ! subroutine name + integer :: c,p + integer :: rooting_profile_method ! Rooting profile method to use + integer :: rooting_profile_varidx ! Rooting profile variant index to use + !------------------------------------------------------------------------ + + SHR_ASSERT_ALL_FL((ubound(rootfr) == (/bounds%endp, nlevgrnd/)), sourcefile, __LINE__) + + if ( water_carbon == 'water' ) then + rooting_profile_method = rooting_profile_method_water + rooting_profile_varidx = rooting_profile_varindex_water + else if (water_carbon == 'carbon') then + rooting_profile_method = rooting_profile_method_carbon + rooting_profile_varidx = rooting_profile_varindex_carbon + else + call endrun(subname // ':: input type can only be water or carbon = '//water_carbon ) + end if + + select case( rooting_profile_method ) + + case (zeng_2001_root) + rootfr(bounds%begp:bounds%endp, 1 : nlevsoi) = zeng2001_rootfr(bounds, nlevsoi) + case (jackson_1996_root) + rootfr(bounds%begp:bounds%endp, 1 : nlevsoi) = jackson1996_rootfr(bounds, nlevsoi, rooting_profile_varidx, water_carbon) + case (koven_exp_root) + rootfr(bounds%begp:bounds%endp, 1 : nlevsoi) = exponential_rootfr(bounds, nlevsoi) + case default + call endrun(subname // ':: a root fraction function must be specified!') + end select + rootfr(bounds%begp:bounds%endp,nlevsoi+1:nlevgrnd)=0._r8 + + ! shift roots up above bedrock boundary (distribute equally to each layer) + ! may not matter if normalized later + do p = bounds%begp,bounds%endp + c = patch%column(p) + rootfr(p,1:col%nbedrock(c)) = rootfr(p,1:col%nbedrock(c)) & + + sum(rootfr(p,col%nbedrock(c)+1:nlevsoi))/real(col%nbedrock(c)) + rootfr(p,col%nbedrock(c)+1:nlevsoi) = 0._r8 + enddo + end subroutine init_vegrootfr + + !------------------------------------------------------------------------- + function zeng2001_rootfr(bounds, ubj) result(rootfr) + ! + ! DESCRIPTION + ! compute root profile for soil water uptake + ! using equation from Zeng 2001, J. Hydrometeorology + ! + ! USES + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use pftconMod , only : pftcon + use PatchType , only : patch + use ColumnType , only : col + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: ubj ! ubnd + ! + ! !RESULT + real(r8) :: rootfr(bounds%begp:bounds%endp , 1:ubj ) ! + ! + ! !LOCAL VARIABLES: + integer :: p, lev, c + !------------------------------------------------------------------------ + + !(computing from surface, d is depth in meter): + ! Y = 1 -1/2 (exp(-ad)+exp(-bd) under the constraint that + ! Y(d =0.1m) = 1-beta^(10 cm) and Y(d=d_obs)=0.99 with + ! beta & d_obs given in Zeng et al. (1998). + + do p = bounds%begp,bounds%endp + + if (.not. patch%is_fates(p)) then + c = patch%column(p) + do lev = 1, ubj-1 + rootfr(p,lev) = .5_r8*( & + exp(-pftcon%roota_par(patch%itype(p)) * col%zi(c,lev-1)) & + + exp(-pftcon%rootb_par(patch%itype(p)) * col%zi(c,lev-1)) & + - exp(-pftcon%roota_par(patch%itype(p)) * col%zi(c,lev )) & + - exp(-pftcon%rootb_par(patch%itype(p)) * col%zi(c,lev )) ) + end do + rootfr(p,ubj) = .5_r8*( & + exp(-pftcon%roota_par(patch%itype(p)) * col%zi(c,ubj-1)) & + + exp(-pftcon%rootb_par(patch%itype(p)) * col%zi(c,ubj-1)) ) + + else + rootfr(p,1:ubj) = 0._r8 + endif + + enddo + return + + end function zeng2001_rootfr + + !------------------------------------------------------------------------- + function jackson1996_rootfr(bounds, ubj, varindx, water_carbon) result(rootfr) + ! + ! DESCRIPTION + ! compute root profile for soil water uptake + ! using equation from Jackson et al. 1996, Oec. + ! + ! USES + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use pftconMod , only : pftcon + use PatchType , only : patch + use ColumnType , only : col + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: ubj ! ubnd + integer , intent(in) :: varindx ! variant index + character(len=*) , intent(in) :: water_carbon ! roots for water or carbon + ! + ! !RESULT + real(r8) :: rootfr(bounds%begp:bounds%endp , 1:ubj ) ! + ! + ! !LOCAL VARIABLES: + real(r8), parameter :: m_to_cm = 1.e2_r8 + real(r8) :: beta !patch specific shape parameter + integer :: p, lev, c + !------------------------------------------------------------------------ + + !(computing from surface, d is depth in centimeters): + ! Y = (1 - beta^d); beta given in Jackson et al. (1996). + + rootfr(bounds%begp:bounds%endp, :) = 0._r8 + do p = bounds%begp,bounds%endp + c = patch%column(p) + if (.not.patch%is_fates(p)) then + beta = pftcon%rootprof_beta(patch%itype(p),varindx) + do lev = 1, ubj + rootfr(p,lev) = ( & + beta ** (col%zi(c,lev-1)*m_to_cm) - & + beta ** (col%zi(c,lev)*m_to_cm) ) + end do + else + rootfr(p,:) = 0. + endif + + enddo + return + + end function jackson1996_rootfr + + !------------------------------------------------------------------------- + function exponential_rootfr(bounds, ubj) result(rootfr) + ! + ! DESCRIPTION + ! compute root profile for soil water uptake + ! using equation from Koven + ! + ! USES + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use pftconMod , only : pftcon + use PatchType , only : patch + use ColumnType , only : col + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: ubj ! ubnd + ! + ! !RESULT + real(r8) :: rootfr(bounds%begp:bounds%endp , 1:ubj ) ! + ! + ! !LOCAL VARIABLES: + real(r8), parameter :: rootprof_exp = 3. ! how steep profile is for root C inputs (1/ e-folding depth) (1/m) + real(r8) :: norm + integer :: p, lev, c + + !------------------------------------------------------------------------ + + rootfr(bounds%begp:bounds%endp, :) = 0._r8 + do p = bounds%begp,bounds%endp + c = patch%column(p) + if (.not.patch%is_fates(p)) then + do lev = 1, ubj + rootfr(p,lev) = exp(-rootprof_exp * col%z(c,lev)) * col%dz(c,lev) + end do + else + rootfr(p,1) = 0. + endif + norm = -1./rootprof_exp * (exp(-rootprof_exp * col%z(c,ubj)) - 1._r8) + rootfr(p,:) = rootfr(p,:) / norm + + enddo + + return + + end function exponential_rootfr + +end module RootBiophysMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeBGCMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeBGCMod.F90 new file mode 100755 index 000000000..e1dfb5831 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeBGCMod.F90 @@ -0,0 +1,1132 @@ +module SoilBiogeochemDecompCascadeBGCMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Sets the coeffiecients used in the decomposition cascade submodel. + ! This uses the CENTURY/BGC parameters + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_TKFRZ + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : nlevsoi, nlevgrnd, nlevdecomp, ndecomp_cascade_transitions, ndecomp_pools + use clm_varpar , only : i_met_lit, i_cel_lit, i_lig_lit, i_cwd + use clm_varctl , only : iulog, spinup_state, anoxia, use_lch4, use_vertsoilc, use_fates, use_soil_matrixcn + use clm_varcon , only : zsoi + use decompMod , only : bounds_type + use spmdMod , only : masterproc + use abortutils , only : endrun + use CNSharedParamsMod , only : CNParamsShareInst, nlev_soildecomp_standard + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use ch4Mod , only : ch4_type + use ColumnType , only : col + use GridcellType , only : grc + use SoilBiogeochemStateType , only : get_spinup_latitude_term + + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: DecompCascadeBGCreadNML ! Read in namelist + public :: readParams ! Read in parameters from params file + public :: init_decompcascade_bgc ! Initialization + public :: decomp_rate_constants_bgc ! Figure out decomposition rates + ! + ! !PUBLIC DATA MEMBERS + logical , public :: normalize_q10_to_century_tfunc = .true.! do we normalize the century decomp. rates so that they match the CLM Q10 at a given tep? + logical , public :: use_century_tfunc = .false. + real(r8), public :: normalization_tref = 15._r8 ! reference temperature for normalizaion (degrees C) + ! + ! !PRIVATE DATA MEMBERS + + integer, private :: i_soil1 = -9 ! Soil Organic Matter (SOM) first pool + integer, private :: i_soil2 = -9 ! SOM second pool + integer, private :: i_soil3 = -9 ! SOM third pool + integer, private, parameter :: nsompools = 3 ! Number of SOM pools + integer, private, parameter :: i_litr1 = i_met_lit ! First litter pool, metobolic + integer, private, parameter :: i_litr2 = i_cel_lit ! Second litter pool, cellulose + integer, private, parameter :: i_litr3 = i_lig_lit ! Third litter pool, lignin + + type, private :: params_type + real(r8):: cn_s1_bgc !C:N for SOM 1 + real(r8):: cn_s2_bgc !C:N for SOM 2 + real(r8):: cn_s3_bgc !C:N for SOM 3 + + real(r8):: rf_l1s1_bgc !respiration fraction litter 1 -> SOM 1 + real(r8):: rf_l2s1_bgc + real(r8):: rf_l3s2_bgc + + real(r8):: rf_s2s1_bgc + real(r8):: rf_s2s3_bgc + real(r8):: rf_s3s1_bgc + + real(r8):: rf_cwdl2_bgc + real(r8):: rf_cwdl3_bgc + + real(r8):: tau_l1_bgc ! 1/turnover time of litter 1 from Century (l/18.5) (1/yr) + real(r8):: tau_l2_l3_bgc ! 1/turnover time of litter 2 and litter 3 from Century (1/4.9) (1/yr) + real(r8):: tau_s1_bgc ! 1/turnover time of SOM 1 from Century (1/7.3) (1/yr) + real(r8):: tau_s2_bgc ! 1/turnover time of SOM 2 from Century (1/0.2) (1/yr) + real(r8):: tau_s3_bgc ! 1/turnover time of SOM 3 from Century (1/0.0045) (1/yr) + real(r8):: tau_cwd_bgc ! corrected fragmentation rate constant CWD, century leaves wood decomposition rates open, within range of 0 - 0.5 yr^-1 (1/0.3) (1/yr) + + real(r8) :: cwd_fcel_bgc !cellulose fraction for CWD + real(r8) :: cwd_flig_bgc ! + + real(r8) :: k_frag_bgc !fragmentation rate for CWD + real(r8) :: minpsi_bgc !minimum soil water potential for heterotrophic resp + real(r8) :: maxpsi_bgc !maximum soil water potential for heterotrophic resp + + real(r8) :: initial_Cstocks(nsompools) ! Initial Carbon stocks for a cold-start + real(r8) :: initial_Cstocks_depth ! Soil depth for initial Carbon stocks for a cold-start + + end type params_type + ! + type(params_type), private :: params_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine DecompCascadeBGCreadNML( NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for soil BGC Decomposition Cascade + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'DecompCascadeBGCreadNML' + character(len=*), parameter :: nmlname = 'CENTURY_soilBGCDecompCascade' + !----------------------------------------------------------------------- + real(r8) :: initial_Cstocks(nsompools), initial_Cstocks_depth + namelist /CENTURY_soilBGCDecompCascade/ initial_Cstocks, initial_Cstocks_depth + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + initial_Cstocks(:) = 200._r8 + initial_Cstocks_depth = 0.3 + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=CENTURY_soilBGCDecompCascade, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(__FILE__, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(__FILE__, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast (initial_Cstocks , mpicom) + call shr_mpi_bcast (initial_Cstocks_depth, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=CENTURY_soilBGCDecompCascade) + write(iulog,*) ' ' + end if + + params_inst%initial_Cstocks(:) = initial_Cstocks(:) + params_inst%initial_Cstocks_depth = initial_Cstocks_depth + + end subroutine DecompCascadeBGCreadNML + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !DESCRIPTION: + ! + ! !USES: + use ncdio_pio , only: file_desc_t,ncd_io + ! + ! !ARGUMENTS: + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNDecompBgcParamsType' + character(len=100) :: errCode = 'Error reading in CN const file ' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + ! Read off of netcdf file + tString='tau_l1' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%tau_l1_bgc=tempr + + tString='tau_l2_l3' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%tau_l2_l3_bgc=tempr + + tString='tau_s1' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%tau_s1_bgc=tempr + + tString='tau_s2' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%tau_s2_bgc=tempr + + tString='tau_s3' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%tau_s3_bgc=tempr + + tString='tau_cwd' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%tau_cwd_bgc=tempr + + tString='cn_s1_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cn_s1_bgc=tempr + + tString='cn_s2_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cn_s2_bgc=tempr + + tString='cn_s3_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cn_s3_bgc=tempr + + tString='rf_l1s1_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_l1s1_bgc=tempr + + tString='rf_l2s1_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_l2s1_bgc=tempr + + tString='rf_l3s2_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_l3s2_bgc=tempr + + tString='rf_s2s1_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_s2s1_bgc=tempr + + tString='rf_s2s3_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_s2s3_bgc=tempr + + tString='rf_s3s1_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_s3s1_bgc=tempr + + tString='rf_cwdl2_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_cwdl2_bgc=tempr + + tString='rf_cwdl3_bgc' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_cwdl3_bgc=tempr + + tString='cwd_fcel' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cwd_fcel_bgc=tempr + + tString='k_frag' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_frag_bgc=tempr + + tString='minpsi_hr' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%minpsi_bgc=tempr + + tString='maxpsi_hr' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%maxpsi_bgc=tempr + + tString='cwd_flig' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cwd_flig_bgc=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine init_decompcascade_bgc(bounds, soilbiogeochem_state_inst, soilstate_inst ) + ! + ! !DESCRIPTION: + ! initialize rate constants and decomposition pathways following the decomposition cascade of the BGC model. + ! written by C. Koven + ! + ! !USES: + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilstate_type) , intent(in) :: soilstate_inst + ! + ! !LOCAL VARIABLES + !-- properties of each decomposing pool + real(r8) :: rf_l1s1 + real(r8) :: rf_l2s1 + real(r8) :: rf_l3s2 + !real(r8) :: rf_s1s2(bounds%begc:bounds%endc,1:nlevdecomp) + !real(r8) :: rf_s1s3(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8), allocatable :: rf_s1s2(:,:) + real(r8), allocatable :: rf_s1s3(:,:) + real(r8) :: rf_s2s1 + real(r8) :: rf_s2s3 + real(r8) :: rf_s3s1 + real(r8) :: rf_cwdl2 + real(r8) :: rf_cwdl3 + real(r8) :: cwd_fcel + real(r8) :: cwd_flig + real(r8) :: cn_s1 + real(r8) :: cn_s2 + real(r8) :: cn_s3 + !real(r8) :: f_s1s2(bounds%begc:bounds%endc,1:nlevdecomp) + !real(r8) :: f_s1s3(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8), allocatable :: f_s1s2(:,:) + real(r8), allocatable :: f_s1s3(:,:) + real(r8) :: f_s2s1 + real(r8) :: f_s2s3 + + integer :: i_l1s1 + integer :: i_l2s1 + integer :: i_l3s2 + integer :: i_s1s2 + integer :: i_s1s3 + integer :: i_s2s1 + integer :: i_s2s3 + integer :: i_s3s1 + integer :: i_cwdl2 + integer :: i_cwdl3 + real(r8):: speedup_fac ! acceleration factor, higher when vertsoilc = .true. + + integer :: c, j ! indices + real(r8) :: t ! temporary variable + !----------------------------------------------------------------------- + + associate( & + rf_decomp_cascade => soilbiogeochem_state_inst%rf_decomp_cascade_col , & ! Input: [real(r8) (:,:,:) ] respired fraction in decomposition step (frac) + pathfrac_decomp_cascade => soilbiogeochem_state_inst%pathfrac_decomp_cascade_col , & ! Input: [real(r8) (:,:,:) ] what fraction of C leaving a given pool passes through a given transition (frac) + + cellsand => soilstate_inst%cellsand_col , & ! Input: [real(r8) (:,:) ] column 3D sand + + cascade_donor_pool => decomp_cascade_con%cascade_donor_pool , & ! Output: [integer (:) ] which pool is C taken from for a given decomposition step + cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool , & ! Output: [integer (:) ] which pool is C added to for a given decomposition step + floating_cn_ratio_decomp_pools => decomp_cascade_con%floating_cn_ratio_decomp_pools , & ! Output: [logical (:) ] TRUE => pool has fixed C:N ratio + is_litter => decomp_cascade_con%is_litter , & ! Output: [logical (:) ] TRUE => pool is a litter pool + is_soil => decomp_cascade_con%is_soil , & ! Output: [logical (:) ] TRUE => pool is a soil pool + is_cwd => decomp_cascade_con%is_cwd , & ! Output: [logical (:) ] TRUE => pool is a cwd pool + initial_cn_ratio => decomp_cascade_con%initial_cn_ratio , & ! Output: [real(r8) (:) ] c:n ratio for initialization of pools + initial_stock => decomp_cascade_con%initial_stock , & ! Output: [real(r8) (:) ] initial concentration for seeding at spinup + initial_stock_soildepth => decomp_cascade_con%initial_stock_soildepth , & ! Output: [real(r8) (:) ] soil depth for initial concentration for seeding at spinup + is_metabolic => decomp_cascade_con%is_metabolic , & ! Output: [logical (:) ] TRUE => pool is metabolic material + is_cellulose => decomp_cascade_con%is_cellulose , & ! Output: [logical (:) ] TRUE => pool is cellulose + is_lignin => decomp_cascade_con%is_lignin , & ! Output: [logical (:) ] TRUE => pool is lignin + spinup_factor => decomp_cascade_con%spinup_factor & ! Output: [real(r8) (:) ] factor for AD spinup associated with each pool + + ) + + allocate(rf_s1s2(bounds%begc:bounds%endc,1:nlevdecomp)) + allocate(rf_s1s3(bounds%begc:bounds%endc,1:nlevdecomp)) + allocate(f_s1s2(bounds%begc:bounds%endc,1:nlevdecomp)) + allocate(f_s1s3(bounds%begc:bounds%endc,1:nlevdecomp)) + + !------- time-constant coefficients ---------- ! + ! set soil organic matter compartment C:N ratios + cn_s1 = params_inst%cn_s1_bgc + cn_s2 = params_inst%cn_s2_bgc + cn_s3 = params_inst%cn_s3_bgc + + ! set respiration fractions for fluxes between compartments + rf_l1s1 = params_inst%rf_l1s1_bgc + rf_l2s1 = params_inst%rf_l2s1_bgc + rf_l3s2 = params_inst%rf_l3s2_bgc + rf_s2s1 = params_inst%rf_s2s1_bgc + rf_s2s3 = params_inst%rf_s2s3_bgc + rf_s3s1 = params_inst%rf_s3s1_bgc + + rf_cwdl2 = params_inst%rf_cwdl2_bgc + rf_cwdl3 = params_inst%rf_cwdl3_bgc + + ! set the cellulose and lignin fractions for coarse woody debris + cwd_fcel = params_inst%cwd_fcel_bgc + cwd_flig = params_inst%cwd_flig_bgc + + ! set path fractions + f_s2s1 = 0.42_r8/(0.45_r8) + f_s2s3 = 0.03_r8/(0.45_r8) + + ! some of these are dependent on the soil texture properties + do c = bounds%begc, bounds%endc + do j = 1, nlevdecomp + t = 0.85_r8 - 0.68_r8 * 0.01_r8 * (100._r8 - cellsand(c,j)) + f_s1s2(c,j) = 1._r8 - .004_r8 / (1._r8 - t) + f_s1s3(c,j) = .004_r8 / (1._r8 - t) + rf_s1s2(c,j) = t + rf_s1s3(c,j) = t + end do + end do + initial_stock_soildepth = params_inst%initial_Cstocks_depth + + !------------------- list of pools and their attributes ------------ + floating_cn_ratio_decomp_pools(i_litr1) = .true. + decomp_cascade_con%decomp_pool_name_restart(i_litr1) = 'litr1' + decomp_cascade_con%decomp_pool_name_history(i_litr1) = 'LITR1' + decomp_cascade_con%decomp_pool_name_long(i_litr1) = 'litter 1' + decomp_cascade_con%decomp_pool_name_short(i_litr1) = 'L1' + is_litter(i_litr1) = .true. + is_soil(i_litr1) = .false. + is_cwd(i_litr1) = .false. + initial_cn_ratio(i_litr1) = 90._r8 + initial_stock(i_litr1) = 0._r8 + is_metabolic(i_litr1) = .true. + is_cellulose(i_litr1) = .false. + is_lignin(i_litr1) = .false. + + floating_cn_ratio_decomp_pools(i_litr2) = .true. + decomp_cascade_con%decomp_pool_name_restart(i_litr2) = 'litr2' + decomp_cascade_con%decomp_pool_name_history(i_litr2) = 'LITR2' + decomp_cascade_con%decomp_pool_name_long(i_litr2) = 'litter 2' + decomp_cascade_con%decomp_pool_name_short(i_litr2) = 'L2' + is_litter(i_litr2) = .true. + is_soil(i_litr2) = .false. + is_cwd(i_litr2) = .false. + initial_cn_ratio(i_litr2) = 90._r8 + initial_stock(i_litr2) = 0._r8 + is_metabolic(i_litr2) = .false. + is_cellulose(i_litr2) = .true. + is_lignin(i_litr2) = .false. + + floating_cn_ratio_decomp_pools(i_litr3) = .true. + decomp_cascade_con%decomp_pool_name_restart(i_litr3) = 'litr3' + decomp_cascade_con%decomp_pool_name_history(i_litr3) = 'LITR3' + decomp_cascade_con%decomp_pool_name_long(i_litr3) = 'litter 3' + decomp_cascade_con%decomp_pool_name_short(i_litr3) = 'L3' + is_litter(i_litr3) = .true. + is_soil(i_litr3) = .false. + is_cwd(i_litr3) = .false. + initial_cn_ratio(i_litr3) = 90._r8 + initial_stock(i_litr3) = 0._r8 + is_metabolic(i_litr3) = .false. + is_cellulose(i_litr3) = .false. + is_lignin(i_litr3) = .true. + + if (.not. use_fates) then + ! CWD + floating_cn_ratio_decomp_pools(i_cwd) = .true. + decomp_cascade_con%decomp_pool_name_restart(i_cwd) = 'cwd' + decomp_cascade_con%decomp_pool_name_history(i_cwd) = 'CWD' + decomp_cascade_con%decomp_pool_name_long(i_cwd) = 'coarse woody debris' + decomp_cascade_con%decomp_pool_name_short(i_cwd) = 'CWD' + is_litter(i_cwd) = .false. + is_soil(i_cwd) = .false. + is_cwd(i_cwd) = .true. + initial_cn_ratio(i_cwd) = 90._r8 + initial_stock(i_cwd) = 0._r8 + is_metabolic(i_cwd) = .false. + is_cellulose(i_cwd) = .false. + is_lignin(i_cwd) = .false. + endif + + if (.not. use_fates) then + i_soil1 = 5 + else + i_soil1 = 4 + endif + floating_cn_ratio_decomp_pools(i_soil1) = .false. + decomp_cascade_con%decomp_pool_name_restart(i_soil1) = 'soil1' + decomp_cascade_con%decomp_pool_name_history(i_soil1) = 'SOIL1' + decomp_cascade_con%decomp_pool_name_long(i_soil1) = 'soil 1' + decomp_cascade_con%decomp_pool_name_short(i_soil1) = 'S1' + is_litter(i_soil1) = .false. + is_soil(i_soil1) = .true. + is_cwd(i_soil1) = .false. + initial_cn_ratio(i_soil1) = cn_s1 + initial_stock(i_soil1) = params_inst%initial_Cstocks(1) + is_metabolic(i_soil1) = .false. + is_cellulose(i_soil1) = .false. + is_lignin(i_soil1) = .false. + + if (.not. use_fates) then + i_soil2 = 6 + else + i_soil2 = 5 + endif + floating_cn_ratio_decomp_pools(i_soil2) = .false. + decomp_cascade_con%decomp_pool_name_restart(i_soil2) = 'soil2' + decomp_cascade_con%decomp_pool_name_history(i_soil2) = 'SOIL2' + decomp_cascade_con%decomp_pool_name_long(i_soil2) = 'soil 2' + decomp_cascade_con%decomp_pool_name_short(i_soil2) = 'S2' + is_litter(i_soil2) = .false. + is_soil(i_soil2) = .true. + is_cwd(i_soil2) = .false. + initial_cn_ratio(i_soil2) = cn_s2 + initial_stock(i_soil2) = params_inst%initial_Cstocks(2) + is_metabolic(i_soil2) = .false. + is_cellulose(i_soil2) = .false. + is_lignin(i_soil2) = .false. + + if (.not. use_fates) then + i_soil3 = 7 + else + i_soil3 = 6 + endif + floating_cn_ratio_decomp_pools(i_soil3) = .false. + decomp_cascade_con%decomp_pool_name_restart(i_soil3) = 'soil3' + decomp_cascade_con%decomp_pool_name_history(i_soil3) = 'SOIL3' + decomp_cascade_con%decomp_pool_name_long(i_soil3) = 'soil 3' + decomp_cascade_con%decomp_pool_name_short(i_soil3) = 'S3' + is_litter(i_soil3) = .false. + is_soil(i_soil3) = .true. + is_cwd(i_soil3) = .false. + initial_cn_ratio(i_soil3) = cn_s3 + initial_stock(i_soil3) = params_inst%initial_Cstocks(3) + is_metabolic(i_soil3) = .false. + is_cellulose(i_soil3) = .false. + is_lignin(i_soil3) = .false. + + + speedup_fac = 1._r8 + + !lit1 + spinup_factor(i_litr1) = 1._r8 + !lit2,3 + spinup_factor(i_litr2) = 1._r8 + spinup_factor(i_litr3) = 1._r8 + !CWD + if (.not. use_fates) then + spinup_factor(i_cwd) = max(1._r8, (speedup_fac * params_inst%tau_cwd_bgc / 2._r8 )) + end if + !som1 + spinup_factor(i_soil1) = 1._r8 + !som2,3 + spinup_factor(i_soil2) = max(1._r8, (speedup_fac * params_inst%tau_s2_bgc)) + spinup_factor(i_soil3) = max(1._r8, (speedup_fac * params_inst%tau_s3_bgc)) + + if ( masterproc ) then + write(iulog,*) 'Spinup_state ',spinup_state + write(iulog,*) 'Spinup factors ',spinup_factor + end if + + !---------------- list of transitions and their time-independent coefficients ---------------! + i_l1s1 = 1 + decomp_cascade_con%cascade_step_name(i_l1s1) = 'L1S1' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l1s1) = rf_l1s1 + cascade_donor_pool(i_l1s1) = i_litr1 + cascade_receiver_pool(i_l1s1) = i_soil1 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l1s1) = 1.0_r8 + + i_l2s1 = 2 + decomp_cascade_con%cascade_step_name(i_l2s1) = 'L2S1' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l2s1) = rf_l2s1 + cascade_donor_pool(i_l2s1) = i_litr2 + cascade_receiver_pool(i_l2s1) = i_soil1 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l2s1)= 1.0_r8 + + i_l3s2 = 3 + decomp_cascade_con%cascade_step_name(i_l3s2) = 'L3S2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l3s2) = rf_l3s2 + cascade_donor_pool(i_l3s2) = i_litr3 + cascade_receiver_pool(i_l3s2) = i_soil2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l3s2) = 1.0_r8 + + i_s1s2 = 4 + decomp_cascade_con%cascade_step_name(i_s1s2) = 'S1S2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s2) = rf_s1s2(bounds%begc:bounds%endc,1:nlevdecomp) + cascade_donor_pool(i_s1s2) = i_soil1 + cascade_receiver_pool(i_s1s2) = i_soil2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s2) = f_s1s2(bounds%begc:bounds%endc,1:nlevdecomp) + + if (use_soil_matrixcn)then !use fates will automatically turn off use_soil_matrixcn + i_cwdl2 = 5 + decomp_cascade_con%cascade_step_name(i_cwdl2) = 'CWDL2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl2) = rf_cwdl2 + cascade_donor_pool(i_cwdl2) = i_cwd + cascade_receiver_pool(i_cwdl2) = i_litr2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl2) = cwd_fcel + + i_cwdl3 = 6 + decomp_cascade_con%cascade_step_name(i_cwdl3) = 'CWDL3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl3) = rf_cwdl3 + cascade_donor_pool(i_cwdl3) = i_cwd + cascade_receiver_pool(i_cwdl3) = i_litr3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl3) = cwd_flig + + i_s1s3 = 7 + decomp_cascade_con%cascade_step_name(i_s1s3) = 'S1S3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s3) = rf_s1s3(bounds%begc:bounds%endc,1:nlevdecomp) + cascade_donor_pool(i_s1s3) = i_soil1 + cascade_receiver_pool(i_s1s3) = i_soil3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s3) = f_s1s3(bounds%begc:bounds%endc,1:nlevdecomp) + + i_s2s1 = 8 + decomp_cascade_con%cascade_step_name(i_s2s1) = 'S2S1' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s1) = rf_s2s1 + cascade_donor_pool(i_s2s1) = i_soil2 + cascade_receiver_pool(i_s2s1) = i_soil1 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s1) = f_s2s1 + + i_s2s3 = 9 + decomp_cascade_con%cascade_step_name(i_s2s3) = 'S2S3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s3) = rf_s2s3 + cascade_donor_pool(i_s2s3) = i_soil2 + cascade_receiver_pool(i_s2s3) = i_soil3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s3) = f_s2s3 + + i_s3s1 = 10 + decomp_cascade_con%cascade_step_name(i_s3s1) = 'S3S1' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s3s1) = rf_s3s1 + cascade_donor_pool(i_s3s1) = i_soil3 + cascade_receiver_pool(i_s3s1) = i_soil1 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s3s1) = 1.0_r8 + else + i_s1s3 = 5 + decomp_cascade_con%cascade_step_name(i_s1s3) = 'S1S3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s3) = rf_s1s3(bounds%begc:bounds%endc,1:nlevdecomp) + cascade_donor_pool(i_s1s3) = i_soil1 + cascade_receiver_pool(i_s1s3) = i_soil3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s3) = f_s1s3(bounds%begc:bounds%endc,1:nlevdecomp) + + i_s2s1 = 6 + decomp_cascade_con%cascade_step_name(i_s2s1) = 'S2S1' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s1) = rf_s2s1 + cascade_donor_pool(i_s2s1) = i_soil2 + cascade_receiver_pool(i_s2s1) = i_soil1 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s1) = f_s2s1 + + i_s2s3 = 7 + decomp_cascade_con%cascade_step_name(i_s2s3) = 'S2S3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s3) = rf_s2s3 + cascade_donor_pool(i_s2s3) = i_soil2 + cascade_receiver_pool(i_s2s3) = i_soil3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s3) = f_s2s3 + + i_s3s1 = 8 + decomp_cascade_con%cascade_step_name(i_s3s1) = 'S3S1' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s3s1) = rf_s3s1 + cascade_donor_pool(i_s3s1) = i_soil3 + cascade_receiver_pool(i_s3s1) = i_soil1 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s3s1) = 1.0_r8 + + if (.not. use_fates) then + i_cwdl2 = 9 + decomp_cascade_con%cascade_step_name(i_cwdl2) = 'CWDL2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl2) = rf_cwdl2 + cascade_donor_pool(i_cwdl2) = i_cwd + cascade_receiver_pool(i_cwdl2) = i_litr2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl2) = cwd_fcel + + i_cwdl3 = 10 + decomp_cascade_con%cascade_step_name(i_cwdl3) = 'CWDL3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl3) = rf_cwdl3 + cascade_donor_pool(i_cwdl3) = i_cwd + cascade_receiver_pool(i_cwdl3) = i_litr3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl3) = cwd_flig + end if + end if + + ! if(use_soil_matrixcn) call InitSoilTransfer() + + deallocate(rf_s1s2) + deallocate(rf_s1s3) + deallocate(f_s1s2) + deallocate(f_s1s3) + + end associate + + end subroutine init_decompcascade_bgc + + !----------------------------------------------------------------------- + subroutine decomp_rate_constants_bgc(bounds, num_soilc, filter_soilc, & + soilstate_inst, temperature_inst, ch4_inst, soilbiogeochem_carbonflux_inst) + ! + ! !DESCRIPTION: + ! calculate rate constants and decomposition pathways for the CENTURY decomposition cascade model + ! written by C. Koven based on original CLM4 decomposition cascade + ! + ! !USES: + use clm_time_manager , only : get_days_per_year, get_step_size + use shr_const_mod , only : SHR_CONST_PI + use clm_varcon , only : secspday + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(ch4_type) , intent(in) :: ch4_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + ! + ! !LOCAL VARIABLES: + real(r8):: frw(bounds%begc:bounds%endc) ! rooting fraction weight + real(r8), allocatable:: fr(:,:) ! column-level rooting fraction by soil depth + real(r8):: psi ! temporary soilpsi for water scalar + real(r8):: rate_scalar ! combined rate scalar for decomp + real(r8):: k_l1 ! decomposition rate constant litter 1 (1/sec) + real(r8):: k_l2_l3 ! decomposition rate constant litter 2 and litter 3 (1/sec) + real(r8):: k_s1 ! decomposition rate constant SOM 1 (1/sec) + real(r8):: k_s2 ! decomposition rate constant SOM 2 (1/sec) + real(r8):: k_s3 ! decomposition rate constant SOM 3 (1/sec) + real(r8):: k_frag ! fragmentation rate constant CWD (1/sec) + real(r8):: cwdc_loss ! fragmentation rate for CWD carbon (gC/m2/s) + real(r8):: cwdn_loss ! fragmentation rate for CWD nitrogen (gN/m2/s) + real(r8):: Q10 ! temperature dependence + real(r8):: froz_q10 ! separate q10 for frozen soil respiration rates. default to same as above zero rates + real(r8):: decomp_depth_efolding ! (meters) e-folding depth for reduction in decomposition [ + integer :: c, fc, j, k, l + real(r8):: dt ! decomposition time step + real(r8):: catanf ! hyperbolic temperature function from CENTURY + real(r8):: catanf_30 ! reference rate at 30C + real(r8):: t1 ! temperature argument + real(r8):: normalization_factor ! factor by which to offset the decomposition rates frm century to a q10 formulation + real(r8):: days_per_year ! days per year + real(r8):: depth_scalar(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8):: mino2lim !minimum anaerobic decomposition rate + real(r8):: spinup_geogterm_l1(bounds%begc:bounds%endc) ! geographically-varying spinup term for l1 + real(r8):: spinup_geogterm_l23(bounds%begc:bounds%endc) ! geographically-varying spinup term for l2 and l3 + real(r8):: spinup_geogterm_cwd(bounds%begc:bounds%endc) ! geographically-varying spinup term for cwd + real(r8):: spinup_geogterm_s1(bounds%begc:bounds%endc) ! geographically-varying spinup term for s1 + real(r8):: spinup_geogterm_s2(bounds%begc:bounds%endc) ! geographically-varying spinup term for s2 + real(r8):: spinup_geogterm_s3(bounds%begc:bounds%endc) ! geographically-varying spinup term for s3 + + !----------------------------------------------------------------------- + + !----- CENTURY T response function + catanf(t1) = 11.75_r8 +(29.7_r8 / SHR_CONST_PI) * atan( SHR_CONST_PI * 0.031_r8 * ( t1 - 15.4_r8 )) + + associate( & + minpsi => params_inst%minpsi_bgc , & ! Input: [real(r8) ] minimum soil suction (mm) + maxpsi => params_inst%maxpsi_bgc , & ! Input: [real(r8) ] maximum soil suction (mm) + soilpsi => soilstate_inst%soilpsi_col , & ! Input: [real(r8) (:,:) ] soil water potential in each soil layer (MPa) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + + o2stress_sat => ch4_inst%o2stress_sat_col , & ! Input: [real(r8) (:,:) ] Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) + o2stress_unsat => ch4_inst%o2stress_unsat_col , & ! Input: [real(r8) (:,:) ] Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) + finundated => ch4_inst%finundated_col , & ! Input: [real(r8) (:) ] fractional inundated area + + t_scalar => soilbiogeochem_carbonflux_inst%t_scalar_col , & ! Output: [real(r8) (:,:) ] soil temperature scalar for decomp + w_scalar => soilbiogeochem_carbonflux_inst%w_scalar_col , & ! Output: [real(r8) (:,:) ] soil water scalar for decomp + o_scalar => soilbiogeochem_carbonflux_inst%o_scalar_col , & ! Output: [real(r8) (:,:) ] fraction by which decomposition is limited by anoxia + decomp_k => soilbiogeochem_carbonflux_inst%decomp_k_col , & ! Output: [real(r8) (:,:,:) ] rate constant for decomposition (1./sec) + ! Ksoil => soilbiogeochem_carbonflux_inst%Ksoil , & ! Output: [real(r8) (:,:,:) ] rate constant for decomposition (1./sec) + spinup_factor => decomp_cascade_con%spinup_factor & ! Input: [real(r8) (:) ] factor for AD spinup associated with each pool +! matrix_decomp_k => soilbiogeochem_carbonflux_inst%matrix_decomp_k_col & ! Output: [real(r8) (:,:,:) ] rate constant for decomposition (1./sec) + ) + + mino2lim = CNParamsShareInst%mino2lim + + if ( use_century_tfunc .and. normalize_q10_to_century_tfunc ) then + call endrun(msg='ERROR: cannot have both use_century_tfunc and normalize_q10_to_century_tfunc set as true'//& + errMsg(sourcefile, __LINE__)) + endif + + days_per_year = get_days_per_year() + dt = real( get_step_size(), r8 ) + + ! set "Q10" parameter + Q10 = CNParamsShareInst%Q10 + + ! set "froz_q10" parameter + froz_q10 = CNParamsShareInst%froz_q10 + + ! Set "decomp_depth_efolding" parameter + decomp_depth_efolding = CNParamsShareInst%decomp_depth_efolding + + ! translate to per-second time constant + k_l1 = 1._r8 / (secspday * days_per_year * params_inst%tau_l1_bgc) + k_l2_l3 = 1._r8 / (secspday * days_per_year * params_inst%tau_l2_l3_bgc) + k_s1 = 1._r8 / (secspday * days_per_year * params_inst%tau_s1_bgc) + k_s2 = 1._r8 / (secspday * days_per_year * params_inst%tau_s2_bgc) + k_s3 = 1._r8 / (secspday * days_per_year * params_inst%tau_s3_bgc) + k_frag = 1._r8 / (secspday * days_per_year * params_inst%tau_cwd_bgc) + + ! calc ref rate + catanf_30 = catanf(30._r8) + + if ( spinup_state >= 1 ) then + do fc = 1,num_soilc + c = filter_soilc(fc) + ! + if ( abs(spinup_factor(i_litr1) - 1._r8) .gt. .000001_r8) then + spinup_geogterm_l1(c) = spinup_factor(i_litr1) * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + else + spinup_geogterm_l1(c) = 1._r8 + endif + ! + if ( abs(spinup_factor(i_litr2) - 1._r8) .gt. .000001_r8) then + spinup_geogterm_l23(c) = spinup_factor(i_litr2) * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + else + spinup_geogterm_l23(c) = 1._r8 + endif + ! + if ( .not. use_fates ) then + if ( abs(spinup_factor(i_cwd) - 1._r8) .gt. .000001_r8) then + spinup_geogterm_cwd(c) = spinup_factor(i_cwd) * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + else + spinup_geogterm_cwd(c) = 1._r8 + endif + endif + ! + if ( abs(spinup_factor(i_soil1) - 1._r8) .gt. .000001_r8) then + spinup_geogterm_s1(c) = spinup_factor(i_soil1) * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + else + spinup_geogterm_s1(c) = 1._r8 + endif + ! + if ( abs(spinup_factor(i_soil2) - 1._r8) .gt. .000001_r8) then + spinup_geogterm_s2(c) = spinup_factor(i_soil2) * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + else + spinup_geogterm_s2(c) = 1._r8 + endif + ! + if ( abs(spinup_factor(i_soil3) - 1._r8) .gt. .000001_r8) then + spinup_geogterm_s3(c) = spinup_factor(i_soil3) * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + else + spinup_geogterm_s3(c) = 1._r8 + endif + ! + end do + else + do fc = 1,num_soilc + c = filter_soilc(fc) + spinup_geogterm_l1(c) = 1._r8 + spinup_geogterm_l23(c) = 1._r8 + spinup_geogterm_cwd(c) = 1._r8 + spinup_geogterm_s1(c) = 1._r8 + spinup_geogterm_s2(c) = 1._r8 + spinup_geogterm_s3(c) = 1._r8 + end do + endif + + !--- time dependent coefficients-----! + if ( nlevdecomp .eq. 1 ) then + + ! calculate function to weight the temperature and water potential scalars + ! for decomposition control. + + + ! the following normalizes values in fr so that they + ! sum to 1.0 across top nlevdecomp levels on a column + frw(bounds%begc:bounds%endc) = 0._r8 + !nlev_soildecomp_standard=5 + allocate(fr(bounds%begc:bounds%endc,nlev_soildecomp_standard)) + do j=1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + frw(c) = frw(c) + col%dz(c,j) + end do + end do + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + if (frw(c) /= 0._r8) then + fr(c,j) = col%dz(c,j) / frw(c) + else + fr(c,j) = 0._r8 + end if + end do + end do + + 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 25 C. + + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + if (j==1) t_scalar(c,:) = 0._r8 + if (t_soisno(c,j) >= SHR_CONST_TKFRZ) then + t_scalar(c,1)=t_scalar(c,1) + & + (Q10**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8))*fr(c,j) + else + t_scalar(c,1)=t_scalar(c,1) + & + (Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-SHR_CONST_TKFRZ)/10._r8))*fr(c,j) + endif + end do + end do + + else + ! original century uses an arctangent function to calculate the temperature dependence of decomposition + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + if (j==1) t_scalar(c,:) = 0._r8 + + t_scalar(c,1)=t_scalar(c,1) +max(catanf(t_soisno(c,j)-SHR_CONST_TKFRZ)/catanf_30*fr(c,j),0.01_r8) + end do + end do + + endif + + ! calculate the rate constant scalar for soil water content. + ! Uses the log relationship with water potential given in + ! Andren, O., and K. Paustian, 1987. Barley straw decomposition in the field: + ! a comparison of models. Ecology, 68(5):1190-1200. + ! and supported by data in + ! Orchard, V.A., and F.J. Cook, 1983. Relationship between soil respiration + ! and soil moisture. Soil Biol. Biochem., 15(4):447-453. + + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + if (j==1) w_scalar(c,:) = 0._r8 + psi = min(soilpsi(c,j),maxpsi) + ! decomp only if soilpsi is higher than minpsi + if (psi > minpsi) then + w_scalar(c,1) = w_scalar(c,1) + (log(minpsi/psi)/log(minpsi/maxpsi))*fr(c,j) + end if + end do + end do + + if (use_lch4) then + ! Calculate ANOXIA + if (anoxia) then + ! Check for anoxia w/o LCH4 now done in controlMod. + + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (j==1) o_scalar(c,:) = 0._r8 + + o_scalar(c,1) = o_scalar(c,1) + fr(c,j) * max(o2stress_unsat(c,j), mino2lim) + end do + end do + else + o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 + end if + else + o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 + end if + + deallocate(fr) + + else + + 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 25 C. + ! Peter Thornton: 3/13/09 + ! Replaced the Lloyd and Taylor function with a Q10 formula, with Q10 = 1.5 + ! as part of the modifications made to improve the seasonal cycle of + ! atmospheric CO2 concentration in global simulations. This does not impact + ! the base rates at 25 C, which are calibrated from microcosm studies. + + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if (t_soisno(c,j) >= SHR_CONST_TKFRZ) then + t_scalar(c,j)= (Q10**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8)) + else + t_scalar(c,j)= (Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-SHR_CONST_TKFRZ)/10._r8)) + endif + end do + end do + + else + + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + t_scalar(c,j)= max(catanf(t_soisno(c,j)-SHR_CONST_TKFRZ)/catanf_30, 0.01_r8) + end do + end do + + endif + + ! calculate the rate constant scalar for soil water content. + ! Uses the log relationship with water potential given in + ! Andren, O., and K. Paustian, 1987. Barley straw decomposition in the field: + ! a comparison of models. Ecology, 68(5):1190-1200. + ! and supported by data in + ! Orchard, V.A., and F.J. Cook, 1983. Relationship between soil respiration + ! and soil moisture. Soil Biol. Biochem., 15(4):447-453. + + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + psi = min(soilpsi(c,j),maxpsi) + ! decomp only if soilpsi is higher than minpsi + if (psi > minpsi) then + w_scalar(c,j) = (log(minpsi/psi)/log(minpsi/maxpsi)) + else + w_scalar(c,j) = 0._r8 + end if + end do + end do + + if (use_lch4) then + ! Calculate ANOXIA + ! Check for anoxia w/o LCH4 now done in controlMod. + + if (anoxia) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + o_scalar(c,j) = max(o2stress_unsat(c,j), mino2lim) + end do + end do + else + o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 + end if + else + o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 + end if + + end if + + if ( normalize_q10_to_century_tfunc ) then + ! scale all decomposition rates by a constant to compensate for offset between original CENTURY temp func and Q10 + normalization_factor = (catanf(normalization_tref)/catanf_30) / (q10**((normalization_tref-25._r8)/10._r8)) + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + t_scalar(c,j) = t_scalar(c,j) * normalization_factor + end do + end do + endif + + if (use_vertsoilc) then + ! add a term to reduce decomposition rate at depth + ! for now used a fixed e-folding depth + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + depth_scalar(c,j) = exp(-zsoi(j)/decomp_depth_efolding) + end do + end do + end if + + ! calculate rate constants for all litter and som pools + if (use_vertsoilc) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + decomp_k(c,j,i_litr1) = k_l1 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) & + * spinup_geogterm_l1(c) + decomp_k(c,j,i_litr2) = k_l2_l3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) & + * spinup_geogterm_l23(c) + decomp_k(c,j,i_litr3) = k_l2_l3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) & + * spinup_geogterm_l23(c) + decomp_k(c,j,i_soil1) = k_s1 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) & + * spinup_geogterm_s1(c) + decomp_k(c,j,i_soil2) = k_s2 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) & + * spinup_geogterm_s2(c) + decomp_k(c,j,i_soil3) = k_s3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) & + * spinup_geogterm_s3(c) +! if(use_soil_matrixcn)then +! Ksoil%DM(c,j+nlevdecomp*(i_litr1-1)) = k_l1 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l1(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_litr2-1)) = k_l2_l3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l23(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_litr3-1)) = k_l2_l3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l23(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_soil1-1)) = k_s1 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s1(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_soil2-1)) = k_s2 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s2(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_soil3-1)) = k_s3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s3(c) * dt +! end if !use_soil_matrixcn + end do + end do + else + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + decomp_k(c,j,i_litr1) = k_l1 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l1(c) + decomp_k(c,j,i_litr2) = k_l2_l3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l23(c) + decomp_k(c,j,i_litr3) = k_l2_l3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l23(c) + decomp_k(c,j,i_soil1) = k_s1 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s1(c) + decomp_k(c,j,i_soil2) = k_s2 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s2(c) + decomp_k(c,j,i_soil3) = k_s3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s3(c) +! if(use_soil_matrixcn)then +! Ksoil%DM(c,j+nlevdecomp*(i_litr1-1)) = k_l1 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l1(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_litr2-1)) = k_l2_l3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l23(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_litr3-1)) = k_l2_l3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_l23(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_soil1-1)) = k_s1 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s1(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_soil2-1)) = k_s2 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s2(c) * dt +! Ksoil%DM(c,j+nlevdecomp*(i_soil3-1)) = k_s3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) * spinup_geogterm_s3(c) * dt +! end if !use_soil_matrixcn + end do + end do + end if + + ! do the same for cwd, but only if fates is not enabled, because fates handles CWD on its own structure + if (.not. use_fates) then + if (use_vertsoilc) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + decomp_k(c,j,i_cwd) = k_frag * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * & + o_scalar(c,j) * spinup_geogterm_cwd(c) +! if(use_soil_matrixcn)then +! Ksoil%DM(c,j+nlevdecomp*(i_cwd-1)) = k_frag * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * & +! o_scalar(c,j) * spinup_geogterm_cwd(c) * dt +! end if !use_soil_matrixcn + end do + end do + else + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + decomp_k(c,j,i_cwd) = k_frag * t_scalar(c,j) * w_scalar(c,j) * & + o_scalar(c,j) * spinup_geogterm_cwd(c) +! if(use_soil_matrixcn)then +! Ksoil%DM(c,j+nlevdecomp*(i_cwd-1)) = k_frag * t_scalar(c,j) * w_scalar(c,j) * & +! o_scalar(c,j) * spinup_geogterm_cwd(c) * dt +! end if !use_soil_matrixcn + end do + end do + end if + end if + + end associate + + end subroutine decomp_rate_constants_bgc + +end module SoilBiogeochemDecompCascadeBGCMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeCNMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeCNMod.F90 new file mode 100755 index 000000000..54ea95761 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeCNMod.F90 @@ -0,0 +1,996 @@ +module SoilBiogeochemDecompCascadeCNMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Sets the coeffiecients used in the decomposition cascade submodel. + ! This uses the CN parameters as in CLMCN 4.0 + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_TKFRZ + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : nlevsoi, nlevgrnd, nlevdecomp, ndecomp_cascade_transitions, ndecomp_pools + use clm_varpar , only : i_met_lit, i_cel_lit, i_lig_lit, i_cwd + use clm_varctl , only : iulog, spinup_state, anoxia, use_lch4, use_vertsoilc, use_fates, use_soil_matrixcn + use clm_varcon , only : zsoi + use decompMod , only : bounds_type + use abortutils , only : endrun + use CNSharedParamsMod , only : CNParamsShareInst, nlev_soildecomp_standard + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use ch4Mod , only : ch4_type + use ColumnType , only : col + + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: readParams + public :: init_decompcascade_cn + public :: decomp_rate_constants_cn + + type, private :: params_type + real(r8):: cn_s1_cn !C:N for SOM 1 + real(r8):: cn_s2_cn !C:N for SOM 2 + real(r8):: cn_s3_cn !C:N for SOM 3 + real(r8):: cn_s4_cn !C:N for SOM 4 + + real(r8):: rf_l1s1_cn !respiration fraction litter 1 -> SOM 1 + real(r8):: rf_l2s2_cn !respiration fraction litter 2 -> SOM 2 + real(r8):: rf_l3s3_cn !respiration fraction litter 3 -> SOM 3 + real(r8):: rf_s1s2_cn !respiration fraction SOM 1 -> SOM 2 + real(r8):: rf_s2s3_cn !respiration fraction SOM 2 -> SOM 3 + real(r8):: rf_s3s4_cn !respiration fraction SOM 3 -> SOM 4 + + real(r8) :: cwd_fcel_cn !cellulose fraction for CWD + real(r8) :: cwd_flig_cn ! + + real(r8) :: k_l1_cn !decomposition rate for litter 1 + real(r8) :: k_l2_cn !decomposition rate for litter 2 + real(r8) :: k_l3_cn !decomposition rate for litter 3 + real(r8) :: k_s1_cn !decomposition rate for SOM 1 + real(r8) :: k_s2_cn !decomposition rate for SOM 2 + real(r8) :: k_s3_cn !decomposition rate for SOM 3 + real(r8) :: k_s4_cn !decomposition rate for SOM 4 + + real(r8) :: k_frag_cn !fragmentation rate for CWD + real(r8) :: minpsi_cn !minimum soil water potential for heterotrophic resp + real(r8) :: maxpsi_cn !maximum soil water potential for heterotrophic resp + + integer :: nsompools = 4 + real(r8), allocatable :: spinup_vector(:) ! multipliers for soil decomp during accelerated spinup + + end type params_type + ! + type(params_type), private :: params_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !USES: + use ncdio_pio , only : file_desc_t,ncd_io + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !CALLED FROM: readParamsMod.F90::CNParamsReadFile + ! + ! !REVISION HISTORY: + ! Dec 3 2012 : Created by S. Muszala + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'SoilBiogeochemDecompCnParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + + !EOP + !----------------------------------------------------------------------- + + ! These are not read off of netcdf file + allocate(params_inst%spinup_vector(params_inst%nsompools)) + params_inst%spinup_vector(:) = (/ 1.0_r8, 1.0_r8, 5.0_r8, 70.0_r8 /) + + ! Read off of netcdf file + tString='cn_s1' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cn_s1_cn=tempr + + tString='cn_s2' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cn_s2_cn=tempr + + tString='cn_s3' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cn_s3_cn=tempr + + tString='cn_s4' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cn_s4_cn=tempr + + tString='rf_l1s1' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_l1s1_cn=tempr + + tString='rf_l2s2' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_l2s2_cn=tempr + + tString='rf_l3s3' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_l3s3_cn=tempr + + tString='rf_s1s2' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_s1s2_cn=tempr + + tString='rf_s2s3' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_s2s3_cn=tempr + + tString='rf_s3s4' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rf_s3s4_cn=tempr + + tString='cwd_fcel' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cwd_fcel_cn=tempr + + tString='k_l1' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_l1_cn=tempr + + tString='k_l2' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_l2_cn=tempr + + tString='k_l3' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_l3_cn=tempr + + tString='k_s1' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_s1_cn=tempr + + tString='k_s2' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_s2_cn=tempr + + tString='k_s3' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_s3_cn=tempr + + tString='k_s4' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_s4_cn=tempr + + tString='k_frag' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_frag_cn=tempr + + tString='minpsi_hr' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%minpsi_cn=tempr + + tString='maxpsi_hr' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%maxpsi_cn=tempr + + tString='cwd_flig' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cwd_flig_cn=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine init_decompcascade_cn(bounds, soilbiogeochem_state_inst) + ! + ! !DESCRIPTION: + ! initialize rate constants and decomposition pathways for the BGC model originally implemented in CLM-CN + ! written by C. Koven based on original CLM4 decomposition cascade by P. Thornton + ! + ! !USES: + use SoilBiogeochemDecompCascadeConType, only : i_atm + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + ! + !-- properties of each pathway along decomposition cascade + !-- properties of each decomposing pool + real(r8) :: rf_l1s1 !respiration fraction litter 1 -> SOM 1 + real(r8) :: rf_l2s2 !respiration fraction litter 2 -> SOM 2 + real(r8) :: rf_l3s3 !respiration fraction litter 3 -> SOM 3 + real(r8) :: rf_s1s2 !respiration fraction SOM 1 -> SOM 2 + real(r8) :: rf_s2s3 !respiration fraction SOM 2 -> SOM 3 + real(r8) :: rf_s3s4 !respiration fraction SOM 3 -> SOM 4 + real(r8) :: cwd_fcel + real(r8) :: cwd_flig + real(r8) :: cn_s1 + real(r8) :: cn_s2 + real(r8) :: cn_s3 + real(r8) :: cn_s4 + + integer :: i_litr1 + integer :: i_litr2 + integer :: i_litr3 + integer :: i_soil1 + integer :: i_soil2 + integer :: i_soil3 + integer :: i_soil4 + integer :: i_l1s1 + integer :: i_l2s2 + integer :: i_l3s3 + integer :: i_s1s2 + integer :: i_s2s3 + integer :: i_s3s4 + integer :: i_s4atm + integer :: i_cwdl2 + integer :: i_cwdl3 + !----------------------------------------------------------------------- + + associate( & + rf_decomp_cascade => soilbiogeochem_state_inst%rf_decomp_cascade_col , & ! Output: [real(r8) (:,:,:) ] respired fraction in decomposition step (frac) + pathfrac_decomp_cascade => soilbiogeochem_state_inst%pathfrac_decomp_cascade_col , & ! Output: [real(r8) (:,:,:) ] what fraction of C leaving a given pool passes through a given transition (frac) + + cascade_donor_pool => decomp_cascade_con%cascade_donor_pool , & ! Output: [integer (:) ] which pool is C taken from for a given decomposition step + cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool , & ! Output: [integer (:) ] which pool is C added to for a given decomposition step + floating_cn_ratio_decomp_pools => decomp_cascade_con%floating_cn_ratio_decomp_pools , & ! Output: [logical (:) ] TRUE => pool has fixed C:N ratio + is_litter => decomp_cascade_con%is_litter , & ! Output: [logical (:) ] TRUE => pool is a litter pool + is_soil => decomp_cascade_con%is_soil , & ! Output: [logical (:) ] TRUE => pool is a soil pool + is_cwd => decomp_cascade_con%is_cwd , & ! Output: [logical (:) ] TRUE => pool is a cwd pool + initial_cn_ratio => decomp_cascade_con%initial_cn_ratio , & ! Output: [real(r8) (:) ] c:n ratio for initialization of pools + initial_stock => decomp_cascade_con%initial_stock , & ! Output: [real(r8) (:) ] initial concentration for seeding at spinup + is_metabolic => decomp_cascade_con%is_metabolic , & ! Output: [logical (:) ] TRUE => pool is metabolic material + is_cellulose => decomp_cascade_con%is_cellulose , & ! Output: [logical (:) ] TRUE => pool is cellulose + is_lignin => decomp_cascade_con%is_lignin , & ! Output: [logical (:) ] TRUE => pool is lignin + spinup_factor => decomp_cascade_con%spinup_factor & ! Output: [real(r8) (:) ] factor for AD spinup associated with each pool + ) + + !------- time-constant coefficients ---------- ! + ! set soil organic matter compartment C:N ratios (from Biome-BGC v4.2.0) + cn_s1=params_inst%cn_s1_cn + cn_s2=params_inst%cn_s2_cn + cn_s3=params_inst%cn_s3_cn + cn_s4=params_inst%cn_s4_cn + + ! set respiration fractions for fluxes between compartments + ! (from Biome-BGC v4.2.0) + rf_l1s1=params_inst%rf_l1s1_cn + rf_l2s2=params_inst%rf_l2s2_cn + rf_l3s3=params_inst%rf_l3s3_cn + rf_s1s2=params_inst%rf_s1s2_cn + rf_s2s3=params_inst%rf_s2s3_cn + rf_s3s4=params_inst%rf_s3s4_cn + + ! set the cellulose and lignin fractions for coarse woody debris + cwd_fcel=params_inst%cwd_fcel_cn + cwd_flig=params_inst%cwd_flig_cn + + !------------------- list of pools and their attributes ------------ + + i_litr1 = i_met_lit + floating_cn_ratio_decomp_pools(i_litr1) = .true. + decomp_cascade_con%decomp_pool_name_restart(i_litr1) = 'litr1' + decomp_cascade_con%decomp_pool_name_history(i_litr1) = 'LITR1' + decomp_cascade_con%decomp_pool_name_long(i_litr1) = 'litter 1' + decomp_cascade_con%decomp_pool_name_short(i_litr1) = 'L1' + is_litter(i_litr1) = .true. + is_soil(i_litr1) = .false. + is_cwd(i_litr1) = .false. + initial_cn_ratio(i_litr1) = 90._r8 + initial_stock(i_litr1) = 0._r8 + is_metabolic(i_litr1) = .true. + is_cellulose(i_litr1) = .false. + is_lignin(i_litr1) = .false. + + i_litr2 = i_cel_lit + floating_cn_ratio_decomp_pools(i_litr2) = .true. + decomp_cascade_con%decomp_pool_name_restart(i_litr2) = 'litr2' + decomp_cascade_con%decomp_pool_name_history(i_litr2) = 'LITR2' + decomp_cascade_con%decomp_pool_name_long(i_litr2) = 'litter 2' + decomp_cascade_con%decomp_pool_name_short(i_litr2) = 'L2' + is_litter(i_litr2) = .true. + is_soil(i_litr2) = .false. + is_cwd(i_litr2) = .false. + initial_cn_ratio(i_litr2) = 90._r8 + initial_stock(i_litr2) = 0._r8 + is_metabolic(i_litr2) = .false. + is_cellulose(i_litr2) = .true. + is_lignin(i_litr2) = .false. + + i_litr3 = i_lig_lit + floating_cn_ratio_decomp_pools(i_litr3) = .true. + decomp_cascade_con%decomp_pool_name_restart(i_litr3) = 'litr3' + decomp_cascade_con%decomp_pool_name_history(i_litr3) = 'LITR3' + decomp_cascade_con%decomp_pool_name_long(i_litr3) = 'litter 3' + decomp_cascade_con%decomp_pool_name_short(i_litr3) = 'L3' + is_litter(i_litr3) = .true. + is_soil(i_litr3) = .false. + is_cwd(i_litr3) = .false. + initial_cn_ratio(i_litr3) = 90._r8 + initial_stock(i_litr3) = 0._r8 + is_metabolic(i_litr3) = .false. + is_cellulose(i_litr3) = .false. + is_lignin(i_litr3) = .true. + + if (.not. use_fates) then + floating_cn_ratio_decomp_pools(i_cwd) = .true. + decomp_cascade_con%decomp_pool_name_restart(i_cwd) = 'cwd' + decomp_cascade_con%decomp_pool_name_history(i_cwd) = 'CWD' + decomp_cascade_con%decomp_pool_name_long(i_cwd) = 'coarse woody debris' + decomp_cascade_con%decomp_pool_name_short(i_cwd) = 'CWD' + is_litter(i_cwd) = .false. + is_soil(i_cwd) = .false. + is_cwd(i_cwd) = .true. + initial_cn_ratio(i_cwd) = 500._r8 + initial_stock(i_cwd) = 0._r8 + is_metabolic(i_cwd) = .false. + is_cellulose(i_cwd) = .false. + is_lignin(i_cwd) = .false. + end if + + if ( .not. use_fates ) then + i_soil1 = 5 + else + i_soil1 = 4 + endif + floating_cn_ratio_decomp_pools(i_soil1) = .false. + decomp_cascade_con%decomp_pool_name_restart(i_soil1) = 'soil1' + decomp_cascade_con%decomp_pool_name_history(i_soil1) = 'SOIL1' + decomp_cascade_con%decomp_pool_name_long(i_soil1) = 'soil 1' + decomp_cascade_con%decomp_pool_name_short(i_soil1) = 'S1' + is_litter(i_soil1) = .false. + is_soil(i_soil1) = .true. + is_cwd(i_soil1) = .false. + initial_cn_ratio(i_soil1) = cn_s1 + initial_stock(i_soil1) = 0._r8 + is_metabolic(i_soil1) = .false. + is_cellulose(i_soil1) = .false. + is_lignin(i_soil1) = .false. + + if ( .not. use_fates ) then + i_soil2 = 6 + else + i_soil2 = 5 + endif + floating_cn_ratio_decomp_pools(i_soil2) = .false. + decomp_cascade_con%decomp_pool_name_restart(i_soil2) = 'soil2' + decomp_cascade_con%decomp_pool_name_history(i_soil2) = 'SOIL2' + decomp_cascade_con%decomp_pool_name_long(i_soil2) = 'soil 2' + decomp_cascade_con%decomp_pool_name_short(i_soil2) = 'S2' + is_litter(i_soil2) = .false. + is_soil(i_soil2) = .true. + is_cwd(i_soil2) = .false. + initial_cn_ratio(i_soil2) = cn_s2 + initial_stock(i_soil2) = 0._r8 + is_metabolic(i_soil2) = .false. + is_cellulose(i_soil2) = .false. + is_lignin(i_soil2) = .false. + + if ( .not. use_fates ) then + i_soil3 = 7 + else + i_soil3 = 6 + endif + floating_cn_ratio_decomp_pools(i_soil3) = .false. + decomp_cascade_con%decomp_pool_name_restart(i_soil3) = 'soil3' + decomp_cascade_con%decomp_pool_name_history(i_soil3) = 'SOIL3' + decomp_cascade_con%decomp_pool_name_long(i_soil3) = 'soil 3' + decomp_cascade_con%decomp_pool_name_short(i_soil3) = 'S3' + is_litter(i_soil3) = .false. + is_soil(i_soil3) = .true. + is_cwd(i_soil3) = .false. + initial_cn_ratio(i_soil3) = cn_s3 + initial_stock(i_soil3) = 0._r8 + is_metabolic(i_soil3) = .false. + is_cellulose(i_soil3) = .false. + is_lignin(i_soil3) = .false. + + if ( .not. use_fates ) then + i_soil4 = 8 + else + i_soil4 = 7 + endif + floating_cn_ratio_decomp_pools(i_soil4) = .false. + decomp_cascade_con%decomp_pool_name_restart(i_soil4) = 'soil4' + decomp_cascade_con%decomp_pool_name_history(i_soil4) = 'SOIL4' + decomp_cascade_con%decomp_pool_name_long(i_soil4) = 'soil 4' + decomp_cascade_con%decomp_pool_name_short(i_soil4) = 'S4' + is_litter(i_soil4) = .false. + is_soil(i_soil4) = .true. + is_cwd(i_soil4) = .false. + initial_cn_ratio(i_soil4) = cn_s4 + initial_stock(i_soil4) = 10._r8 + is_metabolic(i_soil4) = .false. + is_cellulose(i_soil4) = .false. + is_lignin(i_soil4) = .false. + + floating_cn_ratio_decomp_pools(i_atm) = .false. + decomp_cascade_con%decomp_pool_name_restart(i_atm) = 'atmosphere' + decomp_cascade_con%decomp_pool_name_history(i_atm) = 'atmosphere' + decomp_cascade_con%decomp_pool_name_long(i_atm) = 'atmosphere' + decomp_cascade_con%decomp_pool_name_short(i_atm) = '' + is_litter(i_atm) = .true. + is_soil(i_atm) = .false. + is_cwd(i_atm) = .false. + initial_cn_ratio(i_atm) = 0._r8 + initial_stock(i_atm) = 0._r8 + is_metabolic(i_atm) = .false. + is_cellulose(i_atm) = .false. + is_lignin(i_atm) = .false. + + + spinup_factor(i_litr1) = 1._r8 + spinup_factor(i_litr2) = 1._r8 + spinup_factor(i_litr3) = 1._r8 + if (.not. use_fates) then + spinup_factor(i_cwd) = 1._r8 + end if + spinup_factor(i_soil1) = params_inst%spinup_vector(1) + spinup_factor(i_soil2) = params_inst%spinup_vector(2) + spinup_factor(i_soil3) = params_inst%spinup_vector(3) + spinup_factor(i_soil4) = params_inst%spinup_vector(4) + + + !---------------- list of transitions and their time-independent coefficients ---------------! + i_l1s1 = 1 + decomp_cascade_con%cascade_step_name(i_l1s1) = 'L1S1' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l1s1) = rf_l1s1 + cascade_donor_pool(i_l1s1) = i_litr1 + cascade_receiver_pool(i_l1s1) = i_soil1 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l1s1) = 1.0_r8 + + i_l2s2 = 2 + decomp_cascade_con%cascade_step_name(i_l2s2) = 'L2S2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l2s2) = rf_l2s2 + cascade_donor_pool(i_l2s2) = i_litr2 + cascade_receiver_pool(i_l2s2) = i_soil2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l2s2) = 1.0_r8 + + i_l3s3 = 3 + decomp_cascade_con%cascade_step_name(i_l3s3) = 'L3S3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l3s3) = rf_l3s3 + cascade_donor_pool(i_l3s3) = i_litr3 + cascade_receiver_pool(i_l3s3) = i_soil3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_l3s3) = 1.0_r8 + + if (use_soil_matrixcn)then !use fates will automatically turn off use_soil_matrixcn + i_cwdl2 = 4 + decomp_cascade_con%cascade_step_name(i_cwdl2) = 'CWDL2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl2) = 0._r8 + cascade_donor_pool(i_cwdl2) = i_cwd + cascade_receiver_pool(i_cwdl2) = i_litr2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl2) = cwd_fcel + + i_cwdl3 = 5 + decomp_cascade_con%cascade_step_name(i_cwdl3) = 'CWDL3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl3) = 0._r8 + cascade_donor_pool(i_cwdl3) = i_cwd + cascade_receiver_pool(i_cwdl3) = i_litr3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl3) = cwd_flig + + i_s1s2 = 6 + decomp_cascade_con%cascade_step_name(i_s1s2) = 'S1S2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s2) = rf_s1s2 + cascade_donor_pool(i_s1s2) = i_soil1 + cascade_receiver_pool(i_s1s2) = i_soil2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s2) = 1.0_r8 + + i_s2s3 = 7 + decomp_cascade_con%cascade_step_name(i_s2s3) = 'S2S3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s3) = rf_s2s3 + cascade_donor_pool(i_s2s3) = i_soil2 + cascade_receiver_pool(i_s2s3) = i_soil3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s3) = 1.0_r8 + + i_s3s4 = 8 + decomp_cascade_con%cascade_step_name(i_s3s4) = 'S3S4' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s3s4) = rf_s3s4 + cascade_donor_pool(i_s3s4) = i_soil3 + cascade_receiver_pool(i_s3s4) = i_soil4 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s3s4) = 1.0_r8 + + i_s4atm = 9 + decomp_cascade_con%cascade_step_name(i_s4atm) = 'S4' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s4atm) = 1. + cascade_donor_pool(i_s4atm) = i_soil4 + cascade_receiver_pool(i_s4atm) = i_atm + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s4atm) = 1.0_r8 + else + i_s1s2 = 4 + decomp_cascade_con%cascade_step_name(i_s1s2) = 'S1S2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s2) = rf_s1s2 + cascade_donor_pool(i_s1s2) = i_soil1 + cascade_receiver_pool(i_s1s2) = i_soil2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s1s2) = 1.0_r8 + + i_s2s3 = 5 + decomp_cascade_con%cascade_step_name(i_s2s3) = 'S2S3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s3) = rf_s2s3 + cascade_donor_pool(i_s2s3) = i_soil2 + cascade_receiver_pool(i_s2s3) = i_soil3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s2s3) = 1.0_r8 + + i_s3s4 = 6 + decomp_cascade_con%cascade_step_name(i_s3s4) = 'S3S4' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s3s4) = rf_s3s4 + cascade_donor_pool(i_s3s4) = i_soil3 + cascade_receiver_pool(i_s3s4) = i_soil4 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s3s4) = 1.0_r8 + + i_s4atm = 7 + decomp_cascade_con%cascade_step_name(i_s4atm) = 'S4' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s4atm) = 1. + cascade_donor_pool(i_s4atm) = i_soil4 + cascade_receiver_pool(i_s4atm) = i_atm + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_s4atm) = 1.0_r8 + + if (.not. use_fates) then + i_cwdl2 = 8 + decomp_cascade_con%cascade_step_name(i_cwdl2) = 'CWDL2' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl2) = 0._r8 + cascade_donor_pool(i_cwdl2) = i_cwd + cascade_receiver_pool(i_cwdl2) = i_litr2 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl2) = cwd_fcel + + i_cwdl3 = 9 + decomp_cascade_con%cascade_step_name(i_cwdl3) = 'CWDL3' + rf_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl3) = 0._r8 + cascade_donor_pool(i_cwdl3) = i_cwd + cascade_receiver_pool(i_cwdl3) = i_litr3 + pathfrac_decomp_cascade(bounds%begc:bounds%endc,1:nlevdecomp,i_cwdl3) = cwd_flig + end if + end if + + !if(use_soil_matrixcn)call InitSoilTransfer() + + end associate + + end subroutine init_decompcascade_cn + + !----------------------------------------------------------------------- + subroutine decomp_rate_constants_cn(bounds, & + num_soilc, filter_soilc, & + soilstate_inst, temperature_inst, ch4_inst, soilbiogeochem_carbonflux_inst) + ! + ! !DESCRIPTION: + ! calculate rate constants and decomposition pathways for the BGC model + ! originally implemented in CLM-CN + ! written by C. Koven based on original CLM4 decomposition cascade by P. Thornton + ! + ! !USES: + use clm_time_manager, only : get_step_size_real + use clm_varcon , only : secspday + use clm_varpar , only : i_cwd + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(ch4_type) , intent(in) :: ch4_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + ! + ! !LOCAL VARIABLES: + real(r8):: dt ! decomp timestep (seconds) + real(r8):: dtd ! decomp timestep (days) + real(r8):: frw(bounds%begc:bounds%endc) ! rooting fraction weight + real(r8), allocatable:: fr(:,:) ! column-level rooting fraction by soil depth + real(r8):: minpsi, maxpsi ! limits for soil water scalar for decomp + real(r8):: psi ! temporary soilpsi for water scalar + real(r8):: rate_scalar ! combined rate scalar for decomp + real(r8):: k_l1 ! decomposition rate constant litter 1 + real(r8):: k_l2 ! decomposition rate constant litter 2 + real(r8):: k_l3 ! decomposition rate constant litter 3 + real(r8):: k_s1 ! decomposition rate constant SOM 1 + real(r8):: k_s2 ! decomposition rate constant SOM 2 + real(r8):: k_s3 ! decomposition rate constant SOM 3 + real(r8):: k_s4 ! decomposition rate constant SOM 4 + real(r8):: k_frag ! fragmentation rate constant CWD + real(r8):: ck_l1 ! corrected decomposition rate constant litter 1 + real(r8):: ck_l2 ! corrected decomposition rate constant litter 2 + real(r8):: ck_l3 ! corrected decomposition rate constant litter 3 + real(r8):: ck_s1 ! corrected decomposition rate constant SOM 1 + real(r8):: ck_s2 ! corrected decomposition rate constant SOM 2 + real(r8):: ck_s3 ! corrected decomposition rate constant SOM 3 + real(r8):: ck_s4 ! corrected decomposition rate constant SOM 4 + real(r8):: ck_frag ! corrected fragmentation rate constant CWD + real(r8):: cwdc_loss ! fragmentation rate for CWD carbon (gC/m2/s) + real(r8):: cwdn_loss ! fragmentation rate for CWD nitrogen (gN/m2/s) + integer :: i_litr1 + integer :: i_litr2 + integer :: i_litr3 + integer :: i_soil1 + integer :: i_soil2 + integer :: i_soil3 + integer :: i_soil4 + integer :: c, fc, j, k, l + 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):: decomp_depth_efolding ! (meters) e-folding depth for reduction in decomposition [ + real(r8):: depth_scalar(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8) :: mino2lim ! minimum anaerobic decomposition rate as a + ! fraction of potential aerobic rate + !----------------------------------------------------------------------- + + associate( & + dz => col%dz , & ! Input: [real(r8) (:,:) ] soil layer thickness (m) + + soilpsi => soilstate_inst%soilpsi_col , & ! Input: [real(r8) (:,:) ] soil water potential in each soil layer (MPa) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + + o2stress_sat => ch4_inst%o2stress_sat_col , & ! Input: [real(r8) (:,:) ] Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) + o2stress_unsat => ch4_inst%o2stress_unsat_col , & ! Input: [real(r8) (:,:) ] Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) + finundated => ch4_inst%finundated_col , & ! Input: [real(r8) (:) ] fractional inundated area (excluding dedicated wetland columns) + + t_scalar => soilbiogeochem_carbonflux_inst%t_scalar_col , & ! Output: [real(r8) (:,:) ] soil temperature scalar for decomp + w_scalar => soilbiogeochem_carbonflux_inst%w_scalar_col , & ! Output: [real(r8) (:,:) ] soil water scalar for decomp + o_scalar => soilbiogeochem_carbonflux_inst%o_scalar_col , & ! Output: [real(r8) (:,:) ] fraction by which decomposition is limited by anoxia + decomp_k => soilbiogeochem_carbonflux_inst%decomp_k_col & ! Output: [real(r8) (:,:,:) ] rate constant for decomposition (1./sec) + ! Ksoil => soilbiogeochem_carbonflux_inst%Ksoil & ! Output: [real(r8) (:,:,:) ] rate constant for decomposition (1./sec) + ) + + mino2lim = CNParamsShareInst%mino2lim + + ! set time steps + dt = get_step_size_real() + dtd = dt/secspday + + ! set initial base rates for decomposition mass loss (1/day) + ! (from Biome-BGC v4.2.0, using three SOM pools) + ! Value inside log function is the discrete-time values for a + ! daily time step model, and the result of the log function is + ! the corresponding continuous-time decay rate (1/day), following + ! Olson, 1963. + k_l1=params_inst%k_l1_cn + k_l2=params_inst%k_l2_cn + k_l3=params_inst%k_l3_cn + + k_s1=params_inst%k_s1_cn + k_s2=params_inst%k_s2_cn + k_s3=params_inst%k_s3_cn + k_s4=params_inst%k_s4_cn + + k_frag=params_inst%k_frag_cn + + ! calculate the new discrete-time decay rate for model timestep + k_l1 = 1.0_r8-exp(-k_l1*dtd) + k_l2 = 1.0_r8-exp(-k_l2*dtd) + k_l3 = 1.0_r8-exp(-k_l3*dtd) + + k_s1 = 1.0_r8-exp(-k_s1*dtd) + k_s2 = 1.0_r8-exp(-k_s2*dtd) + k_s3 = 1.0_r8-exp(-k_s3*dtd) + k_s4 = 1.0_r8-exp(-k_s4*dtd) + + k_frag = 1.0_r8-exp(-k_frag*dtd) + + minpsi = params_inst%minpsi_cn + maxpsi = params_inst%maxpsi_cn + + Q10 = CNParamsShareInst%Q10 + + ! set "froz_q10" parameter + froz_q10 = CNParamsShareInst%froz_q10 + + if (use_vertsoilc) then + ! Set "decomp_depth_efolding" parameter + decomp_depth_efolding = CNParamsShareInst%decomp_depth_efolding + end if + + ! The following code implements the acceleration part of the AD spinup + ! algorithm, by multiplying all of the SOM decomposition base rates by + ! spinup_vector, scalar between 1 and 70X, defined as a constant for each + ! pool here + + if ( spinup_state .eq. 1 ) then + k_s1 = k_s1 * params_inst%spinup_vector(1) + k_s2 = k_s2 * params_inst%spinup_vector(2) + k_s3 = k_s3 * params_inst%spinup_vector(3) + k_s4 = k_s4 * params_inst%spinup_vector(4) + endif + + i_litr1 = 1 + i_litr2 = 2 + i_litr3 = 3 + if (use_fates) then + i_soil1 = 4 + i_soil2 = 5 + i_soil3 = 6 + i_soil4 = 7 + else + i_soil1 = 5 + i_soil2 = 6 + i_soil3 = 7 + i_soil4 = 8 + endif + + !--- time dependent coefficients-----! + if ( nlevdecomp .eq. 1 ) then + + ! calculate function to weight the temperature and water potential scalars + ! for decomposition control. + + + ! the following normalizes values in fr so that they + ! sum to 1.0 across top nlevdecomp levels on a column + frw(bounds%begc:bounds%endc) = 0._r8 + !nlev_soildecomp_standard=5 + allocate(fr(bounds%begc:bounds%endc,nlev_soildecomp_standard)) + do j=1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + frw(c) = frw(c) + dz(c,j) + end do + end do + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + if (frw(c) /= 0._r8) then + fr(c,j) = dz(c,j) / frw(c) + else + fr(c,j) = 0._r8 + end if + end do + end do + + ! calculate rate constant scalar for soil temperature + ! assuming that the base rate constants are assigned for non-moisture + ! limiting conditions at 25 C. + ! Peter Thornton: 3/13/09 + ! Replaced the Lloyd and Taylor function with a Q10 formula, with Q10 = 1.5 + ! as part of the modifications made to improve the seasonal cycle of + ! atmospheric CO2 concentration in global simulations. This does not impact + ! the base rates at 25 C, which are calibrated from microcosm studies. + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + if (j==1) t_scalar(c,:) = 0._r8 + !! use separate (possibly equal) t funcs above and below freezing point + !! t_scalar(c,1)=t_scalar(c,1) + (1.5**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8))*fr(c,j) + if (t_soisno(c,j) >= SHR_CONST_TKFRZ) then + t_scalar(c,1)=t_scalar(c,1) + & + (Q10**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8))*fr(c,j) + else + t_scalar(c,1)=t_scalar(c,1) + & + (Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-SHR_CONST_TKFRZ)/10._r8))*fr(c,j) + endif + end do + end do + + ! calculate the rate constant scalar for soil water content. + ! Uses the log relationship with water potential given in + ! Andren, O., and K. Paustian, 1987. Barley straw decomposition in the field: + ! a comparison of models. Ecology, 68(5):1190-1200. + ! and supported by data in + ! Orchard, V.A., and F.J. Cook, 1983. Relationship between soil respiration + ! and soil moisture. Soil Biol. Biochem., 15(4):447-453. + + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + if (j==1) w_scalar(c,:) = 0._r8 + psi = min(soilpsi(c,j),maxpsi) + ! decomp only if soilpsi is higher than minpsi + if (psi > minpsi) then + w_scalar(c,1) = w_scalar(c,1) + (log(minpsi/psi)/log(minpsi/maxpsi))*fr(c,j) + end if + end do + end do + + if (use_lch4) then + ! Calculate ANOXIA + if (anoxia) then + ! Check for anoxia w/o LCH4 now done in controlMod. + + do j = 1,nlev_soildecomp_standard + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (j==1) o_scalar(c,:) = 0._r8 + + o_scalar(c,1) = o_scalar(c,1) + fr(c,j) * max(o2stress_unsat(c,j), mino2lim) + end do + end do + else + o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 + end if + else + o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 + end if + + deallocate(fr) + + else + + ! calculate rate constant scalar for soil temperature + ! assuming that the base rate constants are assigned for non-moisture + ! limiting conditions at 25 C. + ! Peter Thornton: 3/13/09 + ! Replaced the Lloyd and Taylor function with a Q10 formula, with Q10 = 1.5 + ! as part of the modifications made to improve the seasonal cycle of + ! atmospheric CO2 concentration in global simulations. This does not impact + ! the base rates at 25 C, which are calibrated from microcosm studies. + + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + !! use separate (possibly equal) t funcs above and below freezing point + !! t_scalar(c,j)= (1.5**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8)) + if (t_soisno(c,j) >= SHR_CONST_TKFRZ) then + t_scalar(c,j)= (Q10**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8)) + else + t_scalar(c,j)= (Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-SHR_CONST_TKFRZ)/10._r8)) + endif + end do + end do + + + ! calculate the rate constant scalar for soil water content. + ! Uses the log relationship with water potential given in + ! Andren, O., and K. Paustian, 1987. Barley straw decomposition in the field: + ! a comparison of models. Ecology, 68(5):1190-1200. + ! and supported by data in + ! Orchard, V.A., and F.J. Cook, 1983. Relationship between soil respiration + ! and soil moisture. Soil Biol. Biochem., 15(4):447-453. + + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + psi = min(soilpsi(c,j),maxpsi) + ! decomp only if soilpsi is higher than minpsi + if (psi > minpsi) then + w_scalar(c,j) = (log(minpsi/psi)/log(minpsi/maxpsi)) + else + w_scalar(c,j) = 0._r8 + end if + end do + end do + + end if + + if (use_lch4) then + ! Calculate ANOXIA + ! Check for anoxia w/o LCH4 now done in controlMod. + + if (anoxia) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + o_scalar(c,j) = max(o2stress_unsat(c,j), mino2lim) + end do + end do + else + o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 + end if + else + o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 + end if + + if (use_vertsoilc) then + ! add a term to reduce decomposition rate at depth + ! for now used a fixed e-folding depth + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + depth_scalar(c,j) = exp(-zsoi(j)/decomp_depth_efolding) + end do + end do + end if + + ! calculate rate constants for all litter and som pools + if (use_vertsoilc) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + decomp_k(c,j,i_litr1) = k_l1 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_litr2) = k_l2 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_litr3) = k_l3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_soil1) = k_s1 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_soil2) = k_s2 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_soil3) = k_s3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_soil4) = k_s4 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) / dt +! if(use_soil_matrixcn)then +! Ksoil%DM(c,j+nlevdecomp*(i_litr1-1)) = k_l1 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_litr2-1)) = k_l2 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_litr3-1)) = k_l3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_soil1-1)) = k_s1 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_soil2-1)) = k_s2 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_soil3-1)) = k_s3 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_soil4-1)) = k_s4 * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) +! end if + end do + end do + else + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + decomp_k(c,j,i_litr1) = k_l1 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_litr2) = k_l2 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_litr3) = k_l3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_soil1) = k_s1 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_soil2) = k_s2 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_soil3) = k_s3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) / dt + decomp_k(c,j,i_soil4) = k_s4 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) / dt +! if(use_soil_matrixcn)then +! Ksoil%DM(c,j+nlevdecomp*(i_litr1-1)) = k_l1 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_litr2-1)) = k_l2 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_litr3-1)) = k_l3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_soil1-1)) = k_s1 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_soil2-1)) = k_s2 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_soil3-1)) = k_s3 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) +! Ksoil%DM(c,j+nlevdecomp*(i_soil4-1)) = k_s4 * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) +! end if + end do + end do + end if + + ! do the same for cwd, but only if fates is not enabled (because fates handles CWD on its own structure + if (.not. use_fates) then + if (use_vertsoilc) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + decomp_k(c,j,i_cwd) = k_frag * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * o_scalar(c,j) / dt +! if(use_soil_matrixcn)then +! Ksoil%DM(c,j+nlevdecomp*(i_cwd-1)) = k_frag * t_scalar(c,j) * w_scalar(c,j) * depth_scalar(c,j) * & +! o_scalar(c,j) +! end if + end do + end do + else + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + decomp_k(c,j,i_cwd) = k_frag * t_scalar(c,j) * w_scalar(c,j) * o_scalar(c,j) / dt +! if(use_soil_matrixcn)then +! Ksoil%DM(c,j+nlevdecomp*(i_cwd-1)) = k_frag * t_scalar(c,j) * w_scalar(c,j) * & +! o_scalar(c,j) +! end if + end do + end do + end if + end if + + end associate + + end subroutine decomp_rate_constants_cn + + end module SoilBiogeochemDecompCascadeCNMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompMod.F90 new file mode 100755 index 000000000..883308a70 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompMod.F90 @@ -0,0 +1,282 @@ +module SoilBiogeochemDecompMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module holding routines used in litter and soil decomposition model + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use clm_varpar , only : nlevdecomp, ndecomp_cascade_transitions, ndecomp_pools + use clm_varctl , only : use_nitrif_denitrif, use_lch4, use_fates, use_soil_matrixcn + use clm_varcon , only : dzsoi_decomp + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: readParams + public :: SoilBiogeochemDecomp + ! + type, private :: params_type + real(r8) :: dnp !denitrification proportion + end type params_type + ! + type(params_type), private :: params_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !DESCRIPTION: + ! Read parameters + ! + ! !USES: + use ncdio_pio , only: file_desc_t,ncd_io + use abortutils , only: endrun + ! + ! !ARGUMENTS: + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + tString='dnp' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%dnp=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemDecomp (bounds, num_soilc, filter_soilc, & + soilbiogeochem_state_inst, soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & + cn_decomp_pools, p_decomp_cpool_loss, pmnf_decomp_cascade) + ! + ! !USES: + use SoilBiogeochemDecompCascadeConType, only : i_atm + ! + ! !ARGUMENT: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_carbonstate_type) , intent(in) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + real(r8) , intent(inout) :: cn_decomp_pools(bounds%begc:,1:,1:) ! c:n ratios of applicable pools + real(r8) , intent(inout) :: p_decomp_cpool_loss(bounds%begc:,1:,1:) ! potential C loss from one pool to another + real(r8) , intent(inout) :: pmnf_decomp_cascade(bounds%begc:,1:,1:) ! potential mineral N flux from one pool to another + ! + ! !LOCAL VARIABLES: + integer :: c,j,k,l,m ! indices + integer :: fc ! lake filter column index + integer :: begc,endc ! bounds + ! For methane code + real(r8):: hrsum(bounds%begc:bounds%endc,1:nlevdecomp) ! sum of HR (gC/m2/s) + !----------------------------------------------------------------------- + + begc = bounds%begc; endc = bounds%endc + + SHR_ASSERT_ALL_FL((ubound(cn_decomp_pools) == (/endc,nlevdecomp,ndecomp_pools/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(p_decomp_cpool_loss) == (/endc,nlevdecomp,ndecomp_cascade_transitions/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(pmnf_decomp_cascade) == (/endc,nlevdecomp,ndecomp_cascade_transitions/)) , sourcefile, __LINE__) + + associate( & + cascade_donor_pool => decomp_cascade_con%cascade_donor_pool , & ! Input: [integer (:) ] which pool is C taken from for a given decomposition step + cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool , & ! Input: [integer (:) ] which pool is C added to for a given decomposition step + floating_cn_ratio_decomp_pools => decomp_cascade_con%floating_cn_ratio_decomp_pools , & ! Input: [logical (:) ] TRUE => pool has fixed C:N ratio + initial_cn_ratio => decomp_cascade_con%initial_cn_ratio , & ! Input: [real(r8) (:) ] c:n ratio for initialization of pools + + fpi_vr => soilbiogeochem_state_inst%fpi_vr_col , & ! Input: [real(r8) (:,:) ] fraction of potential immobilization (no units) + rf_decomp_cascade => soilbiogeochem_state_inst%rf_decomp_cascade_col , & ! Input: [real(r8) (:,:,:) ] respired fraction in decomposition step (frac) + pathfrac_decomp_cascade => soilbiogeochem_state_inst%pathfrac_decomp_cascade_col , & ! Input: [real(r8) (:,:,:) ] what fraction of C leaving a given pool passes through a given transition (frac) + + decomp_npools_vr => soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools + decomp_cpools_vr => soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools + + decomp_cascade_ntransfer_vr => soilbiogeochem_nitrogenflux_inst%decomp_cascade_ntransfer_vr_col , & ! Output: [real(r8) (:,:,:) ] vert-res transfer of N from donor to receiver pool along decomp. cascade (gN/m3/s) + decomp_cascade_sminn_flux_vr => soilbiogeochem_nitrogenflux_inst%decomp_cascade_sminn_flux_vr_col , & ! Output: [real(r8) (:,:,:) ] vert-res mineral N flux for transition along decomposition cascade (gN/m3/s) + potential_immob_vr => soilbiogeochem_nitrogenflux_inst%potential_immob_vr_col , & ! Output: [real(r8) (:,:) ] + sminn_to_denit_decomp_cascade_vr => soilbiogeochem_nitrogenflux_inst%sminn_to_denit_decomp_cascade_vr_col , & ! Output: [real(r8) (:,:,:) ] + gross_nmin_vr => soilbiogeochem_nitrogenflux_inst%gross_nmin_vr_col , & ! Output: [real(r8) (:,:) ] + net_nmin_vr => soilbiogeochem_nitrogenflux_inst%net_nmin_vr_col , & ! Output: [real(r8) (:,:) ] + gross_nmin => soilbiogeochem_nitrogenflux_inst%gross_nmin_col , & ! Output: [real(r8) (:) ] gross rate of N mineralization (gN/m2/s) + net_nmin => soilbiogeochem_nitrogenflux_inst%net_nmin_col , & ! Output: [real(r8) (:) ] net rate of N mineralization (gN/m2/s) + + w_scalar => soilbiogeochem_carbonflux_inst%w_scalar_col , & ! Input: [real(r8) (:,:) ] fraction by which decomposition is limited by moisture availability + decomp_cascade_hr_vr => soilbiogeochem_carbonflux_inst%decomp_cascade_hr_vr_col , & ! Output: [real(r8) (:,:,:) ] vertically-resolved het. resp. from decomposing C pools (gC/m3/s) + decomp_cascade_ctransfer_vr => soilbiogeochem_carbonflux_inst%decomp_cascade_ctransfer_vr_col , & ! Output: [real(r8) (:,:,:) ] vertically-resolved het. resp. from decomposing C pools (gC/m3/s) + decomp_k => soilbiogeochem_carbonflux_inst%decomp_k_col , & ! Output: [real(r8) (:,:,:) ] rate constant for decomposition (1./sec) + phr_vr => soilbiogeochem_carbonflux_inst%phr_vr_col , & ! Input: [real(r8) (:,:) ] potential HR (gC/m3/s) + fphr => soilbiogeochem_carbonflux_inst%fphr_col & ! Output: [real(r8) (:,:) ] fraction of potential SOM + LITTER heterotrophic + ! Ksoil => soilbiogeochem_carbonflux_inst%Ksoil & ! In/Output: [real(r8) (:,:,:) ] rate constant for decomposition (1./sec) + ) + + ! column loop to calculate actual immobilization and decomp rates, following + ! resolution of plant/heterotroph competition for mineral N + + if ( .not. use_fates) then + ! calculate c:n ratios of applicable pools + do l = 1, ndecomp_pools + if ( floating_cn_ratio_decomp_pools(l) ) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if ( decomp_npools_vr(c,j,l) > 0._r8 ) then + cn_decomp_pools(c,j,l) = decomp_cpools_vr(c,j,l) / decomp_npools_vr(c,j,l) + end if + end do + end do + else + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + cn_decomp_pools(c,j,l) = initial_cn_ratio(l) + end do + end do + end if + end do + + ! column loop to calculate actual immobilization and decomp rates, following + ! resolution of plant/heterotroph competition for mineral N + + ! upon return from SoilBiogeochemCompetition, the fraction of potential immobilization + ! has been set (soilbiogeochem_state_inst%fpi_vr_col). now finish the decomp calculations. + ! Only the immobilization steps are limited by fpi_vr (pmnf > 0) + ! Also calculate denitrification losses as a simple proportion + ! of mineralization flux. + + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (decomp_cpools_vr(c,j,cascade_donor_pool(k)) > 0._r8) then + if ( pmnf_decomp_cascade(c,j,k) > 0._r8 ) then + p_decomp_cpool_loss(c,j,k) = p_decomp_cpool_loss(c,j,k) * fpi_vr(c,j) + pmnf_decomp_cascade(c,j,k) = pmnf_decomp_cascade(c,j,k) * fpi_vr(c,j) + if (use_soil_matrixcn)then ! correct only when one transfer from each litter pool +! Ksoil%DM(c,j+nlevdecomp*(cascade_donor_pool(k)-1)) & +! = Ksoil%DM(c,j+nlevdecomp*(cascade_donor_pool(k)-1)) * fpi_vr(c,j) + end if + if (.not. use_nitrif_denitrif) then + sminn_to_denit_decomp_cascade_vr(c,j,k) = 0._r8 + end if + else + if (.not. use_nitrif_denitrif) then + sminn_to_denit_decomp_cascade_vr(c,j,k) = -params_inst%dnp * pmnf_decomp_cascade(c,j,k) + end if + end if + decomp_cascade_hr_vr(c,j,k) = rf_decomp_cascade(c,j,k) * p_decomp_cpool_loss(c,j,k) + decomp_cascade_ctransfer_vr(c,j,k) = (1._r8 - rf_decomp_cascade(c,j,k)) * p_decomp_cpool_loss(c,j,k) + if (decomp_npools_vr(c,j,cascade_donor_pool(k)) > 0._r8 .and. cascade_receiver_pool(k) /= i_atm) then + decomp_cascade_ntransfer_vr(c,j,k) = p_decomp_cpool_loss(c,j,k) / cn_decomp_pools(c,j,cascade_donor_pool(k)) + else + decomp_cascade_ntransfer_vr(c,j,k) = 0._r8 + endif + if ( cascade_receiver_pool(k) /= 0 ) then + decomp_cascade_sminn_flux_vr(c,j,k) = pmnf_decomp_cascade(c,j,k) + else ! keep sign convention negative for terminal pools + decomp_cascade_sminn_flux_vr(c,j,k) = - pmnf_decomp_cascade(c,j,k) + endif + net_nmin_vr(c,j) = net_nmin_vr(c,j) - pmnf_decomp_cascade(c,j,k) + else + decomp_cascade_ntransfer_vr(c,j,k) = 0._r8 + if (.not. use_nitrif_denitrif) then + sminn_to_denit_decomp_cascade_vr(c,j,k) = 0._r8 + end if + decomp_cascade_sminn_flux_vr(c,j,k) = 0._r8 + end if + + end do + end do + end do + else + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + ! + decomp_cascade_hr_vr(c,j,k) = rf_decomp_cascade(c,j,k) * p_decomp_cpool_loss(c,j,k) + ! + decomp_cascade_ctransfer_vr(c,j,k) = (1._r8 - rf_decomp_cascade(c,j,k)) * p_decomp_cpool_loss(c,j,k) + ! + end do + end do + end do + end if + + if (use_lch4) then + ! Calculate total fraction of potential HR, for methane code + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + hrsum(c,j) = 0._r8 + end do + end do + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + hrsum(c,j) = hrsum(c,j) + rf_decomp_cascade(c,j,k) * p_decomp_cpool_loss(c,j,k) + end do + end do + end do + + + ! Nitrogen limitation / (low)-moisture limitation + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if (phr_vr(c,j) > 0._r8) then + fphr(c,j) = hrsum(c,j) / phr_vr(c,j) * w_scalar(c,j) + fphr(c,j) = max(fphr(c,j), 0.01_r8) ! Prevent overflow errors for 0 respiration + else + fphr(c,j) = 1._r8 + end if + end do + end do + end if + + + ! vertically integrate net and gross mineralization fluxes for diagnostic output + + do fc = 1,num_soilc + c = filter_soilc(fc) + do j = 1,nlevdecomp + if(.not.use_fates)then + net_nmin(c) = net_nmin(c) + net_nmin_vr(c,j) * dzsoi_decomp(j) + gross_nmin(c) = gross_nmin(c) + gross_nmin_vr(c,j) * dzsoi_decomp(j) + ! else + ! net_nmin(c) = 0.0_r8 + ! gross_nmin(c) = 0.0_r8 + endif + end do + end do + + end associate + + end subroutine SoilBiogeochemDecomp + +end module SoilBiogeochemDecompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemLittVertTranspMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemLittVertTranspMod.F90 new file mode 100755 index 000000000..ea6b6aba8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemLittVertTranspMod.F90 @@ -0,0 +1,551 @@ +module SoilBiogeochemLittVertTranspMod + + !----------------------------------------------------------------------- + ! calculate vertical mixing of all decomposing C and N pools + ! + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog, use_c13, use_c14, spinup_state, use_vertsoilc, use_fates, use_cn + use clm_varctl , only : use_soil_matrixcn + use clm_varcon , only : secspday + use decompMod , only : bounds_type + use abortutils , only : endrun + use ActiveLayerMod , only : active_layer_type + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use ColumnType , only : col + use GridcellType , only : grc + use SoilBiogeochemStateType , only : get_spinup_latitude_term + ! + implicit none + private + ! + public :: readParams + public :: SoilBiogeochemLittVertTransp + + type, private :: params_type + real(r8) :: som_diffus ! Soil organic matter diffusion + real(r8) :: cryoturb_diffusion_k ! The cryoturbation diffusive constant cryoturbation to the active layer thickness + real(r8) :: max_altdepth_cryoturbation ! (m) maximum active layer thickness for cryoturbation to occur + end type params_type + + type(params_type), private :: params_inst + ! + real(r8), public :: som_adv_flux = 0._r8 + real(r8), public :: max_depth_cryoturb = 3._r8 ! (m) this is the maximum depth of cryoturbation + real(r8) :: som_diffus ! [m^2/sec] = 1 cm^2 / yr + real(r8) :: cryoturb_diffusion_k ! [m^2/sec] = 5 cm^2 / yr = 1m^2 / 200 yr + real(r8) :: max_altdepth_cryoturbation ! (m) maximum active layer thickness for cryoturbation to occur + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + use ncdio_pio , only : file_desc_t,ncd_io + ! + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + character(len=32) :: subname = 'SoilBiogeochemLittVertTranspType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + ! + ! read in parameters + ! + + tString='som_diffus' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%som_diffus=tempr + + tString='cryoturb_diffusion_k' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%cryoturb_diffusion_k=tempr + + tString='max_altdepth_cryoturbation' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%max_altdepth_cryoturbation=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemLittVertTransp(bounds, num_soilc, filter_soilc, & + active_layer_inst, soilbiogeochem_state_inst, & + soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + c13_soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonflux_inst, & + c14_soilbiogeochem_carbonstate_inst, c14_soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! Calculate vertical mixing of soil and litter pools. Also reconcile sources and sinks of these pools + ! calculated in the CStateUpdate1 and NStateUpdate1 subroutines. + ! Advection-diffusion code based on algorithm in Patankar (1980) + ! Initial code by C. Koven and W. Riley + ! + ! !USES: + use clm_time_manager , only : get_step_size_real + use clm_varpar , only : nlevdecomp, ndecomp_pools, nlevdecomp_full + use clm_varcon , only : zsoi, dzsoi_decomp, zisoi + use TridiagonalMod , only : Tridiagonal + use ColumnType , only : col + use clm_varctl , only : use_bedrock + + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(active_layer_type) , intent(in) :: active_layer_inst + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c13_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: c14_soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: diffus (bounds%begc:bounds%endc,1:nlevdecomp+1) ! diffusivity (m2/s) (includes spinup correction, if any) + real(r8) :: adv_flux(bounds%begc:bounds%endc,1:nlevdecomp+1) ! advective flux (m/s) (includes spinup correction, if any) + real(r8) :: aaa ! "A" function in Patankar + real(r8) :: pe ! Pe for "A" function in Patankar + real(r8) :: w_m1, w_p1 ! Weights for calculating harmonic mean of diffusivity + real(r8) :: d_m1, d_p1 ! Harmonic mean of diffusivity + real(r8) :: a_tri(bounds%begc:bounds%endc,0:nlevdecomp+1) ! "a" vector for tridiagonal matrix + real(r8) :: b_tri(bounds%begc:bounds%endc,0:nlevdecomp+1) ! "b" vector for tridiagonal matrix + real(r8) :: c_tri(bounds%begc:bounds%endc,0:nlevdecomp+1) ! "c" vector for tridiagonal matrix + real(r8) :: r_tri(bounds%begc:bounds%endc,0:nlevdecomp+1) ! "r" vector for tridiagonal solution + real(r8) :: d_p1_zp1(bounds%begc:bounds%endc,1:nlevdecomp+1) ! diffusivity/delta_z for next j (set to zero for no diffusion) + real(r8) :: d_m1_zm1(bounds%begc:bounds%endc,1:nlevdecomp+1) ! diffusivity/delta_z for previous j (set to zero for no diffusion) + real(r8) :: f_p1(bounds%begc:bounds%endc,1:nlevdecomp+1) ! water flux for next j + real(r8) :: f_m1(bounds%begc:bounds%endc,1:nlevdecomp+1) ! water flux for previous j + real(r8) :: pe_p1(bounds%begc:bounds%endc,1:nlevdecomp+1) ! Peclet # for next j + real(r8) :: pe_m1(bounds%begc:bounds%endc,1:nlevdecomp+1) ! Peclet # for previous j + real(r8) :: dz_node(1:nlevdecomp+1) ! difference between nodes + real(r8) :: epsilon_t (bounds%begc:bounds%endc,1:nlevdecomp+1,1:ndecomp_pools) ! + real(r8) :: conc_trcr(bounds%begc:bounds%endc,0:nlevdecomp+1) ! + real(r8) :: a_p_0 + real(r8) :: deficit + integer :: ntype + integer :: i_type,s,fc,c,j,l,i ! indices + integer :: jtop(bounds%begc:bounds%endc) ! top level at each column + real(r8) :: dtime ! land model time step (sec) + integer :: zerolev_diffus + real(r8) :: spinup_term ! spinup accelerated decomposition factor, used to accelerate transport as well + real(r8) :: epsilon ! small number + real(r8), pointer :: conc_ptr(:,:,:) ! pointer, concentration state variable being transported + real(r8), pointer :: source(:,:,:) ! pointer, source term + real(r8), pointer :: trcr_tendency_ptr(:,:,:) ! poiner, store the vertical tendency (gain/loss due to vertical transport) + real(r8), pointer :: matrix_input(:,:) ! poiner, store the vertical tendency (gain/loss due to vertical transport) + !----------------------------------------------------------------------- + + ! Set statement functions + aaa (pe) = max (0._r8, (1._r8 - 0.1_r8 * abs(pe))**5) ! A function from Patankar, Table 5.2, pg 95 + + associate( & + is_cwd => decomp_cascade_con%is_cwd , & ! Input: [logical (:) ] TRUE => pool is a cwd pool + spinup_factor => decomp_cascade_con%spinup_factor , & ! Input: [real(r8) (:) ] spinup accelerated decomposition factor, used to accelerate transport as well + + altmax => active_layer_inst%altmax_col , & ! Input: [real(r8) (:) ] maximum annual depth of thaw + altmax_lastyear => active_layer_inst%altmax_lastyear_col , & ! Input: [real(r8) (:) ] prior year maximum annual depth of thaw + + som_adv_coef => soilbiogeochem_state_inst%som_adv_coef_col , & ! Output: [real(r8) (:,:) ] SOM advective flux (m/s) + som_diffus_coef => soilbiogeochem_state_inst%som_diffus_coef_col,& ! Output: [real(r8) (:,:) ] SOM diffusivity due to bio/cryo-turbation (m2/s) + tri_ma_vr => soilbiogeochem_carbonflux_inst%tri_ma_vr & ! Output: [real(r8) (:,:) ] Vertical CN transfer rate in sparse matrix format (gC*m3)/(gC*m3*step)) + ) + + !Set parameters of vertical mixing of SOM + som_diffus = params_inst%som_diffus + cryoturb_diffusion_k = params_inst%cryoturb_diffusion_k + max_altdepth_cryoturbation = params_inst%max_altdepth_cryoturbation + + dtime = get_step_size_real() + + ntype = 2 + if ( use_c13 ) then + ntype = ntype+1 + endif + if ( use_c14 ) then + ntype = ntype+1 + endif + if ( use_fates ) then + ntype = 1 + endif + spinup_term = 1._r8 + epsilon = 1.e-30 + + if (use_vertsoilc) then + !------ first get diffusivity / advection terms -------! + ! use different mixing rates for bioturbation and cryoturbation, with fixed bioturbation and cryoturbation set to a maximum depth + do fc = 1, num_soilc + c = filter_soilc (fc) + if (( max(altmax(c), altmax_lastyear(c)) <= max_altdepth_cryoturbation ) .and. & + ( max(altmax(c), altmax_lastyear(c)) > 0._r8) ) then + ! use mixing profile modified slightly from Koven et al. (2009): constant through active layer, linear decrease from base of active layer to zero at a fixed depth + do j = 1,nlevdecomp+1 + if ( j <= col%nbedrock(c)+1 ) then + if ( zisoi(j) < max(altmax(c), altmax_lastyear(c)) ) then + som_diffus_coef(c,j) = cryoturb_diffusion_k + som_adv_coef(c,j) = 0._r8 + else + som_diffus_coef(c,j) = max(cryoturb_diffusion_k * & + ( 1._r8 - ( zisoi(j) - max(altmax(c), altmax_lastyear(c)) ) / & + ( min(max_depth_cryoturb, zisoi(col%nbedrock(c)+1)) - max(altmax(c), altmax_lastyear(c)) ) ), 0._r8) ! go linearly to zero between ALT and max_depth_cryoturb + som_adv_coef(c,j) = 0._r8 + endif + else + som_adv_coef(c,j) = 0._r8 + som_diffus_coef(c,j) = 0._r8 + endif + end do + elseif ( max(altmax(c), altmax_lastyear(c)) > 0._r8 ) then + ! constant advection, constant diffusion + do j = 1,nlevdecomp+1 + if ( j <= col%nbedrock(c)+1 ) then + som_adv_coef(c,j) = som_adv_flux + som_diffus_coef(c,j) = som_diffus + else + som_adv_coef(c,j) = 0._r8 + som_diffus_coef(c,j) = 0._r8 + endif + end do + else + ! completely frozen soils--no mixing + do j = 1,nlevdecomp+1 + som_adv_coef(c,j) = 0._r8 + som_diffus_coef(c,j) = 0._r8 + end do + endif + end do + + ! Set the distance between the node and the one ABOVE it + dz_node(1) = zsoi(1) + do j = 2,nlevdecomp+1 + dz_node(j)= zsoi(j) - zsoi(j-1) + enddo + + endif + + !------ loop over litter/som types + do i_type = 1, ntype + + select case (i_type) + case (1) ! C + conc_ptr => soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col + source => soilbiogeochem_carbonflux_inst%decomp_cpools_sourcesink_col + trcr_tendency_ptr => soilbiogeochem_carbonflux_inst%decomp_cpools_transport_tendency_col + ! matrix_input => soilbiogeochem_carbonflux_inst%matrix_Cinput%V + case (2) ! N + if (use_cn ) then + conc_ptr => soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col + source => soilbiogeochem_nitrogenflux_inst%decomp_npools_sourcesink_col + trcr_tendency_ptr => soilbiogeochem_nitrogenflux_inst%decomp_npools_transport_tendency_col + ! matrix_input => soilbiogeochem_nitrogenflux_inst%matrix_Ninput%V + endif + case (3) + if ( use_c13 ) then + ! C13 + conc_ptr => c13_soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col + source => c13_soilbiogeochem_carbonflux_inst%decomp_cpools_sourcesink_col + trcr_tendency_ptr => c13_soilbiogeochem_carbonflux_inst%decomp_cpools_transport_tendency_col + else + ! C14 + conc_ptr => c14_soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col + source => c14_soilbiogeochem_carbonflux_inst%decomp_cpools_sourcesink_col + trcr_tendency_ptr => c14_soilbiogeochem_carbonflux_inst%decomp_cpools_transport_tendency_col + endif + case (4) + if ( use_c14 .and. use_c13 ) then + ! C14 + conc_ptr => c14_soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col + source => c14_soilbiogeochem_carbonflux_inst%decomp_cpools_sourcesink_col + trcr_tendency_ptr => c14_soilbiogeochem_carbonflux_inst%decomp_cpools_transport_tendency_col + else + write(iulog,*) 'error. ncase = 4, but c13 and c14 not both enabled.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + end select + if (use_vertsoilc) then + + do s = 1, ndecomp_pools + if ( .not. is_cwd(s) ) then + if(.not. use_soil_matrixcn .or. s .eq. 1)then + do j = 1,nlevdecomp+1 + do fc = 1, num_soilc + c = filter_soilc (fc) + ! + if ( spinup_state >= 1 ) then + ! increase transport (both advection and diffusion) by the same factor as accelerated decomposition for a given pool + spinup_term = spinup_factor(s) + else + spinup_term = 1._r8 + endif + + if (abs(spinup_term - 1._r8) > .000001_r8 ) then + spinup_term = spinup_term * get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + endif + + if ( abs(som_adv_coef(c,j)) * spinup_term < epsilon ) then + adv_flux(c,j) = epsilon + else + adv_flux(c,j) = som_adv_coef(c,j) * spinup_term + endif + ! + if ( abs(som_diffus_coef(c,j)) * spinup_term < epsilon ) then + diffus(c,j) = epsilon + else + diffus(c,j) = som_diffus_coef(c,j) * spinup_term + endif + ! + end do + end do + + ! Set Pe (Peclet #) and D/dz throughout column + + do fc = 1, num_soilc ! dummy terms here + c = filter_soilc (fc) + conc_trcr(c,0) = 0._r8 + conc_trcr(c,col%nbedrock(c)+1:nlevdecomp+1) = 0._r8 + end do + + + do j = 1,nlevdecomp+1 + do fc = 1, num_soilc + c = filter_soilc (fc) + + conc_trcr(c,j) = conc_ptr(c,j,s) + + ! dz_tracer below is the difference between gridcell edges (dzsoi_decomp) + ! dz_node_tracer is difference between cell centers + + ! Calculate the D and F terms in the Patankar algorithm + if (j == 1) then + d_m1_zm1(c,j) = 0._r8 + w_p1 = (zsoi(j+1) - zisoi(j)) / dz_node(j+1) + if ( diffus(c,j+1) > 0._r8 .and. diffus(c,j) > 0._r8) then + d_p1 = 1._r8 / ((1._r8 - w_p1) / diffus(c,j) + w_p1 / diffus(c,j+1)) ! Harmonic mean of diffus + else + d_p1 = 0._r8 + endif + d_p1_zp1(c,j) = d_p1 / dz_node(j+1) + f_m1(c,j) = adv_flux(c,j) ! Include infiltration here + f_p1(c,j) = adv_flux(c,j+1) + pe_m1(c,j) = 0._r8 + pe_p1(c,j) = f_p1(c,j) / d_p1_zp1(c,j) ! Peclet # + elseif (j >= col%nbedrock(c)+1) then + ! At the bottom, assume no gradient in d_z (i.e., they're the same) + w_m1 = (zisoi(j-1) - zsoi(j-1)) / dz_node(j) + if ( diffus(c,j) > 0._r8 .and. diffus(c,j-1) > 0._r8) then + d_m1 = 1._r8 / ((1._r8 - w_m1) / diffus(c,j) + w_m1 / diffus(c,j-1)) ! Harmonic mean of diffus + else + d_m1 = 0._r8 + endif + d_m1_zm1(c,j) = d_m1 / dz_node(j) + d_p1_zp1(c,j) = d_m1_zm1(c,j) ! Set to be the same + f_m1(c,j) = adv_flux(c,j) + !f_p1(c,j) = adv_flux(c,j+1) + f_p1(c,j) = 0._r8 + pe_m1(c,j) = f_m1(c,j) / d_m1_zm1(c,j) ! Peclet # + pe_p1(c,j) = f_p1(c,j) / d_p1_zp1(c,j) ! Peclet # + else + ! Use distance from j-1 node to interface with j divided by distance between nodes + w_m1 = (zisoi(j-1) - zsoi(j-1)) / dz_node(j) + if ( diffus(c,j-1) > 0._r8 .and. diffus(c,j) > 0._r8) then + d_m1 = 1._r8 / ((1._r8 - w_m1) / diffus(c,j) + w_m1 / diffus(c,j-1)) ! Harmonic mean of diffus + else + d_m1 = 0._r8 + endif + w_p1 = (zsoi(j+1) - zisoi(j)) / dz_node(j+1) + if ( diffus(c,j+1) > 0._r8 .and. diffus(c,j) > 0._r8) then + d_p1 = 1._r8 / ((1._r8 - w_p1) / diffus(c,j) + w_p1 / diffus(c,j+1)) ! Harmonic mean of diffus + else + d_p1 = (1._r8 - w_m1) * diffus(c,j) + w_p1 * diffus(c,j+1) ! Arithmetic mean of diffus + endif + d_m1_zm1(c,j) = d_m1 / dz_node(j) + d_p1_zp1(c,j) = d_p1 / dz_node(j+1) + f_m1(c,j) = adv_flux(c,j) + f_p1(c,j) = adv_flux(c,j+1) + pe_m1(c,j) = f_m1(c,j) / d_m1_zm1(c,j) ! Peclet # + pe_p1(c,j) = f_p1(c,j) / d_p1_zp1(c,j) ! Peclet # + end if + enddo ! fc + enddo ! j; nlevdecomp + end if + + + ! Calculate the tridiagonal coefficients + do j = 0,nlevdecomp +1 + do fc = 1, num_soilc + c = filter_soilc (fc) + ! g = cgridcell(c) + + if (j > 0 .and. j < nlevdecomp+1) then + a_p_0 = dzsoi_decomp(j) / dtime + endif + + if (j == 0) then ! top layer (atmosphere) + a_tri(c,j) = 0._r8 + b_tri(c,j) = 1._r8 + c_tri(c,j) = -1._r8 + r_tri(c,j) = 0._r8 + elseif (j == 1) then + a_tri(c,j) = -(d_m1_zm1(c,j) * aaa(pe_m1(c,j)) + max( f_m1(c,j), 0._r8)) ! Eqn 5.47 Patankar + c_tri(c,j) = -(d_p1_zp1(c,j) * aaa(pe_p1(c,j)) + max(-f_p1(c,j), 0._r8)) + b_tri(c,j) = - a_tri(c,j) - c_tri(c,j) + a_p_0 + r_tri(c,j) = source(c,j,s) * dzsoi_decomp(j) /dtime + (a_p_0 - adv_flux(c,j)) * conc_trcr(c,j) + if(s .eq. 1 .and. i_type .eq. 1 .and. use_soil_matrixcn .and. use_vertsoilc)then !vertical matrix are the same for all pools + do i = 1,ndecomp_pools-1 !excluding cwd + tri_ma_vr(c,1+(i-1)*(nlevdecomp*3-2)) = (b_tri(c,j) - a_p_0) / dzsoi_decomp(j) * (-dtime) + tri_ma_vr(c,3+(i-1)*(nlevdecomp*3-2)) = c_tri(c,j) / dzsoi_decomp(j) * (-dtime) + end do + end if + elseif (j < nlevdecomp+1) then + a_tri(c,j) = -(d_m1_zm1(c,j) * aaa(pe_m1(c,j)) + max( f_m1(c,j), 0._r8)) ! Eqn 5.47 Patankar + c_tri(c,j) = -(d_p1_zp1(c,j) * aaa(pe_p1(c,j)) + max(-f_p1(c,j), 0._r8)) + b_tri(c,j) = - a_tri(c,j) - c_tri(c,j) + a_p_0 + r_tri(c,j) = source(c,j,s) * dzsoi_decomp(j) /dtime + a_p_0 * conc_trcr(c,j) + if(s .eq. 1 .and. i_type .eq. 1 .and. use_soil_matrixcn .and. use_vertsoilc)then + if(j .le. col%nbedrock(c))then + do i = 1,ndecomp_pools-1 + tri_ma_vr(c,j*3-4+(i-1)*(nlevdecomp*3-2)) = a_tri(c,j) / dzsoi_decomp(j) * (-dtime) + if(j .ne. nlevdecomp)then + tri_ma_vr(c,j*3 +(i-1)*(nlevdecomp*3-2)) = c_tri(c,j) / dzsoi_decomp(j) * (-dtime) + end if + tri_ma_vr(c,j*3-2+(i-1)*(nlevdecomp*3-2)) = (b_tri(c,j) - a_p_0) / dzsoi_decomp(j) * (-dtime) + end do + else + if(j .eq. col%nbedrock(c) + 1 .and. j .ne. nlevdecomp .and. j .gt. 1)then + do i = 1,ndecomp_pools-1 + tri_ma_vr(c,(j-1)*3-2+(i-1)*(nlevdecomp*3-2)) = tri_ma_vr(c,(j-1)*3-2+(i-1)*(nlevdecomp*3-2)) & + + a_tri(c,j) / dzsoi_decomp(j-1)*(-dtime) + end do + end if + end if + end if + else ! j==nlevdecomp+1; 0 concentration gradient at bottom + a_tri(c,j) = -1._r8 + b_tri(c,j) = 1._r8 + c_tri(c,j) = 0._r8 + r_tri(c,j) = 0._r8 + endif + enddo ! fc; column + enddo ! j; nlevdecomp + + do fc = 1, num_soilc + c = filter_soilc (fc) + jtop(c) = 0 + enddo + + ! subtract initial concentration and source terms for tendency calculation + do fc = 1, num_soilc + c = filter_soilc (fc) + do j = 1, nlevdecomp + if (.not. use_soil_matrixcn) then + trcr_tendency_ptr(c,j,s) = 0.-(conc_trcr(c,j) + source(c,j,s)) + else + trcr_tendency_ptr(c,j,s) = 0.0_r8 + end if !soil_matrix + end do + end do + + if (.not. use_soil_matrixcn) then + ! Solve for the concentration profile for this time step + call Tridiagonal(bounds, 0, nlevdecomp+1, & + jtop(bounds%begc:bounds%endc), & + num_soilc, filter_soilc, & + a_tri(bounds%begc:bounds%endc, :), & + b_tri(bounds%begc:bounds%endc, :), & + c_tri(bounds%begc:bounds%endc, :), & + r_tri(bounds%begc:bounds%endc, :), & + conc_trcr(bounds%begc:bounds%endc,0:nlevdecomp+1)) + ! add post-transport concentration to calculate tendency term + do fc = 1, num_soilc + c = filter_soilc (fc) + do j = 1, nlevdecomp + trcr_tendency_ptr(c,j,s) = trcr_tendency_ptr(c,j,s) + conc_trcr(c,j) + trcr_tendency_ptr(c,j,s) = trcr_tendency_ptr(c,j,s) / dtime + end do + end do + else + do j = 1,nlevdecomp + do fc =1,num_soilc + c = filter_soilc(fc) + matrix_input(c,j+(s-1)*nlevdecomp) = matrix_input(c,j+(s-1)*nlevdecomp) + source(c,j,s) + end do + end do + end if !soil_matrix + else + ! for CWD pools, just add + do j = 1,nlevdecomp + do fc = 1, num_soilc + c = filter_soilc (fc) + if(.not. use_soil_matrixcn)then + conc_trcr(c,j) = conc_ptr(c,j,s) + source(c,j,s) + else + matrix_input(c,j+(s-1)*nlevdecomp) = matrix_input(c,j+(s-1)*nlevdecomp) + source(c,j,s) + end if + if (j > col%nbedrock(c) .and. source(c,j,s) > 0._r8) then + write(iulog,*) 'source >0',c,j,s,source(c,j,s) + end if + if (j > col%nbedrock(c) .and. conc_ptr(c,j,s) > 0._r8) then + write(iulog,*) 'conc_ptr >0',c,j,s,conc_ptr(c,j,s) + end if + end do + end do + end if ! not CWD + + if (.not. use_soil_matrixcn) then + do j = 1,nlevdecomp + do fc = 1, num_soilc + c = filter_soilc (fc) + conc_ptr(c,j,s) = conc_trcr(c,j) + ! Correct for small amounts of carbon that leak into bedrock + if (j > col%nbedrock(c)) then + conc_ptr(c,col%nbedrock(c),s) = conc_ptr(c,col%nbedrock(c),s) + & + conc_trcr(c,j) * (dzsoi_decomp(j) / dzsoi_decomp(col%nbedrock(c))) + conc_ptr(c,j,s) = 0._r8 + end if + end do + end do + end if !not soil_matrix + end do ! s (pool loop) + + else + + !! for single level case, no transport; just update the fluxes calculated in the StateUpdate1 subroutines + do l = 1, ndecomp_pools + do j = 1,nlevdecomp + do fc = 1, num_soilc + c = filter_soilc (fc) + + conc_ptr(c,j,l) = conc_ptr(c,j,l) + source(c,j,l) + + trcr_tendency_ptr(c,j,l) = 0._r8 + + end do + end do + end do + endif + + end do ! i_type + + end associate + + end subroutine SoilBiogeochemLittVertTransp + +end module SoilBiogeochemLittVertTranspMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNLeachingMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNLeachingMod.F90 new file mode 100755 index 000000000..7e8d847b5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNLeachingMod.F90 @@ -0,0 +1,289 @@ +module SoilBiogeochemNLeachingMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for mineral nitrogen dynamics (deposition, fixation, leaching) + ! for coupled carbon-nitrogen code. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use clm_varcon , only : dzsoi_decomp, zisoi + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterFluxBulkType , only : waterfluxbulk_type + use ColumnType , only : col + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: readParams + public :: SoilBiogeochemNLeaching + ! + ! !PRIVATE DATA: + type, private :: params_type + real(r8):: sf ! soluble fraction of mineral N (unitless) + real(r8):: sf_no3 ! soluble fraction of NO3 (unitless) + end type params_type + + type(params_type), private :: params_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !DESCRIPTION: + ! Read in parameters + ! + ! !USES: + use ncdio_pio , only : file_desc_t,ncd_io + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + ! + ! !ARGUMENTS: + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNNDynamicsParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + tString='sf_minn' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%sf=tempr + + tString='sf_no3' + call ncd_io(varname=trim(tString),data=tempr, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%sf_no3=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemNLeaching(bounds, num_soilc, filter_soilc, & + waterstatebulk_inst, waterfluxbulk_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update the nitrogen leaching rate + ! as a function of soluble mineral N and total soil water outflow. + ! + ! !USES: + use clm_varpar , only : nlevdecomp, nlevsoi + use clm_time_manager , only : get_step_size_real + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + type(soilbiogeochem_nitrogenstate_type) , intent(in) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: j,c,fc ! indices + real(r8) :: dt ! radiation time step (seconds) + real(r8) :: sf ! soluble fraction of mineral N (unitless) + real(r8) :: sf_no3 ! soluble fraction of NO3 (unitless) + real(r8) :: disn_conc ! dissolved mineral N concentration (gN/kg water) + real(r8) :: tot_water(bounds%begc:bounds%endc) ! total column liquid water (kg water/m2) + real(r8) :: surface_water(bounds%begc:bounds%endc) ! liquid water to shallow surface depth (kg water/m2) + real(r8) :: drain_tot(bounds%begc:bounds%endc) ! total drainage flux (mm H2O /s) + real(r8), parameter :: depth_runoff_Nloss = 0.05 ! (m) depth over which runoff mixes with soil water for N loss to runoff + !----------------------------------------------------------------------- + + associate( & + h2osoi_liq => waterstatebulk_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) + + qflx_drain => waterfluxbulk_inst%qflx_drain_col , & ! Input: [real(r8) (:) ] sub-surface runoff (mm H2O /s) + qflx_surf => waterfluxbulk_inst%qflx_surf_col , & ! Input: [real(r8) (:) ] total surface runoff (mm H2O /s) + + sminn_vr => soilbiogeochem_nitrogenstate_inst%sminn_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral N + smin_no3_vr => soilbiogeochem_nitrogenstate_inst%smin_no3_vr_col , & ! Input: [real(r8) (:,:) ] + + sminn_leached_vr => soilbiogeochem_nitrogenflux_inst%sminn_leached_vr_col , & ! Output: [real(r8) (:,:) ] rate of mineral N leaching (gN/m3/s) + smin_no3_leached_vr => soilbiogeochem_nitrogenflux_inst%smin_no3_leached_vr_col , & ! Output: [real(r8) (:,:) ] rate of mineral NO3 leaching (gN/m3/s) + smin_no3_runoff_vr => soilbiogeochem_nitrogenflux_inst%smin_no3_runoff_vr_col & ! Output: [real(r8) (:,:) ] rate of mineral NO3 loss with runoff (gN/m3/s) + ) + + ! set time steps + dt = get_step_size_real() + + if (.not. use_nitrif_denitrif) then + ! set constant sf + sf = params_inst%sf + else + ! Assume that 100% of the soil NO3 is in a soluble form + sf_no3 = params_inst%sf_no3 + end if + + ! calculate the total soil water + tot_water(bounds%begc:bounds%endc) = 0._r8 + do j = 1,nlevsoi + do fc = 1,num_soilc + c = filter_soilc(fc) + tot_water(c) = tot_water(c) + h2osoi_liq(c,j) + end do + end do + + ! for runoff calculation; calculate total water to a given depth + surface_water(bounds%begc:bounds%endc) = 0._r8 + do j = 1,nlevsoi + if ( zisoi(j) <= depth_runoff_Nloss) then + do fc = 1,num_soilc + c = filter_soilc(fc) + surface_water(c) = surface_water(c) + h2osoi_liq(c,j) + end do + elseif ( zisoi(j-1) < depth_runoff_Nloss) then + do fc = 1,num_soilc + c = filter_soilc(fc) + surface_water(c) = surface_water(c) + h2osoi_liq(c,j) * ( (depth_runoff_Nloss - zisoi(j-1)) / col%dz(c,j)) + end do + endif + end do + + ! Loop through columns + do fc = 1,num_soilc + c = filter_soilc(fc) + drain_tot(c) = qflx_drain(c) + end do + + + if (.not. use_nitrif_denitrif) then + + !---------------------------------------- + ! --------- NITRIF_NITRIF OFF------------ + !---------------------------------------- + + do j = 1,nlevdecomp + ! Loop through columns + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (.not. use_vertsoilc) then + ! calculate the dissolved mineral N concentration (gN/kg water) + ! assumes that 10% of mineral nitrogen is soluble + disn_conc = 0._r8 + if (tot_water(c) > 0._r8) then + disn_conc = (sf * sminn_vr(c,j) ) / tot_water(c) + end if + + ! calculate the N leaching flux as a function of the dissolved + ! concentration and the sub-surface drainage flux + sminn_leached_vr(c,j) = disn_conc * drain_tot(c) + else + ! calculate the dissolved mineral N concentration (gN/kg water) + ! assumes that 10% of mineral nitrogen is soluble + disn_conc = 0._r8 + if (h2osoi_liq(c,j) > 0._r8) then + disn_conc = (sf * sminn_vr(c,j) * col%dz(c,j) )/(h2osoi_liq(c,j) ) + end if + + ! calculate the N leaching flux as a function of the dissolved + ! concentration and the sub-surface drainage flux + sminn_leached_vr(c,j) = disn_conc * drain_tot(c) * h2osoi_liq(c,j) / ( tot_water(c) * col%dz(c,j) ) + + end if + + ! limit the flux based on current sminn state + ! only let at most the assumed soluble fraction + ! of sminn be leached on any given timestep + sminn_leached_vr(c,j) = min(sminn_leached_vr(c,j), (sf * sminn_vr(c,j))/dt) + + ! limit the flux to a positive value + sminn_leached_vr(c,j) = max(sminn_leached_vr(c,j), 0._r8) + + end do + end do + + else + + !---------------------------------------- + ! --------- NITRIF_NITRIF ON------------- + !---------------------------------------- + + do j = 1,nlevdecomp + ! Loop through columns + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (.not. use_vertsoilc) then + ! calculate the dissolved mineral N concentration (gN/kg water) + ! assumes that 10% of mineral nitrogen is soluble + disn_conc = 0._r8 + if (tot_water(c) > 0._r8) then + disn_conc = (sf_no3 * smin_no3_vr(c,j) )/tot_water(c) + end if + + ! calculate the N leaching flux as a function of the dissolved + ! concentration and the sub-surface drainage flux + smin_no3_leached_vr(c,j) = disn_conc * drain_tot(c) + else + ! calculate the dissolved mineral N concentration (gN/kg water) + ! assumes that 10% of mineral nitrogen is soluble + disn_conc = 0._r8 + if (h2osoi_liq(c,j) > 0._r8) then + disn_conc = (sf_no3 * smin_no3_vr(c,j) * col%dz(c,j) )/(h2osoi_liq(c,j) ) + end if + ! + ! calculate the N leaching flux as a function of the dissolved + ! concentration and the sub-surface drainage flux + smin_no3_leached_vr(c,j) = disn_conc * drain_tot(c) * h2osoi_liq(c,j) / ( tot_water(c) * col%dz(c,j) ) + ! + ! ensure that leaching rate isn't larger than soil N pool + smin_no3_leached_vr(c,j) = min(smin_no3_leached_vr(c,j), smin_no3_vr(c,j) / dt ) + ! + ! limit the leaching flux to a positive value + smin_no3_leached_vr(c,j) = max(smin_no3_leached_vr(c,j), 0._r8) + ! + ! + ! calculate the N loss from surface runoff, assuming a shallow mixing of surface waters into soil and removal based on runoff + if ( zisoi(j) <= depth_runoff_Nloss ) then + smin_no3_runoff_vr(c,j) = disn_conc * qflx_surf(c) * & + h2osoi_liq(c,j) / ( surface_water(c) * col%dz(c,j) ) + elseif ( zisoi(j-1) < depth_runoff_Nloss ) then + smin_no3_runoff_vr(c,j) = disn_conc * qflx_surf(c) * & + h2osoi_liq(c,j) * ((depth_runoff_Nloss - zisoi(j-1)) / & + col%dz(c,j)) / ( surface_water(c) * (depth_runoff_Nloss-zisoi(j-1) )) + else + smin_no3_runoff_vr(c,j) = 0._r8 + endif + ! + ! ensure that runoff rate isn't larger than soil N pool + smin_no3_runoff_vr(c,j) = min(smin_no3_runoff_vr(c,j), smin_no3_vr(c,j) / dt - smin_no3_leached_vr(c,j)) + ! + ! limit the flux to a positive value + smin_no3_runoff_vr(c,j) = max(smin_no3_runoff_vr(c,j), 0._r8) + + + endif + ! limit the flux based on current smin_no3 state + ! only let at most the assumed soluble fraction + ! of smin_no3 be leached on any given timestep + smin_no3_leached_vr(c,j) = min(smin_no3_leached_vr(c,j), (sf_no3 * smin_no3_vr(c,j))/dt) + + ! limit the flux to a positive value + smin_no3_leached_vr(c,j) = max(smin_no3_leached_vr(c,j), 0._r8) + + end do + end do + endif + + end associate + + end subroutine SoilBiogeochemNLeaching + +end module SoilBiogeochemNLeachingMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNStateUpdate1Mod.F90 new file mode 100755 index 000000000..eab4f40d5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNStateUpdate1Mod.F90 @@ -0,0 +1,272 @@ +module SoilBiogeochemNStateUpdate1Mod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for nitrogen state variable updates, non-mortality fluxes. + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use clm_time_manager , only : get_step_size_real + use clm_varpar , only : nlevdecomp, ndecomp_pools, ndecomp_cascade_transitions + use clm_varpar , only : i_met_lit, i_cel_lit, i_lig_lit, i_cwd + use clm_varctl , only : iulog, use_nitrif_denitrif, use_crop + use clm_varctl , only : use_soil_matrixcn + use clm_varcon , only : nitrif_n2o_loss_frac, dzsoi_decomp + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenfluxType , only : soilbiogeochem_nitrogenflux_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use CNSharedParamsMod , only : use_fun + use ColumnType , only : col + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: SoilBiogeochemNStateUpdate1 + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemNStateUpdate1(num_soilc, filter_soilc, & + soilbiogeochem_state_inst, soilbiogeochem_nitrogenflux_inst, soilbiogeochem_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! On the radiation time step, update all the prognostic nitrogen state + ! variables (except for gap-phase mortality and fire fluxes) + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_state_type) , intent(in) :: soilbiogeochem_state_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p,j,l,k ! indices + integer :: fp,fc ! lake filter indices + real(r8):: dt ! radiation time step (seconds) + + !----------------------------------------------------------------------- + + associate( & + cascade_donor_pool => decomp_cascade_con%cascade_donor_pool , & ! Input: [integer (:) ] which pool is C taken from for a given decomposition step + cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool , & ! Input: [integer (:) ] which pool is C added to for a given decomposition step + + ndep_prof => soilbiogeochem_state_inst%ndep_prof_col , & ! Input: [real(r8) (:,:) ] profile over which N deposition is distributed through column (1/m) + nfixation_prof => soilbiogeochem_state_inst%nfixation_prof_col , & ! Input: [real(r8) (:,:) ] profile over which N fixation is distributed through column (1/m) + + nf => soilbiogeochem_nitrogenflux_inst , & ! Output: + ns => soilbiogeochem_nitrogenstate_inst & ! Output: + ) + + ! set time steps + dt = get_step_size_real() + + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if(use_fun)then !RF in FUN logic, the fixed N goes straight into the plant, and not into the SMINN pool. + ! N deposition and fixation (put all into NH4 pool) + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) + nf%ndep_to_sminn_col(c)*dt * ndep_prof(c,j) + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) + nf%ffix_to_sminn_col(c)*dt * nfixation_prof(c,j) + else + if (.not. use_nitrif_denitrif) then + + ! N deposition and fixation + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) + nf%ndep_to_sminn_col(c)*dt * ndep_prof(c,j) + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) + nf%nfix_to_sminn_col(c)*dt * nfixation_prof(c,j) + + else + + ! N deposition and fixation (put all into NH4 pool) + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) + nf%ndep_to_sminn_col(c)*dt * ndep_prof(c,j) + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) + nf%nfix_to_sminn_col(c)*dt * nfixation_prof(c,j) + + end if + end if + + end do + + end do + + ! repeating N dep and fixation for crops + if ( use_crop )then + do j = 1, nlevdecomp + + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + if (.not. use_nitrif_denitrif) then + + ! N deposition and fixation + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) & + + nf%fert_to_sminn_col(c)*dt * ndep_prof(c,j) + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) & + + nf%soyfixn_to_sminn_col(c)*dt * nfixation_prof(c,j) + + else + + ! N deposition and fixation (put all into NH4 pool) + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) & + + nf%fert_to_sminn_col(c)*dt * ndep_prof(c,j) + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) & + + nf%soyfixn_to_sminn_col(c)*dt * nfixation_prof(c,j) + + end if + end do + end do + end if + + ! decomposition fluxes + if (.not. use_soil_matrixcn) then + do k = 1, ndecomp_cascade_transitions + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + nf%decomp_npools_sourcesink_col(c,j,cascade_donor_pool(k)) = & + nf%decomp_npools_sourcesink_col(c,j,cascade_donor_pool(k)) - & + nf%decomp_cascade_ntransfer_vr_col(c,j,k) * dt + end do + end do + end do + + + do k = 1, ndecomp_cascade_transitions + if ( cascade_receiver_pool(k) /= 0 ) then ! skip terminal transitions + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + nf%decomp_npools_sourcesink_col(c,j,cascade_receiver_pool(k)) = & + nf%decomp_npools_sourcesink_col(c,j,cascade_receiver_pool(k)) + & + (nf%decomp_cascade_ntransfer_vr_col(c,j,k) + & + nf%decomp_cascade_sminn_flux_vr_col(c,j,k)) * dt + end do + end do + else ! terminal transitions + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + nf%decomp_npools_sourcesink_col(c,j,cascade_donor_pool(k)) = & + nf%decomp_npools_sourcesink_col(c,j,cascade_donor_pool(k)) - & + nf%decomp_cascade_sminn_flux_vr_col(c,j,k) * dt + end do + end do + end if + end do + end if ! + + if (.not. use_nitrif_denitrif) then + + !-------------------------------------------------------- + !------------- NITRIF_DENITRIF OFF ------------------- + !-------------------------------------------------------- + + ! immobilization/mineralization in litter-to-SOM and SOM-to-SOM fluxes and denitrification fluxes + do k = 1, ndecomp_cascade_transitions + if ( cascade_receiver_pool(k) /= 0 ) then ! skip terminal transitions + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) - & + (nf%sminn_to_denit_decomp_cascade_vr_col(c,j,k) + & + nf%decomp_cascade_sminn_flux_vr_col(c,j,k))* dt + end do + end do + else + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) - & + nf%sminn_to_denit_decomp_cascade_vr_col(c,j,k)* dt + + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) + & + nf%decomp_cascade_sminn_flux_vr_col(c,j,k)* dt + + end do + end do + endif + end do + + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + ! "bulk denitrification" + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) - nf%sminn_to_denit_excess_vr_col(c,j) * dt + + ! total plant uptake from mineral N + if ( .not. use_fun ) then + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) - nf%sminn_to_plant_vr_col(c,j)*dt + else + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) - nf%sminn_to_plant_fun_vr_col(c,j)*dt + end if + ! flux that prevents N limitation (when Carbon_only is set) + ns%sminn_vr_col(c,j) = ns%sminn_vr_col(c,j) + nf%supplement_to_sminn_vr_col(c,j)*dt + end do + end do + + else + + !-------------------------------------------------------- + !------------- NITRIF_DENITRIF ON -------------------- + !-------------------------------------------------------- + + do j = 1, nlevdecomp + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! mineralization fluxes (divert a fraction of this stream to nitrification flux, add the rest to NH4 pool) + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) + nf%gross_nmin_vr_col(c,j)*dt + + ! immobilization fluxes + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) - nf%actual_immob_nh4_vr_col(c,j)*dt + + ns%smin_no3_vr_col(c,j) = ns%smin_no3_vr_col(c,j) - nf%actual_immob_no3_vr_col(c,j)*dt + + ! plant uptake fluxes + if ( .not. use_fun )then + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) - nf%smin_nh4_to_plant_vr_col(c,j)*dt + + ns%smin_no3_vr_col(c,j) = ns%smin_no3_vr_col(c,j) - nf%smin_no3_to_plant_vr_col(c,j)*dt + else + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) - nf%sminn_to_plant_fun_nh4_vr_col(c,j)*dt + + ns%smin_no3_vr_col(c,j) = ns%smin_no3_vr_col(c,j) - nf%sminn_to_plant_fun_no3_vr_col(c,j)*dt + end if + + + ! Account for nitrification fluxes + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) - nf%f_nit_vr_col(c,j) * dt + + ns%smin_no3_vr_col(c,j) = ns%smin_no3_vr_col(c,j) + nf%f_nit_vr_col(c,j) * dt & + * (1._r8 - nitrif_n2o_loss_frac) + + ! Account for denitrification fluxes + ns%smin_no3_vr_col(c,j) = ns%smin_no3_vr_col(c,j) - nf%f_denit_vr_col(c,j) * dt + + ! flux that prevents N limitation (when Carbon_only is set; put all into NH4) + ns%smin_nh4_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) + nf%supplement_to_sminn_vr_col(c,j)*dt + + ! update diagnostic total + ns%sminn_vr_col(c,j) = ns%smin_nh4_vr_col(c,j) + ns%smin_no3_vr_col(c,j) + + end do ! end of column loop + end do + + end if + + end associate + + end subroutine SoilBiogeochemNStateUpdate1 + +end module SoilBiogeochemNStateUpdate1Mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNitrifDenitrifMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNitrifDenitrifMod.F90 new file mode 100755 index 000000000..784b90719 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNitrifDenitrifMod.F90 @@ -0,0 +1,396 @@ +module SoilBiogeochemNitrifDenitrifMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculate nitrification and denitrification rates + ! + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_TKFRZ + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : nlevdecomp + use clm_varcon , only : rpi, grav + use clm_varcon , only : d_con_g, d_con_w, secspday + use clm_varctl , only : use_lch4 + use abortutils , only : endrun + use decompMod , only : bounds_type + use SoilStatetype , only : soilstate_type + use WaterStateBulkType , only : waterstatebulk_type + use TemperatureType , only : temperature_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use ch4Mod , only : ch4_type + use ColumnType , only : col + ! + implicit none + private + ! + public :: readParams ! Read in parameters from params file + public :: SoilBiogeochemNitrifDenitrif ! Calculate nitrification and + ! + type, private :: params_type + real(r8) :: k_nitr_max_perday ! maximum nitrification rate constant (1/day) + real(r8) :: surface_tension_water ! surface tension of water(J/m^2), Arah an and Vinten 1995 + real(r8) :: rij_kro_a ! Arah and Vinten 1995) + real(r8) :: rij_kro_alpha ! parameter to calculate anoxic fraction of soil (Arah and Vinten 1995) + real(r8) :: rij_kro_beta ! (Arah and Vinten 1995) + real(r8) :: rij_kro_gamma ! (Arah and Vinten 1995) + real(r8) :: rij_kro_delta ! (Arah and Vinten 1995) + real(r8) :: denitrif_respiration_coefficient ! Multiplier for heterotrophic respiration for max denitrif rates + real(r8) :: denitrif_respiration_exponent ! Exponents for heterotrophic respiration for max denitrif rates + real(r8) :: denitrif_nitrateconc_coefficient ! Multiplier for nitrate concentration for max denitrif rates + real(r8) :: denitrif_nitrateconc_exponent ! Exponent for nitrate concentration for max denitrif rates + end type params_type + + type(params_type), private :: params_inst + + logical, public :: no_frozen_nitrif_denitrif = .false. ! stop nitrification and denitrification in frozen soils + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + use ncdio_pio, only: file_desc_t,ncd_io + ! + ! !ARGUMENTS: + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNNitrifDenitrifParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + ! + ! read in constants + ! + tString='surface_tension_water' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%surface_tension_water=tempr + + tString='rij_kro_a' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rij_kro_a=tempr + + tString='rij_kro_alpha' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rij_kro_alpha=tempr + + tString='rij_kro_beta' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rij_kro_beta=tempr + + tString='rij_kro_gamma' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rij_kro_gamma=tempr + + tString='rij_kro_delta' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%rij_kro_delta=tempr + + tString='k_nitr_max_perday' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%k_nitr_max_perday=tempr + + tString='denitrif_nitrateconc_coefficient' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%denitrif_nitrateconc_coefficient=tempr + + tString='denitrif_nitrateconc_exponent' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%denitrif_nitrateconc_exponent=tempr + + tString='denitrif_respiration_coefficient' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%denitrif_respiration_coefficient=tempr + + tString='denitrif_respiration_exponent' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%denitrif_respiration_exponent=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemNitrifDenitrif(bounds, num_soilc, filter_soilc, & + soilstate_inst, waterstatebulk_inst, temperature_inst, ch4_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst) + ! + ! !DESCRIPTION: + ! calculate nitrification and denitrification rates + ! + ! !USES: + use clm_time_manager , only : get_curr_date + use CNSharedParamsMod , only : CNParamsShareInst + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilstate_type) , intent(in) :: soilstate_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(temperature_type) , intent(in) :: temperature_inst + type(ch4_type) , intent(in) :: ch4_inst + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(in) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + ! + ! !LOCAL VARIABLES: + integer :: c, fc, reflev, j + real(r8) :: soil_hr_vr(bounds%begc:bounds%endc,1:nlevdecomp) ! total soil respiration rate (g C / m3 / s) + real(r8) :: g_per_m3__to__ug_per_gsoil + real(r8) :: g_per_m3_sec__to__ug_per_gsoil_day + real(r8) :: mu, sigma + real(r8) :: t + real(r8) :: pH(bounds%begc:bounds%endc) + !debug-- put these type structure for outing to hist files + real(r8) :: co2diff_con(2) ! diffusion constants for CO2 + real(r8) :: eps + real(r8) :: f_a + real(r8) :: surface_tension_water ! (J/m^2), Arah and Vinten 1995 + real(r8) :: rij_kro_a ! Arah and Vinten 1995 + real(r8) :: rij_kro_alpha ! Arah and Vinten 1995 + real(r8) :: rij_kro_beta ! Arah and Vinten 1995 + real(r8) :: rij_kro_gamma ! Arah and Vinten 1995 + real(r8) :: rij_kro_delta ! Arah and Vinten 1995 + real(r8) :: rho_w = 1.e3_r8 ! (kg/m3) + real(r8) :: r_max + real(r8) :: r_min(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8) :: ratio_diffusivity_water_gas(bounds%begc:bounds%endc,1:nlevdecomp) + real(r8) :: om_frac + real(r8) :: anaerobic_frac_sat, r_psi_sat, r_min_sat ! scalar values in sat portion for averaging + real(r8) :: organic_max ! organic matter content (kg/m3) where + ! soil is assumed to act like peat + character(len=32) :: subname='nitrif_denitrif' ! subroutine name + !----------------------------------------------------------------------- + + associate( & + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) (nlevgrnd) + watfc => soilstate_inst%watfc_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at field capacity (nlevsoi) + bd => soilstate_inst%bd_col , & ! Input: [real(r8) (:,:) ] bulk density of dry soil material [kg/m3] + bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" (nlevgrnd) + cellorg => soilstate_inst%cellorg_col , & ! Input: [real(r8) (:,:) ] column 3D org (kg/m3 organic matter) (nlevgrnd) + sucsat => soilstate_inst%sucsat_col , & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) + soilpsi => soilstate_inst%soilpsi_col , & ! Input: [real(r8) (:,:) ] soil water potential in each soil layer (MPa) + + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (nlevgrnd) + h2osoi_liq => waterstatebulk_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) + + o2_decomp_depth_unsat => ch4_inst%o2_decomp_depth_unsat_col , & ! Input: [real(r8) (:,:) ] O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + conc_o2_unsat => ch4_inst%conc_o2_unsat_col , & ! Input: [real(r8) (:,:) ] O2 conc in each soil layer (mol/m3) (nlevsoi) + o2_decomp_depth_sat => ch4_inst%o2_decomp_depth_sat_col , & ! Input: [real(r8) (:,:) ] O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + conc_o2_sat => ch4_inst%conc_o2_sat_col , & ! Input: [real(r8) (:,:) ] O2 conc in each soil layer (mol/m3) (nlevsoi) + finundated => ch4_inst%finundated_col , & ! Input: [real(r8) (:) ] fractional inundated area in soil column (excluding dedicated wetland columns) + + smin_nh4_vr => soilbiogeochem_nitrogenstate_inst%smin_nh4_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral NH4 pool + smin_no3_vr => soilbiogeochem_nitrogenstate_inst%smin_no3_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3) soil mineral NO3 pool + + phr_vr => soilbiogeochem_carbonflux_inst%phr_vr_col , & ! Input: [real(r8) (:,:) ] potential hr (not N-limited) + w_scalar => soilbiogeochem_carbonflux_inst%w_scalar_col , & ! Input: [real(r8) (:,:) ] soil water scalar for decomp + t_scalar => soilbiogeochem_carbonflux_inst%t_scalar_col , & ! Input: [real(r8) (:,:) ] temperature scalar for decomp + denit_resp_coef => params_inst%denitrif_respiration_coefficient , & ! Input: [real(r8) ] coefficient for max denitrification rate based on respiration + denit_resp_exp => params_inst%denitrif_respiration_exponent , & ! Input: [real(r8) ] exponent for max denitrification rate based on respiration + denit_nitrate_coef => params_inst%denitrif_nitrateconc_coefficient , & ! Input: [real(r8) ] coefficient for max denitrification rate based on nitrate concentration + denit_nitrate_exp => params_inst%denitrif_nitrateconc_exponent , & ! Input: [real(r8) ] exponent for max denitrification rate based on nitrate concentration + k_nitr_max_perday => params_inst%k_nitr_max_perday , & ! Input: [real(r8) ] maximum nitrification rate constant (1/day) + r_psi => soilbiogeochem_nitrogenflux_inst%r_psi_col , & ! Output: [real(r8) (:,:) ] + anaerobic_frac => soilbiogeochem_nitrogenflux_inst%anaerobic_frac_col , & ! Output: [real(r8) (:,:) ] + ! ! subsets of the n flux calcs (for diagnostic/debugging purposes) + smin_no3_massdens_vr => soilbiogeochem_nitrogenflux_inst%smin_no3_massdens_vr_col , & ! Output: [real(r8) (:,:) ] (ugN / g soil) soil nitrate concentration + k_nitr_t_vr => soilbiogeochem_nitrogenflux_inst%k_nitr_t_vr_col , & ! Output: [real(r8) (:,:) ] + k_nitr_ph_vr => soilbiogeochem_nitrogenflux_inst%k_nitr_ph_vr_col , & ! Output: [real(r8) (:,:) ] + k_nitr_h2o_vr => soilbiogeochem_nitrogenflux_inst%k_nitr_h2o_vr_col , & ! Output: [real(r8) (:,:) ] + k_nitr_vr => soilbiogeochem_nitrogenflux_inst%k_nitr_vr_col , & ! Output: [real(r8) (:,:) ] + wfps_vr => soilbiogeochem_nitrogenflux_inst%wfps_vr_col , & ! Output: [real(r8) (:,:) ] + fmax_denit_carbonsubstrate_vr => soilbiogeochem_nitrogenflux_inst%fmax_denit_carbonsubstrate_vr_col , & ! Output: [real(r8) (:,:) ] + fmax_denit_nitrate_vr => soilbiogeochem_nitrogenflux_inst%fmax_denit_nitrate_vr_col , & ! Output: [real(r8) (:,:) ] + f_denit_base_vr => soilbiogeochem_nitrogenflux_inst%f_denit_base_vr_col , & ! Output: [real(r8) (:,:) ] + diffus => soilbiogeochem_nitrogenflux_inst%diffus_col , & ! Output: [real(r8) (:,:) ] diffusivity (unitless fraction of total diffusivity) + ratio_k1 => soilbiogeochem_nitrogenflux_inst%ratio_k1_col , & ! Output: [real(r8) (:,:) ] + ratio_no3_co2 => soilbiogeochem_nitrogenflux_inst%ratio_no3_co2_col , & ! Output: [real(r8) (:,:) ] + soil_co2_prod => soilbiogeochem_nitrogenflux_inst%soil_co2_prod_col , & ! Output: [real(r8) (:,:) ] (ug C / g soil / day) + fr_WFPS => soilbiogeochem_nitrogenflux_inst%fr_WFPS_col , & ! Output: [real(r8) (:,:) ] + soil_bulkdensity => soilbiogeochem_nitrogenflux_inst%soil_bulkdensity_col , & ! Output: [real(r8) (:,:) ] (kg soil / m3) bulk density of soil (including water) + pot_f_nit_vr => soilbiogeochem_nitrogenflux_inst%pot_f_nit_vr_col , & ! Output: [real(r8) (:,:) ] (gN/m3/s) potential soil nitrification flux + + pot_f_denit_vr => soilbiogeochem_nitrogenflux_inst%pot_f_denit_vr_col , & ! Output: [real(r8) (:,:) ] (gN/m3/s) potential soil denitrification flux + n2_n2o_ratio_denit_vr => soilbiogeochem_nitrogenflux_inst%n2_n2o_ratio_denit_vr_col & ! Output: [real(r8) (:,:) ] ratio of N2 to N2O production by denitrification [gN/gN] + ) + + surface_tension_water = params_inst%surface_tension_water + + ! Set parameters from simple-structure model to calculate anoxic fratction (Arah and Vinten 1995) + rij_kro_a = params_inst%rij_kro_a + rij_kro_alpha = params_inst%rij_kro_alpha + rij_kro_beta = params_inst%rij_kro_beta + rij_kro_gamma = params_inst%rij_kro_gamma + rij_kro_delta = params_inst%rij_kro_delta + + organic_max = CNParamsShareInst%organic_max + + pH(bounds%begc:bounds%endc) = 6.5 !!! set all soils with the same pH as placeholder here + co2diff_con(1) = 0.1325_r8 + co2diff_con(2) = 0.0009_r8 + + do j = 1, nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + !---------------- calculate soil anoxia state + ! calculate gas diffusivity of soil at field capacity here + ! use expression from methane code, but neglect OM for now + f_a = 1._r8 - watfc(c,j) / watsat(c,j) + eps = watsat(c,j)-watfc(c,j) ! Air-filled fraction of total soil volume + + ! use diffusivity calculation including peat + if (use_lch4) then + + if (organic_max > 0._r8) then + om_frac = min(cellorg(c,j)/organic_max, 1._r8) + ! Use first power, not square as in iniTimeConst + else + om_frac = 1._r8 + end if + diffus (c,j) = (d_con_g(2,1) + d_con_g(2,2)*t_soisno(c,j)) * 1.e-4_r8 * & + (om_frac * f_a**(10._r8/3._r8) / watsat(c,j)**2 + & + (1._r8-om_frac) * eps**2 * f_a**(3._r8 / bsw(c,j)) ) + + ! calculate anoxic fraction of soils + ! use rijtema and kroess model after Riley et al., 2000 + ! caclulated r_psi as a function of psi + r_min(c,j) = 2 * surface_tension_water / (rho_w * grav * abs(soilpsi(c,j))) + r_max = 2 * surface_tension_water / (rho_w * grav * 0.1_r8) + r_psi(c,j) = sqrt(r_min(c,j) * r_max) + ratio_diffusivity_water_gas(c,j) = (d_con_g(2,1) + d_con_g(2,2)*t_soisno(c,j) ) * 1.e-4_r8 / & + ((d_con_w(2,1) + d_con_w(2,2)*t_soisno(c,j) + d_con_w(2,3)*t_soisno(c,j)**2) * 1.e-9_r8) + + if (o2_decomp_depth_unsat(c,j) > 0._r8) then + anaerobic_frac(c,j) = exp(-rij_kro_a * r_psi(c,j)**(-rij_kro_alpha) * & + o2_decomp_depth_unsat(c,j)**(-rij_kro_beta) * & + conc_o2_unsat(c,j)**rij_kro_gamma * (h2osoi_vol(c,j) + ratio_diffusivity_water_gas(c,j) * & + watsat(c,j))**rij_kro_delta) + else + anaerobic_frac(c,j) = 0._r8 + endif + + else + ! NITRIF_DENITRIF requires Methane model to be active, + ! otherwise diffusivity will be zeroed out here. EBK CDK 10/18/2011 + anaerobic_frac(c,j) = 0._r8 + diffus (c,j) = 0._r8 + !call endrun(msg=' ERROR: NITRIF_DENITRIF requires Methane model to be active'//errMsg(sourcefile, __LINE__) ) + end if + + + !---------------- nitrification + ! follows CENTURY nitrification scheme (Parton et al., (2001, 1996)) + + ! assume nitrification temp function equal to the HR scalar + k_nitr_t_vr(c,j) = min(t_scalar(c,j), 1._r8) + + ! ph function from Parton et al., (2001, 1996) + k_nitr_ph_vr(c,j) = 0.56 + atan(rpi * 0.45 * (-5.+ pH(c)))/rpi + + ! moisture function-- assume the same moisture function as limits heterotrophic respiration + ! Parton et al. base their nitrification- soil moisture rate constants based on heterotrophic rates-- can we do the same? + k_nitr_h2o_vr(c,j) = w_scalar(c,j) + + ! nitrification constant is a set scalar * temp, moisture, and ph scalars + ! note that k_nitr_max_perday is converted from 1/day to 1/s + k_nitr_vr(c,j) = k_nitr_max_perday/secspday * k_nitr_t_vr(c,j) * k_nitr_h2o_vr(c,j) * k_nitr_ph_vr(c,j) + + ! first-order decay of ammonium pool with scalar defined above + pot_f_nit_vr(c,j) = max(smin_nh4_vr(c,j) * k_nitr_vr(c,j), 0._r8) + + ! limit to oxic fraction of soils + pot_f_nit_vr(c,j) = pot_f_nit_vr(c,j) * (1._r8 - anaerobic_frac(c,j)) + + ! limit to non-frozen soil layers + if ( t_soisno(c,j) <= SHR_CONST_TKFRZ .and. no_frozen_nitrif_denitrif) then + pot_f_nit_vr(c,j) = 0._r8 + endif + + + !---------------- denitrification + ! first some input variables an unit conversions + soil_hr_vr(c,j) = phr_vr(c,j) + + ! CENTURY papers give denitrification in units of per gram soil; need to convert from volumetric to mass-based units here + soil_bulkdensity(c,j) = bd(c,j) + h2osoi_liq(c,j)/col%dz(c,j) + + g_per_m3__to__ug_per_gsoil = 1.e3_r8 / soil_bulkdensity(c,j) + + g_per_m3_sec__to__ug_per_gsoil_day = g_per_m3__to__ug_per_gsoil * secspday + + smin_no3_massdens_vr(c,j) = max(smin_no3_vr(c,j), 0._r8) * g_per_m3__to__ug_per_gsoil + + soil_co2_prod(c,j) = (soil_hr_vr(c,j) * (g_per_m3_sec__to__ug_per_gsoil_day)) + + !! maximum potential denitrification rates based on heterotrophic respiration rates or nitrate concentrations, + !! from (del Grosso et al., 2000) + fmax_denit_carbonsubstrate_vr(c,j) = (denit_resp_coef * (soil_co2_prod(c,j)**denit_resp_exp)) & + / g_per_m3_sec__to__ug_per_gsoil_day + ! + fmax_denit_nitrate_vr(c,j) = (denit_nitrate_coef * smin_no3_massdens_vr(c,j)**denit_nitrate_exp) & + / g_per_m3_sec__to__ug_per_gsoil_day + + ! find limiting denitrification rate + f_denit_base_vr(c,j) = max(min(fmax_denit_carbonsubstrate_vr(c,j), fmax_denit_nitrate_vr(c,j)),0._r8) + + ! limit to non-frozen soil layers + if ( t_soisno(c,j) <= SHR_CONST_TKFRZ .and. no_frozen_nitrif_denitrif ) then + f_denit_base_vr(c,j) = 0._r8 + endif + + ! limit to anoxic fraction of soils + pot_f_denit_vr(c,j) = f_denit_base_vr(c,j) * anaerobic_frac(c,j) + + ! now calculate the ratio of N2O to N2 from denitrifictaion, following Del Grosso et al., 2000 + ! diffusivity constant (figure 6b) + ratio_k1(c,j) = max(1.7_r8, 38.4_r8 - 350._r8 * diffus(c,j)) + + ! ratio function (figure 7c) + if ( soil_co2_prod(c,j) > 1.0e-9_r8 ) then + ratio_no3_co2(c,j) = smin_no3_massdens_vr(c,j) / soil_co2_prod(c,j) + else + ! fucntion saturates at large no3/co2 ratios, so set as some nominally large number + ratio_no3_co2(c,j) = 100._r8 + endif + + ! total water limitation function (Del Grosso et al., 2000, figure 7a) + wfps_vr(c,j) = max(min(h2osoi_vol(c,j)/watsat(c, j), 1._r8), 0._r8) * 100._r8 + fr_WFPS(c,j) = max(0.1_r8, 0.015_r8 * wfps_vr(c,j) - 0.32_r8) + + ! final ratio expression + n2_n2o_ratio_denit_vr(c,j) = max(0.16*ratio_k1(c,j), ratio_k1(c,j)*exp(-0.8 * ratio_no3_co2(c,j))) * fr_WFPS(c,j) + + end do + + end do + + end associate + + end subroutine SoilBiogeochemNitrifDenitrif + +end module SoilBiogeochemNitrifDenitrifMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemPotentialMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemPotentialMod.F90 new file mode 100755 index 000000000..b9b9afad0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemPotentialMod.F90 @@ -0,0 +1,264 @@ +module SoilBiogeochemPotentialMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculate potential decomp rates and total immobilization demand. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use clm_varpar , only : nlevdecomp, ndecomp_cascade_transitions, ndecomp_pools + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use clm_varctl , only : use_fates, iulog + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: readParams + public :: SoilBiogeochemPotential + ! + type, private :: params_type + real(r8) :: dnp !denitrification proportion + end type Params_type + ! + type(params_type), private :: params_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !DESCRIPTION: + ! Read parameters + ! + ! !USES: + use ncdio_pio , only: file_desc_t,ncd_io + use abortutils , only: endrun + use shr_log_mod , only: errMsg => shr_log_errMsg + ! + ! !ARGUMENTS: + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'CNDecompParamsType' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: tempr ! temporary to read in constant + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + tString='dnp' + call ncd_io(trim(tString),tempr, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%dnp=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemPotential (bounds, num_soilc, filter_soilc, & + soilbiogeochem_state_inst, soilbiogeochem_carbonstate_inst, soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenstate_inst, soilbiogeochem_nitrogenflux_inst, & + cn_decomp_pools, p_decomp_cpool_loss, pmnf_decomp_cascade) + ! + ! !USES: + use shr_log_mod , only : errMsg => shr_log_errMsg + use SoilBiogeochemDecompCascadeConType, only : i_atm + ! + ! !ARGUMENT: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + type(soilbiogeochem_carbonstate_type) , intent(in) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonflux_type) , intent(inout) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + type(soilbiogeochem_nitrogenflux_type) , intent(inout) :: soilbiogeochem_nitrogenflux_inst + real(r8) , intent(out) :: cn_decomp_pools(bounds%begc:,1:,1:) ! c:n ratios of applicable pools + real(r8) , intent(out) :: p_decomp_cpool_loss(bounds%begc:,1:,1:) ! potential C loss from one pool to another + real(r8) , intent(out) :: pmnf_decomp_cascade(bounds%begc:,1:,1:) ! potential mineral N flux, from one pool to another + ! + ! !LOCAL VARIABLES: + integer :: c,j,k,l,m !indices + integer :: fc !filter column index + integer :: begc,endc !bounds + real(r8):: immob(bounds%begc:bounds%endc,1:nlevdecomp) !potential N immobilization + real(r8):: ratio !temporary variable + !----------------------------------------------------------------------- + + begc = bounds%begc; endc = bounds%endc + + SHR_ASSERT_ALL_FL((ubound(cn_decomp_pools) == (/endc,nlevdecomp,ndecomp_pools/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(p_decomp_cpool_loss) == (/endc,nlevdecomp,ndecomp_cascade_transitions/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(pmnf_decomp_cascade) == (/endc,nlevdecomp,ndecomp_cascade_transitions/)) , sourcefile, __LINE__) + + associate( & + cascade_donor_pool => decomp_cascade_con%cascade_donor_pool , & ! Input: [integer (:) ] which pool is C taken from for a given decomposition step + cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool , & ! Input: [integer (:) ] which pool is C added to for a given decomposition step + floating_cn_ratio_decomp_pools => decomp_cascade_con%floating_cn_ratio_decomp_pools , & ! Input: [logical (:) ] TRUE => pool has fixed C:N ratio + initial_cn_ratio => decomp_cascade_con%initial_cn_ratio , & ! Input: [real(r8) (:) ] c:n ratio for initialization of pools + + fpi_vr => soilbiogeochem_state_inst%fpi_vr_col , & ! Input: [real(r8) (:,:) ] fraction of potential immobilization (no units) + rf_decomp_cascade => soilbiogeochem_state_inst%rf_decomp_cascade_col , & ! Input: [real(r8) (:,:,:) ] respired fraction in decomposition step (frac) + pathfrac_decomp_cascade => soilbiogeochem_state_inst%pathfrac_decomp_cascade_col , & ! Input: [real(r8) (:,:,:) ] what fraction of C leaving a given pool passes through a given transition (frac) + + decomp_npools_vr => soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools + + decomp_cpools_vr => soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col , & ! Input: [real(r8) (:,:,:) ] (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools + + decomp_cascade_ntransfer_vr => soilbiogeochem_nitrogenflux_inst%decomp_cascade_ntransfer_vr_col , & ! Output: [real(r8) (:,:,:) ] vert-res transfer of N from donor to receiver pool along decomp. cascade (gN/m3/s) + decomp_cascade_sminn_flux_vr => soilbiogeochem_nitrogenflux_inst%decomp_cascade_sminn_flux_vr_col , & ! Output: [real(r8) (:,:,:) ] vert-res mineral N flux for transition along decomposition cascade (gN/m3/s) + potential_immob_vr => soilbiogeochem_nitrogenflux_inst%potential_immob_vr_col , & ! Output: [real(r8) (:,:) ] + sminn_to_denit_decomp_cascade_vr => soilbiogeochem_nitrogenflux_inst%sminn_to_denit_decomp_cascade_vr_col , & ! Output: [real(r8) (:,:,:) ] + gross_nmin_vr => soilbiogeochem_nitrogenflux_inst%gross_nmin_vr_col , & ! Output: [real(r8) (:,:) ] + net_nmin_vr => soilbiogeochem_nitrogenflux_inst%net_nmin_vr_col , & ! Output: [real(r8) (:,:) ] + gross_nmin => soilbiogeochem_nitrogenflux_inst%gross_nmin_col , & ! Output: [real(r8) (:) ] gross rate of N mineralization (gN/m2/s) + net_nmin => soilbiogeochem_nitrogenflux_inst%net_nmin_col , & ! Output: [real(r8) (:) ] net rate of N mineralization (gN/m2/s) + + w_scalar => soilbiogeochem_carbonflux_inst%w_scalar_col , & ! Input: [real(r8) (:,:) ] fraction by which decomposition is limited by moisture availability + decomp_cascade_hr_vr => soilbiogeochem_carbonflux_inst%decomp_cascade_hr_vr_col , & ! Output: [real(r8) (:,:,:) ] vertically-resolved het. resp. from decomposing C pools (gC/m3/s) + decomp_cascade_ctransfer_vr => soilbiogeochem_carbonflux_inst%decomp_cascade_ctransfer_vr_col , & ! Output: [real(r8) (:,:,:) ] vertically-resolved het. resp. from decomposing C pools (gC/m3/s) + decomp_k => soilbiogeochem_carbonflux_inst%decomp_k_col , & ! Output: [real(r8) (:,:,:) ] rate constant for decomposition (1./sec) + phr_vr => soilbiogeochem_carbonflux_inst%phr_vr_col , & ! Output: [real(r8) (:,:) ] potential HR (gC/m3/s) + fphr => soilbiogeochem_carbonflux_inst%fphr_col & ! Output: [real(r8) (:,:) ] fraction of potential SOM + LITTER heterotrophic + ) + + if ( .not. use_fates ) then + ! set initial values for potential C and N fluxes + p_decomp_cpool_loss(begc:endc, :, :) = 0._r8 + pmnf_decomp_cascade(begc:endc, :, :) = 0._r8 + + ! column loop to calculate potential decomp rates and total immobilization demand + + !! calculate c:n ratios of applicable pools + do l = 1, ndecomp_pools + if ( floating_cn_ratio_decomp_pools(l) ) then + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if ( decomp_npools_vr(c,j,l) > 0._r8 ) then + cn_decomp_pools(c,j,l) = decomp_cpools_vr(c,j,l) / decomp_npools_vr(c,j,l) + end if + end do + end do + else + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + cn_decomp_pools(c,j,l) = initial_cn_ratio(l) + end do + end do + end if + end do + + ! calculate the non-nitrogen-limited fluxes + ! these fluxes include the "/ dt" term to put them on a + ! per second basis, since the rate constants have been + ! calculated on a per timestep basis. + + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + + if (decomp_cpools_vr(c,j,cascade_donor_pool(k)) > 0._r8 .and. & + decomp_k(c,j,cascade_donor_pool(k)) > 0._r8 ) then + p_decomp_cpool_loss(c,j,k) = decomp_cpools_vr(c,j,cascade_donor_pool(k)) & + * decomp_k(c,j,cascade_donor_pool(k)) * pathfrac_decomp_cascade(c,j,k) + if ( .not. floating_cn_ratio_decomp_pools(cascade_receiver_pool(k)) ) then !! not transition of cwd to litter + + if (cascade_receiver_pool(k) /= i_atm ) then ! not 100% respiration + ratio = 0._r8 + + if (decomp_npools_vr(c,j,cascade_donor_pool(k)) > 0._r8) then + ratio = cn_decomp_pools(c,j,cascade_receiver_pool(k))/cn_decomp_pools(c,j,cascade_donor_pool(k)) + endif + + pmnf_decomp_cascade(c,j,k) = (p_decomp_cpool_loss(c,j,k) * (1.0_r8 - rf_decomp_cascade(c,j,k) - ratio) & + / cn_decomp_pools(c,j,cascade_receiver_pool(k)) ) + + else ! 100% respiration + pmnf_decomp_cascade(c,j,k) = - p_decomp_cpool_loss(c,j,k) / cn_decomp_pools(c,j,cascade_donor_pool(k)) + endif + + else ! CWD -> litter + pmnf_decomp_cascade(c,j,k) = 0._r8 + end if + end if + end do + + end do + end do + + ! Sum up all the potential immobilization fluxes (positive pmnf flux) + ! and all the mineralization fluxes (negative pmnf flux) + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + immob(c,j) = 0._r8 + end do + end do + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + if (pmnf_decomp_cascade(c,j,k) > 0._r8) then + immob(c,j) = immob(c,j) + pmnf_decomp_cascade(c,j,k) + else + gross_nmin_vr(c,j) = gross_nmin_vr(c,j) - pmnf_decomp_cascade(c,j,k) + end if + end do + end do + end do + + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + potential_immob_vr(c,j) = immob(c,j) + end do + end do + else ! use_fates + ! As a first step we are making this a C-only model, so no N downregulation of fluxes. + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + p_decomp_cpool_loss(c,j,k) = decomp_cpools_vr(c,j,cascade_donor_pool(k)) & + * decomp_k(c,j,cascade_donor_pool(k)) * pathfrac_decomp_cascade(c,j,k) + end do + end do + end do + end if + + ! Add up potential hr for methane calculations + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + phr_vr(c,j) = 0._r8 + end do + end do + do k = 1, ndecomp_cascade_transitions + do j = 1,nlevdecomp + do fc = 1,num_soilc + c = filter_soilc(fc) + phr_vr(c,j) = phr_vr(c,j) + rf_decomp_cascade(c,j,k) * p_decomp_cpool_loss(c,j,k) + end do + end do + end do + + end associate + + end subroutine SoilBiogeochemPotential + +end module SoilBiogeochemPotentialMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemPrecisionControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemPrecisionControlMod.F90 new file mode 100755 index 000000000..3740700ab --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemPrecisionControlMod.F90 @@ -0,0 +1,196 @@ +module SoilBiogeochemPrecisionControlMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! controls on very low values in critical state variables + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varpar , only : ndecomp_pools + use SoilBiogeochemCarbonStateType , only : soilbiogeochem_carbonstate_type + use SoilBiogeochemNitrogenStateType , only : soilbiogeochem_nitrogenstate_type + use ColumnType , only : col + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: SoilBiogeochemPrecisionControlInit ! Initialization + public:: SoilBiogeochemPrecisionControl ! Apply precision control to soil biogeochemistry carbon and nitrogen states + + ! !PUBLIC DATA: + real(r8), public :: ccrit ! critical carbon state value for truncation (gC/m2) + real(r8), public :: ncrit ! critical nitrogen state value for truncation (gN/m2) + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemPrecisionControlInit( soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, soilbiogeochem_nitrogenstate_inst) + + ! + ! !DESCRIPTION: + ! Initialization of soil biogeochemistry precision control + ! + ! !USES: + use clm_varctl , only : use_c13, use_c14 + ! + ! !ARGUMENTS: + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + real(r8), parameter :: totvegcthresh = 1.0_r8 ! Total vegetation carbon threshold to zero out decomposition pools + !----------------------------------------------------------------------- + ccrit = 1.e-8_r8 ! critical carbon state value for truncation (gC/m2) + ncrit = 1.e-8_r8 ! critical nitrogen state value for truncation (gN/m2) + + call soilbiogeochem_carbonstate_inst%setTotVgCThresh( totvegcthresh ) + if ( use_c13 )then + call c13_soilbiogeochem_carbonstate_inst%setTotVgCThresh( totvegcthresh ) + end if + if ( use_c14 )then + call c14_soilbiogeochem_carbonstate_inst%setTotVgCThresh( totvegcthresh ) + end if + call soilbiogeochem_nitrogenstate_inst%setTotVgCThresh( totvegcthresh ) + + end subroutine SoilBiogeochemPrecisionControlInit + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemPrecisionControl(num_soilc, filter_soilc, & + soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & + c14_soilbiogeochem_carbonstate_inst, soilbiogeochem_nitrogenstate_inst) + + ! + ! !DESCRIPTION: + ! On the radiation time step, force leaf and deadstem c and n to 0 if + ! they get too small. + ! + ! !USES: + use clm_varctl , only : iulog, use_c13, use_c14, use_nitrif_denitrif, use_cn + use clm_varpar , only : nlevdecomp + use CNSharedParamsMod, only: use_fun + ! + ! !ARGUMENTS: + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_carbonstate_type) , intent(inout) :: soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c13_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_carbonstate_type) , intent(inout) :: c14_soilbiogeochem_carbonstate_inst + type(soilbiogeochem_nitrogenstate_type) , intent(inout) :: soilbiogeochem_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: c,j,k ! indices + integer :: fc ! filter indices + real(r8):: cc,cn ! truncation terms for column-level corrections + real(r8):: cc13 ! truncation terms for column-level corrections + real(r8):: cc14 ! truncation terms for column-level corrections + !----------------------------------------------------------------------- + + ! soilbiogeochem_carbonstate_inst%ctrunc_vr_col Output: [real(r8) (:,:) ] (gC/m3) column-level sink for C truncation + ! soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col Output: [real(r8) (:,:,:) ] (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools + + ! soilbiogeochem_nitrogenstate_inst%ntrunc_vr_col Output: [real(r8) (:,:) ] (gN/m3) column-level sink for N truncation + ! soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col Output: [real(r8) (:,:,:) ] (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools + ! soilbiogeochem_nitrogenstate_inst%smin_nh4_vr_col Output: [real(r8) (:,:) ] (gN/m3) soil mineral NH4 + ! soilbiogeochem_nitrogenstate_inst%smin_no3_vr_col Output: [real(r8) (:,:) ] (gN/m3) soil mineral NO3 + + associate(& + cs => soilbiogeochem_carbonstate_inst , & + ns => soilbiogeochem_nitrogenstate_inst , & + c13cs => c13_soilbiogeochem_carbonstate_inst , & + c14cs => c14_soilbiogeochem_carbonstate_inst & + ) + + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + do j = 1,nlevdecomp + ! initialize the column-level C and N truncation terms + cc = 0._r8 + if ( use_c13 ) cc13 = 0._r8 + if ( use_c14 ) cc14 = 0._r8 + cn = 0._r8 + + ! do tests on state variables for precision control + ! for linked C-N state variables, perform precision test on + ! the C component, but truncate both C and N components + + + ! all decomposing pools C and N + do k = 1, ndecomp_pools + + if (abs(cs%decomp_cpools_vr_col(c,j,k)) < ccrit) then + cc = cc + cs%decomp_cpools_vr_col(c,j,k) + cs%decomp_cpools_vr_col(c,j,k) = 0._r8 + + if (use_cn) then + cn = cn + ns%decomp_npools_vr_col(c,j,k) + ns%decomp_npools_vr_col(c,j,k) = 0._r8 + endif + + if ( use_c13 ) then + cc13 = cc13 + c13cs%decomp_cpools_vr_col(c,j,k) + c13cs%decomp_cpools_vr_col(c,j,k) = 0._r8 + endif + if ( use_c14 ) then + cc14 = cc14 + c14cs%decomp_cpools_vr_col(c,j,k) + c14cs%decomp_cpools_vr_col(c,j,k) = 0._r8 + endif + end if + + end do + + ! not doing precision control on soil mineral N, since it will + ! be getting the N truncation flux anyway. + + cs%ctrunc_vr_col(c,j) = cs%ctrunc_vr_col(c,j) + cc + + if (use_cn) then + ns%ntrunc_vr_col(c,j) = ns%ntrunc_vr_col(c,j) + cn + endif + if ( use_c13 ) then + c13cs%ctrunc_vr_col(c,j) = c13cs%ctrunc_vr_col(c,j) + cc13 + endif + if ( use_c14 ) then + c14cs%ctrunc_vr_col(c,j) = c14cs%ctrunc_vr_col(c,j) + cc14 + endif + end do + + end do ! end of column loop + + if(.not.use_fun)then + if (use_nitrif_denitrif) then + ! remove small negative perturbations for stability purposes, if any should arise. + + do fc = 1,num_soilc + c = filter_soilc(fc) + do j = 1,nlevdecomp + if (abs(ns%smin_no3_vr_col(c,j)) < ncrit/1e4_r8) then + if ( ns%smin_no3_vr_col(c,j) < 0._r8 ) then + !write(iulog, *) '-10^-12 < smin_no3 < 0. resetting to zero.' + !write(iulog, *) 'smin_no3_vr_col(c,j), c, j: ', ns%smin_no3_vr_col(c,j), c, j + ns%smin_no3_vr_col(c,j) = 0._r8 + endif + end if + if (abs(ns%smin_nh4_vr_col(c,j)) < ncrit/1e4_r8) then + if ( ns%smin_nh4_vr_col(c,j) < 0._r8 ) then + !write(iulog, *) '-10^-12 < smin_nh4 < 0. resetting to zero.' + !write(iulog, *) 'smin_nh4_vr_col(c,j), c, j: ', ns%smin_nh4_vr_col(c,j), c, j + ns%smin_nh4_vr_col(c,j) = 0._r8 + endif + end if + end do + end do + endif + endif + + end associate + + end subroutine SoilBiogeochemPrecisionControl + +end module SoilBiogeochemPrecisionControlMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemVerticalProfileMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemVerticalProfileMod.F90 new file mode 100755 index 000000000..fe689d975 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemVerticalProfileMod.F90 @@ -0,0 +1,277 @@ +module SoilBiogeochemVerticalProfileMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculate vertical profiles for distributing soil and litter C and N + ! + ! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: SoilBiogeochemVerticalProfile + ! + real(r8), public :: surfprof_exp = 10. ! how steep profile is for surface components (1/ e_folding depth) (1/m) + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine SoilBiogeochemVerticalProfile(bounds, num_soilc,filter_soilc,num_soilp,filter_soilp, & + active_layer_inst, soilstate_inst, soilbiogeochem_state_inst) + ! + ! !DESCRIPTION: + ! calculate vertical profiles for distributing soil and litter C and N + ! + ! BUG(wjs, 2014-12-15, bugz 2107) + ! Because of this routine's placement in the driver sequence (it is + ! called very early in each timestep, before weights are adjusted and filters are + ! updated), it may be necessary for this routine to compute values over inactive as well + ! as active points (since some inactive points may soon become active) - so that's what + ! is done now. Currently, it seems to be okay to do this, because the variables computed + ! here seem to only depend on quantities that are valid over inactive as well as active + ! points. However, note that this routine is (mistakenly) called from two places + ! currently - the above note applies to its call from the driver, but its call from + ! CNDecompMod uses the standard filters that just apply over active points + ! + ! !USES: + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun + use clm_varcon , only : zsoi, dzsoi, zisoi, dzsoi_decomp, zmin_bedrock + use clm_varpar , only : nlevdecomp, nlevgrnd, nlevdecomp_full, maxsoil_patches + use clm_varctl , only : use_vertsoilc, iulog, use_bedrock + use pftconMod , only : noveg, pftcon + use SoilBiogeochemStateType , only : soilbiogeochem_state_type + use ActiveLayerMod , only : active_layer_type + use SoilStateType , only : soilstate_type + use ColumnType , only : col + use PatchType , only : patch + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + integer , intent(in) :: num_soilp ! number of soil patches in filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + type(active_layer_type) , intent(in) :: active_layer_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(soilbiogeochem_state_type) , intent(inout) :: soilbiogeochem_state_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: surface_prof(1:nlevdecomp) + real(r8) :: surface_prof_tot + real(r8) :: rootfr_tot + real(r8) :: cinput_rootfr(bounds%begp:bounds%endp, 1:nlevdecomp_full) ! pft-native root fraction used for calculating inputs + real(r8) :: col_cinput_rootfr(bounds%begc:bounds%endc, 1:nlevdecomp_full) ! col-native root fraction used for calculating inputs + integer :: c, j, fc, p, fp, pi + integer :: alt_ind + ! debugging temp variables + real(r8) :: froot_prof_sum + real(r8) :: croot_prof_sum + real(r8) :: leaf_prof_sum + real(r8) :: stem_prof_sum + real(r8) :: ndep_prof_sum + real(r8) :: nfixation_prof_sum + real(r8) :: delta = 1.e-10 + integer :: begp, endp + integer :: begc, endc + character(len=32) :: subname = 'SoilBiogeochemVerticalProfile' + !----------------------------------------------------------------------- + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + associate( & + altmax_lastyear_indx => active_layer_inst%altmax_lastyear_indx_col , & ! Input: [integer (:) ] frost table depth (m) + + crootfr => soilstate_inst%crootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer (nlevgrnd) + + nfixation_prof => soilbiogeochem_state_inst%nfixation_prof_col , & ! Input : [real(r8) (:,:) ] (1/m) profile for N fixation additions + ndep_prof => soilbiogeochem_state_inst%ndep_prof_col , & ! Input : [real(r8) (:,:) ] (1/m) profile for N fixation additions + leaf_prof => soilbiogeochem_state_inst%leaf_prof_patch , & ! Output : [real(r8) (:,:) ] (1/m) profile of leaves + froot_prof => soilbiogeochem_state_inst%froot_prof_patch , & ! Output : [real(r8) (:,:) ] (1/m) profile of fine roots + croot_prof => soilbiogeochem_state_inst%croot_prof_patch , & ! Output : [real(r8) (:,:) ] (1/m) profile of coarse roots + stem_prof => soilbiogeochem_state_inst%stem_prof_patch & ! Output : [real(r8) (:,:) ] (1/m) profile of stems + ) + + if (use_vertsoilc) then + + ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) + surface_prof(:) = 0._r8 + do j = 1, nlevdecomp + surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) + if (use_bedrock) then + if (zsoi(j) > zmin_bedrock) then + surface_prof(j) = 0._r8 + end if + end if + end do + + ! initialize profiles to zero + leaf_prof(begp:endp, :) = 0._r8 + froot_prof(begp:endp, :) = 0._r8 + croot_prof(begp:endp, :) = 0._r8 + stem_prof(begp:endp, :) = 0._r8 + nfixation_prof(begc:endc, :) = 0._r8 + ndep_prof(begc:endc, :) = 0._r8 + + cinput_rootfr(begp:endp, :) = 0._r8 + col_cinput_rootfr(begc:endc, :) = 0._r8 + + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + if (patch%itype(p) /= noveg) then + do j = 1, nlevdecomp + cinput_rootfr(p,j) = crootfr(p,j) / dzsoi_decomp(j) + end do + + else + cinput_rootfr(p,1) = 0. + endif + end do + + do fp = 1,num_soilp + p = filter_soilp(fp) + c = patch%column(p) + ! integrate rootfr over active layer of soil column + rootfr_tot = 0._r8 + surface_prof_tot = 0._r8 + do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) + rootfr_tot = rootfr_tot + cinput_rootfr(p,j) * dzsoi_decomp(j) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) + end do + if ( (altmax_lastyear_indx(c) > 0) .and. (rootfr_tot > 0._r8) .and. (surface_prof_tot > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalnet to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) + froot_prof(p,j) = cinput_rootfr(p,j) / rootfr_tot + croot_prof(p,j) = cinput_rootfr(p,j) / rootfr_tot + + if (j > col%nbedrock(c) .and. cinput_rootfr(p,j) > 0._r8) then + write(iulog,*) 'cinput_rootfr > 0 in bedrock' + end if + ! set all surface processes to shallower profile + leaf_prof(p,j) = surface_prof(j)/ surface_prof_tot + stem_prof(p,j) = surface_prof(j)/ surface_prof_tot + end do + else + ! if fully frozen, or no roots, put everything in the top layer + froot_prof(p,1) = 1./dzsoi_decomp(1) + croot_prof(p,1) = 1./dzsoi_decomp(1) + leaf_prof(p,1) = 1./dzsoi_decomp(1) + stem_prof(p,1) = 1./dzsoi_decomp(1) + endif + + end do + + !! aggregate root profile to column + ! call p2c (decomp, nlevdecomp_full, & + ! cinput_rootfr(bounds%begp:bounds%endp, :), & + ! col_cinput_rootfr(bounds%begc:bounds%endc, :), & + ! 'unity') + do pi = 1,maxsoil_patches + do fc = 1,num_soilc + c = filter_soilc(fc) + if (pi <= col%npatches(c)) then + p = col%patchi(c) + pi - 1 + do j = 1,nlevdecomp + col_cinput_rootfr(c,j) = col_cinput_rootfr(c,j) + cinput_rootfr(p,j) * patch%wtcol(p) + end do + end if + end do + end do + + ! repeat for column-native profiles: Ndep and Nfix + do fc = 1,num_soilc + c = filter_soilc(fc) + rootfr_tot = 0._r8 + surface_prof_tot = 0._r8 + ! redo column ntegration over active layer for column-native profiles + do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) + rootfr_tot = rootfr_tot + col_cinput_rootfr(c,j) * dzsoi_decomp(j) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) + end do + if ( (altmax_lastyear_indx(c) > 0) .and. (rootfr_tot > 0._r8) .and. (surface_prof_tot > 0._r8) ) then + do j = 1, min(max(altmax_lastyear_indx(c), 1), nlevdecomp) + nfixation_prof(c,j) = col_cinput_rootfr(c,j) / rootfr_tot + ndep_prof(c,j) = surface_prof(j)/ surface_prof_tot + end do + else + nfixation_prof(c,1) = 1./dzsoi_decomp(1) + ndep_prof(c,1) = 1./dzsoi_decomp(1) + endif + end do + + else + + ! for one layer decomposition model, set profiles to unity + leaf_prof(begp:endp, :) = 1._r8 + froot_prof(begp:endp, :) = 1._r8 + croot_prof(begp:endp, :) = 1._r8 + stem_prof(begp:endp, :) = 1._r8 + nfixation_prof(begc:endc, :) = 1._r8 + ndep_prof(begc:endc, :) = 1._r8 + + end if + + + ! check to make sure integral of all profiles = 1. + do fc = 1,num_soilc + c = filter_soilc(fc) + ndep_prof_sum = 0. + nfixation_prof_sum = 0. + do j = 1, nlevdecomp + ndep_prof_sum = ndep_prof_sum + ndep_prof(c,j) * dzsoi_decomp(j) + nfixation_prof_sum = nfixation_prof_sum + nfixation_prof(c,j) * dzsoi_decomp(j) + end do + if ( ( abs(ndep_prof_sum - 1._r8) > delta ) .or. ( abs(nfixation_prof_sum - 1._r8) > delta ) ) then + write(iulog, *) 'profile sums: ', ndep_prof_sum, nfixation_prof_sum + write(iulog, *) 'c: ', c + write(iulog, *) 'altmax_lastyear_indx: ', altmax_lastyear_indx(c) + write(iulog, *) 'nfixation_prof: ', nfixation_prof(c,:) + write(iulog, *) 'ndep_prof: ', ndep_prof(c,:) + write(iulog, *) 'cinput_rootfr: ', cinput_rootfr(c,:) + write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp(:) + write(iulog, *) 'surface_prof: ', surface_prof(:) + write(iulog, *) 'npfts(c): ', col%npatches(c) + do p = col%patchi(c), col%patchi(c) + col%npatches(c) -1 + write(iulog, *) 'p, itype(p), wtcol(p): ', p, patch%itype(p), patch%wtcol(p) + write(iulog, *) 'cinput_rootfr(p,:): ', cinput_rootfr(p,:) + end do + call endrun(msg=" ERROR: _prof_sum-1>delta"//errMsg(sourcefile, __LINE__)) + endif + end do + + do fp = 1,num_soilp + p = filter_soilp(fp) + froot_prof_sum = 0. + croot_prof_sum = 0. + leaf_prof_sum = 0. + stem_prof_sum = 0. + do j = 1, nlevdecomp + froot_prof_sum = froot_prof_sum + froot_prof(p,j) * dzsoi_decomp(j) + croot_prof_sum = croot_prof_sum + croot_prof(p,j) * dzsoi_decomp(j) + leaf_prof_sum = leaf_prof_sum + leaf_prof(p,j) * dzsoi_decomp(j) + stem_prof_sum = stem_prof_sum + stem_prof(p,j) * dzsoi_decomp(j) + end do + if ( ( abs(froot_prof_sum - 1._r8) > delta ) .or. ( abs(croot_prof_sum - 1._r8) > delta ) .or. & + ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then + write(iulog, *) 'profile sums: ', froot_prof_sum, croot_prof_sum, leaf_prof_sum, stem_prof_sum + call endrun(msg=' ERROR: sum-1 > delta'//errMsg(sourcefile, __LINE__)) + endif + end do + + end associate + + end subroutine SoilBiogeochemVerticalProfile + +end module SoilBiogeochemVerticalProfileMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilStateInitTimeConstMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilStateInitTimeConstMod.F90 new file mode 100755 index 000000000..e6e213aed --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilStateInitTimeConstMod.F90 @@ -0,0 +1,711 @@ +module SoilStateInitTimeConstMod + + !------------------------------------------------------------------------------ + ! DESCRIPTION: + ! Set hydraulic and thermal properties + ! + ! !USES + use shr_kind_mod , only : r8 => shr_kind_r8 + use SoilStateType , only : soilstate_type + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: SoilStateInitTimeConst + public :: readParams + ! + ! !PRIVATE MEMBER FUNCTIONS: + private :: ReadNL + ! + ! !PUBLIC DATA: + real(r8), public :: organic_max ! organic matter (kg/m3) where soil is assumed to act like peat + + ! !PRIVATE DATA: + type, private :: params_type + real(r8) :: tkd_sand ! Thermal conductivity of sand (W/m/K) + real(r8) :: tkd_clay ! Thermal conductivity of clay (W/m/K) + real(r8) :: tkd_om ! Thermal conductivity of dry organic matter (Farouki, 1981) (W/m/K) + real(r8) :: tkm_om ! Thermal conductivity of organic matter (Farouki, 1986) (W/m/K) + real(r8) :: pd ! Particle density of soil (kg/m3) + real(r8) :: csol_clay ! Heat capacity of clay *10^6 (J/K/m3) + real(r8) :: csol_om ! Heat capacity of peat soil *10^6 (Farouki, 1986) (J/K/m3) + real(r8) :: csol_sand ! Heat capacity of sand *10^6 (J/K/m3) + real(r8) :: bsw_sf ! Scale factor for bsw (unitless) + real(r8) :: hksat_sf ! Scale factor for hksat (unitless) + real(r8) :: sucsat_sf ! Scale factor for sucsat (unitless) + real(r8) :: watsat_sf ! Scale factor for watsat (unitless) + real(r8) :: sand_pf ! Perturbation factor (via addition) for percent sand (percent) + real(r8) :: clay_pf ! Perturbation factor (via addition) for percent clay of clay+silt (percent) + end type params_type + type(params_type), private :: params_inst + + ! Control variables (from namelist) + logical, private :: organic_frac_squared ! If organic fraction should be squared (as in CLM4.5) + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + ! +contains + + !----------------------------------------------------------------------- + subroutine ReadNL( nlfilename ) + ! + ! !DESCRIPTION: + ! Read namelist for SoilStateType + ! + ! !USES: + use shr_mpi_mod , only : shr_mpi_bcast + use shr_log_mod , only : errMsg => shr_log_errMsg + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use clm_varctl , only : iulog + use spmdMod , only : mpicom, masterproc + use abortUtils , only : endrun + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: nlfilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + character(len=32) :: subname = 'SoilState_readnl' ! subroutine name + !----------------------------------------------------------------------- + + character(len=*), parameter :: nl_name = 'clm_soilstate_inparm' ! Namelist name + ! MUST agree with name in namelist and read + namelist / clm_soilstate_inparm / organic_frac_squared + + ! preset values + + organic_frac_squared = .false. + + if ( masterproc )then + + unitn = getavu() + write(iulog,*) 'Read in '//nl_name//' namelist' + call opnfil (nlfilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nl_name, status=ierr) + if (ierr == 0) then + read(unit=unitn, nml=clm_soilstate_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading '//nl_name//' namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR finding '//nl_name//' namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + + end if + + call shr_mpi_bcast(organic_frac_squared, mpicom) + + end subroutine ReadNL + + !----------------------------------------------------------------------- + subroutine readParams( ncid ) + ! + ! !USES: + use ncdio_pio, only: file_desc_t + use paramUtilMod, only: readNcdioScalar + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'readParams_SoilStateInitTimeConst' + !-------------------------------------------------------------------- + + ! Thermal conductivity of sand (W/m/K) + call readNcdioScalar(ncid, 'tkd_sand', subname, params_inst%tkd_sand) + ! Thermal conductivity of clay (W/m/K) + call readNcdioScalar(ncid, 'tkd_clay', subname, params_inst%tkd_clay) + ! Thermal conductivity of dry organic matter (Farouki, 1981) (W/m/K) + call readNcdioScalar(ncid, 'tkd_om', subname, params_inst%tkd_om) + ! Thermal conductivity of organic matter (Farouki, 1986) (W/m/K) + call readNcdioScalar(ncid, 'tkm_om', subname, params_inst%tkm_om) + ! Particle density of soil (kg/m3) + call readNcdioScalar(ncid, 'pd', subname, params_inst%pd) + ! Heat capacity of clay *10^6 (J/K/m3) + call readNcdioScalar(ncid, 'csol_clay', subname, params_inst%csol_clay) + ! Heat capacity of peat soil *10^6 (Farouki, 1986) (J/K/m3) + call readNcdioScalar(ncid, 'csol_om', subname, params_inst%csol_om) + ! Heat capacity of sand *10^6 (J/K/m3) + call readNcdioScalar(ncid, 'csol_sand', subname, params_inst%csol_sand) + ! Scale factor for bsw (unitless) + call readNcdioScalar(ncid, 'bsw_sf', subname, params_inst%bsw_sf) + ! Scale factor for hksat (unitless) + call readNcdioScalar(ncid, 'hksat_sf', subname, params_inst%hksat_sf) + ! Scale factor for sucsat (unitless) + call readNcdioScalar(ncid, 'sucsat_sf', subname, params_inst%sucsat_sf) + ! Scale factor for watsat (unitless) + call readNcdioScalar(ncid, 'watsat_sf', subname, params_inst%watsat_sf) + ! Perturbation factor (via addition) for percent sand (percent) + call readNcdioScalar(ncid, 'sand_pf', subname, params_inst%sand_pf) + ! Perturbation factor (via addition) for percent clay of clay+silt (percent) + call readNcdioScalar(ncid, 'clay_pf', subname, params_inst%clay_pf) + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine SoilStateInitTimeConst(bounds, soilstate_inst, nlfilename) + ! + ! !USES: + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use decompMod , only : bounds_type + use abortutils , only : endrun + use spmdMod , only : masterproc + use ncdio_pio , only : file_desc_t, ncd_io + use ncdio_pio , only : ncd_pio_openfile, ncd_pio_closefile + use clm_varpar , only : numrad + use clm_varpar , only : nlevsoi, nlevgrnd, nlevlak, nlayer, nlevmaxurbgrnd, nlevsno + use clm_varcon , only : zsoi, dzsoi, zisoi, spval + use clm_varcon , only : secspday, denh2o, grlnd + use clm_varctl , only : use_cn, use_lch4, use_fates + use clm_varctl , only : iulog + use landunit_varcon , only : istdlak, istwet, istsoil, istcrop, istice_mec + use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, icol_road_imperv + use fileutils , only : getfil + !use organicFileMod , only : organicrd + !use FuncPedotransferMod , only : pedotransf, get_ipedof + use RootBiophysMod , only : init_vegrootfr + use GridcellType , only : grc + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(soilstate_type) , intent(inout) :: soilstate_inst + character(len=*) , intent(in) :: nlfilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: p, lev, c, l, g, j ! indices + real(r8) :: om_frac ! organic matter fraction + real(r8) :: om_watsat_lake = 0.9_r8 ! porosity of organic soil + real(r8) :: om_hksat_lake = 0.1_r8 ! saturated hydraulic conductivity of organic soil [mm/s] + real(r8) :: om_sucsat_lake = 10.3_r8 ! saturated suction for organic matter (Letts, 2000) + real(r8) :: om_b_lake = 2.7_r8 ! Clapp Hornberger paramater for oragnic soil (Letts, 2000) (lake) + real(r8) :: om_watsat ! porosity of organic soil + real(r8) :: om_hksat ! saturated hydraulic conductivity of organic soil [mm/s] + real(r8) :: om_sucsat ! saturated suction for organic matter (mm)(Letts, 2000) + real(r8) :: om_b ! Clapp Hornberger paramater for oragnic soil (Letts, 2000) + real(r8) :: zsapric = 0.5_r8 ! depth (m) that organic matter takes on characteristics of sapric peat + real(r8) :: pcalpha = 0.5_r8 ! percolation threshold + real(r8) :: pcbeta = 0.139_r8 ! percolation exponent + real(r8) :: pc_lake = 0.5_r8 ! percolation threshold + real(r8) :: perc_frac ! "percolating" fraction of organic soil + real(r8) :: perc_norm ! normalize to 1 when 100% organic soil + real(r8) :: uncon_hksat ! series conductivity of mineral/organic soil + real(r8) :: uncon_frac ! fraction of "unconnected" soil + real(r8) :: bd ! bulk density of dry soil material [kg/m^3] + real(r8) :: tkm ! mineral conductivity + real(r8) :: xksat ! maximum hydraulic conductivity of soil [mm/s] + real(r8) :: clay,sand ! temporaries + real(r8) :: perturbed_sand ! temporary for paramfile implementation of +/- sand percentage + real(r8) :: residual_clay_frac ! temporary for paramfile implementation of +/- residual clay percentage + real(r8) :: perturbed_residual_clay_frac ! temporary for paramfile implementation of +/- residual clay percentage + integer :: dimid ! dimension id + logical :: readvar + type(file_desc_t) :: ncid ! netcdf id + real(r8) ,pointer :: zsoifl (:) ! Output: [real(r8) (:)] original soil midpoint + real(r8) ,pointer :: zisoifl (:) ! Output: [real(r8) (:)] original soil interface depth + real(r8) ,pointer :: gti (:) ! read in - fmax + real(r8) ,pointer :: sand3d (:,:) ! read in - soil texture: percent sand (needs to be a pointer for use in ncdio) + real(r8) ,pointer :: clay3d (:,:) ! read in - soil texture: percent clay (needs to be a pointer for use in ncdio) + real(r8) ,pointer :: organic3d (:,:) ! read in - organic matter: kg/m3 (needs to be a pointer for use in ncdio) + character(len=256) :: locfn ! local filename + integer :: ipedof + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + integer :: found ! flag that equals 0 if not found and 1 if found + !----------------------------------------------------------------------- + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + do c = begc,endc + soilstate_inst%smpmin_col(c) = -1.e8_r8 + end do + + ! -------------------------------------------------------------------- + ! Read namelist + ! -------------------------------------------------------------------- + + call ReadNL( nlfilename ) + + ! -------------------------------------------------------------------- + ! Initialize root fraction (computing from surface, d is depth in meter): + ! -------------------------------------------------------------------- + +! ! Currently pervious road has same properties as soil +! do c = begc,endc +! l = col%landunit(c) +! +! if (lun%urbpoi(l) .and. col%itype(c) == icol_road_perv) then +! do lev = 1, nlevgrnd +! soilstate_inst%rootfr_road_perv_col(c,lev) = 0._r8 +! enddo +! do lev = 1,nlevsoi +! soilstate_inst%rootfr_road_perv_col(c,lev) = 1.0_r8/real(nlevsoi,r8) +! end do +!! remove roots below bedrock layer +! soilstate_inst%rootfr_road_perv_col(c,1:col%nbedrock(c)) = & +! soilstate_inst%rootfr_road_perv_col(c,1:col%nbedrock(c)) & +! + sum(soilstate_inst%rootfr_road_perv_col(c,col%nbedrock(c)+1:nlevsoi)) & +! /real(col%nbedrock(c)) +! soilstate_inst%rootfr_road_perv_col(c,col%nbedrock(c)+1:nlevsoi) = 0._r8 +! end if +! end do + +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then +! soilstate_inst%rootfr_col (c,nlevsoi+1:nlevgrnd) = 0._r8 +! else +! ! Inactive CH4 columns +! ! (Also includes (lun%itype(l)==istdlak .and. allowlakeprod), which used to be +! ! in a separate branch of the conditional) +! soilstate_inst%rootfr_col (c,:) = spval +! end if +! end do + +! ! Initialize root fraction +! ! Note that fates has its own root fraction root fraction routine and should not +! ! use the following since it depends on patch%itype - which fates should not use +! +! if (.not. use_fates) then +! call init_vegrootfr(bounds, nlevsoi, nlevgrnd, & +! soilstate_inst%rootfr_patch(begp:endp,1:nlevgrnd),'water') +! call init_vegrootfr(bounds, nlevsoi, nlevgrnd, & +! soilstate_inst%crootfr_patch(begp:endp,1:nlevgrnd),'carbon') +! end if + +! ! -------------------------------------------------------------------- +! ! dynamic memory allocation +! ! -------------------------------------------------------------------- +! +! allocate(sand3d(begg:endg,nlevsoifl)) +! allocate(clay3d(begg:endg,nlevsoifl)) +! +! ! Determine organic_max from parameter file +! +! call getfil (paramfile, locfn, 0) +! call ncd_pio_openfile (ncid, trim(locfn), 0) +! call ncd_io(ncid=ncid, varname='organic_max', flag='read', data=organic_max, readvar=readvar) +! if ( .not. readvar ) call endrun(msg=' ERROR: organic_max not on param file'//errMsg(sourcefile, __LINE__)) +! call ncd_pio_closefile(ncid) +! +! ! -------------------------------------------------------------------- +! ! Read surface dataset +! ! -------------------------------------------------------------------- +! +! if (masterproc) then +! write(iulog,*) 'Attempting to read soil color, sand and clay boundary data .....' +! end if +! +! call getfil (fsurdat, locfn, 0) +! call ncd_pio_openfile (ncid, locfn, 0) +! +! ! Read in organic matter dataset +! +! allocate(organic3d(begg:endg,nlevsoifl)) +! call organicrd(organic3d) +! +! ! Read in sand and clay data +! +! call ncd_io(ncid=ncid, varname='PCT_SAND', flag='read', data=sand3d, dim1name=grlnd, readvar=readvar) +! if (.not. readvar) then +! call endrun(msg=' ERROR: PCT_SAND NOT on surfdata file'//errMsg(sourcefile, __LINE__)) +! end if +! +! call ncd_io(ncid=ncid, varname='PCT_CLAY', flag='read', data=clay3d, dim1name=grlnd, readvar=readvar) +! if (.not. readvar) then +! call endrun(msg=' ERROR: PCT_CLAY NOT on surfdata file'//errMsg(sourcefile, __LINE__)) +! end if +! +! do p = begp,endp +! g = patch%gridcell(p) +! if ( sand3d(g,1)+clay3d(g,1) == 0.0_r8 )then +! if ( any( sand3d(g,:)+clay3d(g,:) /= 0.0_r8 ) )then +! call endrun(msg='found depth points that do NOT sum to zero when surface does'//& +! errMsg(sourcefile, __LINE__)) +! end if +! sand3d(g,:) = 1.0_r8 +! clay3d(g,:) = 1.0_r8 +! end if +! if ( any( sand3d(g,:)+clay3d(g,:) == 0.0_r8 ) )then +! call endrun(msg='after setting, found points sum to zero'//errMsg(sourcefile, __LINE__)) +! end if +! +! soilstate_inst%sandfrac_patch(p) = sand3d(g,1)/100.0_r8 +! soilstate_inst%clayfrac_patch(p) = clay3d(g,1)/100.0_r8 +! end do + +! ! Read fmax +! +! allocate(gti(begg:endg)) +! call ncd_io(ncid=ncid, varname='FMAX', flag='read', data=gti, dim1name=grlnd, readvar=readvar) +! if (.not. readvar) then +! call endrun(msg=' ERROR: FMAX NOT on surfdata file'//errMsg(sourcefile, __LINE__)) +! end if +! do c = begc, endc +! g = col%gridcell(c) +! soilstate_inst%wtfact_col(c) = gti(g) +! end do +! deallocate(gti) +! +! ! Close file +! +! call ncd_pio_closefile(ncid) +! +! ! -------------------------------------------------------------------- +! ! get original soil depths to be used in interpolation of sand and clay +! ! -------------------------------------------------------------------- +! +! ! Note that the depths on the file are assumed to be the same as the depths in the +! ! model when running with 10SL_3.5m. Ideally zsoifl and zisoifl would be read from +! ! the surface dataset rather than assumed here. +! ! +! ! We need to specify zsoifl down to nlevsoifl+1 (rather than just nlevsoifl) so that +! ! we can get the appropriate zisoifl at level nlevsoifl (i.e., the bottom interface +! ! depth). +! allocate(zsoifl(1:nlevsoifl+1), zisoifl(0:nlevsoifl)) +! do j = 1, nlevsoifl+1 +! zsoifl(j) = 0.025_r8*(exp(0.5_r8*(j-0.5_r8))-1._r8) !node depths +! enddo +! +! zisoifl(0) = 0._r8 +! do j = 1, nlevsoifl +! zisoifl(j) = 0.5_r8*(zsoifl(j)+zsoifl(j+1)) !interface depths +! enddo +! +! ! -------------------------------------------------------------------- +! ! Set soil hydraulic and thermal properties: non-lake +! ! -------------------------------------------------------------------- +! +! ! urban roof, sunwall and shadewall thermal properties used to +! ! derive thermal conductivity and heat capacity are set to special +! ! value because thermal conductivity and heat capacity for urban +! ! roof, sunwall and shadewall are prescribed in SoilThermProp.F90 +! ! in SoilPhysicsMod.F90 +! +! do c = begc, endc +! g = col%gridcell(c) +! l = col%landunit(c) +! +! ! istwet and istice_mec and +! ! urban roof, sunwall, shadewall properties set to special value +! if (lun%itype(l)==istwet .or. lun%itype(l)==istice_mec .or. & +! (lun%urbpoi(l) .and. col%itype(c) /= icol_road_perv .and. & +! col%itype(c) /= icol_road_imperv)) then +! +! do lev = 1,nlevmaxurbgrnd +! soilstate_inst%watsat_col(c,lev) = spval +! end do +! +! do lev = 1,nlevgrnd +! soilstate_inst%bsw_col(c,lev) = spval +! soilstate_inst%watfc_col(c,lev) = spval +! soilstate_inst%hksat_col(c,lev) = spval +! soilstate_inst%sucsat_col(c,lev) = spval +! soilstate_inst%watdry_col(c,lev) = spval +! soilstate_inst%watopt_col(c,lev) = spval +! soilstate_inst%bd_col(c,lev) = spval +! if (lev <= nlevsoi) then +! soilstate_inst%cellsand_col(c,lev) = spval +! soilstate_inst%cellclay_col(c,lev) = spval +! soilstate_inst%cellorg_col(c,lev) = spval +! end if +! end do +! +! do lev = 1,nlevgrnd +! soilstate_inst%tkmg_col(c,lev) = spval +! soilstate_inst%tksatu_col(c,lev) = spval +! soilstate_inst%tkdry_col(c,lev) = spval +! soilstate_inst%csol_col(c,lev)= spval +! end do +! +! else +! +! do lev = 1,nlevgrnd +! ! Top-most model soil level corresponds to dataset's top-most soil +! ! level regardless of corresponding depths +! if (lev .eq. 1) then +! clay = clay3d(g,1) +! sand = sand3d(g,1) +! om_frac = organic3d(g,1)/organic_max +! else if (lev <= nlevsoi) then +! found = 0 ! reset value +! if (zsoi(lev) <= zisoifl(1)) then +! ! Search above the dataset's range of zisoifl depths +! clay = clay3d(g,1) +! sand = sand3d(g,1) +! om_frac = organic3d(g,1)/organic_max +! found = 1 +! else if (zsoi(lev) > zisoifl(nlevsoifl)) then +! ! Search below the dataset's range of zisoifl depths +! clay = clay3d(g,nlevsoifl) +! sand = sand3d(g,nlevsoifl) +! om_frac = organic3d(g,nlevsoifl)/organic_max +! found = 1 +! else +! ! For remaining model soil levels, search within dataset's +! ! range of zisoifl values. Look for model node depths +! ! that are between the dataset's interface depths. +! do j = 1,nlevsoifl-1 +! if (zsoi(lev) > zisoifl(j) .AND. zsoi(lev) <= zisoifl(j+1)) then +! clay = clay3d(g,j+1) +! sand = sand3d(g,j+1) +! om_frac = organic3d(g,j+1)/organic_max +! found = 1 +! endif +! if (found == 1) exit ! no need to stay in the loop +! end do +! end if +! ! If not found, then something's wrong +! if (found == 0) then +! write(iulog,*) 'For model soil level =', lev +! call endrun(msg="ERROR finding a soil dataset depth to interpolate the model depth to"//errmsg(sourcefile, __LINE__)) +! end if +! else ! if lev > nlevsoi +! clay = clay3d(g,nlevsoifl) +! sand = sand3d(g,nlevsoifl) +! om_frac = 0._r8 +! endif +! +! if (organic_frac_squared) then +! om_frac = om_frac**2._r8 +! end if +! +! if (lun%urbpoi(l)) then +! om_frac = 0._r8 ! No organic matter for urban +! end if +! +! if (lev <= nlevsoi) then +! ! This is separated into sections for non-perturbation and perturbation of sand/clay +! ! because the perturbation code is not bfb when sand_pf=clay_pf=0. This occurs because +! ! of a divide and then a multiply in the code. +! if (params_inst%sand_pf == 0._r8 .and. params_inst%clay_pf == 0._r8) then +! soilstate_inst%cellsand_col(c,lev) = sand +! soilstate_inst%cellclay_col(c,lev) = clay +! else +! ! by default, will read sand and clay from the surface dataset +! ! - sand_pf can be used to perturb the absolute percent sand +! ! - clay_pf can be used to perturb what percent of (clay+silt) is clay +! if (sand<100._r8) then +! residual_clay_frac = clay/(100._r8-sand) +! else +! residual_clay_frac = 0.5_r8 +! end if +! perturbed_sand = min(100._r8,max(0._r8,sand+params_inst%sand_pf)) +! perturbed_residual_clay_frac = min(1._r8,max(0._r8,residual_clay_frac + & +! params_inst%clay_pf/100._r8)) +! soilstate_inst%cellsand_col(c,lev) = perturbed_sand +! soilstate_inst%cellclay_col(c,lev) = (100._r8-perturbed_sand)*perturbed_residual_clay_frac +! end if +! soilstate_inst%cellorg_col(c,lev) = om_frac*organic_max +! end if +! +! if (lun%itype(l) /= istdlak) then ! soil columns of both urban and non-urban types +! +! ! Note that the following properties are overwritten for urban impervious road +! ! layers that are not soil in SoilThermProp.F90 within SoilTemperatureMod.F90 +! +! !determine the type of pedotransfer function to be used based on soil order +! !I will use the following implementation to further explore the ET problem, now +! !I set soil order to 0 for all soils. Jinyun Tang, Mar 20, 2014 +! +! ipedof=get_ipedof(0) +! call pedotransf(ipedof, sand, clay, & +! soilstate_inst%watsat_col(c,lev), soilstate_inst%bsw_col(c,lev), soilstate_inst%sucsat_col(c,lev), xksat) +! +! om_watsat = max(0.93_r8 - 0.1_r8 *(zsoi(lev)/zsapric), 0.83_r8) +! om_b = min(2.7_r8 + 9.3_r8 *(zsoi(lev)/zsapric), 12.0_r8) +! om_sucsat = min(10.3_r8 - 0.2_r8 *(zsoi(lev)/zsapric), 10.1_r8) +! om_hksat = max(0.28_r8 - 0.2799_r8*(zsoi(lev)/zsapric), xksat) +! +! soilstate_inst%bd_col(c,lev) = (1._r8 - soilstate_inst%watsat_col(c,lev))*params_inst%pd +! soilstate_inst%watsat_col(c,lev) = params_inst%watsat_sf * ( (1._r8 - om_frac) * & +! soilstate_inst%watsat_col(c,lev) + om_watsat*om_frac ) +! tkm = (1._r8-om_frac) * (params_inst%tkd_sand*sand+params_inst%tkd_clay*clay)/ & +! (sand+clay)+params_inst%tkm_om*om_frac ! W/(m K) +! soilstate_inst%bsw_col(c,lev) = params_inst%bsw_sf * ( (1._r8-om_frac) * & +! (2.91_r8 + 0.159_r8*clay) + om_frac*om_b ) +! soilstate_inst%sucsat_col(c,lev) = params_inst%sucsat_sf * ( (1._r8-om_frac) * & +! soilstate_inst%sucsat_col(c,lev) + om_sucsat*om_frac ) +! soilstate_inst%hksat_min_col(c,lev) = xksat +! +! ! perc_frac is zero unless perf_frac greater than percolation threshold +! if (om_frac > pcalpha) then +! perc_norm=(1._r8 - pcalpha)**(-pcbeta) +! perc_frac=perc_norm*(om_frac - pcalpha)**pcbeta +! else +! perc_frac=0._r8 +! endif +! +! ! uncon_frac is fraction of mineral soil plus fraction of "nonpercolating" organic soil +! uncon_frac=(1._r8-om_frac)+(1._r8-perc_frac)*om_frac +! +! ! uncon_hksat is series addition of mineral/organic conductivites +! if (om_frac < 1._r8) then +! uncon_hksat=uncon_frac/((1._r8-om_frac)/xksat & +! +((1._r8-perc_frac)*om_frac)/om_hksat) +! else +! uncon_hksat = 0._r8 +! end if +! soilstate_inst%hksat_col(c,lev) = params_inst%hksat_sf * ( uncon_frac*uncon_hksat + & +! (perc_frac*om_frac)*om_hksat ) +! +! soilstate_inst%tkmg_col(c,lev) = tkm ** (1._r8- soilstate_inst%watsat_col(c,lev)) +! +! soilstate_inst%tksatu_col(c,lev) = soilstate_inst%tkmg_col(c,lev)*0.57_r8**soilstate_inst%watsat_col(c,lev) +! +! soilstate_inst%tkdry_col(c,lev) = ((0.135_r8*soilstate_inst%bd_col(c,lev) + 64.7_r8) / & +! (params_inst%pd - 0.947_r8*soilstate_inst%bd_col(c,lev)))*(1._r8-om_frac) + params_inst%tkd_om*om_frac +! +! soilstate_inst%csol_col(c,lev) = ((1._r8-om_frac)*(params_inst%csol_sand*sand+ & +! params_inst%csol_clay*clay) / (sand+clay) + params_inst%csol_om*om_frac)*1.e6_r8 ! J/(m3 K) +! +! soilstate_inst%watdry_col(c,lev) = soilstate_inst%watsat_col(c,lev) * & +! (316230._r8/soilstate_inst%sucsat_col(c,lev)) ** (-1._r8/soilstate_inst%bsw_col(c,lev)) +! soilstate_inst%watopt_col(c,lev) = soilstate_inst%watsat_col(c,lev) * & +! (158490._r8/soilstate_inst%sucsat_col(c,lev)) ** (-1._r8/soilstate_inst%bsw_col(c,lev)) +! +! !! added by K.Sakaguchi for beta from Lee and Pielke, 1992 +! ! water content at field capacity, defined as hk = 0.1 mm/day +! ! used eqn (7.70) in CLM3 technote with k = 0.1 (mm/day) / secspday (day/sec) +! soilstate_inst%watfc_col(c,lev) = soilstate_inst%watsat_col(c,lev) * & +! (0.1_r8 / (soilstate_inst%hksat_col(c,lev)*secspday))**(1._r8/(2._r8*soilstate_inst%bsw_col(c,lev)+3._r8)) +! end if +! end do +! +! ! Urban pervious and impervious road +! if (col%itype(c) == icol_road_imperv) then +! ! Impervious road layers -- same as above except set watdry and watopt as missing +! do lev = 1,nlevgrnd +! soilstate_inst%watdry_col(c,lev) = spval +! soilstate_inst%watopt_col(c,lev) = spval +! end do +! else if (col%itype(c) == icol_road_perv) then +! ! pervious road layers - set in UrbanInitTimeConst +! end if +! +! end if +! end do +! +! ! -------------------------------------------------------------------- +! ! Set soil hydraulic and thermal properties: lake +! ! -------------------------------------------------------------------- +! +! do c = begc, endc +! g = col%gridcell(c) +! l = col%landunit(c) +! +! if (lun%itype(l)==istdlak) then +! +! do lev = 1,nlevgrnd +! if ( lev <= nlevsoi )then +! clay = soilstate_inst%cellclay_col(c,lev) +! sand = soilstate_inst%cellsand_col(c,lev) +! if ( organic_frac_squared )then +! om_frac = (soilstate_inst%cellorg_col(c,lev)/organic_max)**2._r8 +! else +! om_frac = soilstate_inst%cellorg_col(c,lev)/organic_max +! end if +! else +! clay = soilstate_inst%cellclay_col(c,nlevsoi) +! sand = soilstate_inst%cellsand_col(c,nlevsoi) +! om_frac = 0.0_r8 +! end if +! +! soilstate_inst%watsat_col(c,lev) = 0.489_r8 - 0.00126_r8*sand +! +! soilstate_inst%bsw_col(c,lev) = 2.91 + 0.159*clay +! +! soilstate_inst%sucsat_col(c,lev) = 10._r8 * ( 10._r8**(1.88_r8-0.0131_r8*sand) ) +! +! bd = (1._r8-soilstate_inst%watsat_col(c,lev))*params_inst%pd +! +! soilstate_inst%watsat_col(c,lev) = params_inst%watsat_sf * ( (1._r8 - om_frac) * & +! soilstate_inst%watsat_col(c,lev) + om_watsat_lake * om_frac ) +! +! tkm = (1._r8-om_frac)*(params_inst%tkd_sand*sand+params_inst%tkd_clay*clay)/(sand+clay) + & +! params_inst%tkm_om * om_frac ! W/(m K) +! +! soilstate_inst%bsw_col(c,lev) = params_inst%bsw_sf * ( (1._r8-om_frac) * & +! (2.91_r8 + 0.159_r8*clay) + om_frac * om_b_lake ) +! +! soilstate_inst%sucsat_col(c,lev) = params_inst%sucsat_sf * ( (1._r8-om_frac) * & +! soilstate_inst%sucsat_col(c,lev) + om_sucsat_lake * om_frac ) +! +! xksat = 0.0070556 *( 10.**(-0.884+0.0153*sand) ) ! mm/s +! +! ! perc_frac is zero unless perf_frac greater than percolation threshold +! if (om_frac > pc_lake) then +! perc_norm = (1._r8 - pc_lake)**(-pcbeta) +! perc_frac = perc_norm*(om_frac - pc_lake)**pcbeta +! else +! perc_frac = 0._r8 +! endif +! +! ! uncon_frac is fraction of mineral soil plus fraction of "nonpercolating" organic soil +! uncon_frac = (1._r8-om_frac) + (1._r8-perc_frac)*om_frac +! +! ! uncon_hksat is series addition of mineral/organic conductivites +! if (om_frac < 1._r8) then +! xksat = 0.0070556 *( 10.**(-0.884+0.0153*sand) ) ! mm/s +! uncon_hksat = uncon_frac/((1._r8-om_frac)/xksat + ((1._r8-perc_frac)*om_frac)/om_hksat_lake) +! else +! uncon_hksat = 0._r8 +! end if +! +! soilstate_inst%hksat_col(c,lev) = params_inst%hksat_sf * ( uncon_frac*uncon_hksat + & +! (perc_frac*om_frac)*om_hksat_lake ) +! soilstate_inst%tkmg_col(c,lev) = tkm ** (1._r8- soilstate_inst%watsat_col(c,lev)) +! soilstate_inst%tksatu_col(c,lev) = soilstate_inst%tkmg_col(c,lev)*0.57_r8**soilstate_inst%watsat_col(c,lev) +! soilstate_inst%tkdry_col(c,lev) = ((0.135_r8*bd + 64.7_r8) / (params_inst%pd - 0.947_r8*bd))*(1._r8-om_frac) + & +! params_inst%tkd_om * om_frac +! soilstate_inst%csol_col(c,lev) = ((1._r8-om_frac)*(params_inst%csol_sand*sand+ & +! params_inst%csol_clay*clay) / (sand+clay) + params_inst%csol_om * om_frac)*1.e6_r8 ! J/(m3 K) +! soilstate_inst%watdry_col(c,lev) = soilstate_inst%watsat_col(c,lev) & +! * (316230._r8/soilstate_inst%sucsat_col(c,lev)) ** (-1._r8/soilstate_inst%bsw_col(c,lev)) +! soilstate_inst%watopt_col(c,lev) = soilstate_inst%watsat_col(c,lev) & +! * (158490._r8/soilstate_inst%sucsat_col(c,lev)) ** (-1._r8/soilstate_inst%bsw_col(c,lev)) +! +! !! added by K.Sakaguchi for beta from Lee and Pielke, 1992 +! ! water content at field capacity, defined as hk = 0.1 mm/day +! ! used eqn (7.70) in CLM3 technote with k = 0.1 (mm/day) / (# seconds/day) +! soilstate_inst%watfc_col(c,lev) = soilstate_inst%watsat_col(c,lev) * (0.1_r8 / & +! (soilstate_inst%hksat_col(c,lev)*secspday))**(1._r8/(2._r8*soilstate_inst%bsw_col(c,lev)+3._r8)) +! end do +! endif +! +! end do +! +! ! -------------------------------------------------------------------- +! ! Initialize threshold soil moisture and mass fracion of clay limited to 0.20 +! ! -------------------------------------------------------------------- +! +! do c = begc,endc +! g = col%gridcell(c) +! +! soilstate_inst%gwc_thr_col(c) = 0.17_r8 + 0.14_r8 * clay3d(g,1) * 0.01_r8 +! soilstate_inst%mss_frc_cly_vld_col(c) = min(clay3d(g,1) * 0.01_r8, 0.20_r8) +! end do +! +! ! -------------------------------------------------------------------- +! ! Deallocate memory +! ! -------------------------------------------------------------------- +! +! deallocate(sand3d, clay3d, organic3d) +! deallocate(zisoifl, zsoifl) + + end subroutine SoilStateInitTimeConst + +end module SoilStateInitTimeConstMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilWaterRetentionCurveMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilWaterRetentionCurveMod.F90 new file mode 100755 index 000000000..74f8299d5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilWaterRetentionCurveMod.F90 @@ -0,0 +1,111 @@ +module SoilWaterRetentionCurveMod + + !--------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abstract base class for functions to compute soil water retention curve + ! + ! !USES: + implicit none + save + private + ! + ! !PUBLIC TYPES: + public :: soil_water_retention_curve_type + + type, abstract :: soil_water_retention_curve_type + private + contains + ! compute hydraulic conductivity + procedure(soil_hk_interface), deferred :: soil_hk + + ! compute soil suction potential + procedure(soil_suction_interface), deferred :: soil_suction + + ! compute relative saturation at which soil suction is equal to a target value + procedure(soil_suction_inverse_interface), deferred :: soil_suction_inverse + end type soil_water_retention_curve_type + + abstract interface + + ! Note: The following interfaces are set up based on the arguments needed for the + ! clapphornberg1978 implementations. It's likely that these interfaces are not + ! totally general for all desired implementations. In that case, we'll need to think + ! about how to support different interfaces. Some possible solutions are: + ! + ! - Make the interfaces contain all possible inputs that are needed by any + ! implementation; each implementation will then ignore the inputs it doesn't need. + ! + ! - For inputs that are needed only by particular implementations - and particularly + ! for inputs that are constant in time (e.g., this is the case for bsw, I think): + ! pass these into the constructor, and save pointers to these inputs as components + ! of the child type that needs them. Then they aren't needed as inputs to the + ! individual routines, allowing the interfaces for these routines to remain more + ! consistent between different implementations. + + subroutine soil_hk_interface(this, c, j, s, imped, soilstate_inst, & + hk, dhkds) + + ! !DESCRIPTION: + ! Compute hydraulic conductivity + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use SoilStateType , only : soilstate_type + import :: soil_water_retention_curve_type + ! + ! !ARGUMENTS: + class(soil_water_retention_curve_type), intent(in) :: this + integer, intent(in) :: c !column index + integer, intent(in) :: j !level index + real(r8), intent(in) :: s !relative saturation, [0, 1] + real(r8), intent(in) :: imped !ice impedance + type(soilstate_type), intent(in) :: soilstate_inst + real(r8), intent(out):: hk !hydraulic conductivity [mm/s] + real(r8), optional, intent(out):: dhkds !d[hk]/ds [mm/s] + end subroutine soil_hk_interface + + + subroutine soil_suction_interface(this, c, j, s, soilstate_inst, & + smp, dsmpds) + + ! !DESCRIPTION: + ! Compute soil suction potential + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use SoilStateType , only : soilstate_type + import :: soil_water_retention_curve_type + ! + ! !ARGUMENTS: + class(soil_water_retention_curve_type), intent(in) :: this + integer, intent(in) :: c !column index + integer, intent(in) :: j !level index + real(r8), intent(in) :: s !relative saturation, [0, 1] + type(soilstate_type), intent(in) :: soilstate_inst + real(r8), intent(out) :: smp !soil suction, negative, [mm] + real(r8), optional, intent(out) :: dsmpds !d[smp]/ds, [mm] + end subroutine soil_suction_interface + + subroutine soil_suction_inverse_interface(this, c, j, smp_target, & + soilstate_inst, s_target) + ! !DESCRIPTION: + ! Compute relative saturation at which soil suction is equal to a target value. + ! This is done by inverting the soil_suction equation to solve for s. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use SoilStateType , only : soilstate_type + import :: soil_water_retention_curve_type + ! + ! !ARGUMENTS: + class(soil_water_retention_curve_type), intent(in) :: this + integer, intent(in) :: c !column index + integer, intent(in) :: j !level index + real(r8), intent(in) :: smp_target ! target soil suction, negative [mm] + type(soilstate_type), intent(in) :: soilstate_inst + real(r8) , intent(out) :: s_target ! relative saturation at which smp = smp_target [0,1] + end subroutine soil_suction_inverse_interface + + end interface + +end module SoilWaterRetentionCurveMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceAlbedoMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceAlbedoMod.F90 new file mode 100755 index 000000000..53854cb71 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceAlbedoMod.F90 @@ -0,0 +1,1699 @@ +module SurfaceAlbedoMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Performs surface albedo calculations + ! + ! !PUBLIC TYPES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun +! use landunit_varcon , only : istsoil, istcrop, istdlak +! use clm_varcon , only : grlnd, namep + use clm_varpar , only : numrad, nlevcan, nlevsno, nlevcan + use clm_varctl , only : iulog + use pftconMod , only : pftcon +! use SnowSnicarMod , only : sno_nbr_aer, SNICAR_RT, DO_SNO_AER, DO_SNO_OC +! use AerosolMod , only : aerosol_type + use CanopyStateType , only : canopystate_type +! use LakeStateType , only : lakestate_type + use SurfaceAlbedoType , only : surfalb_type + use TemperatureType , only : temperature_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use GridcellType , only : grc + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + ! + implicit none + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: SurfaceAlbedo_readnl + ! public :: SurfaceAlbedoInitTimeConst + ! public :: SurfaceAlbedo ! Surface albedo and two-stream fluxes + ! + ! !PRIVATE MEMBER FUNCTIONS: + ! private :: SoilAlbedo ! Determine ground surface albedo + public :: TwoStream ! Two-stream fluxes for canopy radiative transfer + ! + ! !PUBLIC DATA MEMBERS: + ! The CLM default albice values are too high. + ! Full-spectral albedo for land ice is ~0.5 (Paterson, Physics of Glaciers, 1994, p. 59) + ! This is the value used in CAM3 by Pritchard et al., GRL, 35, 2008. + + ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: albice(numrad) = (/ 0.80_r8, 0.55_r8 /) + + ! namelist default setting for inputting alblakwi + real(r8), public :: lake_melt_icealb(numrad) = (/ 0.10_r8, 0.10_r8/) + + ! albedo frozen lakes by waveband (1=vis, 2=nir) + ! unclear what the reference is for this + real(r8), private :: alblak(numrad) = (/0.60_r8, 0.40_r8/) + + ! albedo of melting lakes due to puddling, open water, or white ice + ! From D. Mironov (2010) Boreal Env. Research + ! To revert albedo of melting lakes to the cold snow-free value, set + ! lake_melt_icealb namelist to 0.60, 0.40 like alblak above. + real(r8), private :: alblakwi(numrad) + + ! Coefficient for calculating ice "fraction" for lake surface albedo + ! From D. Mironov (2010) Boreal Env. Research + real(r8), parameter :: calb = 95.6_r8 + + ! + ! !PRIVATE DATA MEMBERS: + logical, private :: snowveg_affects_radiation = .true. ! Whether snow on the vegetation canopy affects the radiation/albedo calculations + + ! + ! !PRIVATE DATA FUNCTIONS: + real(r8), allocatable, private :: albsat(:,:) ! wet soil albedo by color class and waveband (1=vis,2=nir) + real(r8), allocatable, private :: albdry(:,:) ! dry soil albedo by color class and waveband (1=vis,2=nir) + integer , allocatable, private :: isoicol(:) ! column soil color class + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine SurfaceAlbedo_readnl( NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for SurfaceAlbedo + ! + ! !USES: + use spmdMod , only : masterproc, mpicom + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use shr_mpi_mod , only : shr_mpi_bcast + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + character(len=*), parameter :: nmlname = "surfacealbedo_inparm" + + character(len=*), parameter :: subname = 'SurfaceAlbedo_readnl' + !----------------------------------------------------------------------- + + namelist /surfacealbedo_inparm/ snowveg_affects_radiation + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=surfacealbedo_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + end if + + call shr_mpi_bcast(snowveg_affects_radiation, mpicom) + + if (masterproc) then + write(iulog,*) + write(iulog,*) nmlname, ' settings' + write(iulog,nml=surfacealbedo_inparm) + write(iulog,*) + end if + + end subroutine SurfaceAlbedo_readnl + +! +! !----------------------------------------------------------------------- +! subroutine SurfaceAlbedoInitTimeConst(bounds) +! ! +! ! !DESCRIPTION: +! ! Initialize module time constant variables +! ! +! ! !USES: +! use shr_log_mod, only : errMsg => shr_log_errMsg +! use fileutils , only : getfil +! use abortutils , only : endrun +! use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_pio_openfile, ncd_pio_closefile +! use spmdMod , only : masterproc +! ! +! ! !ARGUMENTS: +! type(bounds_type), intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! integer :: c,g ! indices +! integer :: mxsoil_color ! maximum number of soil color classes +! type(file_desc_t) :: ncid ! netcdf id +! character(len=256) :: locfn ! local filename +! integer :: ier ! error status +! logical :: readvar +! integer ,pointer :: soic2d (:) ! read in - soil color +! !--------------------------------------------------------------------- +! +! ! Allocate module variable for soil color +! +! allocate(isoicol(bounds%begc:bounds%endc)) +! +! ! Determine soil color and number of soil color classes +! +! call getfil (fsurdat, locfn, 0) +! call ncd_pio_openfile (ncid, locfn, 0) +! +! call ncd_io(ncid=ncid, varname='mxsoil_color', flag='read', data=mxsoil_color, readvar=readvar) +! if ( .not. readvar ) then +! call endrun(msg=' ERROR: mxsoil_color NOT on surfdata file '//errMsg(sourcefile, __LINE__)) +! end if +! +! allocate(soic2d(bounds%begg:bounds%endg)) +! call ncd_io(ncid=ncid, varname='SOIL_COLOR', flag='read', data=soic2d, dim1name=grlnd, readvar=readvar) +! if (.not. readvar) then +! call endrun(msg=' ERROR: SOIL_COLOR NOT on surfdata file'//errMsg(sourcefile, __LINE__)) +! end if +! do c = bounds%begc, bounds%endc +! g = col%gridcell(c) +! isoicol(c) = soic2d(g) +! end do +! deallocate(soic2d) +! +! call ncd_pio_closefile(ncid) +! +! ! Determine saturated and dry soil albedos for n color classes and +! ! numrad wavebands (1=vis, 2=nir) +! +! allocate(albsat(mxsoil_color,numrad), albdry(mxsoil_color,numrad), stat=ier) +! if (ier /= 0) then +! write(iulog,*)'allocation error for albsat, albdry' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if +! +! if (masterproc) then +! write(iulog,*) 'Attempting to read soil colo data .....' +! end if +! +! if (mxsoil_color == 8) then +! albsat(1:8,1) = (/0.12_r8,0.11_r8,0.10_r8,0.09_r8,0.08_r8,0.07_r8,0.06_r8,0.05_r8/) +! albsat(1:8,2) = (/0.24_r8,0.22_r8,0.20_r8,0.18_r8,0.16_r8,0.14_r8,0.12_r8,0.10_r8/) +! albdry(1:8,1) = (/0.24_r8,0.22_r8,0.20_r8,0.18_r8,0.16_r8,0.14_r8,0.12_r8,0.10_r8/) +! albdry(1:8,2) = (/0.48_r8,0.44_r8,0.40_r8,0.36_r8,0.32_r8,0.28_r8,0.24_r8,0.20_r8/) +! else if (mxsoil_color == 20) then +! albsat(1:20,1) = (/0.25_r8,0.23_r8,0.21_r8,0.20_r8,0.19_r8,0.18_r8,0.17_r8,0.16_r8,& +! 0.15_r8,0.14_r8,0.13_r8,0.12_r8,0.11_r8,0.10_r8,0.09_r8,0.08_r8,0.07_r8,0.06_r8,0.05_r8,0.04_r8/) +! albsat(1:20,2) = (/0.50_r8,0.46_r8,0.42_r8,0.40_r8,0.38_r8,0.36_r8,0.34_r8,0.32_r8,& +! 0.30_r8,0.28_r8,0.26_r8,0.24_r8,0.22_r8,0.20_r8,0.18_r8,0.16_r8,0.14_r8,0.12_r8,0.10_r8,0.08_r8/) +! albdry(1:20,1) = (/0.36_r8,0.34_r8,0.32_r8,0.31_r8,0.30_r8,0.29_r8,0.28_r8,0.27_r8,& +! 0.26_r8,0.25_r8,0.24_r8,0.23_r8,0.22_r8,0.20_r8,0.18_r8,0.16_r8,0.14_r8,0.12_r8,0.10_r8,0.08_r8/) +! albdry(1:20,2) = (/0.61_r8,0.57_r8,0.53_r8,0.51_r8,0.49_r8,0.48_r8,0.45_r8,0.43_r8,& +! 0.41_r8,0.39_r8,0.37_r8,0.35_r8,0.33_r8,0.31_r8,0.29_r8,0.27_r8,0.25_r8,0.23_r8,0.21_r8,0.16_r8/) +! else +! write(iulog,*)'maximum color class = ',mxsoil_color,' is not supported' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if +! +! ! Set alblakwi +! alblakwi(:) = lake_melt_icealb(:) +! +! end subroutine SurfaceAlbedoInitTimeConst +! +! !----------------------------------------------------------------------- +! subroutine SurfaceAlbedo(bounds,nc, & +! num_nourbanc, filter_nourbanc, & +! num_nourbanp, filter_nourbanp, & +! num_urbanc , filter_urbanc, & +! num_urbanp , filter_urbanp, & +! nextsw_cday , declinp1, & +! clm_fates, & +! aerosol_inst, canopystate_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, & +! lakestate_inst, temperature_inst, surfalb_inst) +! ! +! ! !DESCRIPTION: +! ! Surface albedo and two-stream fluxes +! ! Surface albedos. Also fluxes (per unit incoming direct and diffuse +! ! radiation) reflected, transmitted, and absorbed by vegetation. +! ! Calculate sunlit and shaded fluxes as described by +! ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to +! ! a multi-layer canopy to calculate APAR profile +! ! +! ! The calling sequence is: +! ! -> SurfaceAlbedo: albedos for next time step +! ! -> SoilAlbedo: soil/lake/glacier/wetland albedos +! ! -> SNICAR_RT: snow albedos: direct beam (SNICAR) +! ! -> SNICAR_RT: snow albedos: diffuse (SNICAR) +! ! -> TwoStream: absorbed, reflected, transmitted solar fluxes (vis dir,vis dif, nir dir, nir dif) +! ! +! ! Note that this is called with the "inactive_and_active" version of the filters, because +! ! the variables computed here are needed over inactive points that might later become +! ! active (due to landuse change). Thus, this routine cannot depend on variables that are +! ! only computed over active points. +! ! +! ! !USES: +! use shr_orb_mod +! use clm_time_manager , only : get_nstep +! use abortutils , only : endrun +! use clm_varctl , only : use_subgrid_fluxes, use_snicar_frc, use_fates +! use CLMFatesInterfaceMod, only : hlm_fates_interface_type +! +! ! !ARGUMENTS: +! type(bounds_type) , intent(in) :: bounds ! bounds +! integer , intent(in) :: nc ! clump index +! integer , intent(in) :: num_nourbanc ! number of columns in non-urban filter +! integer , intent(in) :: filter_nourbanc(:) ! column filter for non-urban points +! integer , intent(in) :: num_nourbanp ! number of patches in non-urban filter +! integer , intent(in) :: filter_nourbanp(:) ! patch filter for non-urban points +! integer , intent(in) :: num_urbanc ! number of columns in urban filter +! integer , intent(in) :: filter_urbanc(:) ! column filter for urban points +! integer , intent(in) :: num_urbanp ! number of patches in urban filter +! integer , intent(in) :: filter_urbanp(:) ! patch filter for rban points +! real(r8) , intent(in) :: nextsw_cday ! calendar day at Greenwich (1.00, ..., days/year) +! real(r8) , intent(in) :: declinp1 ! declination angle (radians) for next time step +! type(hlm_fates_interface_type), intent(inout) :: clm_fates +! type(aerosol_type) , intent(in) :: aerosol_inst +! type(canopystate_type) , intent(in) :: canopystate_inst +! type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst +! type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst +! type(lakestate_type) , intent(in) :: lakestate_inst +! type(temperature_type) , intent(in) :: temperature_inst +! type(surfalb_type) , intent(inout) :: surfalb_inst +! ! +! ! !LOCAL VARIABLES: +! integer :: i ! index for layers [idx] +! integer :: aer ! index for sno_nbr_aer +! real(r8) :: extkn ! nitrogen allocation coefficient +! integer :: fp,fc,g,c,p,iv ! indices +! integer :: ib ! band index +! integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse +! real(r8) :: dinc ! lai+sai increment for canopy layer +! real(r8) :: dincmax ! maximum lai+sai increment for canopy layer +! real(r8) :: dincmax_sum ! cumulative sum of maximum lai+sai increment for canopy layer +! real(r8) :: laisum ! sum of canopy layer lai for error check +! real(r8) :: saisum ! sum of canopy layer sai for error check +! integer :: flg_slr ! flag for SNICAR (=1 if direct, =2 if diffuse) +! integer :: flg_snw_ice ! flag for SNICAR (=1 when called from CLM, =2 when called from sea-ice) +! integer :: num_vegsol ! number of vegetated patches where coszen>0 +! integer :: num_novegsol ! number of vegetated patches where coszen>0 +! integer :: filter_vegsol (bounds%endp-bounds%begp+1) ! patch filter where vegetated and coszen>0 +! integer :: filter_novegsol (bounds%endp-bounds%begp+1) ! patch filter where vegetated and coszen>0 +! real(r8) :: wl (bounds%begp:bounds%endp) ! fraction of LAI+SAI that is LAI +! real(r8) :: ws (bounds%begp:bounds%endp) ! fraction of LAI+SAI that is SAI +! real(r8) :: blai(bounds%begp:bounds%endp) ! lai buried by snow: tlai - elai +! real(r8) :: bsai(bounds%begp:bounds%endp) ! sai buried by snow: tsai - esai +! real(r8) :: coszen_gcell (bounds%begg:bounds%endg) ! cosine solar zenith angle for next time step (grc) +! real(r8) :: coszen_patch (bounds%begp:bounds%endp) ! cosine solar zenith angle for next time step (patch) +! real(r8) :: rho(bounds%begp:bounds%endp,numrad) ! leaf/stem refl weighted by fraction LAI and SAI +! real(r8) :: tau(bounds%begp:bounds%endp,numrad) ! leaf/stem tran weighted by fraction LAI and SAI +! real(r8) :: h2osno_total (bounds%begc:bounds%endc) ! total snow water (mm H2O) +! real(r8) :: albsfc (bounds%begc:bounds%endc,numrad) ! albedo of surface underneath snow (col,bnd) +! real(r8) :: albsnd(bounds%begc:bounds%endc,numrad) ! snow albedo (direct) +! real(r8) :: albsni(bounds%begc:bounds%endc,numrad) ! snow albedo (diffuse) +! real(r8) :: albsnd_pur (bounds%begc:bounds%endc,numrad) ! direct pure snow albedo (radiative forcing) +! real(r8) :: albsni_pur (bounds%begc:bounds%endc,numrad) ! diffuse pure snow albedo (radiative forcing) +! real(r8) :: albsnd_bc (bounds%begc:bounds%endc,numrad) ! direct snow albedo without BC (radiative forcing) +! real(r8) :: albsni_bc (bounds%begc:bounds%endc,numrad) ! diffuse snow albedo without BC (radiative forcing) +! real(r8) :: albsnd_oc (bounds%begc:bounds%endc,numrad) ! direct snow albedo without OC (radiative forcing) +! real(r8) :: albsni_oc (bounds%begc:bounds%endc,numrad) ! diffuse snow albedo without OC (radiative forcing) +! real(r8) :: albsnd_dst (bounds%begc:bounds%endc,numrad) ! direct snow albedo without dust (radiative forcing) +! real(r8) :: albsni_dst (bounds%begc:bounds%endc,numrad) ! diffuse snow albedo without dust (radiative forcing) +! real(r8) :: flx_absd_snw (bounds%begc:bounds%endc,-nlevsno+1:1,numrad) ! flux absorption factor for just snow (direct) [frc] +! real(r8) :: flx_absi_snw (bounds%begc:bounds%endc,-nlevsno+1:1,numrad) ! flux absorption factor for just snow (diffuse) [frc] +! real(r8) :: foo_snw (bounds%begc:bounds%endc,-nlevsno+1:1,numrad) ! dummy array for forcing calls +! real(r8) :: h2osno_liq (bounds%begc:bounds%endc,-nlevsno+1:0) ! liquid snow content (col,lyr) [kg m-2] +! real(r8) :: h2osno_ice (bounds%begc:bounds%endc,-nlevsno+1:0) ! ice content in snow (col,lyr) [kg m-2] +! integer :: snw_rds_in (bounds%begc:bounds%endc,-nlevsno+1:0) ! snow grain size sent to SNICAR (col,lyr) [microns] +! real(r8) :: mss_cnc_aer_in_frc_pur (bounds%begc:bounds%endc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of aerosol species for forcing calculation (zero) (col,lyr,aer) [kg kg-1] +! real(r8) :: mss_cnc_aer_in_frc_bc (bounds%begc:bounds%endc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of aerosol species for BC forcing (col,lyr,aer) [kg kg-1] +! real(r8) :: mss_cnc_aer_in_frc_oc (bounds%begc:bounds%endc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of aerosol species for OC forcing (col,lyr,aer) [kg kg-1] +! real(r8) :: mss_cnc_aer_in_frc_dst (bounds%begc:bounds%endc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of aerosol species for dust forcing (col,lyr,aer) [kg kg-1] +! real(r8) :: mss_cnc_aer_in_fdb (bounds%begc:bounds%endc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of all aerosol species for feedback calculation (col,lyr,aer) [kg kg-1] +! real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero +! integer , parameter :: nband =numrad ! number of solar radiation waveband classes +! !----------------------------------------------------------------------- +! +! associate(& +! rhol => pftcon%rhol , & ! Input: leaf reflectance: 1=vis, 2=nir +! rhos => pftcon%rhos , & ! Input: stem reflectance: 1=vis, 2=nir +! taul => pftcon%taul , & ! Input: leaf transmittance: 1=vis, 2=nir +! taus => pftcon%taus , & ! Input: stem transmittance: 1=vis, 2=nir +! +! tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index, no burying by snow +! tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index, no burying by snow +! elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow +! esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow +! +! frac_sno => waterdiagnosticbulk_inst%frac_sno_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) +! h2osoi_liq => waterstatebulk_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid water content (col,lyr) [kg/m2] +! h2osoi_ice => waterstatebulk_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:) ] ice lens content (col,lyr) [kg/m2] +! snw_rds => waterdiagnosticbulk_inst%snw_rds_col , & ! Input: [real(r8) (:,:) ] snow grain radius (col,lyr) [microns] +! +! mss_cnc_bcphi => aerosol_inst%mss_cnc_bcphi_col , & ! Input: [real(r8) (:,:) ] mass concentration of hydrophilic BC (col,lyr) [kg/kg] +! mss_cnc_bcpho => aerosol_inst%mss_cnc_bcpho_col , & ! Input: [real(r8) (:,:) ] mass concentration of hydrophobic BC (col,lyr) [kg/kg] +! mss_cnc_ocphi => aerosol_inst%mss_cnc_ocphi_col , & ! Input: [real(r8) (:,:) ] mass concentration of hydrophilic OC (col,lyr) [kg/kg] +! mss_cnc_ocpho => aerosol_inst%mss_cnc_ocpho_col , & ! Input: [real(r8) (:,:) ] mass concentration of hydrophobic OC (col,lyr) [kg/kg] +! mss_cnc_dst1 => aerosol_inst%mss_cnc_dst1_col , & ! Input: [real(r8) (:,:) ] mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] +! mss_cnc_dst2 => aerosol_inst%mss_cnc_dst2_col , & ! Input: [real(r8) (:,:) ] mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] +! mss_cnc_dst3 => aerosol_inst%mss_cnc_dst3_col , & ! Input: [real(r8) (:,:) ] mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] +! mss_cnc_dst4 => aerosol_inst%mss_cnc_dst4_col , & ! Input: [real(r8) (:,:) ] mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] +! +! fsun_z => surfalb_inst%fsun_z_patch , & ! Output: [real(r8) (:,:) ] sunlit fraction of canopy layer +! tlai_z => surfalb_inst%tlai_z_patch , & ! Output: [real(r8) (:,:) ] tlai increment for canopy layer +! tsai_z => surfalb_inst%tsai_z_patch , & ! Output: [real(r8) (:,:) ] tsai increment for canopy layer +! vcmaxcintsun => surfalb_inst%vcmaxcintsun_patch , & ! Output: [real(r8) (:) ] leaf to canopy scaling coefficient, sunlit leaf vcmax +! vcmaxcintsha => surfalb_inst%vcmaxcintsha_patch , & ! Output: [real(r8) (:) ] leaf to canopy scaling coefficient, shaded leaf vcmax +! ncan => surfalb_inst%ncan_patch , & ! Output: [integer (:) ] number of canopy layers +! nrad => surfalb_inst%nrad_patch , & ! Output: [integer (:) ] number of canopy layers, above snow for radiative transfer +! coszen_col => surfalb_inst%coszen_col , & ! Output: [real(r8) (:) ] cosine of solar zenith angle +! albgrd => surfalb_inst%albgrd_col , & ! Output: [real(r8) (:,:) ] ground albedo (direct) +! albgri => surfalb_inst%albgri_col , & ! Output: [real(r8) (:,:) ] ground albedo (diffuse) +! albsod => surfalb_inst%albsod_col , & ! Output: [real(r8) (:,:) ] direct-beam soil albedo (col,bnd) [frc] +! albsoi => surfalb_inst%albsoi_col , & ! Output: [real(r8) (:,:) ] diffuse soil albedo (col,bnd) [frc] +! albgrd_pur => surfalb_inst%albgrd_pur_col , & ! Output: [real(r8) (:,:) ] pure snow ground albedo (direct) +! albgri_pur => surfalb_inst%albgri_pur_col , & ! Output: [real(r8) (:,:) ] pure snow ground albedo (diffuse) +! albgrd_bc => surfalb_inst%albgrd_bc_col , & ! Output: [real(r8) (:,:) ] ground albedo without BC (direct) +! albgri_bc => surfalb_inst%albgri_bc_col , & ! Output: [real(r8) (:,:) ] ground albedo without BC (diffuse) +! albgrd_oc => surfalb_inst%albgrd_oc_col , & ! Output: [real(r8) (:,:) ] ground albedo without OC (direct) +! albgri_oc => surfalb_inst%albgri_oc_col , & ! Output: [real(r8) (:,:) ] ground albedo without OC (diffuse) +! albgrd_dst => surfalb_inst%albgrd_dst_col , & ! Output: [real(r8) (:,:) ] ground albedo without dust (direct) +! albgri_dst => surfalb_inst%albgri_dst_col , & ! Output: [real(r8) (:,:) ] ground albedo without dust (diffuse) +! albsnd_hst => surfalb_inst%albsnd_hst_col , & ! Output: [real(r8) (:,:) ] snow albedo, direct, for history files (col,bnd) [frc] +! albsni_hst => surfalb_inst%albsni_hst_col , & ! Output: [real(r8) (:,:) ] snow ground albedo, diffuse, for history files (col,bnd) [frc] +! albd => surfalb_inst%albd_patch , & ! Output: [real(r8) (:,:) ] surface albedo (direct) +! albi => surfalb_inst%albi_patch , & ! Output: [real(r8) (:,:) ] surface albedo (diffuse) +! albdSF => surfalb_inst%albdSF_patch , & ! Output: [real(r8) (:,:) ] diagnostic snow-free surface albedo (direct) +! albiSF => surfalb_inst%albiSF_patch , & ! Output: [real(r8) (:,:) ] diagnostic snow-free surface albedo (diffuse) +! fabd => surfalb_inst%fabd_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit direct flux +! fabd_sun => surfalb_inst%fabd_sun_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit direct flux +! fabd_sha => surfalb_inst%fabd_sha_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit direct flux +! fabi => surfalb_inst%fabi_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit diffuse flux +! fabi_sun => surfalb_inst%fabi_sun_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit diffuse flux +! fabi_sha => surfalb_inst%fabi_sha_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit diffuse flux +! ftdd => surfalb_inst%ftdd_patch , & ! Output: [real(r8) (:,:) ] down direct flux below canopy per unit direct flux +! ftid => surfalb_inst%ftid_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit direct flux +! ftii => surfalb_inst%ftii_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit diffuse flux +! flx_absdv => surfalb_inst%flx_absdv_col , & ! Output: [real(r8) (:,:) ] direct flux absorption factor (col,lyr): VIS [frc] +! flx_absdn => surfalb_inst%flx_absdn_col , & ! Output: [real(r8) (:,:) ] direct flux absorption factor (col,lyr): NIR [frc] +! flx_absiv => surfalb_inst%flx_absiv_col , & ! Output: [real(r8) (:,:) ] diffuse flux absorption factor (col,lyr): VIS [frc] +! flx_absin => surfalb_inst%flx_absin_col , & ! Output: [real(r8) (:,:) ] diffuse flux absorption factor (col,lyr): NIR [frc] +! fabd_sun_z => surfalb_inst%fabd_sun_z_patch , & ! Output: [real(r8) (:,:) ] absorbed sunlit leaf direct PAR (per unit lai+sai) for each canopy layer +! fabd_sha_z => surfalb_inst%fabd_sha_z_patch , & ! Output: [real(r8) (:,:) ] absorbed shaded leaf direct PAR (per unit lai+sai) for each canopy layer +! fabi_sun_z => surfalb_inst%fabi_sun_z_patch , & ! Output: [real(r8) (:,:) ] absorbed sunlit leaf diffuse PAR (per unit lai+sai) for each canopy layer +! fabi_sha_z => surfalb_inst%fabi_sha_z_patch & ! Output: [real(r8) (:,:) ] absorbed shaded leaf diffuse PAR (per unit lai+sai) for each canopy layer +! ) +! +! ! Cosine solar zenith angle for next time step +! +! do g = bounds%begg,bounds%endg +! coszen_gcell(g) = shr_orb_cosz (nextsw_cday, grc%lat(g), grc%lon(g), declinp1) +! end do +! do c = bounds%begc,bounds%endc +! g = col%gridcell(c) +! coszen_col(c) = coszen_gcell(g) +! end do +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! g = patch%gridcell(p) +! coszen_patch(p) = coszen_gcell(g) +! end do +! +! ! Initialize output because solar radiation only done if coszen > 0 +! +! do ib = 1, numrad +! do fc = 1,num_nourbanc +! c = filter_nourbanc(fc) +! albsod(c,ib) = 0._r8 +! albsoi(c,ib) = 0._r8 +! albgrd(c,ib) = 0._r8 +! albgri(c,ib) = 0._r8 +! albgrd_pur(c,ib) = 0._r8 +! albgri_pur(c,ib) = 0._r8 +! albgrd_bc(c,ib) = 0._r8 +! albgri_bc(c,ib) = 0._r8 +! albgrd_oc(c,ib) = 0._r8 +! albgri_oc(c,ib) = 0._r8 +! albgrd_dst(c,ib) = 0._r8 +! albgri_dst(c,ib) = 0._r8 +! do i=-nlevsno+1,1,1 +! flx_absdv(c,i) = 0._r8 +! flx_absdn(c,i) = 0._r8 +! flx_absiv(c,i) = 0._r8 +! flx_absin(c,i) = 0._r8 +! enddo +! end do +! +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! albd(p,ib) = 1._r8 +! albi(p,ib) = 1._r8 +! if (use_SSRE) then +! albdSF(p,ib) = 1._r8 +! albiSF(p,ib) = 1._r8 +! end if +! fabd(p,ib) = 0._r8 +! fabd_sun(p,ib) = 0._r8 +! fabd_sha(p,ib) = 0._r8 +! fabi(p,ib) = 0._r8 +! fabi_sun(p,ib) = 0._r8 +! fabi_sha(p,ib) = 0._r8 +! ftdd(p,ib) = 0._r8 +! ftid(p,ib) = 0._r8 +! ftii(p,ib) = 0._r8 +! end do +! +! end do ! end of numrad loop +! +! ! SoilAlbedo called before SNICAR_RT +! ! so that reflectance of soil beneath snow column is known +! ! ahead of time for snow RT calculation. +! +! ! Snow albedos +! ! Note that snow albedo routine will only compute nonzero snow albedos +! ! where h2osno> 0 and coszen > 0 +! +! ! Ground surface albedos +! ! Note that ground albedo routine will only compute nonzero snow albedos +! ! where coszen > 0 +! +! call SoilAlbedo(bounds, & +! num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! albsnd(bounds%begc:bounds%endc, :), & +! albsni(bounds%begc:bounds%endc, :), & +! lakestate_inst, temperature_inst, waterstatebulk_inst, surfalb_inst) +! +! ! set variables to pass to SNICAR. +! +! flg_snw_ice = 1 ! calling from CLM, not CSIM +! do c=bounds%begc,bounds%endc +! albsfc(c,:) = albsoi(c,:) +! h2osno_liq(c,:) = h2osoi_liq(c,-nlevsno+1:0) +! h2osno_ice(c,:) = h2osoi_ice(c,-nlevsno+1:0) +! snw_rds_in(c,:) = nint(snw_rds(c,:)) +! end do +! +! ! zero aerosol input arrays +! do aer = 1, sno_nbr_aer +! do i = -nlevsno+1, 0 +! do c = bounds%begc, bounds%endc +! mss_cnc_aer_in_frc_pur(c,i,aer) = 0._r8 +! mss_cnc_aer_in_frc_bc(c,i,aer) = 0._r8 +! mss_cnc_aer_in_frc_oc(c,i,aer) = 0._r8 +! mss_cnc_aer_in_frc_dst(c,i,aer) = 0._r8 +! mss_cnc_aer_in_fdb(c,i,aer) = 0._r8 +! end do +! end do +! end do +! +! ! Set aerosol input arrays +! ! feedback input arrays have been zeroed +! ! set soot and dust aerosol concentrations: +! if (DO_SNO_AER) then +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc,:,1) = mss_cnc_bcphi(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc,:,2) = mss_cnc_bcpho(bounds%begc:bounds%endc,:) +! +! ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: +! ! 1) Knowledge of their optical properties is primitive +! ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, +! ! it has a negligible darkening effect. +! if (DO_SNO_OC) then +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc,:,3) = mss_cnc_ocphi(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc,:,4) = mss_cnc_ocpho(bounds%begc:bounds%endc,:) +! endif +! +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc,:,5) = mss_cnc_dst1(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc,:,6) = mss_cnc_dst2(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc,:,7) = mss_cnc_dst3(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc,:,8) = mss_cnc_dst4(bounds%begc:bounds%endc,:) +! endif +! +! call waterstatebulk_inst%CalculateTotalH2osno(bounds, num_nourbanc, filter_nourbanc, & +! caller = 'SurfaceAlbedo', & +! h2osno_total = h2osno_total(bounds%begc:bounds%endc)) +! +! ! If radiative forcing is being calculated, first estimate clean-snow albedo +! +! if (use_snicar_frc) then +! ! 1. BC input array: +! ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] +! mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc,:,5) = mss_cnc_dst1(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc,:,6) = mss_cnc_dst2(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc,:,7) = mss_cnc_dst3(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc,:,8) = mss_cnc_dst4(bounds%begc:bounds%endc,:) +! if (DO_SNO_OC) then +! mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc,:,3) = mss_cnc_ocphi(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc,:,4) = mss_cnc_ocpho(bounds%begc:bounds%endc,:) +! endif +! +! ! BC FORCING CALCULATIONS +! flg_slr = 1; ! direct-beam +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsnd_bc(bounds%begc:bounds%endc, :), & +! foo_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! +! flg_slr = 2; ! diffuse +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsni_bc(bounds%begc:bounds%endc, :), & +! foo_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! +! ! 2. OC input array: +! ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] +! if (DO_SNO_OC) then +! mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc,:,1) = mss_cnc_bcphi(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc,:,2) = mss_cnc_bcpho(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc,:,5) = mss_cnc_dst1(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc,:,6) = mss_cnc_dst2(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc,:,7) = mss_cnc_dst3(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc,:,8) = mss_cnc_dst4(bounds%begc:bounds%endc,:) +! +! ! OC FORCING CALCULATIONS +! flg_slr = 1; ! direct-beam +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsnd_oc(bounds%begc:bounds%endc, :), & +! foo_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! +! flg_slr = 2; ! diffuse +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsni_oc(bounds%begc:bounds%endc, :), & +! foo_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! endif +! +! ! 3. DUST input array: +! ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] +! mss_cnc_aer_in_frc_dst(bounds%begc:bounds%endc,:,1) = mss_cnc_bcphi(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_dst(bounds%begc:bounds%endc,:,2) = mss_cnc_bcpho(bounds%begc:bounds%endc,:) +! if (DO_SNO_OC) then +! mss_cnc_aer_in_frc_dst(bounds%begc:bounds%endc,:,3) = mss_cnc_ocphi(bounds%begc:bounds%endc,:) +! mss_cnc_aer_in_frc_dst(bounds%begc:bounds%endc,:,4) = mss_cnc_ocpho(bounds%begc:bounds%endc,:) +! endif +! +! ! DUST FORCING CALCULATIONS +! flg_slr = 1; ! direct-beam +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_frc_dst(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsnd_dst(bounds%begc:bounds%endc, :), & +! foo_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! +! flg_slr = 2; ! diffuse +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_frc_dst(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsni_dst(bounds%begc:bounds%endc, :), & +! foo_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! +! ! 4. ALL AEROSOL FORCING CALCULATION +! ! (pure snow albedo) +! flg_slr = 1; ! direct-beam +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_frc_pur(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsnd_pur(bounds%begc:bounds%endc, :), & +! foo_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! +! flg_slr = 2; ! diffuse +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_frc_pur(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsni_pur(bounds%begc:bounds%endc, :), & +! foo_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! end if +! +! ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: +! flg_slr = 1; ! direct-beam +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsnd(bounds%begc:bounds%endc, :), & +! flx_absd_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! +! flg_slr = 2; ! diffuse +! call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & +! coszen_col(bounds%begc:bounds%endc), & +! flg_slr, & +! h2osno_liq(bounds%begc:bounds%endc, :), & +! h2osno_ice(bounds%begc:bounds%endc, :), & +! h2osno_total(bounds%begc:bounds%endc), & +! snw_rds_in(bounds%begc:bounds%endc, :), & +! mss_cnc_aer_in_fdb(bounds%begc:bounds%endc, :, :), & +! albsfc(bounds%begc:bounds%endc, :), & +! albsni(bounds%begc:bounds%endc, :), & +! flx_absi_snw(bounds%begc:bounds%endc, :, :), & +! waterdiagnosticbulk_inst) +! +! ! ground albedos and snow-fraction weighting of snow absorption factors +! do ib = 1, nband +! do fc = 1,num_nourbanc +! c = filter_nourbanc(fc) +! if (coszen_col(c) > 0._r8) then +! ! ground albedo was originally computed in SoilAlbedo, but is now computed here +! ! because the order of SoilAlbedo and SNICAR_RT was switched for SNICAR. +! albgrd(c,ib) = albsod(c,ib)*(1._r8-frac_sno(c)) + albsnd(c,ib)*frac_sno(c) +! albgri(c,ib) = albsoi(c,ib)*(1._r8-frac_sno(c)) + albsni(c,ib)*frac_sno(c) +! +! ! albedos for radiative forcing calculations: +! if (use_snicar_frc) then +! ! BC forcing albedo +! albgrd_bc(c,ib) = albsod(c,ib)*(1.-frac_sno(c)) + albsnd_bc(c,ib)*frac_sno(c) +! albgri_bc(c,ib) = albsoi(c,ib)*(1.-frac_sno(c)) + albsni_bc(c,ib)*frac_sno(c) +! +! if (DO_SNO_OC) then +! ! OC forcing albedo +! albgrd_oc(c,ib) = albsod(c,ib)*(1.-frac_sno(c)) + albsnd_oc(c,ib)*frac_sno(c) +! albgri_oc(c,ib) = albsoi(c,ib)*(1.-frac_sno(c)) + albsni_oc(c,ib)*frac_sno(c) +! endif +! +! ! dust forcing albedo +! albgrd_dst(c,ib) = albsod(c,ib)*(1.-frac_sno(c)) + albsnd_dst(c,ib)*frac_sno(c) +! albgri_dst(c,ib) = albsoi(c,ib)*(1.-frac_sno(c)) + albsni_dst(c,ib)*frac_sno(c) +! +! ! pure snow albedo for all-aerosol radiative forcing +! albgrd_pur(c,ib) = albsod(c,ib)*(1.-frac_sno(c)) + albsnd_pur(c,ib)*frac_sno(c) +! albgri_pur(c,ib) = albsoi(c,ib)*(1.-frac_sno(c)) + albsni_pur(c,ib)*frac_sno(c) +! end if +! +! ! also in this loop (but optionally in a different loop for vectorized code) +! ! weight snow layer radiative absorption factors based on snow fraction and soil albedo +! ! (NEEDED FOR ENERGY CONSERVATION) +! do i = -nlevsno+1,1,1 +! if (.not. use_subgrid_fluxes .or. lun%itype(col%landunit(c)) == istdlak) then +! if (ib == 1) then +! flx_absdv(c,i) = flx_absd_snw(c,i,ib)*frac_sno(c) + & +! ((1.-frac_sno(c))*(1-albsod(c,ib))*(flx_absd_snw(c,i,ib)/(1.-albsnd(c,ib)))) +! flx_absiv(c,i) = flx_absi_snw(c,i,ib)*frac_sno(c) + & +! ((1.-frac_sno(c))*(1-albsoi(c,ib))*(flx_absi_snw(c,i,ib)/(1.-albsni(c,ib)))) +! elseif (ib == 2) then +! flx_absdn(c,i) = flx_absd_snw(c,i,ib)*frac_sno(c) + & +! ((1.-frac_sno(c))*(1-albsod(c,ib))*(flx_absd_snw(c,i,ib)/(1.-albsnd(c,ib)))) +! flx_absin(c,i) = flx_absi_snw(c,i,ib)*frac_sno(c) + & +! ((1.-frac_sno(c))*(1-albsoi(c,ib))*(flx_absi_snw(c,i,ib)/(1.-albsni(c,ib)))) +! endif +! else +! if (ib == 1) then +! flx_absdv(c,i) = flx_absd_snw(c,i,ib) +! flx_absiv(c,i) = flx_absi_snw(c,i,ib) +! elseif (ib == 2) then +! flx_absdn(c,i) = flx_absd_snw(c,i,ib) +! flx_absin(c,i) = flx_absi_snw(c,i,ib) +! endif +! endif +! enddo +! endif +! enddo +! enddo +! +! ! For diagnostics, set snow albedo to spval over non-snow non-urban points +! ! so that it is not averaged in history buffer (OPTIONAL) +! ! TODO - this is set to 0 not spval - seems wrong since it will be averaged in +! +! do ib = 1, nband +! do fc = 1,num_nourbanc +! c = filter_nourbanc(fc) +! if ((coszen_col(c) > 0._r8) .and. (h2osno_total(c) > 0._r8)) then +! albsnd_hst(c,ib) = albsnd(c,ib) +! albsni_hst(c,ib) = albsni(c,ib) +! else +! albsnd_hst(c,ib) = 0._r8 +! albsni_hst(c,ib) = 0._r8 +! endif +! enddo +! enddo +! +! ! Create solar-vegetated filter for the following calculations +! +! num_vegsol = 0 +! num_novegsol = 0 +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! if (coszen_patch(p) > 0._r8) then +! if ((lun%itype(patch%landunit(p)) == istsoil .or. & +! lun%itype(patch%landunit(p)) == istcrop ) & +! .and. (elai(p) + esai(p)) > 0._r8) then +! num_vegsol = num_vegsol + 1 +! filter_vegsol(num_vegsol) = p +! else +! num_novegsol = num_novegsol + 1 +! filter_novegsol(num_novegsol) = p +! end if +! end if +! end do +! +! ! Weight reflectance/transmittance by lai and sai +! ! Only perform on vegetated patches where coszen > 0 +! +! do fp = 1,num_vegsol +! p = filter_vegsol(fp) +! wl(p) = elai(p) / max( elai(p)+esai(p), mpe ) +! ws(p) = esai(p) / max( elai(p)+esai(p), mpe ) +! end do +! +! do ib = 1, numrad +! do fp = 1,num_vegsol +! p = filter_vegsol(fp) +! rho(p,ib) = max( rhol(patch%itype(p),ib)*wl(p) + rhos(patch%itype(p),ib)*ws(p), mpe ) +! tau(p,ib) = max( taul(patch%itype(p),ib)*wl(p) + taus(patch%itype(p),ib)*ws(p), mpe ) +! end do +! end do +! +! ! Diagnose number of canopy layers for radiative transfer, in increments of dincmax. +! ! Add to number of layers so long as cumulative leaf+stem area does not exceed total +! ! leaf+stem area. Then add any remaining leaf+stem area to next layer and exit the loop. +! ! Do this first for elai and esai (not buried by snow) and then for the part of the +! ! canopy that is buried by snow. +! ! ------------------ +! ! tlai_z = leaf area increment for a layer +! ! tsai_z = stem area increment for a layer +! ! nrad = number of canopy layers above snow +! ! ncan = total number of canopy layers +! ! +! ! tlai_z summed from 1 to nrad = elai +! ! tlai_z summed from 1 to ncan = tlai +! +! ! tsai_z summed from 1 to nrad = esai +! ! tsai_z summed from 1 to ncan = tsai +! ! ------------------ +! ! +! ! Canopy layering needs to be done for all "num_nourbanp" not "num_vegsol" +! ! because layering is needed for all time steps regardless of radiation +! ! +! ! Sun/shade big leaf code uses only one layer (nrad = ncan = 1), triggered by +! ! nlevcan = 1 +! +! dincmax = 0.25_r8 +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! +! if (nlevcan == 1) then +! nrad(p) = 1 +! ncan(p) = 1 +! tlai_z(p,1) = elai(p) +! tsai_z(p,1) = esai(p) +! else if (nlevcan > 1) then +! if (elai(p)+esai(p) == 0._r8) then +! nrad(p) = 0 +! else +! dincmax_sum = 0._r8 +! do iv = 1, nlevcan +! dincmax_sum = dincmax_sum + dincmax +! if (((elai(p)+esai(p))-dincmax_sum) > 1.e-06_r8) then +! nrad(p) = iv +! dinc = dincmax +! tlai_z(p,iv) = dinc * elai(p) / max(elai(p)+esai(p), mpe) +! tsai_z(p,iv) = dinc * esai(p) / max(elai(p)+esai(p), mpe) +! else +! nrad(p) = iv +! dinc = dincmax - (dincmax_sum - (elai(p)+esai(p))) +! tlai_z(p,iv) = dinc * elai(p) / max(elai(p)+esai(p), mpe) +! tsai_z(p,iv) = dinc * esai(p) / max(elai(p)+esai(p), mpe) +! exit +! end if +! end do +! +! ! Mimumum of 4 canopy layers +! +! if (nrad(p) < 4) then +! nrad(p) = 4 +! do iv = 1, nrad(p) +! tlai_z(p,iv) = elai(p) / nrad(p) +! tsai_z(p,iv) = esai(p) / nrad(p) +! end do +! end if +! end if +! end if +! +! ! Error check: make sure cumulative of increments does not exceed total +! +! laisum = 0._r8 +! saisum = 0._r8 +! do iv = 1, nrad(p) +! laisum = laisum + tlai_z(p,iv) +! saisum = saisum + tsai_z(p,iv) +! end do +! if (abs(laisum-elai(p)) > 1.e-06_r8 .or. abs(saisum-esai(p)) > 1.e-06_r8) then +! write (iulog,*) 'multi-layer canopy error 01 in SurfaceAlbedo: ',& +! nrad(p),elai(p),laisum,esai(p),saisum +! call endrun(decomp_index=p, clmlevel=namep, msg=errmsg(sourcefile, __LINE__)) +! end if +! +! ! Repeat to find canopy layers buried by snow +! +! if (nlevcan > 1) then +! blai(p) = tlai(p) - elai(p) +! bsai(p) = tsai(p) - esai(p) +! if (blai(p)+bsai(p) == 0._r8) then +! ncan(p) = nrad(p) +! else +! dincmax_sum = 0._r8 +! do iv = nrad(p)+1, nlevcan +! dincmax_sum = dincmax_sum + dincmax +! if (((blai(p)+bsai(p))-dincmax_sum) > 1.e-06_r8) then +! ncan(p) = iv +! dinc = dincmax +! tlai_z(p,iv) = dinc * blai(p) / max(blai(p)+bsai(p), mpe) +! tsai_z(p,iv) = dinc * bsai(p) / max(blai(p)+bsai(p), mpe) +! else +! ncan(p) = iv +! dinc = dincmax - (dincmax_sum - (blai(p)+bsai(p))) +! tlai_z(p,iv) = dinc * blai(p) / max(blai(p)+bsai(p), mpe) +! tsai_z(p,iv) = dinc * bsai(p) / max(blai(p)+bsai(p), mpe) +! exit +! end if +! end do +! end if +! +! ! Error check: make sure cumulative of increments does not exceed total +! +! laisum = 0._r8 +! saisum = 0._r8 +! do iv = 1, ncan(p) +! laisum = laisum + tlai_z(p,iv) +! saisum = saisum + tsai_z(p,iv) +! end do +! if (abs(laisum-tlai(p)) > 1.e-06_r8 .or. abs(saisum-tsai(p)) > 1.e-06_r8) then +! write (iulog,*) 'multi-layer canopy error 02 in SurfaceAlbedo: ',nrad(p),ncan(p) +! write (iulog,*) tlai(p),elai(p),blai(p),laisum,tsai(p),esai(p),bsai(p),saisum +! call endrun(decomp_index=p, clmlevel=namep, msg=errmsg(sourcefile, __LINE__)) +! end if +! end if +! +! end do +! +! ! Zero fluxes for active canopy layers +! +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! do iv = 1, nrad(p) +! fabd_sun_z(p,iv) = 0._r8 +! fabd_sha_z(p,iv) = 0._r8 +! fabi_sun_z(p,iv) = 0._r8 +! fabi_sha_z(p,iv) = 0._r8 +! fsun_z(p,iv) = 0._r8 +! end do +! end do +! +! ! Default leaf to canopy scaling coefficients, used when coszen <= 0. +! ! This is the leaf nitrogen profile integrated over the full canopy. +! ! Integrate exp(-kn*x) over x=0 to x=elai and assign to shaded canopy, +! ! because sunlit fraction is 0. Canopy scaling coefficients are set in +! ! TwoStream for coszen > 0. So kn must be set here and in TwoStream. +! +! extkn = 0.30_r8 +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! if (nlevcan == 1) then +! vcmaxcintsun(p) = 0._r8 +! vcmaxcintsha(p) = (1._r8 - exp(-extkn*elai(p))) / extkn +! if (elai(p) > 0._r8) then +! vcmaxcintsha(p) = vcmaxcintsha(p) / elai(p) +! else +! vcmaxcintsha(p) = 0._r8 +! end if +! else if (nlevcan > 1) then +! vcmaxcintsun(p) = 0._r8 +! vcmaxcintsha(p) = 0._r8 +! end if +! end do +! +! ! Calculate surface albedos and fluxes +! ! Only perform on vegetated pfts where coszen > 0 +! +! if (use_fates) then +! +! call clm_fates%wrap_canopy_radiation(bounds, nc, & +! num_vegsol, filter_vegsol, & +! coszen_patch(bounds%begp:bounds%endp), surfalb_inst) +! +! else +! +! call TwoStream (bounds, filter_vegsol, num_vegsol, & +! coszen_patch(bounds%begp:bounds%endp), & +! rho(bounds%begp:bounds%endp, :), & +! tau(bounds%begp:bounds%endp, :), & +! canopystate_inst, temperature_inst, waterdiagnosticbulk_inst, surfalb_inst) +! ! Run TwoStream again just to calculate the Snow Free (SF) albedo's +! if (use_SSRE) then +! if ( nlevcan > 1 )then +! call endrun( 'ERROR: use_ssre option was NOT developed with allowance for multi-layer canopy: '// & +! 'nlevcan can ONLY be 1 in when use_ssre is on') +! end if +! call TwoStream (bounds, filter_vegsol, num_vegsol, & +! coszen_patch(bounds%begp:bounds%endp), & +! rho(bounds%begp:bounds%endp, :), & +! tau(bounds%begp:bounds%endp, :), & +! canopystate_inst, temperature_inst, waterdiagnosticbulk_inst, surfalb_inst, & +! SFonly=.true.) +! end if +! +! endif +! +! ! Determine values for non-vegetated patches where coszen > 0 +! +! do ib = 1,numrad +! do fp = 1,num_novegsol +! p = filter_novegsol(fp) +! c = patch%column(p) +! fabd(p,ib) = 0._r8 +! fabd_sun(p,ib) = 0._r8 +! fabd_sha(p,ib) = 0._r8 +! fabi(p,ib) = 0._r8 +! fabi_sun(p,ib) = 0._r8 +! fabi_sha(p,ib) = 0._r8 +! ftdd(p,ib) = 1._r8 +! ftid(p,ib) = 0._r8 +! ftii(p,ib) = 1._r8 +! albd(p,ib) = albgrd(c,ib) +! albi(p,ib) = albgri(c,ib) +! if (use_SSRE) then +! albdSF(p,ib) = albsod(c,ib) +! albiSF(p,ib) = albsoi(c,ib) +! end if +! end do +! end do +! +! end associate +! +! end subroutine SurfaceAlbedo +! +! !----------------------------------------------------------------------- +! subroutine SoilAlbedo (bounds, & +! num_nourbanc, filter_nourbanc, & +! coszen, albsnd, albsni, & +! lakestate_inst, temperature_inst, waterstatebulk_inst, surfalb_inst) +! ! +! ! !DESCRIPTION: +! ! Determine ground surface albedo, accounting for snow +! ! +! ! !USES: +! use clm_varpar , only : numrad +! use clm_varcon , only : tfrz +! use landunit_varcon , only : istice_mec, istdlak +! use LakeCon , only : lakepuddling +! ! +! ! !ARGUMENTS: +! type(bounds_type) , intent(in) :: bounds +! integer , intent(in) :: num_nourbanc ! number of columns in non-urban points in column filter +! integer , intent(in) :: filter_nourbanc(:) ! column filter for non-urban points +! real(r8), intent(in) :: coszen( bounds%begc: ) ! cos solar zenith angle next time step [col] +! real(r8), intent(in) :: albsnd( bounds%begc: , 1: ) ! snow albedo (direct) [col, numrad] +! real(r8), intent(in) :: albsni( bounds%begc: , 1: ) ! snow albedo (diffuse) [col, numrad] +! type(temperature_type) , intent(in) :: temperature_inst +! type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst +! type(lakestate_type) , intent(in) :: lakestate_inst +! type(surfalb_type) , intent(inout) :: surfalb_inst +! ! +! ! !LOCAL VARIABLES: +! ! +! integer, parameter :: nband =numrad ! number of solar radiation waveband classes +! integer :: fc ! non-urban filter column index +! integer :: c,l ! indices +! integer :: ib ! waveband number (1=vis, 2=nir) +! real(r8) :: inc ! soil water correction factor for soil albedo +! integer :: soilcol ! soilcolor +! real(r8) :: sicefr ! Lake surface ice fraction (based on D. Mironov 2010) +! !----------------------------------------------------------------------- +! +! ! Enforce expected array sizes +! SHR_ASSERT_ALL_FL((ubound(coszen) == (/bounds%endc/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(albsnd) == (/bounds%endc, numrad/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(albsni) == (/bounds%endc, numrad/)), sourcefile, __LINE__) +! +! associate(& +! snl => col%snl , & ! Input: [integer (:) ] number of snow layers +! +! t_grnd => temperature_inst%t_grnd_col , & ! Input: [real(r8) (:) ] ground temperature (Kelvin) +! +! h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water [m3/m3] +! +! lake_icefrac => lakestate_inst%lake_icefrac_col , & ! Input: [real(r8) (:,:) ] mass fraction of lake layer that is frozen +! +! albgrd => surfalb_inst%albgrd_col , & ! Output: [real(r8) (:,:) ] ground albedo (direct) +! albgri => surfalb_inst%albgri_col , & ! Output: [real(r8) (:,:) ] ground albedo (diffuse) +! albsod => surfalb_inst%albsod_col , & ! Output: [real(r8) (:,:) ] soil albedo (direct) +! albsoi => surfalb_inst%albsoi_col & ! Output: [real(r8) (:,:) ] soil albedo (diffuse) +! ) +! +! ! Compute soil albedos +! +! do ib = 1, nband +! do fc = 1,num_nourbanc +! c = filter_nourbanc(fc) +! if (coszen(c) > 0._r8) then +! l = col%landunit(c) +! +! if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then ! soil +! inc = max(0.11_r8-0.40_r8*h2osoi_vol(c,1), 0._r8) +! soilcol = isoicol(c) +! ! changed from local variable to clm_type: +! !albsod = min(albsat(soilcol,ib)+inc, albdry(soilcol,ib)) +! !albsoi = albsod +! albsod(c,ib) = min(albsat(soilcol,ib)+inc, albdry(soilcol,ib)) +! albsoi(c,ib) = albsod(c,ib) +! else if (lun%itype(l) == istice_mec) then ! land ice +! ! changed from local variable to clm_type: +! !albsod = albice(ib) +! !albsoi = albsod +! albsod(c,ib) = albice(ib) +! albsoi(c,ib) = albsod(c,ib) +! ! unfrozen lake, wetland +! else if (t_grnd(c) > tfrz .or. (lakepuddling .and. lun%itype(l) == istdlak .and. t_grnd(c) == tfrz .and. & +! lake_icefrac(c,1) < 1._r8 .and. lake_icefrac(c,2) > 0._r8) ) then +! +! albsod(c,ib) = 0.05_r8/(max(0.001_r8,coszen(c)) + 0.15_r8) +! ! This expression is apparently from BATS according to Yongjiu Dai. +! +! ! The diffuse albedo should be an average over the whole sky of an angular-dependent direct expression. +! ! The expression above may have been derived to encompass both (e.g. Henderson-Sellers 1986), +! ! but I'll assume it applies more appropriately to the direct form for now. +! +! ! ZMS: Attn EK, currently restoring this for wetlands even though it is wrong in order to try to get +! ! bfb baseline comparison when no lakes are present. I'm assuming wetlands will be phased out anyway. +! if (lun%itype(l) == istdlak) then +! albsoi(c,ib) = 0.10_r8 +! else +! albsoi(c,ib) = albsod(c,ib) +! end if +! +! else ! frozen lake, wetland +! ! Introduce crude surface frozen fraction according to D. Mironov (2010) +! ! Attn EK: This formulation is probably just as good for "wetlands" if they are not phased out. +! ! Tenatively I'm restricting this to lakes because I haven't tested it for wetlands. But if anything +! ! the albedo should be lower when melting over frozen ground than a solid frozen lake. +! ! +! if (lun%itype(l) == istdlak .and. .not. lakepuddling .and. snl(c) == 0) then +! ! Need to reference snow layers here because t_grnd could be over snow or ice +! ! but we really want the ice surface temperature with no snow +! sicefr = 1._r8 - exp(-calb * (tfrz - t_grnd(c))/tfrz) +! albsod(c,ib) = sicefr*alblak(ib) + (1._r8-sicefr)*max(alblakwi(ib), & +! 0.05_r8/(max(0.001_r8,coszen(c)) + 0.15_r8)) +! albsoi(c,ib) = sicefr*alblak(ib) + (1._r8-sicefr)*max(alblakwi(ib), 0.10_r8) +! ! Make sure this is no less than the open water albedo above. +! ! Setting lake_melt_icealb(:) = alblak(:) in namelist reverts the melting albedo to the cold +! ! snow-free value. +! else +! albsod(c,ib) = alblak(ib) +! albsoi(c,ib) = albsod(c,ib) +! end if +! end if +! +! ! Weighting is done in SurfaceAlbedo, after the call to SNICAR_RT +! ! This had to be done, because SoilAlbedo is called before SNICAR_RT, so at +! ! this point, snow albedo is not yet known. +! end if +! end do +! end do +! +! end associate +! end subroutine SoilAlbedo +! + !----------------------------------------------------------------------- + subroutine TwoStream (bounds, & + filter_vegsol, num_vegsol, & + coszen, rho, tau, & + canopystate_inst, temperature_inst, waterdiagnosticbulk_inst, surfalb_inst, & + SFonly) + ! + ! !DESCRIPTION: + ! Two-stream fluxes for canopy radiative transfer + ! Use two-stream approximation of Dickinson (1983) Adv Geophysics + ! 25:305-353 and Sellers (1985) Int J Remote Sensing 6:1335-1372 + ! to calculate fluxes absorbed by vegetation, reflected by vegetation, + ! and transmitted through vegetation for unit incoming direct or diffuse + ! flux given an underlying surface with known albedo. + ! Calculate sunlit and shaded fluxes as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy to calculate APAR profile + ! + ! !USES: + use clm_varpar, only : numrad, nlevcan + use clm_varcon, only : omegas, tfrz, betads, betais + use clm_varctl, only : iulog + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: filter_vegsol (:) ! filter for vegetated patches with coszen>0 + integer , intent(in) :: num_vegsol ! number of vegetated patches where coszen>0 + real(r8), intent(in) :: coszen( bounds%begp: ) ! cosine solar zenith angle for next time step [pft] + real(r8), intent(in) :: rho( bounds%begp: , 1: ) ! leaf/stem refl weighted by fraction LAI and SAI [pft, numrad] + real(r8), intent(in) :: tau( bounds%begp: , 1: ) ! leaf/stem tran weighted by fraction LAI and SAI [pft, numrad] + type(canopystate_type) , intent(in) :: canopystate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(surfalb_type) , intent(inout) :: surfalb_inst + logical, optional , intent(in) :: SFonly ! If should just calculate the Snow Free albedos + ! + ! !LOCAL VARIABLES: + integer :: fp,p,c,iv ! array indices + integer :: ib ! waveband number + real(r8) :: cosz ! 0.001 <= coszen <= 1.000 + real(r8) :: asu ! single scattering albedo + real(r8) :: chil(bounds%begp:bounds%endp) ! -0.4 <= xl <= 0.6 + real(r8) :: gdir(bounds%begp:bounds%endp) ! leaf projection in solar direction (0 to 1) + real(r8) :: twostext(bounds%begp:bounds%endp)! optical depth of direct beam per unit leaf area + real(r8) :: avmu(bounds%begp:bounds%endp) ! average diffuse optical depth + real(r8) :: omega(bounds%begp:bounds%endp,numrad) ! fraction of intercepted radiation that is scattered (0 to 1) + real(r8) :: omegal ! omega for leaves + real(r8) :: betai ! upscatter parameter for diffuse radiation + real(r8) :: betail ! betai for leaves + real(r8) :: betad ! upscatter parameter for direct beam radiation + real(r8) :: betadl ! betad for leaves + real(r8) :: tmp0,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9 ! temporary + real(r8) :: p1,p2,p3,p4,s1,s2,u1,u2,u3 ! temporary + real(r8) :: b,c1,d,d1,d2,f,h,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10 ! temporary + real(r8) :: phi1,phi2,sigma ! temporary + real(r8) :: temp1 ! temporary + real(r8) :: temp0 (bounds%begp:bounds%endp) ! temporary + real(r8) :: temp2(bounds%begp:bounds%endp) ! temporary + real(r8) :: t1 ! temporary + real(r8) :: a1,a2 ! parameter for sunlit/shaded leaf radiation absorption + real(r8) :: v,dv,u,du ! temporary for flux derivatives + real(r8) :: dh2,dh3,dh5,dh6,dh7,dh8,dh9,dh10 ! temporary for flux derivatives + real(r8) :: da1,da2 ! temporary for flux derivatives + real(r8) :: d_ftid,d_ftii ! ftid, ftii derivative with respect to lai+sai + real(r8) :: d_fabd,d_fabi ! fabd, fabi derivative with respect to lai+sai + real(r8) :: d_fabd_sun,d_fabd_sha ! fabd_sun, fabd_sha derivative with respect to lai+sai + real(r8) :: d_fabi_sun,d_fabi_sha ! fabi_sun, fabi_sha derivative with respect to lai+sai + real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) + real(r8) :: extkb ! direct beam extinction coefficient + real(r8) :: extkn ! nitrogen allocation coefficient + logical :: lSFonly ! Local version of SFonly (Snow Free) flag + !----------------------------------------------------------------------- + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(coszen) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(rho) == (/bounds%endp, numrad/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(tau) == (/bounds%endp, numrad/)), sourcefile, __LINE__) + + if ( present(SFonly) )then + lSFonly = SFonly + else + lSFonly = .false. + end if + + associate(& + xl => pftcon%xl , & ! Input: ecophys const - leaf/stem orientation index + + t_veg => temperature_inst%t_veg_patch , & ! Input: [real(r8) (:) ] vegetation temperature (Kelvin) + + fwet => waterdiagnosticbulk_inst%fwet_patch , & ! Input: [real(r8) (:) ] fraction of canopy that is wet (0 to 1) + fcansno => waterdiagnosticbulk_inst%fcansno_patch , & ! Input: [real(r8) (:) ] fraction of canopy that is snow-covered (0 to 1) + + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow + + tlai_z => surfalb_inst%tlai_z_patch , & ! Input: [real(r8) (:,:) ] tlai increment for canopy layer + tsai_z => surfalb_inst%tsai_z_patch , & ! Input: [real(r8) (:,:) ] tsai increment for canopy layer + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] number of canopy layers, above snow for radiative transfer + albgrd => surfalb_inst%albgrd_col , & ! Input: [real(r8) (:,:) ] ground albedo (direct) (column-level) + albgri => surfalb_inst%albgri_col , & ! Input: [real(r8) (:,:) ] ground albedo (diffuse)(column-level) + + ! For non-Snow Free + fsun_z => surfalb_inst%fsun_z_patch , & ! Output: [real(r8) (:,:) ] sunlit fraction of canopy layer + vcmaxcintsun => surfalb_inst%vcmaxcintsun_patch , & ! Output: [real(r8) (:) ] leaf to canopy scaling coefficient, sunlit leaf vcmax + vcmaxcintsha => surfalb_inst%vcmaxcintsha_patch , & ! Output: [real(r8) (:) ] leaf to canopy scaling coefficient, shaded leaf vcmax + fabd_sun_z => surfalb_inst%fabd_sun_z_patch , & ! Output: [real(r8) (:,:) ] absorbed sunlit leaf direct PAR (per unit lai+sai) for each canopy layer + fabd_sha_z => surfalb_inst%fabd_sha_z_patch , & ! Output: [real(r8) (:,:) ] absorbed shaded leaf direct PAR (per unit lai+sai) for each canopy layer + fabi_sun_z => surfalb_inst%fabi_sun_z_patch , & ! Output: [real(r8) (:,:) ] absorbed sunlit leaf diffuse PAR (per unit lai+sai) for each canopy layer + fabi_sha_z => surfalb_inst%fabi_sha_z_patch , & ! Output: [real(r8) (:,:) ] absorbed shaded leaf diffuse PAR (per unit lai+sai) for each canopy layer + albd => surfalb_inst%albd_patch , & ! Output: [real(r8) (:,:) ] surface albedo (direct) + albi => surfalb_inst%albi_patch , & ! Output: [real(r8) (:,:) ] surface albedo (diffuse) + fabd => surfalb_inst%fabd_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit direct flux + fabd_sun => surfalb_inst%fabd_sun_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit direct flux + fabd_sha => surfalb_inst%fabd_sha_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit direct flux + fabi => surfalb_inst%fabi_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit diffuse flux + fabi_sun => surfalb_inst%fabi_sun_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit diffuse flux + fabi_sha => surfalb_inst%fabi_sha_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit diffuse flux + ftdd => surfalb_inst%ftdd_patch , & ! Output: [real(r8) (:,:) ] down direct flux below canopy per unit direct flx + ftid => surfalb_inst%ftid_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit direct flx + ftii => surfalb_inst%ftii_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit diffuse flx + + ! Needed for SF Snow free case + albsod => surfalb_inst%albsod_col , & ! Input: [real(r8) (:,:) ] soil albedo (direct) + albsoi => surfalb_inst%albsoi_col , & ! Input: [real(r8) (:,:) ] soil albedo (diffuse) + albdSF => surfalb_inst%albdSF_patch , & ! Output: [real(r8) (:,:) ] Snow Free surface albedo (direct) + albiSF => surfalb_inst%albiSF_patch & ! Output: [real(r8) (:,:) ] Snow Free surface albedo (diffuse) + ) + + ! Calculate two-stream parameters that are independent of waveband: + ! chil, gdir, twostext, avmu, and temp0 and temp2 (used for asu) + + do fp = 1,num_vegsol + p = filter_vegsol(fp) + + ! note that the following limit only acts on cosz values > 0 and less than + ! 0.001, not on values cosz = 0, since these zero have already been filtered + ! out in filter_vegsol + cosz = max(0.001_r8, coszen(p)) + + chil(p) = min( max(xl(patch%itype(p)), -0.4_r8), 0.6_r8 ) + if (abs(chil(p)) <= 0.01_r8) chil(p) = 0.01_r8 + phi1 = 0.5_r8 - 0.633_r8*chil(p) - 0.330_r8*chil(p)*chil(p) + phi2 = 0.877_r8 * (1._r8-2._r8*phi1) + gdir(p) = phi1 + phi2*cosz + twostext(p) = gdir(p)/cosz + avmu(p) = ( 1._r8 - phi1/phi2 * log((phi1+phi2)/phi1) ) / phi2 + ! Restrict this calculation of temp0. We have seen cases where small temp0 + ! can cause unrealistic single scattering albedo (asu) associated with the + ! log calculation in temp2 below, thereby eventually causing a negative soil albedo + ! See bugzilla bug 2431: http://bugs.cgd.ucar.edu/show_bug.cgi?id=2431 + temp0(p) = max(gdir(p) + phi2*cosz,1.e-6_r8) + temp1 = phi1*cosz + temp2(p) = ( 1._r8 - temp1/temp0(p) * log((temp1+temp0(p))/temp1) ) + end do + + ! Loop over all wavebands to calculate for the full canopy the scattered fluxes + ! reflected upward and transmitted downward by the canopy and the flux absorbed by the + ! canopy for a unit incoming direct beam and diffuse flux at the top of the canopy given + ! an underlying surface of known albedo. + ! + ! Output: + ! ------------------ + ! Direct beam fluxes + ! ------------------ + ! albd - Upward scattered flux above canopy (per unit direct beam flux) + ! ftid - Downward scattered flux below canopy (per unit direct beam flux) + ! ftdd - Transmitted direct beam flux below canopy (per unit direct beam flux) + ! fabd - Flux absorbed by canopy (per unit direct beam flux) + ! fabd_sun - Sunlit portion of fabd + ! fabd_sha - Shaded portion of fabd + ! fabd_sun_z - absorbed sunlit leaf direct PAR (per unit sunlit lai+sai) for each canopy layer + ! fabd_sha_z - absorbed shaded leaf direct PAR (per unit shaded lai+sai) for each canopy layer + ! ------------------ + ! Diffuse fluxes + ! ------------------ + ! albi - Upward scattered flux above canopy (per unit diffuse flux) + ! ftii - Downward scattered flux below canopy (per unit diffuse flux) + ! fabi - Flux absorbed by canopy (per unit diffuse flux) + ! fabi_sun - Sunlit portion of fabi + ! fabi_sha - Shaded portion of fabi + ! fabi_sun_z - absorbed sunlit leaf diffuse PAR (per unit sunlit lai+sai) for each canopy layer + ! fabi_sha_z - absorbed shaded leaf diffuse PAR (per unit shaded lai+sai) for each canopy layer + + do ib = 1, numrad + do fp = 1,num_vegsol + p = filter_vegsol(fp) + c = patch%column(p) + + ! Calculate two-stream parameters omega, betad, and betai. + ! Omega, betad, betai are adjusted for snow. Values for omega*betad + ! and omega*betai are calculated and then divided by the new omega + ! because the product omega*betai, omega*betad is used in solution. + ! Also, the transmittances and reflectances (tau, rho) are linear + ! weights of leaf and stem values. + + omegal = rho(p,ib) + tau(p,ib) + asu = 0.5_r8*omegal*gdir(p)/temp0(p) *temp2(p) + betadl = (1._r8+avmu(p)*twostext(p))/(omegal*avmu(p)*twostext(p))*asu + betail = 0.5_r8 * ((rho(p,ib)+tau(p,ib)) + (rho(p,ib)-tau(p,ib)) & + * ((1._r8+chil(p))/2._r8)**2) / omegal + + if ( lSFonly .or. ( (.not. snowveg_affects_radiation) .and. (t_veg(p) > tfrz) ) ) then + ! Keep omega, betad, and betai as they are (for Snow free case or + ! when there is no snow + tmp0 = omegal + tmp1 = betadl + tmp2 = betail + else + ! Adjust omega, betad, and betai for intercepted snow + if (snowveg_affects_radiation) then + tmp0 = (1._r8-fcansno(p))*omegal + fcansno(p)*omegas(ib) + tmp1 = ( (1._r8-fcansno(p))*omegal*betadl + fcansno(p)*omegas(ib)*betads ) / tmp0 + tmp2 = ( (1._r8-fcansno(p))*omegal*betail + fcansno(p)*omegas(ib)*betais ) / tmp0 + else + tmp0 = (1._r8-fwet(p))*omegal + fwet(p)*omegas(ib) + tmp1 = ( (1._r8-fwet(p))*omegal*betadl + fwet(p)*omegas(ib)*betads ) / tmp0 + tmp2 = ( (1._r8-fwet(p))*omegal*betail + fwet(p)*omegas(ib)*betais ) / tmp0 + end if + end if ! end Snow free + + omega(p,ib) = tmp0 + betad = tmp1 + betai = tmp2 + + ! Common terms + + b = 1._r8 - omega(p,ib) + omega(p,ib)*betai + c1 = omega(p,ib)*betai + tmp0 = avmu(p)*twostext(p) + d = tmp0 * omega(p,ib)*betad + f = tmp0 * omega(p,ib)*(1._r8-betad) + tmp1 = b*b - c1*c1 + h = sqrt(tmp1) / avmu(p) + sigma = tmp0*tmp0 - tmp1 + p1 = b + avmu(p)*h + p2 = b - avmu(p)*h + p3 = b + tmp0 + p4 = b - tmp0 + + ! Absorbed, reflected, transmitted fluxes per unit incoming radiation + ! for full canopy + + t1 = min(h*(elai(p)+esai(p)), 40._r8) + s1 = exp(-t1) + t1 = min(twostext(p)*(elai(p)+esai(p)), 40._r8) + s2 = exp(-t1) + + ! Direct beam + if ( .not. lSFonly )then + u1 = b - c1/albgrd(c,ib) + u2 = b - c1*albgrd(c,ib) + u3 = f + c1*albgrd(c,ib) + else + ! Snow Free (SF) only + ! albsod instead of albgrd here: + u1 = b - c1/albsod(c,ib) + u2 = b - c1*albsod(c,ib) + u3 = f + c1*albsod(c,ib) + end if + tmp2 = u1 - avmu(p)*h + tmp3 = u1 + avmu(p)*h + d1 = p1*tmp2/s1 - p2*tmp3*s1 + tmp4 = u2 + avmu(p)*h + tmp5 = u2 - avmu(p)*h + d2 = tmp4/s1 - tmp5*s1 + h1 = -d*p4 - c1*f + tmp6 = d - h1*p3/sigma + tmp7 = ( d - c1 - h1/sigma*(u1+tmp0) ) * s2 + h2 = ( tmp6*tmp2/s1 - p2*tmp7 ) / d1 + h3 = - ( tmp6*tmp3*s1 - p1*tmp7 ) / d1 + h4 = -f*p3 - c1*d + tmp8 = h4/sigma + tmp9 = ( u3 - tmp8*(u2-tmp0) ) * s2 + h5 = - ( tmp8*tmp4/s1 + tmp9 ) / d2 + h6 = ( tmp8*tmp5*s1 + tmp9 ) / d2 + if ( .not. lSFonly )then + albd(p,ib) = h1/sigma + h2 + h3 + ftid(p,ib) = h4*s2/sigma + h5*s1 + h6/s1 + ftdd(p,ib) = s2 + fabd(p,ib) = 1._r8 - albd(p,ib) - (1._r8-albgrd(c,ib))*ftdd(p,ib) - (1._r8-albgri(c,ib))*ftid(p,ib) + else + albdSF(p,ib) = h1/sigma + h2 + h3 + end if + + + a1 = h1 / sigma * (1._r8 - s2*s2) / (2._r8 * twostext(p)) & + + h2 * (1._r8 - s2*s1) / (twostext(p) + h) & + + h3 * (1._r8 - s2/s1) / (twostext(p) - h) + + a2 = h4 / sigma * (1._r8 - s2*s2) / (2._r8 * twostext(p)) & + + h5 * (1._r8 - s2*s1) / (twostext(p) + h) & + + h6 * (1._r8 - s2/s1) / (twostext(p) - h) + if ( .not. lSFonly )then + fabd_sun(p,ib) = (1._r8 - omega(p,ib)) * ( 1._r8 - s2 + 1._r8 / avmu(p) * (a1 + a2) ) + fabd_sha(p,ib) = fabd(p,ib) - fabd_sun(p,ib) + end if + + ! Diffuse + if ( .not. lSFonly )then + u1 = b - c1/albgri(c,ib) + u2 = b - c1*albgri(c,ib) + else + ! Snow Free (SF) only + ! albsoi instead of albgri here: + u1 = b - c1/albsoi(c,ib) + u2 = b - c1*albsoi(c,ib) + end if + tmp2 = u1 - avmu(p)*h + tmp3 = u1 + avmu(p)*h + d1 = p1*tmp2/s1 - p2*tmp3*s1 + tmp4 = u2 + avmu(p)*h + tmp5 = u2 - avmu(p)*h + d2 = tmp4/s1 - tmp5*s1 + h7 = (c1*tmp2) / (d1*s1) + h8 = (-c1*tmp3*s1) / d1 + h9 = tmp4 / (d2*s1) + h10 = (-tmp5*s1) / d2 + + + ! Final Snow Free albedo + if ( lSFonly )then + albiSF(p,ib) = h7 + h8 + else + ! For non snow Free case, adjustments continue + albi(p,ib) = h7 + h8 + ftii(p,ib) = h9*s1 + h10/s1 + fabi(p,ib) = 1._r8 - albi(p,ib) - (1._r8-albgri(c,ib))*ftii(p,ib) + + a1 = h7 * (1._r8 - s2*s1) / (twostext(p) + h) + h8 * (1._r8 - s2/s1) / (twostext(p) - h) + a2 = h9 * (1._r8 - s2*s1) / (twostext(p) + h) + h10 * (1._r8 - s2/s1) / (twostext(p) - h) + + fabi_sun(p,ib) = (1._r8 - omega(p,ib)) / avmu(p) * (a1 + a2) + fabi_sha(p,ib) = fabi(p,ib) - fabi_sun(p,ib) + + ! Repeat two-stream calculations for each canopy layer to calculate derivatives. + ! tlai_z and tsai_z are the leaf+stem area increment for a layer. Derivatives are + ! calculated at the center of the layer. Derivatives are needed only for the + ! visible waveband to calculate absorbed PAR (per unit lai+sai) for each canopy layer. + ! Derivatives are calculated first per unit lai+sai and then normalized for sunlit + ! or shaded fraction of canopy layer. + + ! Sun/shade big leaf code uses only one layer, with canopy integrated values from above + ! and also canopy-integrated scaling coefficients + + if (ib == 1) then + if (nlevcan == 1) then + + ! sunlit fraction of canopy + fsun_z(p,1) = (1._r8 - s2) / t1 + + ! absorbed PAR (per unit sun/shade lai+sai) + laisum = elai(p)+esai(p) + fabd_sun_z(p,1) = fabd_sun(p,ib) / (fsun_z(p,1)*laisum) + fabi_sun_z(p,1) = fabi_sun(p,ib) / (fsun_z(p,1)*laisum) + fabd_sha_z(p,1) = fabd_sha(p,ib) / ((1._r8 - fsun_z(p,1))*laisum) + fabi_sha_z(p,1) = fabi_sha(p,ib) / ((1._r8 - fsun_z(p,1))*laisum) + + ! leaf to canopy scaling coefficients + extkn = 0.30_r8 + extkb = twostext(p) + vcmaxcintsun(p) = (1._r8 - exp(-(extkn+extkb)*elai(p))) / (extkn + extkb) + vcmaxcintsha(p) = (1._r8 - exp(-extkn*elai(p))) / extkn - vcmaxcintsun(p) + if (elai(p) > 0._r8) then + vcmaxcintsun(p) = vcmaxcintsun(p) / (fsun_z(p,1)*elai(p)) + vcmaxcintsha(p) = vcmaxcintsha(p) / ((1._r8 - fsun_z(p,1))*elai(p)) + else + vcmaxcintsun(p) = 0._r8 + vcmaxcintsha(p) = 0._r8 + end if + + else if (nlevcan > 1)then + do iv = 1, nrad(p) + + ! Cumulative lai+sai at center of layer + + if (iv == 1) then + laisum = 0.5_r8 * (tlai_z(p,iv)+tsai_z(p,iv)) + else + laisum = laisum + 0.5_r8 * ((tlai_z(p,iv-1)+tsai_z(p,iv-1))+(tlai_z(p,iv)+tsai_z(p,iv))) + end if + + ! Coefficients s1 and s2 depend on cumulative lai+sai. s2 is the sunlit fraction + + t1 = min(h*laisum, 40._r8) + s1 = exp(-t1) + t1 = min(twostext(p)*laisum, 40._r8) + s2 = exp(-t1) + fsun_z(p,iv) = s2 + + ! =============== + ! Direct beam + ! =============== + + ! Coefficients h1-h6 and a1,a2 depend of cumulative lai+sai + + u1 = b - c1/albgrd(c,ib) + u2 = b - c1*albgrd(c,ib) + u3 = f + c1*albgrd(c,ib) + + ! Derivatives for h2, h3, h5, h6 and a1, a2 + + v = d1 + dv = h * p1 * tmp2 / s1 + h * p2 * tmp3 * s1 + + u = tmp6 * tmp2 / s1 - p2 * tmp7 + du = h * tmp6 * tmp2 / s1 + twostext(p) * p2 * tmp7 + dh2 = (v * du - u * dv) / (v * v) + + u = -tmp6 * tmp3 * s1 + p1 * tmp7 + du = h * tmp6 * tmp3 * s1 - twostext(p) * p1 * tmp7 + dh3 = (v * du - u * dv) / (v * v) + + v = d2 + dv = h * tmp4 / s1 + h * tmp5 * s1 + + u = -h4/sigma * tmp4 / s1 - tmp9 + du = -h * h4/sigma * tmp4 / s1 + twostext(p) * tmp9 + dh5 = (v * du - u * dv) / (v * v) + + u = h4/sigma * tmp5 * s1 + tmp9 + du = -h * h4/sigma * tmp5 * s1 - twostext(p) * tmp9 + dh6 = (v * du - u * dv) / (v * v) + + da1 = h1/sigma * s2*s2 + h2 * s2*s1 + h3 * s2/s1 & + + (1._r8 - s2*s1) / (twostext(p) + h) * dh2 & + + (1._r8 - s2/s1) / (twostext(p) - h) * dh3 + da2 = h4/sigma * s2*s2 + h5 * s2*s1 + h6 * s2/s1 & + + (1._r8 - s2*s1) / (twostext(p) + h) * dh5 & + + (1._r8 - s2/s1) / (twostext(p) - h) * dh6 + + ! Flux derivatives + + d_ftid = -twostext(p)*h4/sigma*s2 - h*h5*s1 + h*h6/s1 + dh5*s1 + dh6/s1 + d_fabd = -(dh2+dh3) + (1._r8-albgrd(c,ib))*twostext(p)*s2 - (1._r8-albgri(c,ib))*d_ftid + d_fabd_sun = (1._r8 - omega(p,ib)) * (twostext(p)*s2 + 1._r8 / avmu(p) * (da1 + da2)) + d_fabd_sha = d_fabd - d_fabd_sun + + fabd_sun_z(p,iv) = max(d_fabd_sun, 0._r8) + fabd_sha_z(p,iv) = max(d_fabd_sha, 0._r8) + + ! Flux derivatives are APARsun and APARsha per unit (LAI+SAI). Need + ! to normalize derivatives by sunlit or shaded fraction to get + ! APARsun per unit (LAI+SAI)sun and APARsha per unit (LAI+SAI)sha + + fabd_sun_z(p,iv) = fabd_sun_z(p,iv) / fsun_z(p,iv) + fabd_sha_z(p,iv) = fabd_sha_z(p,iv) / (1._r8 - fsun_z(p,iv)) + + ! =============== + ! Diffuse + ! =============== + + ! Coefficients h7-h10 and a1,a2 depend of cumulative lai+sai + + u1 = b - c1/albgri(c,ib) + u2 = b - c1*albgri(c,ib) + + a1 = h7 * (1._r8 - s2*s1) / (twostext(p) + h) + h8 * (1._r8 - s2/s1) / (twostext(p) - h) + a2 = h9 * (1._r8 - s2*s1) / (twostext(p) + h) + h10 * (1._r8 - s2/s1) / (twostext(p) - h) + + ! Derivatives for h7, h8, h9, h10 and a1, a2 + + v = d1 + dv = h * p1 * tmp2 / s1 + h * p2 * tmp3 * s1 + + u = c1 * tmp2 / s1 + du = h * c1 * tmp2 / s1 + dh7 = (v * du - u * dv) / (v * v) + + u = -c1 * tmp3 * s1 + du = h * c1 * tmp3 * s1 + dh8 = (v * du - u * dv) / (v * v) + + v = d2 + dv = h * tmp4 / s1 + h * tmp5 * s1 + + u = tmp4 / s1 + du = h * tmp4 / s1 + dh9 = (v * du - u * dv) / (v * v) + + u = -tmp5 * s1 + du = h * tmp5 * s1 + dh10 = (v * du - u * dv) / (v * v) + + da1 = h7*s2*s1 + h8*s2/s1 + (1._r8-s2*s1)/(twostext(p)+h)*dh7 + (1._r8-s2/s1)/(twostext(p)-h)*dh8 + da2 = h9*s2*s1 + h10*s2/s1 + (1._r8-s2*s1)/(twostext(p)+h)*dh9 + (1._r8-s2/s1)/(twostext(p)-h)*dh10 + + ! Flux derivatives + + d_ftii = -h * h9 * s1 + h * h10 / s1 + dh9 * s1 + dh10 / s1 + d_fabi = -(dh7+dh8) - (1._r8-albgri(c,ib))*d_ftii + d_fabi_sun = (1._r8 - omega(p,ib)) / avmu(p) * (da1 + da2) + d_fabi_sha = d_fabi - d_fabi_sun + + fabi_sun_z(p,iv) = max(d_fabi_sun, 0._r8) + fabi_sha_z(p,iv) = max(d_fabi_sha, 0._r8) + + ! Flux derivatives are APARsun and APARsha per unit (LAI+SAI). Need + ! to normalize derivatives by sunlit or shaded fraction to get + ! APARsun per unit (LAI+SAI)sun and APARsha per unit (LAI+SAI)sha + + fabi_sun_z(p,iv) = fabi_sun_z(p,iv) / fsun_z(p,iv) + fabi_sha_z(p,iv) = fabi_sha_z(p,iv) / (1._r8 - fsun_z(p,iv)) + + end do ! end of iv loop + end if ! nlevcan + end if ! first band + end if ! NOT lSFonly + + end do ! end of pft loop + end do ! end of radiation band loop + + end associate + +end subroutine TwoStream + +end module SurfaceAlbedoMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceRadiationMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceRadiationMod.F90 new file mode 100755 index 000000000..333636e7e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceRadiationMod.F90 @@ -0,0 +1,1026 @@ +module SurfaceRadiationMod + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Calculate solar fluxes absorbed by vegetation and ground surface + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : use_snicar_frc, use_fates + use decompMod , only : bounds_type + use clm_varcon , only : namec + use atm2lndType , only : atm2lnd_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use CanopyStateType , only : canopystate_type + use SurfaceAlbedoType , only : surfalb_type + use SolarAbsorbedType , only : solarabs_type + use GridcellType , only : grc + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use landunit_varcon , only : istdlak + use nanMod , only : nan + + ! !PRIVATE TYPES: + implicit none + private + + logical, parameter :: local_debug = .false. ! for debugging this module + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: SurfaceRadiation ! Solar fluxes absorbed by veg and ground surface + public :: CanopySunShadeFracs ! Sun/Shade fractions and some area indices computations + + ! + ! !PRIVATE DATA: + type, public :: surfrad_type + real(r8), pointer, private :: sfc_frc_aer_patch (:) ! patch surface forcing of snow with all aerosols (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_bc_patch (:) ! patch surface forcing of snow with BC (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_oc_patch (:) ! patch surface forcing of snow with OC (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_dst_patch (:) ! patch surface forcing of snow with dust (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_aer_sno_patch (:) ! patch surface forcing of snow with all aerosols, averaged only when snow is present (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_bc_sno_patch (:) ! patch surface forcing of snow with BC, averaged only when snow is present (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_oc_sno_patch (:) ! patch surface forcing of snow with OC, averaged only when snow is present (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_dst_sno_patch (:) ! patch surface forcing of snow with dust, averaged only when snow is present (patch) [W/m2] + + real(r8), pointer, private :: parveg_ln_patch (:) ! patch absorbed par by vegetation at local noon (W/m**2) + + real(r8), pointer, private :: fsr_sno_vd_patch (:) ! patch reflected direct beam vis solar radiation from snow (W/m**2) + real(r8), pointer, private :: fsr_sno_nd_patch (:) ! patch reflected direct beam NIR solar radiation from snow (W/m**2) + real(r8), pointer, private :: fsr_sno_vi_patch (:) ! patch reflected diffuse vis solar radiation from snow (W/m**2) + real(r8), pointer, private :: fsr_sno_ni_patch (:) ! patch reflected diffuse NIR solar radiation from snow (W/m**2) + + real(r8), pointer, private :: fsr_vis_d_patch (:) ! patch reflected direct beam vis solar radiation (W/m**2) + real(r8), pointer, private :: fsr_vis_i_patch (:) ! patch reflected diffuse vis solar radiation (W/m**2) + real(r8), pointer, private :: fsr_vis_d_ln_patch (:) ! patch reflected direct beam vis solar radiation at local noon (W/m**2) + ! diagnostic fluxes: + real(r8), pointer, private :: fsrSF_vis_d_patch (:) ! snow-free patch reflected direct beam vis solar radiation (W/m**2) + real(r8), pointer, private :: fsrSF_vis_i_patch (:) ! snow-free patch reflected diffuse vis solar radiation (W/m**2) + real(r8), pointer, private :: fsrSF_vis_d_ln_patch (:) ! snow-free patch reflected direct beam vis solar radiation at local noon (W/m**2) + real(r8), pointer, private :: ssre_fsr_vis_d_patch (:) ! snow radiative effect + real(r8), pointer, private :: ssre_fsr_vis_i_patch (:) ! snow radiative effect + real(r8), pointer, private :: ssre_fsr_vis_d_ln_patch(:)! snow radiative effect + real(r8), pointer, private :: fsds_sno_vd_patch (:) ! patch incident visible, direct radiation on snow (for history files) [W/m2] + real(r8), pointer, private :: fsds_sno_nd_patch (:) ! patch incident near-IR, direct radiation on snow (for history files) [W/m2] + real(r8), pointer, private :: fsds_sno_vi_patch (:) ! patch incident visible, diffuse radiation on snow (for history files) [W/m2] + real(r8), pointer, private :: fsds_sno_ni_patch (:) ! patch incident near-IR, diffuse radiation on snow (for history files) [W/m2] + + real(r8), pointer, private :: fsds_vis_d_patch (:) ! patch incident direct beam vis solar radiation (W/m**2) + real(r8), pointer, private :: fsds_vis_i_patch (:) ! patch incident diffuse vis solar radiation (W/m**2) + real(r8), pointer, private :: fsds_vis_d_ln_patch (:) ! patch incident direct beam vis solar radiation at local noon (W/m**2) + real(r8), pointer, private :: fsds_vis_i_ln_patch (:) ! patch incident diffuse beam vis solar radiation at local noon (W/m**2) + + contains + + procedure, public :: Init + procedure, private :: InitAllocate + ! procedure, private :: InitHistory + ! procedure, private :: InitCold + + end type surfrad_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(surfrad_type) :: this + type(bounds_type), intent(in) :: bounds + + call this%InitAllocate(bounds) + ! call this%InitHistory(bounds) + ! call this%InitCold(bounds) + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! + ! !USES: + ! use shr_infnan_mod, only : nan => shr_infnan_nan + ! + ! !ARGUMENTS: + class(surfrad_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + allocate(this%sfc_frc_aer_patch (begp:endp)) ; this%sfc_frc_aer_patch (:) = nan + allocate(this%sfc_frc_bc_patch (begp:endp)) ; this%sfc_frc_bc_patch (:) = nan + allocate(this%sfc_frc_oc_patch (begp:endp)) ; this%sfc_frc_oc_patch (:) = nan + allocate(this%sfc_frc_dst_patch (begp:endp)) ; this%sfc_frc_dst_patch (:) = nan + allocate(this%sfc_frc_aer_sno_patch (begp:endp)) ; this%sfc_frc_aer_sno_patch (:) = nan + allocate(this%sfc_frc_bc_sno_patch (begp:endp)) ; this%sfc_frc_bc_sno_patch (:) = nan + allocate(this%sfc_frc_oc_sno_patch (begp:endp)) ; this%sfc_frc_oc_sno_patch (:) = nan + allocate(this%sfc_frc_dst_sno_patch (begp:endp)) ; this%sfc_frc_dst_sno_patch (:) = nan + + allocate(this%parveg_ln_patch (begp:endp)) ; this%parveg_ln_patch (:) = nan + + allocate(this%fsr_vis_d_patch (begp:endp)) ; this%fsr_vis_d_patch (:) = nan + allocate(this%fsr_vis_d_ln_patch (begp:endp)) ; this%fsr_vis_d_ln_patch (:) = nan + allocate(this%fsr_vis_i_patch (begp:endp)) ; this%fsr_vis_i_patch (:) = nan + allocate(this%fsrSF_vis_d_patch (begp:endp)) ; this%fsrSF_vis_d_patch (:) = nan + allocate(this%fsrSF_vis_d_ln_patch (begp:endp)) ; this%fsrSF_vis_d_ln_patch (:) = nan + allocate(this%fsrSF_vis_i_patch (begp:endp)) ; this%fsrSF_vis_i_patch (:) = nan + allocate(this%ssre_fsr_vis_d_patch (begp:endp)) ; this%ssre_fsr_vis_d_patch (:) = nan + allocate(this%ssre_fsr_vis_d_ln_patch(begp:endp)) ; this%ssre_fsr_vis_d_ln_patch(:) = nan + allocate(this%ssre_fsr_vis_i_patch (begp:endp)) ; this%ssre_fsr_vis_i_patch (:) = nan + allocate(this%fsr_sno_vd_patch (begp:endp)) ; this%fsr_sno_vd_patch (:) = nan + allocate(this%fsr_sno_nd_patch (begp:endp)) ; this%fsr_sno_nd_patch (:) = nan + allocate(this%fsr_sno_vi_patch (begp:endp)) ; this%fsr_sno_vi_patch (:) = nan + allocate(this%fsr_sno_ni_patch (begp:endp)) ; this%fsr_sno_ni_patch (:) = nan + + allocate(this%fsds_vis_d_patch (begp:endp)) ; this%fsds_vis_d_patch (:) = nan + allocate(this%fsds_vis_i_patch (begp:endp)) ; this%fsds_vis_i_patch (:) = nan + allocate(this%fsds_vis_d_ln_patch (begp:endp)) ; this%fsds_vis_d_ln_patch (:) = nan + allocate(this%fsds_vis_i_ln_patch (begp:endp)) ; this%fsds_vis_i_ln_patch (:) = nan + allocate(this%fsds_sno_vd_patch (begp:endp)) ; this%fsds_sno_vd_patch (:) = nan + allocate(this%fsds_sno_nd_patch (begp:endp)) ; this%fsds_sno_nd_patch (:) = nan + allocate(this%fsds_sno_vi_patch (begp:endp)) ; this%fsds_sno_vi_patch (:) = nan + allocate(this%fsds_sno_ni_patch (begp:endp)) ; this%fsds_sno_ni_patch (:) = nan + + end subroutine InitAllocate + + !----------------------------------------------------------------------- +! subroutine InitHistory(this, bounds) +! ! +! ! History fields initialization +! ! +! ! !USES: +! use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) +! use clm_varcon , only : spval +! use histFileMod , only : hist_addfld1d, hist_addfld2d +! use clm_varctl , only : use_SSRE +! ! +! ! !ARGUMENTS: +! class(surfrad_type) :: this +! type(bounds_type), intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! integer :: begp, endp +! integer :: begc, endc +! real(r8), pointer :: data2dptr(:,:) ! temp. pointers for slicing larger arrays +! !--------------------------------------------------------------------- +! +! begp = bounds%begp; endp = bounds%endp +! begc = bounds%begc; endc = bounds%endc +! +! if (use_snicar_frc) then +! this%sfc_frc_aer_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOAERFRCL', units='W/m^2', & +! avgflag='A', long_name='surface forcing of all aerosols in snow (land) ', & +! ptr_patch=this%sfc_frc_aer_patch, set_urb=spval) +! +! this%sfc_frc_aer_sno_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOAERFRC2L', units='W/m^2', & +! avgflag='A', long_name='surface forcing of all aerosols in snow, averaged only when snow is present (land)', & +! ptr_patch=this%sfc_frc_aer_sno_patch, set_urb=spval) +! +! this%sfc_frc_bc_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOBCFRCL', units='W/m^2', & +! avgflag='A', long_name='surface forcing of BC in snow (land) ', & +! ptr_patch=this%sfc_frc_bc_patch, set_urb=spval) +! +! this%sfc_frc_bc_sno_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOBCFRC2L', units='W/m^2', & +! avgflag='A', long_name='surface forcing of BC in snow, averaged only when snow is present (land)', & +! ptr_patch=this%sfc_frc_bc_sno_patch, set_urb=spval) +! +! this%sfc_frc_oc_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOOCFRCL', units='W/m^2', & +! avgflag='A', long_name='surface forcing of OC in snow (land) ', & +! ptr_patch=this%sfc_frc_oc_patch, set_urb=spval) +! +! this%sfc_frc_oc_sno_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOOCFRC2L', units='W/m^2', & +! avgflag='A', long_name='surface forcing of OC in snow, averaged only when snow is present (land)', & +! ptr_patch=this%sfc_frc_oc_sno_patch, set_urb=spval) +! +! this%sfc_frc_dst_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNODSTFRCL', units='W/m^2', & +! avgflag='A', long_name='surface forcing of dust in snow (land) ', & +! ptr_patch=this%sfc_frc_dst_patch, set_urb=spval) +! +! this%sfc_frc_dst_sno_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNODSTFRC2L', units='W/m^2', & +! avgflag='A', long_name='surface forcing of dust in snow, averaged only when snow is present (land)', & +! ptr_patch=this%sfc_frc_dst_sno_patch, set_urb=spval) +! end if +! +! this%fsds_vis_d_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSDSVD', units='W/m^2', & +! avgflag='A', long_name='direct vis incident solar radiation', & +! ptr_patch=this%fsds_vis_d_patch) +! +! this%fsds_vis_i_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSDSVI', units='W/m^2', & +! avgflag='A', long_name='diffuse vis incident solar radiation', & +! ptr_patch=this%fsds_vis_i_patch) +! +! this%fsr_vis_d_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSRVD', units='W/m^2', & +! avgflag='A', long_name='direct vis reflected solar radiation', & +! ptr_patch=this%fsr_vis_d_patch, c2l_scale_type='urbanf') +! this%fsr_vis_i_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSRVI', units='W/m^2', & +! avgflag='A', long_name='diffuse vis reflected solar radiation', & +! ptr_patch=this%fsr_vis_i_patch, c2l_scale_type='urbanf') +! ! diagnostic fluxes +! if (use_SSRE) then +! this%fsrSF_vis_d_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSRSFVD', units='W/m^2', & +! avgflag='A', long_name='direct vis reflected solar radiation', & +! ptr_patch=this%fsrSF_vis_d_patch, c2l_scale_type='urbanf') +! this%fsrSF_vis_i_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSRSFVI', units='W/m^2', & +! avgflag='A', long_name='diffuse vis reflected solar radiation', & +! ptr_patch=this%fsrSF_vis_i_patch, c2l_scale_type='urbanf') +! +! this%ssre_fsr_vis_d_patch(begp:endp) = spval +! call hist_addfld1d (fname='SSRE_FSRVD', units='W/m^2', & +! avgflag='A', long_name='surface snow radiatve effect on direct vis reflected solar radiation', & +! ptr_patch=this%ssre_fsr_vis_d_patch, c2l_scale_type='urbanf') +! this%ssre_fsr_vis_i_patch(begp:endp) = spval +! call hist_addfld1d (fname='SSRE_FSRVI', units='W/m^2', & +! avgflag='A', long_name='surface snow radiatve effect on diffuse vis reflected solar radiation', & +! ptr_patch=this%ssre_fsr_vis_i_patch, c2l_scale_type='urbanf') +! end if +! this%fsds_vis_d_ln_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSDSVDLN', units='W/m^2', & +! avgflag='A', long_name='direct vis incident solar radiation at local noon', & +! ptr_patch=this%fsds_vis_d_ln_patch) +! +! this%fsds_vis_i_ln_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSDSVILN', units='W/m^2', & +! avgflag='A', long_name='diffuse vis incident solar radiation at local noon', & +! ptr_patch=this%fsds_vis_i_ln_patch) +! +! this%parveg_ln_patch(begp:endp) = spval +! call hist_addfld1d (fname='PARVEGLN', units='W/m^2', & +! avgflag='A', long_name='absorbed par by vegetation at local noon', & +! ptr_patch=this%parveg_ln_patch) +! +! this%fsr_vis_d_ln_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSRVDLN', units='W/m^2', & +! avgflag='A', long_name='direct vis reflected solar radiation at local noon', & +! ptr_patch=this%fsr_vis_d_ln_patch, c2l_scale_type='urbanf') +! ! diagnostic flux +! if (use_SSRE) then +! this%fsrSF_vis_d_ln_patch(begp:endp) = spval +! call hist_addfld1d (fname='FSRSFVDLN', units='W/m^2', & +! avgflag='A', long_name='direct vis reflected solar radiation at local noon', & +! ptr_patch=this%fsrSF_vis_d_ln_patch, c2l_scale_type='urbanf') +! this%ssre_fsr_vis_d_ln_patch(begp:endp) = spval +! call hist_addfld1d (fname='SSRE_FSRVDLN', units='W/m^2', & +! avgflag='A', long_name='surface snow radiatve effect on direct vis reflected solar radiation at local noon', & +! ptr_patch=this%ssre_fsr_vis_d_ln_patch, c2l_scale_type='urbanf') +! end if +! this%fsds_sno_vd_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOFSDSVD', units='W/m^2', & +! avgflag='A', long_name='direct vis incident solar radiation on snow', & +! ptr_patch=this%fsds_sno_vd_patch, default='inactive') +! +! this%fsds_sno_nd_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOFSDSND', units='W/m^2', & +! avgflag='A', long_name='direct nir incident solar radiation on snow', & +! ptr_patch=this%fsds_sno_nd_patch, default='inactive') +! +! this%fsds_sno_vi_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOFSDSVI', units='W/m^2', & +! avgflag='A', long_name='diffuse vis incident solar radiation on snow', & +! ptr_patch=this%fsds_sno_vi_patch, default='inactive') +! +! this%fsds_sno_ni_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOFSDSNI', units='W/m^2', & +! avgflag='A', long_name='diffuse nir incident solar radiation on snow', & +! ptr_patch=this%fsds_sno_ni_patch, default='inactive') +! +! this%fsr_sno_vd_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOFSRVD', units='W/m^2', & +! avgflag='A', long_name='direct vis reflected solar radiation from snow', & +! ptr_patch=this%fsr_sno_vd_patch) +! +! this%fsr_sno_nd_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOFSRND', units='W/m^2', & +! avgflag='A', long_name='direct nir reflected solar radiation from snow', & +! ptr_patch=this%fsr_sno_nd_patch) +! +! this%fsr_sno_vi_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOFSRVI', units='W/m^2', & +! avgflag='A', long_name='diffuse vis reflected solar radiation from snow', & +! ptr_patch=this%fsr_sno_vi_patch) +! +! this%fsr_sno_ni_patch(begp:endp) = spval +! call hist_addfld1d (fname='SNOFSRNI', units='W/m^2', & +! avgflag='A', long_name='diffuse nir reflected solar radiation from snow', & +! ptr_patch=this%fsr_sno_ni_patch) +! +! +! end subroutine InitHistory +! +! !------------------------------------------------------------------------ +! subroutine InitCold(this, bounds) +! ! +! ! !USES: +! ! +! ! !ARGUMENTS: +! class(surfrad_type) :: this +! type(bounds_type), intent(in) :: bounds +! ! +! ! !LOCAL VARIABLES: +! integer :: p,l +! !----------------------------------------------------------------------- +! +! ! nothing for now +! +! end subroutine InitCold + + + subroutine CanopySunShadeFracs(filter_nourbanp, num_nourbanp, & + atm2lnd_inst, surfalb_inst, & + canopystate_inst, solarabs_inst) + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates and returns patch vectors of + ! + ! 1) absorbed PAR for sunlit leaves in canopy layer + ! 2) absorbed PAR for shaded leaves in canopy layer + ! 3) sunlit leaf area + ! 4) shaded leaf area + ! 5) sunlit leaf area for canopy layer + ! 6) shaded leaf area for canopy layer + ! 7) sunlit fraction of canopy + ! + ! This routine has a counterpart when the fates model is turned on. + ! CLMEDInterf_CanopySunShadeFracs() + ! If changes are applied to this routine, please take a moment to review that + ! subroutine as well and consider if any new information related to these types of + ! variables also needs to be augmented in that routine as well. + ! ------------------------------------------------------------------------------------ + + + implicit none + + ! Arguments (in) + + integer, intent(in),dimension(:) :: filter_nourbanp ! patch filter for non-urban points + integer, intent(in) :: num_nourbanp ! size of the nonurban filter + type(atm2lnd_type), intent(in) :: atm2lnd_inst + type(surfalb_type), intent(in) :: surfalb_inst + + ! Arguments (inout) + type(canopystate_type), intent(inout) :: canopystate_inst + type(solarabs_type), intent(inout) :: solarabs_inst + + ! local variables + integer :: fp ! non-urban filter patch index + integer :: p ! patch index + integer :: g ! gridcell index + integer :: iv ! canopy layer index + integer,parameter :: ipar = 1 ! The band index for PAR + + associate( tlai_z => surfalb_inst%tlai_z_patch, & ! tlai increment for canopy layer + fsun_z => surfalb_inst%fsun_z_patch, & ! sunlit fraction of canopy layer + elai => canopystate_inst%elai_patch, & ! one-sided leaf area index + forc_solad => atm2lnd_inst%forc_solad_grc, & ! direct beam radiation (W/m**2) + forc_solai => atm2lnd_inst%forc_solai_grc, & ! diffuse radiation (W/m**2) + fabd_sun_z => surfalb_inst%fabd_sun_z_patch, & ! absorbed sunlit leaf direct PAR + fabd_sha_z => surfalb_inst%fabd_sha_z_patch, & ! absorbed shaded leaf direct PAR + fabi_sun_z => surfalb_inst%fabi_sun_z_patch, & ! absorbed sunlit leaf diffuse PAR + fabi_sha_z => surfalb_inst%fabi_sha_z_patch, & ! absorbed shaded leaf diffuse PAR + nrad => surfalb_inst%nrad_patch, & ! number of canopy layers + parsun_z => solarabs_inst%parsun_z_patch, & ! absorbed PAR for sunlit leaves + parsha_z => solarabs_inst%parsha_z_patch, & ! absorbed PAR for shaded leaves + laisun => canopystate_inst%laisun_patch, & ! sunlit leaf area + laisha => canopystate_inst%laisha_patch, & ! shaded leaf area + laisun_z => canopystate_inst%laisun_z_patch, & ! sunlit leaf area for canopy layer + laisha_z => canopystate_inst%laisha_z_patch, & ! shaded leaf area for canopy layer + fsun => canopystate_inst%fsun_patch) ! sunlit fraction of canopy + + do fp = 1,num_nourbanp + + p = filter_nourbanp(fp) + + do iv = 1, nrad(p) + parsun_z(p,iv) = 0._r8 + parsha_z(p,iv) = 0._r8 + laisun_z(p,iv) = 0._r8 + laisha_z(p,iv) = 0._r8 + end do + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + laisun(p) = 0._r8 + laisha(p) = 0._r8 + do iv = 1, nrad(p) + laisun_z(p,iv) = tlai_z(p,iv) * fsun_z(p,iv) + laisha_z(p,iv) = tlai_z(p,iv) * (1._r8 - fsun_z(p,iv)) + laisun(p) = laisun(p) + laisun_z(p,iv) + laisha(p) = laisha(p) + laisha_z(p,iv) + end do + if (elai(p) > 0._r8) then + fsun(p) = laisun(p) / elai(p) + else + fsun(p) = 0._r8 + end if + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + g = patch%gridcell(p) + + do iv = 1, nrad(p) + parsun_z(p,iv) = forc_solad(g,ipar)*fabd_sun_z(p,iv) + forc_solai(g,ipar)*fabi_sun_z(p,iv) + parsha_z(p,iv) = forc_solad(g,ipar)*fabd_sha_z(p,iv) + forc_solai(g,ipar)*fabi_sha_z(p,iv) + end do + + end do ! end of fp = 1,num_nourbanp loop + end associate + return + end subroutine CanopySunShadeFracs + + !------------------------------------------------------------------------------ + subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & + num_urbanp, filter_urbanp, num_urbanc, filter_urbanc, & + atm2lnd_inst, waterdiagnosticbulk_inst, canopystate_inst, & + surfalb_inst, solarabs_inst, surfrad_inst) + ! + ! !DESCRIPTION: + ! Solar fluxes absorbed by vegetation and ground surface + ! Note possible problem when land is on different grid than atmosphere. + ! Land may have sun above the horizon (coszen > 0) but atmosphere may + ! have sun below the horizon (forc_solad = 0 and forc_solai = 0). This is okay + ! because all fluxes (absorbed, reflected, transmitted) are multiplied + ! by the incoming flux and all will equal zero. + ! Atmosphere may have sun above horizon (forc_solad > 0 and forc_solai > 0) but + ! land may have sun below horizon. This is okay because fabd, fabi, + ! ftdd, ftid, and ftii all equal zero so that sabv=sabg=fsa=0. Also, + ! albd and albi equal one so that fsr=forc_solad+forc_solai. In other words, all + ! the radiation is reflected. NDVI should equal zero in this case. + ! However, the way the code is currently implemented this is only true + ! if (forc_solad+forc_solai)|vis = (forc_solad+forc_solai)|nir. + ! Output variables are parsun,parsha,sabv,sabg,fsa,fsr,ndvi + ! + ! !USES: + use clm_varpar , only : numrad, nlevsno + use clm_varcon , only : spval + use landunit_varcon , only : istsoil, istcrop + use clm_varctl , only : use_subgrid_fluxes, use_snicar_frc, iulog, use_SSRE + use clm_time_manager , only : get_step_size_real, is_near_local_noon + ! use SnowSnicarMod , only : DO_SNO_OC + use abortutils , only : endrun + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_nourbanp ! number of patches in non-urban points in patch filter + integer , intent(in) :: filter_nourbanp(:) ! patch filter for non-urban points + integer , intent(in) :: num_urbanp ! number of patches in non-urban points in patch filter + integer , intent(in) :: filter_urbanp(:) ! patch filter for non-urban points + integer , intent(in) :: num_urbanc ! number of urban columns in clump + integer , intent(in) :: filter_urbanc(:) ! urban column filter + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(surfalb_type) , intent(in) :: surfalb_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(solarabs_type) , intent(inout) :: solarabs_inst + type(surfrad_type) , intent(inout) :: surfrad_inst + ! + ! !LOCAL VARIABLES: + integer , parameter :: nband = numrad ! number of solar radiation waveband classes + real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero + integer :: fp ! non-urban filter patch index + integer :: p ! patch index + integer :: c ! column index + integer :: l ! landunit index + integer :: g ! grid cell index + integer :: ib ! waveband number (1=vis, 2=nir) + integer :: iv ! canopy layer + real(r8) :: absrad ! absorbed solar radiation (W/m**2) + integer :: i ! layer index [idx] + real(r8) :: rnir ! reflected solar radiation [nir] (W/m**2) + real(r8) :: rvis ! reflected solar radiation [vis] (W/m**2) + real(r8) :: rnirSF ! snow-free reflected solar radiation [nir] (W/m**2) + real(r8) :: rvisSF ! snow-free reflected solar radiation [vis] (W/m**2) + real(r8) :: trd(bounds%begp:bounds%endp,numrad) ! transmitted solar radiation: direct (W/m**2) + real(r8) :: tri(bounds%begp:bounds%endp,numrad) ! transmitted solar radiation: diffuse (W/m**2) + real(r8) :: cad(bounds%begp:bounds%endp,numrad) ! direct beam absorbed by canopy (W/m**2) + real(r8) :: cai(bounds%begp:bounds%endp,numrad) ! diffuse radiation absorbed by canopy (W/m**2) + real(r8) :: dtime ! land model time step (sec) + real(r8) :: sabg_snl_sum ! temporary, absorbed energy in all active snow layers [W/m2] + real(r8) :: absrad_pur ! temp: absorbed solar radiation by pure snow [W/m2] + real(r8) :: absrad_bc ! temp: absorbed solar radiation without BC [W/m2] + real(r8) :: absrad_oc ! temp: absorbed solar radiation without OC [W/m2] + real(r8) :: absrad_dst ! temp: absorbed solar radiation without dust [W/m2] + real(r8) :: sabg_pur(bounds%begp:bounds%endp) ! solar radiation absorbed by ground with pure snow [W/m2] + real(r8) :: sabg_bc(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without BC [W/m2] + real(r8) :: sabg_oc(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without OC [W/m2] + real(r8) :: sabg_dst(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without dust [W/m2] + real(r8) :: parveg(bounds%begp:bounds%endp) ! absorbed par by vegetation (W/m**2) + ! + !------------------------------------------------------------------------------ + + associate( & + snl => col%snl , & ! Input: [integer (:) ] negative number of snow layers [nbr] + + forc_solad => atm2lnd_inst%forc_solad_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (W/m**2) + forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] diffuse radiation (W/m**2) + + snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) + frac_sno => waterdiagnosticbulk_inst%frac_sno_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] number of canopy layers, above snow for radiative transfer + coszen => surfalb_inst%coszen_col , & ! Input: [real(r8) (:) ] column cosine of solar zenith angle + albgrd => surfalb_inst%albgrd_col , & ! Input: [real(r8) (:,:) ] ground albedo (direct) + albgri => surfalb_inst%albgri_col , & ! Input: [real(r8) (:,:) ] ground albedo (diffuse) + albsod => surfalb_inst%albsod_col , & ! Input: [real(r8) (:,:) ] direct-beam soil albedo (col,bnd) [frc] + albgrd_oc => surfalb_inst%albgrd_oc_col , & ! Input: [real(r8) (:,:) ] ground albedo without OC (direct) (col,bnd) + albgri_oc => surfalb_inst%albgri_oc_col , & ! Input: [real(r8) (:,:) ] ground albedo without OC (diffuse) (col,bnd) + albgrd_dst => surfalb_inst%albgrd_dst_col , & ! Input: [real(r8) (:,:) ] ground albedo without dust (direct) (col,bnd) + albgri_dst => surfalb_inst%albgri_dst_col , & ! Input: [real(r8) (:,:) ] ground albedo without dust (diffuse) (col,bnd) + albsnd_hst => surfalb_inst%albsnd_hst_col , & ! Input: [real(r8) (:,:) ] snow albedo, direct, for history files (col,bnd) [frc] + albsni_hst => surfalb_inst%albsni_hst_col , & ! Input: [real(r8) (:,:) ] snow ground albedo, diffuse, for history files (col,bnd + flx_absdv => surfalb_inst%flx_absdv_col , & ! Input: [real(r8) (:,:) ] direct flux absorption factor (col,lyr): VIS [frc] + flx_absdn => surfalb_inst%flx_absdn_col , & ! Input: [real(r8) (:,:) ] direct flux absorption factor (col,lyr): NIR [frc] + flx_absiv => surfalb_inst%flx_absiv_col , & ! Input: [real(r8) (:,:) ] diffuse flux absorption factor (col,lyr): VIS [frc] + flx_absin => surfalb_inst%flx_absin_col , & ! Input: [real(r8) (:,:) ] diffuse flux absorption factor (col,lyr): NIR [frc] + albsoi => surfalb_inst%albsoi_col , & ! Input: [real(r8) (:,:) ] diffuse soil albedo (col,bnd) [frc] + albd => surfalb_inst%albd_patch , & ! Input: [real(r8) (:,:) ] surface albedo (direct) + albi => surfalb_inst%albi_patch , & ! Input: [real(r8) (:,:) ] surface albedo (diffuse) + albdSF => surfalb_inst%albdSF_patch , & ! Input: [real(r8) (:,:) ] snow-free surface albedo (direct) + albiSF => surfalb_inst%albiSF_patch , & ! Input: [real(r8) (:,:) ] snow-free surface albedo (diffuse) + fabd => surfalb_inst%fabd_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by canopy per unit direct flux + fabd_sun => surfalb_inst%fabd_sun_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit direct flux + fabd_sha => surfalb_inst%fabd_sha_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit direct flux + fabi => surfalb_inst%fabi_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by canopy per unit diffuse flux + fabi_sun => surfalb_inst%fabi_sun_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit diffuse flux + fabi_sha => surfalb_inst%fabi_sha_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit diffuse flux + ftdd => surfalb_inst%ftdd_patch , & ! Input: [real(r8) (:,:) ] down direct flux below canopy per unit direct flux + ftid => surfalb_inst%ftid_patch , & ! Input: [real(r8) (:,:) ] down diffuse flux below canopy per unit direct flux + ftii => surfalb_inst%ftii_patch , & ! Input: [real(r8) (:,:) ] down diffuse flux below canopy per unit diffuse flux + fabd_sun_z => surfalb_inst%fabd_sun_z_patch , & ! Input: [real(r8) (:,:) ] absorbed sunlit leaf direct PAR (per unit lai+sai) for each canopy layer + fabd_sha_z => surfalb_inst%fabd_sha_z_patch , & ! Input: [real(r8) (:,:) ] absorbed shaded leaf direct PAR (per unit lai+sai) for each canopy layer + fabi_sun_z => surfalb_inst%fabi_sun_z_patch , & ! Input: [real(r8) (:,:) ] absorbed sunlit leaf diffuse PAR (per unit lai+sai) for each canopy layer + fabi_sha_z => surfalb_inst%fabi_sha_z_patch , & ! Input: [real(r8) (:,:) ] absorbed shaded leaf diffuse PAR (per unit lai+sai) for each canopy layer + albgrd_pur => surfalb_inst%albgrd_pur_col , & ! Input: [real(r8) (:,:) ] pure snow ground albedo (direct) + albgri_pur => surfalb_inst%albgri_pur_col , & ! Input: [real(r8) (:,:) ] pure snow ground albedo (diffuse) + albgrd_bc => surfalb_inst%albgrd_bc_col , & ! Input: [real(r8) (:,:) ] ground albedo without BC (direct) (col,bnd) + albgri_bc => surfalb_inst%albgri_bc_col , & ! Input: [real(r8) (:,:) ] ground albedo without BC (diffuse) (col,bnd) + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow + fsun => canopystate_inst%fsun_patch , & ! Output: [real(r8) (:) ] sunlit fraction of canopy + fsa => solarabs_inst%fsa_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed (total) (W/m**2) + fsr => solarabs_inst%fsr_patch , & ! Output: [real(r8) (:) ] solar radiation reflected (W/m**2) + fsrSF => solarabs_inst%fsrSF_patch , & ! Output: [real(r8) (:) ] diagnostic snow-free solar radiation reflected (W/m**2) + ssre_fsr => solarabs_inst%ssre_fsr_patch , & ! Output: [real(r8) (:) ] diagnostic snow-free solar radiation reflected (W/m**2) + sabv => solarabs_inst%sabv_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed by vegetation (W/m**2) + sabg => solarabs_inst%sabg_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed by ground (W/m**2) + sabg_pen => solarabs_inst%sabg_pen_patch , & ! Output: [real(r8) (:) ] solar (rural) radiation penetrating top soisno layer (W/m**2) + sabg_soil => solarabs_inst%sabg_soil_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed by soil (W/m**2) + sabg_snow => solarabs_inst%sabg_snow_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed by snow (W/m**2) + sabg_lyr => solarabs_inst%sabg_lyr_patch , & ! Output: [real(r8) (:,:) ] absorbed radiative flux (patch,lyr) [W/m2] + fsr_nir_d => solarabs_inst%fsr_nir_d_patch , & ! Output: [real(r8) (:) ] reflected direct beam nir solar radiation (W/m**2) + fsr_nir_i => solarabs_inst%fsr_nir_i_patch , & ! Output: [real(r8) (:) ] reflected diffuse nir solar radiation (W/m**2) + fsr_nir_d_ln => solarabs_inst%fsr_nir_d_ln_patch , & ! Output: [real(r8) (:) ] reflected direct beam nir solar rad at local noon (W/m**2) + fsds_nir_d => solarabs_inst%fsds_nir_d_patch , & ! Output: [real(r8) (:) ] incident direct beam nir solar radiation (W/m**2) + fsds_nir_d_ln => solarabs_inst%fsds_nir_d_ln_patch , & ! Output: [real(r8) (:) ] incident direct beam nir solar rad at local noon (W/m**2) + fsds_nir_i => solarabs_inst%fsds_nir_i_patch , & ! Output: [real(r8) (:) ] incident diffuse nir solar radiation (W/m**2) + fsrSF_nir_d => solarabs_inst%fsrSF_nir_d_patch , & ! Output: [real(r8) (:) ] snow-free reflected direct beam nir solar radiation (W/m**2) + fsrSF_nir_i => solarabs_inst%fsrSF_nir_i_patch , & ! Output: [real(r8) (:) ] snow-free reflected diffuse nir solar radiation (W/m**2) + fsrSF_nir_d_ln => solarabs_inst%fsrSF_nir_d_ln_patch, & ! Output: [real(r8) (:) ] snow-free reflected direct beam nir solar rad at local noon (W/m**2) + ssre_fsr_nir_d => solarabs_inst%ssre_fsr_nir_d_patch, & ! Output: [real(r8) (:) ] snow-free reflected direct beam nir solar radiation (W/m**2) + ssre_fsr_nir_i => solarabs_inst%ssre_fsr_nir_i_patch, & ! Output: [real(r8) (:) ] snow-free reflected diffuse nir solar radiation (W/m**2) + ssre_fsr_nir_d_ln=> solarabs_inst%ssre_fsr_nir_d_ln_patch,&!Output: [real(r8) (:) ] snow-free reflected direct beam nir solar rad at local noon (W/m**2) + fsa_r => solarabs_inst%fsa_r_patch , & ! Output: [real(r8) (:) ] rural solar radiation absorbed (total) (W/m**2) + sub_surf_abs_SW => solarabs_inst%sub_surf_abs_SW_patch,& ! Output: [real(r8) (:) ] fraction of solar radiation absorbed below first snow layer (W/M**2) + + parveg_ln => surfrad_inst%parveg_ln_patch , & ! Output: [real(r8) (:) ] absorbed par by vegetation at local noon (W/m**2) + fsr_vis_d => surfrad_inst%fsr_vis_d_patch , & ! Output: [real(r8) (:) ] reflected direct beam vis solar radiation (W/m**2) + fsr_vis_i => surfrad_inst%fsr_vis_i_patch , & ! Output: [real(r8) (:) ] reflected diffuse vis solar radiation (W/m**2) + fsrSF_vis_d => surfrad_inst%fsrSF_vis_d_patch , & ! Output: [real(r8) (:) ] snow-free reflected direct beam vis solar radiation (W/m**2) + fsrSF_vis_i => surfrad_inst%fsrSF_vis_i_patch , & ! Output: [real(r8) (:) ] snow-free reflected diffuse vis solar radiation (W/m**2) + ssre_fsr_vis_d => surfrad_inst%ssre_fsr_vis_d_patch , & ! Output: [real(r8) (:) ] snow-free reflected direct beam vis solar radiation (W/m**2) + ssre_fsr_vis_i => surfrad_inst%ssre_fsr_vis_i_patch , & ! Output: [real(r8) (:) ] snow-free reflected diffuse vis solar radiation (W/m**2) + fsds_vis_i_ln => surfrad_inst%fsds_vis_i_ln_patch , & ! Output: [real(r8) (:) ] incident diffuse beam vis solar rad at local noon (W/m**2) + fsr_vis_d_ln => surfrad_inst%fsr_vis_d_ln_patch , & ! Output: [real(r8) (:) ] reflected direct beam vis solar rad at local noon (W/m**2) + fsrSF_vis_d_ln => surfrad_inst%fsrSF_vis_d_ln_patch , & ! Output: [real(r8) (:) ] snow-free reflected direct beam vis solar rad at local noon (W/m**2) + fsds_vis_d => surfrad_inst%fsds_vis_d_patch , & ! Output: [real(r8) (:) ] incident direct beam vis solar radiation (W/m**2) + fsds_vis_i => surfrad_inst%fsds_vis_i_patch , & ! Output: [real(r8) (:) ] incident diffuse vis solar radiation (W/m**2) + fsds_vis_d_ln => surfrad_inst%fsds_vis_d_ln_patch , & ! Output: [real(r8) (:) ] incident direct beam vis solar rad at local noon (W/m**2) + sfc_frc_aer => surfrad_inst%sfc_frc_aer_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with all aerosols (patch) [W/m2] + sfc_frc_aer_sno => surfrad_inst%sfc_frc_aer_sno_patch, & ! Output: [real(r8) (:) ] surface forcing of snow with all aerosols, averaged only when snow is present (patch) [W/m2] + sfc_frc_bc => surfrad_inst%sfc_frc_bc_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with BC (patch) [W/m2] + sfc_frc_bc_sno => surfrad_inst%sfc_frc_bc_sno_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with BC, averaged only when snow is present (patch) [W/m2] + sfc_frc_oc => surfrad_inst%sfc_frc_oc_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with OC (patch) [W/m2] + sfc_frc_oc_sno => surfrad_inst%sfc_frc_oc_sno_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with OC, averaged only when snow is present (patch) [W/m2] + sfc_frc_dst => surfrad_inst%sfc_frc_dst_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with dust (patch) [W/m2] + sfc_frc_dst_sno => surfrad_inst%sfc_frc_dst_sno_patch, & ! Output: [real(r8) (:) ] surface forcing of snow with dust, averaged only when snow is present (patch) [W/m2] + fsr_sno_vd => surfrad_inst%fsr_sno_vd_patch , & ! Output: [real(r8) (:) ] reflected visible, direct radiation from snow (for history files) (patch) [W/m2] + fsr_sno_nd => surfrad_inst%fsr_sno_nd_patch , & ! Output: [real(r8) (:) ] reflected near-IR, direct radiation from snow (for history files) (patch) [W/m2] + fsr_sno_vi => surfrad_inst%fsr_sno_vi_patch , & ! Output: [real(r8) (:) ] reflected visible, diffuse radiation from snow (for history files) (patch) [W/m2] + fsr_sno_ni => surfrad_inst%fsr_sno_ni_patch , & ! Output: [real(r8) (:) ] reflected near-IR, diffuse radiation from snow (for history files) (patch) [W/m2] + fsds_sno_vd => surfrad_inst%fsds_sno_vd_patch , & ! Output: [real(r8) (:) ] incident visible, direct radiation on snow (for history files) (patch) [W/m2] + fsds_sno_nd => surfrad_inst%fsds_sno_nd_patch , & ! Output: [real(r8) (:) ] incident near-IR, direct radiation on snow (for history files) (patch) [W/m2] + fsds_sno_vi => surfrad_inst%fsds_sno_vi_patch , & ! Output: [real(r8) (:) ] incident visible, diffuse radiation on snow (for history files) (patch) [W/m2] + fsds_sno_ni => surfrad_inst%fsds_sno_ni_patch , & ! Output: [real(r8) (:) ] incident near-IR, diffuse radiation on snow (for history files) (patch) [W/m2] + frac_sno_eff => waterdiagnosticbulk_inst%frac_sno_eff_col & !Input: + + ) + + ! Determine seconds off current time step + dtime = get_step_size_real() + + ! Initialize fluxes + + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + l = patch%landunit(p) + g = patch%gridcell(p) + + sabg_soil(p) = 0._r8 + sabg_snow(p) = 0._r8 + sabg(p) = 0._r8 + sabv(p) = 0._r8 + fsa(p) = 0._r8 + if (lun%itype(l)==istsoil .or. lun%itype(l)==istcrop) then + fsa_r(p) = 0._r8 + end if + sabg_lyr(p,:) = 0._r8 + sabg_pur(p) = 0._r8 + sabg_bc(p) = 0._r8 + sabg_oc(p) = 0._r8 + sabg_dst(p) = 0._r8 + + end do + + ! zero-out fsun for the urban patches + ! the non-urban patches were set prior to this call + ! and split into fates and non-fates specific functions + do fp = 1,num_urbanp + p = filter_urbanp(fp) + fsun(p) = 0._r8 + end do + + ! Loop over nband wavebands + do ib = 1, nband + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + c = patch%column(p) + l = patch%landunit(p) + g = patch%gridcell(p) + + ! Absorbed by canopy + + cad(p,ib) = forc_solad(g,ib)*fabd(p,ib) + cai(p,ib) = forc_solai(g,ib)*fabi(p,ib) + sabv(p) = sabv(p) + cad(p,ib) + cai(p,ib) + fsa(p) = fsa(p) + cad(p,ib) + cai(p,ib) + if (ib == 1) then + parveg(p) = cad(p,ib) + cai(p,ib) + end if + if (lun%itype(l)==istsoil .or. lun%itype(l)==istcrop) then + fsa_r(p) = fsa_r(p) + cad(p,ib) + cai(p,ib) + end if + + ! Transmitted = solar fluxes incident on ground + + trd(p,ib) = forc_solad(g,ib)*ftdd(p,ib) + tri(p,ib) = forc_solad(g,ib)*ftid(p,ib) + forc_solai(g,ib)*ftii(p,ib) + ! Solar radiation absorbed by ground surface + ! calculate absorbed solar by soil/snow separately + absrad = trd(p,ib)*(1._r8-albsod(c,ib)) + tri(p,ib)*(1._r8-albsoi(c,ib)) + sabg_soil(p) = sabg_soil(p) + absrad + absrad = trd(p,ib)*(1._r8-albsnd_hst(c,ib)) + tri(p,ib)*(1._r8-albsni_hst(c,ib)) + sabg_snow(p) = sabg_snow(p) + absrad + absrad = trd(p,ib)*(1._r8-albgrd(c,ib)) + tri(p,ib)*(1._r8-albgri(c,ib)) + sabg(p) = sabg(p) + absrad + fsa(p) = fsa(p) + absrad + if (lun%itype(l)==istsoil .or. lun%itype(l)==istcrop) then + fsa_r(p) = fsa_r(p) + absrad + end if + if (snl(c) == 0) then + sabg_snow(p) = sabg(p) + sabg_soil(p) = sabg(p) + endif + ! if no subgrid fluxes, make sure to set both components equal to weighted average + if (.not. use_subgrid_fluxes .or. lun%itype(l) == istdlak) then + sabg_snow(p) = sabg(p) + sabg_soil(p) = sabg(p) + endif + + if (use_snicar_frc) then + ! Solar radiation absorbed by ground surface without BC + absrad_bc = trd(p,ib)*(1._r8-albgrd_bc(c,ib)) + tri(p,ib)*(1._r8-albgri_bc(c,ib)) + sabg_bc(p) = sabg_bc(p) + absrad_bc + + ! Solar radiation absorbed by ground surface without OC + absrad_oc = trd(p,ib)*(1._r8-albgrd_oc(c,ib)) + tri(p,ib)*(1._r8-albgri_oc(c,ib)) + sabg_oc(p) = sabg_oc(p) + absrad_oc + + ! Solar radiation absorbed by ground surface without dust + absrad_dst = trd(p,ib)*(1._r8-albgrd_dst(c,ib)) + tri(p,ib)*(1._r8-albgri_dst(c,ib)) + sabg_dst(p) = sabg_dst(p) + absrad_dst + + ! Solar radiation absorbed by ground surface without any aerosols + absrad_pur = trd(p,ib)*(1._r8-albgrd_pur(c,ib)) + tri(p,ib)*(1._r8-albgri_pur(c,ib)) + sabg_pur(p) = sabg_pur(p) + absrad_pur + end if + + end do ! end of patch loop + end do ! end nbands loop + + ! compute absorbed flux in each snow layer and top soil layer, + ! based on flux factors computed in the radiative transfer portion of SNICAR. + + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + c = patch%column(p) + l = patch%landunit(p) + sabg_snl_sum = 0._r8 + + sub_surf_abs_SW(p) = 0._r8 + + ! CASE1: No snow layers: all energy is absorbed in top soil layer + if (snl(c) == 0) then + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,1) = sabg(p) + sabg_snl_sum = sabg_lyr(p,1) + + ! CASE 2: Snow layers present: absorbed radiation is scaled according to + ! flux factors computed by SNICAR + else + do i = -nlevsno+1,1,1 + sabg_lyr(p,i) = flx_absdv(c,i)*trd(p,1) + flx_absdn(c,i)*trd(p,2) + & + flx_absiv(c,i)*tri(p,1) + flx_absin(c,i)*tri(p,2) + ! summed radiation in active snow layers: + if (i >= snl(c)+1) then + sabg_snl_sum = sabg_snl_sum + sabg_lyr(p,i) + endif + if (i > snl(c)+1) then ! if snow layer is below surface snow layer + !accumulate subsurface flux as a diagnostic for history file + sub_surf_abs_SW(p) = sub_surf_abs_SW(p) + sabg_lyr(p,i) + endif + enddo + + ! Divide absorbed by total, to get fraction absorbed in subsurface + if (sabg_snl_sum /= 0._r8) then + sub_surf_abs_SW(p) = sub_surf_abs_SW(p)/sabg_snl_sum + else + sub_surf_abs_SW(p) = 0._r8 + endif + + ! Error handling: The situation below can occur when solar radiation is + ! NOT computed every timestep. + ! When the number of snow layers has changed in between computations of the + ! absorbed solar energy in each layer, we must redistribute the absorbed energy + ! to avoid physically unrealistic conditions. The assumptions made below are + ! somewhat arbitrary, but this situation does not arise very frequently. + ! This error handling is implemented to accomodate any value of the + ! radiation frequency. + ! change condition to match sabg_snow isntead of sabg + if (abs(sabg_snl_sum-sabg_snow(p)) > 0.00001_r8) then + if (snl(c) == 0) then + sabg_lyr(p,-nlevsno+1:0) = 0._r8 + sabg_lyr(p,1) = sabg(p) + elseif (snl(c) == -1) then + sabg_lyr(p,-nlevsno+1:-1) = 0._r8 + sabg_lyr(p,0) = sabg_snow(p)*0.6_r8 + sabg_lyr(p,1) = sabg_snow(p)*0.4_r8 + else + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,snl(c)+1) = sabg_snow(p)*0.75_r8 + sabg_lyr(p,snl(c)+2) = sabg_snow(p)*0.25_r8 + endif + endif + + ! If shallow snow depth, all solar radiation absorbed in top or top two snow layers + ! to prevent unrealistic timestep soil warming + if (.not. use_subgrid_fluxes .or. lun%itype(l) == istdlak) then + if (snow_depth(c) < 0.10_r8) then + if (snl(c) == 0) then + sabg_lyr(p,-nlevsno+1:0) = 0._r8 + sabg_lyr(p,1) = sabg(p) + elseif (snl(c) == -1) then + sabg_lyr(p,-nlevsno+1:-1) = 0._r8 + sabg_lyr(p,0) = sabg(p) + sabg_lyr(p,1) = 0._r8 + else + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,snl(c)+1) = sabg(p)*0.75_r8 + sabg_lyr(p,snl(c)+2) = sabg(p)*0.25_r8 + endif + endif + endif + endif + + ! This situation should not happen: + if (abs(sum(sabg_lyr(p,:))-sabg_snow(p)) > 0.00001_r8) then + write(iulog,*)"SNICAR ERROR: Absorbed ground radiation not equal to summed snow layer radiation" + write(iulog,*)"Diff = ",sum(sabg_lyr(p,:))-sabg_snow(p) + write(iulog,*)"sabg_snow(p)= ",sabg_snow(p) + write(iulog,*)"sabg_sum(p) = ",sum(sabg_lyr(p,:)) + write(iulog,*)"snl(c) = ",snl(c) + write(iulog,*)"flx_absdv1 = ",trd(p,1)*(1.-albgrd(c,1)) + write(iulog,*)"flx_absdv2 = ",sum(flx_absdv(c,:))*trd(p,1) + write(iulog,*)"flx_absiv1 = ",tri(p,1)*(1.-albgri(c,1)) + write(iulog,*)"flx_absiv2 = ",sum(flx_absiv(c,:))*tri(p,1) + write(iulog,*)"flx_absdn1 = ",trd(p,2)*(1.-albgrd(c,2)) + write(iulog,*)"flx_absdn2 = ",sum(flx_absdn(c,:))*trd(p,2) + write(iulog,*)"flx_absin1 = ",tri(p,2)*(1.-albgri(c,2)) + write(iulog,*)"flx_absin2 = ",sum(flx_absin(c,:))*tri(p,2) + write(iulog,*)"albgrd_nir = ",albgrd(c,2) + write(iulog,*)"coszen = ",coszen(c) + call endrun(decomp_index=c, clmlevel=namec, msg=errmsg(sourcefile, __LINE__)) + endif + + ! Diagnostic: shortwave penetrating ground (e.g. top layer) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + sabg_pen(p) = sabg(p) - sabg_lyr(p, snl(c)+1) + end if + + if (use_snicar_frc) then + + ! BC aerosol forcing (patch-level): + sfc_frc_bc(p) = sabg(p) - sabg_bc(p) + + ! OC aerosol forcing (patch-level): +! if (DO_SNO_OC) then +! sfc_frc_oc(p) = sabg(p) - sabg_oc(p) +! else +! sfc_frc_oc(p) = 0._r8 +! endif + + ! dust aerosol forcing (patch-level): + sfc_frc_dst(p) = sabg(p) - sabg_dst(p) + + ! all-aerosol forcing (patch-level): + sfc_frc_aer(p) = sabg(p) - sabg_pur(p) + + ! forcings averaged only over snow: + if (frac_sno(c) > 0._r8) then + sfc_frc_bc_sno(p) = sfc_frc_bc(p)/frac_sno(c) + sfc_frc_oc_sno(p) = sfc_frc_oc(p)/frac_sno(c) + sfc_frc_dst_sno(p) = sfc_frc_dst(p)/frac_sno(c) + sfc_frc_aer_sno(p) = sfc_frc_aer(p)/frac_sno(c) + else + sfc_frc_bc_sno(p) = spval + sfc_frc_oc_sno(p) = spval + sfc_frc_dst_sno(p) = spval + sfc_frc_aer_sno(p) = spval + endif + end if + enddo + + ! Radiation diagnostics + + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + g = patch%gridcell(p) + + ! NDVI and reflected solar radiation + + rvis = albd(p,1)*forc_solad(g,1) + albi(p,1)*forc_solai(g,1) + rnir = albd(p,2)*forc_solad(g,2) + albi(p,2)*forc_solai(g,2) + fsr(p) = rvis + rnir + if (use_SSRE) then + rvisSF = albdSF(p,1)*forc_solad(g,1) + albiSF(p,1)*forc_solai(g,1) + rnirSF = albdSF(p,2)*forc_solad(g,2) + albiSF(p,2)*forc_solai(g,2) + fsrSF(p) = rvisSF + rnirSF + ssre_fsr(p) = fsr(p)-fsrSF(p) + end if + fsds_vis_d(p) = forc_solad(g,1) + fsds_nir_d(p) = forc_solad(g,2) + fsds_vis_i(p) = forc_solai(g,1) + fsds_nir_i(p) = forc_solai(g,2) + fsr_vis_d(p) = albd(p,1)*forc_solad(g,1) + fsr_nir_d(p) = albd(p,2)*forc_solad(g,2) + fsr_vis_i(p) = albi(p,1)*forc_solai(g,1) + fsr_nir_i(p) = albi(p,2)*forc_solai(g,2) + if (use_SSRE) then + fsrSF_vis_d(p) = albdSF(p,1)*forc_solad(g,1) + fsrSF_nir_d(p) = albdSF(p,2)*forc_solad(g,2) + fsrSF_vis_i(p) = albiSF(p,1)*forc_solai(g,1) + fsrSF_nir_i(p) = albiSF(p,2)*forc_solai(g,2) + + ssre_fsr_vis_d(p) = fsrSF_vis_d(p)-fsr_vis_d(p) + ssre_fsr_nir_d(p) = fsrSF_nir_d(p)-fsr_nir_d(p) + ssre_fsr_vis_i(p) = fsrSF_vis_i(p)-fsr_vis_i(p) + ssre_fsr_nir_i(p) = fsrSF_nir_i(p)-fsr_nir_i(p) + end if + if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then + fsds_vis_d_ln(p) = forc_solad(g,1) + fsds_nir_d_ln(p) = forc_solad(g,2) + fsr_vis_d_ln(p) = albd(p,1)*forc_solad(g,1) + fsr_nir_d_ln(p) = albd(p,2)*forc_solad(g,2) + fsds_vis_i_ln(p) = forc_solai(g,1) + parveg_ln(p) = parveg(p) + else + fsds_vis_d_ln(p) = spval + fsds_nir_d_ln(p) = spval + fsr_vis_d_ln(p) = spval + fsr_nir_d_ln(p) = spval + fsds_vis_i_ln(p) = spval + parveg_ln(p) = spval + end if + if (use_SSRE) then + if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then + fsrSF_vis_d_ln(p) = albdSF(p,1)*forc_solad(g,1) + fsrSF_nir_d_ln(p) = albdSF(p,2)*forc_solad(g,2) + else + fsrSF_vis_d_ln(p) = spval + fsrSF_nir_d_ln(p) = spval + end if + end if + ! diagnostic variables (downwelling and absorbed radiation partitioning) for history files + ! (OPTIONAL) + c = patch%column(p) + if (snl(c) < 0) then + fsds_sno_vd(p) = forc_solad(g,1) + fsds_sno_nd(p) = forc_solad(g,2) + fsds_sno_vi(p) = forc_solai(g,1) + fsds_sno_ni(p) = forc_solai(g,2) + + fsr_sno_vd(p) = fsds_vis_d(p)*albsnd_hst(c,1) + fsr_sno_nd(p) = fsds_nir_d(p)*albsnd_hst(c,2) + fsr_sno_vi(p) = fsds_vis_i(p)*albsni_hst(c,1) + fsr_sno_ni(p) = fsds_nir_i(p)*albsni_hst(c,2) + else + fsds_sno_vd(p) = spval + fsds_sno_nd(p) = spval + fsds_sno_vi(p) = spval + fsds_sno_ni(p) = spval + + fsr_sno_vd(p) = spval + fsr_sno_nd(p) = spval + fsr_sno_vi(p) = spval + fsr_sno_ni(p) = spval + endif + end do + + ! TODO: urban snow-free albedos: + do fp = 1,num_urbanp + p = filter_urbanp(fp) + g = patch%gridcell(p) + + if(elai(p)==0.0_r8.and.fabd(p,1)>0._r8)then + if ( local_debug ) write(iulog,*) 'absorption without LAI',elai(p),tlai(p),fabd(p,1),p + endif + + ! Solar incident + + fsds_vis_d(p) = forc_solad(g,1) + fsds_nir_d(p) = forc_solad(g,2) + fsds_vis_i(p) = forc_solai(g,1) + fsds_nir_i(p) = forc_solai(g,2) + + ! Determine local noon incident solar + if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then + fsds_vis_d_ln(p) = forc_solad(g,1) + fsds_nir_d_ln(p) = forc_solad(g,2) + fsds_vis_i_ln(p) = forc_solai(g,1) + parveg_ln(p) = 0._r8 + else + fsds_vis_d_ln(p) = spval + fsds_nir_d_ln(p) = spval + fsds_vis_i_ln(p) = spval + parveg_ln(p) = spval + endif + + ! Solar reflected + ! per unit ground area (roof, road) and per unit wall area (sunwall, shadewall) + + fsr_vis_d(p) = albd(p,1) * forc_solad(g,1) + fsr_nir_d(p) = albd(p,2) * forc_solad(g,2) + fsr_vis_i(p) = albi(p,1) * forc_solai(g,1) + fsr_nir_i(p) = albi(p,2) * forc_solai(g,2) + + ! Determine local noon reflected solar + if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then + fsr_vis_d_ln(p) = fsr_vis_d(p) + fsr_nir_d_ln(p) = fsr_nir_d(p) + else + fsr_vis_d_ln(p) = spval + fsr_nir_d_ln(p) = spval + endif + fsr(p) = fsr_vis_d(p) + fsr_nir_d(p) + fsr_vis_i(p) + fsr_nir_i(p) + end do + + end associate + + end subroutine SurfaceRadiation + +end module SurfaceRadiationMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/TridiagonalMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/TridiagonalMod.F90 new file mode 100755 index 000000000..46532b0d8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/TridiagonalMod.F90 @@ -0,0 +1,93 @@ +module TridiagonalMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Tridiagonal matrix solution + ! + ! !PUBLIC TYPES: + implicit none + save + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: Tridiagonal + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine Tridiagonal (bounds, lbj, ubj, jtop, numf, filter, a, b, c, r, u) + ! + ! !DESCRIPTION: + ! Tridiagonal matrix solution + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varctl , only : iulog + use decompMod , only : bounds_type + use ColumnType , only : col + ! + ! !ARGUMENTS: + implicit none + type(bounds_type), intent(in) :: bounds + integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices + integer , intent(in) :: jtop( bounds%begc: ) ! top level for each column [col] + integer , intent(in) :: numf ! filter dimension (should not include hydrologically inactive points) + integer , intent(in) :: filter(:) ! filter (should not include hydrologically inactive points) + real(r8), intent(in) :: a( bounds%begc: , lbj: ) ! "a" left off diagonal of tridiagonal matrix [col, j] + real(r8), intent(in) :: b( bounds%begc: , lbj: ) ! "b" diagonal column for tridiagonal matrix [col, j] + real(r8), intent(in) :: c( bounds%begc: , lbj: ) ! "c" right off diagonal tridiagonal matrix [col, j] + real(r8), intent(in) :: r( bounds%begc: , lbj: ) ! "r" forcing term of tridiagonal matrix [col, j] + real(r8), intent(inout) :: u( bounds%begc: , lbj: ) ! solution [col, j] + ! + integer :: j,ci,fc !indices + real(r8) :: gam(bounds%begc:bounds%endc,lbj:ubj) !temporary + real(r8) :: bet(bounds%begc:bounds%endc) !temporary + !----------------------------------------------------------------------- + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(jtop) == (/bounds%endc/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(a) == (/bounds%endc, ubj/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(b) == (/bounds%endc, ubj/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(c) == (/bounds%endc, ubj/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(r) == (/bounds%endc, ubj/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(u) == (/bounds%endc, ubj/)), sourcefile, __LINE__) + + ! Solve the matrix + + do fc = 1,numf + ci = filter(fc) + bet(ci) = b(ci,jtop(ci)) + end do + + do j = lbj, ubj + do fc = 1,numf + ci = filter(fc) + if (j >= jtop(ci)) then + if (j == jtop(ci)) then + u(ci,j) = r(ci,j) / bet(ci) + else + gam(ci,j) = c(ci,j-1) / bet(ci) + bet(ci) = b(ci,j) - a(ci,j) * gam(ci,j) + u(ci,j) = (r(ci,j) - a(ci,j)*u(ci,j-1)) / bet(ci) + end if + end if + end do + end do + + do j = ubj-1,lbj,-1 + do fc = 1,numf + ci = filter(fc) + if (j >= jtop(ci)) then + u(ci,j) = u(ci,j) - gam(ci,j+1) * u(ci,j+1) + end if + end do + end do + + end subroutine Tridiagonal + +end module TridiagonalMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/abortutils.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/abortutils.F90 new file mode 100755 index 000000000..0d6581540 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/abortutils.F90 @@ -0,0 +1,95 @@ +module abortutils + + !----------------------------------------------------------------------- + ! !MODULE: abortutils + ! + ! !DESCRIPTION: + ! Abort the model for abnormal termination + !----------------------------------------------------------------------- + + private + save + + public :: endrun + + interface endrun + module procedure endrun_vanilla + module procedure endrun_globalindex + end interface + +CONTAINS + + !----------------------------------------------------------------------- + subroutine endrun_vanilla(msg, additional_msg) + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abort the model for abnormal termination + ! + use shr_sys_mod , only: shr_sys_abort + use clm_varctl , only: iulog + ! + ! !ARGUMENTS: + implicit none + + ! Generally you want to at least provide msg. The main reason to separate msg from + ! additional_msg is to supported expected-exception unit testing: you can put + ! volatile stuff in additional_msg, as in: + ! call endrun(msg='Informative message', additional_msg=errmsg(__FILE__, __LINE__)) + ! and then just assert against msg. + character(len=*), intent(in), optional :: msg ! string to be passed to shr_sys_abort + character(len=*), intent(in), optional :: additional_msg ! string to be printed, but not passed to shr_sys_abort + !----------------------------------------------------------------------- + + if (present (additional_msg)) then + write(iulog,*)'ENDRUN: ', trim(additional_msg) + else + write(iulog,*)'ENDRUN:' + end if + + call shr_sys_abort(msg) + + end subroutine endrun_vanilla + + !----------------------------------------------------------------------- + subroutine endrun_globalindex(decomp_index, clmlevel, msg, additional_msg) + + !----------------------------------------------------------------------- + ! Description: + ! Abort the model for abnormal termination + ! + use shr_sys_mod , only: shr_sys_abort + use clm_varctl , only: iulog + ! use GetGlobalValuesMod, only: GetGlobalWrite + ! + ! Arguments: + implicit none + integer , intent(in) :: decomp_index + character(len=*) , intent(in) :: clmlevel + + ! Generally you want to at least provide msg. The main reason to separate msg from + ! additional_msg is to supported expected-exception unit testing: you can put + ! volatile stuff in additional_msg, as in: + ! call endrun(msg='Informative message', additional_msg=errmsg(__FILE__, __LINE__)) + ! and then just assert against msg. + character(len=*), intent(in), optional :: msg ! string to be passed to shr_sys_abort + character(len=*), intent(in), optional :: additional_msg ! string to be printed, but not passed to shr_sys_abort + ! + ! Local Variables: + integer :: igrc, ilun, icol + !----------------------------------------------------------------------- + + ! write(6,*)'calling getglobalwrite with decomp_index= ',decomp_index,' and clmlevel= ',trim(clmlevel) + ! call GetGlobalWrite(decomp_index, clmlevel) + + if (present (additional_msg)) then + write(iulog,*)'ENDRUN: ', additional_msg + else + write(iulog,*)'ENDRUN:' + end if + + call shr_sys_abort(msg) + + end subroutine endrun_globalindex + +end module abortutils diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_time_manager.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_time_manager.F90 new file mode 100755 index 000000000..8b5753dca --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_time_manager.F90 @@ -0,0 +1,631 @@ +module clm_time_manager + +#include "MAPL_Generic.h" +#include "shr_assert.h" + + use, intrinsic :: iso_fortran_env, only: INT64 + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use update_model_para4cn, only: curr_year,curr_month,curr_day,curr_dofyr,curr_hour,curr_min,curr_sec, & + prev_year,prev_month,prev_day,prev_dofyr,prev_hour,prev_min,prev_sec + use clm_varctl , only: iulog + use MAPL_ExceptionHandling + use ESMF + + implicit none + private + +! Public methods + + public ::& + get_step_size, &! return step size in seconds + get_step_size_real, &! return step size in seconds, real-valued + get_rad_step_size, &! return radiation step size in seconds + get_nstep, &! return CN timestep number + + get_curr_date, &! return date components at end of current timestep + get_prev_date, &! return date components at beginning of current timestep +! get_curr_ESMF_Time, &! get current time in terms of the ESMF_Time +! get_start_date, &! return components of the start date +! get_driver_start_ymd, &! return year/month/day (as integer in YYYYMMDD format) of driver start date +! get_ref_date, &! return components of the reference date +! get_curr_time, &! return components of elapsed time since reference date at end of current timestep + get_curr_calday, &! return calendar day at end of current timestep + get_calday, &! return calendar day from input date +! get_calendar, &! return calendar + + get_days_per_year, &! return the days per year for current year + get_local_timestep_time, &! return the local time for the input longitude to the nearest time-step + get_local_time, &! return the local time for the input longitude + get_curr_yearfrac, &! return the fractional position in the current year, as of the end of the current timestep + get_prev_yearfrac, &! return the fractional position in the current year, as of the beginning of the current timestep + + + is_end_curr_day, &! return true on last timestep in current day + is_beg_curr_year, &! return true on first timestep in current year + is_end_curr_year, &! return true on last timestep in current year + is_restart, &! return true if this is a restart run + is_first_step, &! dummy function here, because it is loaded, but not used + is_first_step_of_this_run_segment, &! return true on first step of any run segment (initial, restart or branch run) + is_near_local_noon, &! return true if near local noon + update_rad_dtime ! track radiation interval via nstep + + integer, parameter :: uninit_int = -999999999 + integer, save ::& + dtime = -999999999, &! timestep in seconds + dtime_rad = -999999999, &! radiation interval in seconds + nstep_rad_prev = -999999999 ! radiation interval in seconds + + contains + +!========================================================================================= + + integer function get_step_size( dt ) + + ! Return the step size in seconds. + + integer, optional, intent(in) :: dt ! set to this time step + + integer, save :: dt_default = -999 + + if ( present(dt) ) then + dt_default = dt + end if + + if(dt_default < 0) stop 'CN: dt_default < 0' + get_step_size = dt_default + + end function get_step_size + +!========================================================================================= + +real(r8) function get_step_size_real() + + ! Return the step size in seconds, as a real value + + get_step_size_real = real(get_step_size(), r8) + + end function get_step_size_real + +!========================================================================================= + +integer(INT64) function get_nstep(istep) + + ! Return the timestep number. + + integer(INT64), optional, intent(in) :: istep + + integer(INT64), save :: istep_default = -999 + + if ( present(istep) ) then + istep_default = istep + end if + + if(istep_default < 0) stop 'CN: istep_default < 0' + get_nstep = istep_default ! for FireMod + +end function get_nstep + +!========================================================================================= + subroutine update_rad_dtime(doalb) + !--------------------------------------------------------------------------------- + ! called only on doalb timesteps to save off radiation nsteps + ! + ! Local Arguments + logical,intent(in) :: doalb + integer :: dtime + integer(INT64) :: nstep + + if (doalb) then + + dtime=get_step_size() + nstep = get_nstep() + + if (nstep_rad_prev == uninit_int ) then + dtime_rad = dtime + nstep_rad_prev = nstep + else + dtime_rad = (nstep - nstep_rad_prev) * dtime + nstep_rad_prev = nstep + endif + end if + end subroutine update_rad_dtime + + !========================================================================================= + +integer function get_rad_step_size() + + character(len=*), parameter :: sub = 'clm::get_rad_step_size' + +! if ( .not. check_timemgr_initialized(sub) ) return + + if (nstep_rad_prev == uninit_int ) then + get_rad_step_size=get_step_size() + else + get_rad_step_size=dtime_rad + end if + +end function get_rad_step_size + +!========================================================================================= + + subroutine get_curr_date(yr, mon, day, tod, offset) + + ! Return date components valid at end of current timestep with an optional + ! offset (positive or negative) in seconds. + + implicit none + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + integer, optional, intent(in) :: offset ! Offset from current time in seconds (not used) + + yr = curr_year + mon = curr_month + day = curr_day + tod = 3600*curr_hour + 60*curr_min + curr_sec + + end subroutine get_curr_date +!========================================================================================= + + subroutine get_prev_date(yr, mon, day, tod) + + ! Return date components valid at beginning of current timestep. + + implicit none + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + !--------------------------------------------- + + yr = prev_year + mon = prev_month + day = prev_day + tod = 3600*prev_hour + 60*prev_min + prev_sec + + end subroutine get_prev_date +!========================================================================================= + +function get_curr_calday(offset) + + ! Return calendar day at end of current timestep with optional offset. + ! Calendar day 1.0 = 0Z on Jan 1. + integer, optional, intent(in) :: offset ! Offset from current time in seconds.(not used) + real :: get_curr_calday + + get_curr_calday = curr_dofyr + +end function get_curr_calday + +!========================================================================================= + +function get_calday(ymd, tod) + +! Return calendar day corresponding to specified time instant. +! Calendar day 1.0 = 0Z on Jan 1. + +! fzeng: +! combined info from +! (1) subroutine get_dofyr_pentad in Catchment date_time_util.F90: the method +! (2) subroutine ESMF_TimeGetDayOfYearInteger in CLM4.5 ESMF_TimeMod.F90: +! output day of the year ranges from 1 to 365 +! (3) function get_calday and function TimeSetymd in CLM4.5 clm_time_manager.F90 +! (4) function days_in_month in GEOSsurface_GridComp/Shared/Raster/src/leap_year.F90 + +! Arguments + integer, intent(in) :: & + ymd, &! date in yearmmdd format + tod ! time of day (seconds past 0Z) + +! Return value + real :: get_calday + +! Local variables + integer :: yr, mon, day ! Year, month, day as integers + integer :: i + integer, dimension(12), parameter :: days_in_month_nonleap = & + (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) + + yr = ymd / 10000 + mon = (ymd - yr*10000) / 100 + day = ymd - yr*10000 - mon*100 + + get_calday = day + do i=1,mon-1 + get_calday = get_calday + days_in_month_nonleap(i) + end do + + if ( (get_calday > 366.0) .and. (get_calday <= 367.0) )then + get_calday = get_calday - 1.0 + end if + + if ( (get_calday < 1.0) .or. (get_calday > 366.0) )then + write(iulog,*) 'clm::get_calday = ', get_calday + stop 'clm::get_calday: error calday out of range' + end if + +end function get_calday + +!========================================================================================= + +integer function get_days_per_year( year ) + + integer, optional, intent(in) :: year ! current year + + integer, save :: curr_year = 1999 + logical :: is_leap_year + + if ( present(year) ) then + curr_year = year + end if + + if (mod(curr_year,4) /= 0) then + is_leap_year = .false. + else if (mod(curr_year,400) == 0) then + is_leap_year = .true. + else if (mod(curr_year,100) == 0) then + is_leap_year = .false. + else + is_leap_year = .true. + end if + +!!!is_leap_year = .false. ! gkw: 71l test 20110920 + + if(is_leap_year) then + get_days_per_year = 366 + else + get_days_per_year = 365 + endif + +end function get_days_per_year + +!========================================================================================= + +function is_end_curr_day( ) + + ! Return true if current timestep is last timestep in current day. + + ! Return value + logical :: is_end_curr_day + + ! Local variables + integer ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + call get_curr_date(yr, mon, day, tod) + is_end_curr_day = (tod == 0) + +end function is_end_curr_day + +!========================================================================================= + +logical function is_first_step(first) + + ! Return value + logical, optional, intent(in) :: first ! set to this time step + + logical, save :: is_first_default = .true. + + if ( present(first) ) then + is_first_default = first + end if + + is_first_step = is_first_default + +end function is_first_step + +!========================================================================================= + +logical function is_restart( ) + + ! Determine if it's a restart run + + is_restart = .false. + +end function is_restart + +!========================================================================================= + + logical function is_near_local_noon( londeg, deltasec ) + + !--------------------------------------------------------------------------------- + ! Is this longitude near it's local noon? + ! + ! uses + use clm_varcon, only: degpsec, isecspday + ! Arguments + real(r8), intent(in) :: londeg ! Longitude in degrees + integer , intent(in) :: deltasec ! Number of seconds before or after local noon + + ! Local variables + integer :: local_secs ! Local time in seconds + integer, parameter :: noonsec = isecspday / 2 ! seconds at local noon + !--------------------------------------------------------------------------------- + SHR_ASSERT( deltasec < noonsec, "deltasec must be less than 12 hours" ) + local_secs = get_local_timestep_time( londeg ) + + if ( local_secs >= (noonsec - deltasec) .and. local_secs <= (noonsec + deltasec)) then + is_near_local_noon = .true. + else + is_near_local_noon = .false. + end if + + !--------------------------------------------------------------------------------- + end function is_near_local_noon + + !========================================================================================= + + integer function get_local_timestep_time( londeg, offset, rc ) + + !--------------------------------------------------------------------------------- + ! Get the local time for this longitude that is evenly divisible by the time-step + ! + ! uses + use clm_varcon, only: degpsec, isecspday + ! Arguments + real(r8) , intent(in) :: londeg ! Longitude in degrees + integer, optional, intent(in) :: offset ! Offset from current time in seconds (either sign) + integer, optional, intent(out) :: rc + + ! Local variables + integer :: yr, mon, day ! year, month, day, unused + integer :: secs ! seconds into the day + real(r8) :: lon ! positive longitude + integer :: offset_sec ! offset seconds (either 0 for current time or -dtime for previous time) + !--------------------------------------------------------------------------------- + if ( present(offset) ) then + offset_sec = offset + _ASSERT(.FALSE.,"offset function not enabled") + else + offset_sec = 0 + end if + SHR_ASSERT( londeg >= -180.0_r8, "londeg must be greater than -180" ) + SHR_ASSERT( londeg <= 360.0_r8, "londeg must be less than 360" ) + call get_curr_date(yr, mon, day, secs ) + lon = londeg + if ( lon < 0.0_r8 ) lon = lon + 360.0_r8 + get_local_timestep_time = secs + nint((lon/degpsec)/real(dtime,r8))*dtime + get_local_timestep_time = mod(get_local_timestep_time,isecspday) + end function get_local_timestep_time + + !========================================================================================= + +! function get_curr_ESMF_Time( ) +! +! ! Return the current time as ESMF_Time +! +! type(ESMF_Time) :: get_curr_ESMF_Time +! character(len=*), parameter :: sub = 'clm::get_curr_ESMF_Time' +! integer :: rc, status +! +! ! if ( .not. check_timemgr_initialized(sub) ) return +! +! call ESMF_ClockGet( tm_clock, currTime=get_curr_ESMF_Time, rc=STATUS ) +! VERIFY_(STATUS) +! +! end function get_curr_ESMF_Time + + integer function get_local_time( londeg, starttime, offset ) + + !--------------------------------------------------------------------------------- + ! Get the local time for this longitude + ! + ! uses + use clm_varcon, only: degpsec, isecspday + ! Arguments + real(r8) , intent(in) :: londeg ! Longitude in degrees + integer, optional, intent(in) :: starttime ! Start time (sec) + integer, optional, intent(in) :: offset ! Offset from current time in seconds (either sign) + + ! Local variables + integer :: yr, mon, day ! year, month, day, unused + integer :: secs ! seconds into the day + integer :: start ! start seconds + integer :: offset_sec ! offset seconds (either 0 for current time or -dtime for previous time) + real(r8) :: lon ! positive longitude + !--------------------------------------------------------------------------------- + if ( present(starttime) ) then + start = starttime + else + start = 0 + end if + if ( present(offset) ) then + offset_sec = offset + else + offset_sec = 0 + end if + SHR_ASSERT( start >= 0, "starttime must be greater than or equal to zero" ) + SHR_ASSERT( start <= isecspday, "starttime must be less than or equal to number of seconds in a day" ) + SHR_ASSERT( londeg >= -180.0_r8, "londeg must be greater than -180" ) + SHR_ASSERT( londeg <= 360.0_r8, "londeg must be less than 360" ) + SHR_ASSERT( (offset_sec == 0) .or. (offset_sec == -dtime), "offset must be zero or negative time-step" ) + call get_curr_date(yr, mon, day, secs, offset=offset_sec ) + lon = londeg + if ( lon < 0.0_r8 ) lon = lon + 360.0_r8 + get_local_time = modulo(secs + nint(londeg/degpsec), isecspday) + get_local_time = modulo(get_local_time - start,isecspday) + end function get_local_time + + !----------------------------------------------------------------------- + logical function is_beg_curr_year() + ! + ! !DESCRIPTION: + ! Return true if current timestep is first timestep in current year. + ! + ! !LOCAL VARIABLES: + integer ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + character(len=*), parameter :: subname = 'is_beg_curr_year' + !----------------------------------------------------------------------- + + ! if ( .not. check_timemgr_initialized(subname) ) return + + call get_curr_date(yr, mon, day, tod) + is_beg_curr_year = (mon == 1 .and. day == 1 .and. tod == dtime) + + end function is_beg_curr_year + + !========================================================================================= + + function get_curr_yearfrac( offset ) + + !--------------------------------------------------------------------------------- + ! Get the fractional position in the current year, as of the end of the current + ! timestep. This is 0 at midnight on Jan 1, and 1 at the end of Dec 31. + + ! + ! Arguments + real(r8) :: get_curr_yearfrac ! function result + + integer, optional, intent(in) :: offset ! Offset from current time in seconds. + ! Positive for future times, negative + ! for previous times. + + character(len=*), parameter :: sub = 'clm::get_curr_yearfrac' + real(r8) :: cday ! current calendar day (1.0 = 0Z on Jan 1) + real(r8) :: days_per_year ! days per year + + ! if ( .not. check_timemgr_initialized(sub) ) return + + cday = get_curr_calday(offset=offset) + days_per_year = get_days_per_year() + + get_curr_yearfrac = (cday - 1._r8)/days_per_year + + end function get_curr_yearfrac + + !========================================================================================= + + function get_prev_yearfrac() + + !--------------------------------------------------------------------------------- + ! Get the fractional position in the current year, as of the beginning of the current + ! timestep. This is 0 at midnight on Jan 1, and 1 at the end of Dec 31. + + ! + ! Arguments + real(r8) :: get_prev_yearfrac ! function result + + character(len=*), parameter :: sub = 'clm::get_curr_yearfrac' + + ! if ( .not. check_timemgr_initialized(sub) ) return + + get_prev_yearfrac = get_curr_yearfrac(offset = -dtime) + + end function get_prev_yearfrac + + !----------------------------------------------------------------------- + logical function is_end_curr_year() + ! + ! !DESCRIPTION: + ! Return true if current timestep is last timestep in current year. + ! + ! !LOCAL VARIABLES: + integer ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + character(len=*), parameter :: subname = 'is_end_curr_year' + !----------------------------------------------------------------------- + + call get_curr_date(yr, mon, day, tod) + is_end_curr_year = (mon == 1 .and. day == 1 .and. tod == 0) + + end function is_end_curr_year + + !========================================================================================= + + logical function is_first_step_of_this_run_segment() + + ! Return true if this is the first step of this run segment. This will be true for + ! the first step of a startup, restart or branch run. + character(len=*), parameter :: sub = 'clm::is_first_step_of_this_run_segment' + + !if ( .not. check_timemgr_initialized(sub) ) return + + is_first_step_of_this_run_segment = (is_first_step()) + + end function is_first_step_of_this_run_segment + + !========================================================================================= + +! function get_curr_calday(offset) +! +! ! Return calendar day at end of current timestep with optional offset. +! ! Calendar day 1.0 = 0Z on Jan 1. +! +! ! Arguments +! integer, optional, intent(in) :: offset ! Offset from current time in seconds. +! ! Positive for future times, negative +! ! for previous times. +! ! Return value +! real(r8) :: get_curr_calday +! +! ! Local variables +! character(len=*), parameter :: sub = 'clm::get_curr_calday' +! integer :: rc +! type(ESMF_Time) :: date +! type(ESMF_TimeInterval) :: off, diurnal +! integer :: year, month, day, tod +! !----------------------------------------------------------------------------------------- +! +!! if ( .not. check_timemgr_initialized(sub) ) return +! +! call ESMF_ClockGet( tm_clock, currTime=date, rc=rc ) +! call chkrc(rc, sub//': error return from ESMF_ClockGet') +! +! if (present(offset)) then +! if (offset > 0) then +! call ESMF_TimeIntervalSet( off, s=offset, rc=rc ) +! call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') +! date = date + off +! else if (offset < 0) then +! call ESMF_TimeIntervalSet( off, s=-offset, rc=rc ) +! call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') +! date = date - off +! end if +! end if +! +! if ( tm_perp_calendar ) then +! call ESMF_TimeGet(date, yy=year, mm=month, dd=day, s=tod, rc=rc) +! call chkrc(rc, sub//': error return from ESMF_TimeGet') +! call ESMF_TimeIntervalSet( diurnal, s=tod, rc=rc ) +! call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') +! date = tm_perp_date + diurnal +! end if +! +! call ESMF_TimeGet( date, dayOfYear_r8=get_curr_calday, rc=rc ) +! call chkrc(rc, sub//': error return from ESMF_TimeGet') +! !----------------------------------------------------------------------------------------! +! !!!!!!!!!!!!!! WARNING HACK TO ENABLE Gregorian CALENDAR WITH SHR_ORB !!!!!!!!!!!!!!!!!!!! +! !!!! The following hack fakes day 366 by reusing day 365. This is just because the !!!!!! +! !!!! current shr_orb_decl calculation can't handle days > 366. !!!!!! +! !!!! Dani Bundy-Coleman and Erik Kluzek Aug/2008 !!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! if ( (get_curr_calday > 366.0) .and. (get_curr_calday <= 367.0) .and. & +! (trim(calendar) == GREGORIAN_C) )then +! get_curr_calday = get_curr_calday - 1.0_r8 +! end if +! !!!!!!!!!!!!!! END HACK TO ENABLE Gregorian CALENDAR WITH SHR_ORB !!!!!!!!!!!!!!!!!!!!!!!! +! !----------------------------------------------------------------------------------------! +! if ( (get_curr_calday < 1.0) .or. (get_curr_calday > 366.0) )then +! write(iulog,*) sub, ' = ', get_curr_calday +! if ( present(offset) ) write(iulog,*) 'offset = ', offset +! call shr_sys_abort( sub//': error get_curr_calday out of bounds' ) +! end if +! +! end function get_curr_calday +end module clm_time_manager diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varcon.F90 new file mode 100755 index 000000000..3e195d16d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varcon.F90 @@ -0,0 +1,166 @@ +module clm_varcon + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: clm_varcon +! +! !DESCRIPTION: +! Module containing various model constants +! +! !USES: + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 + use shr_const_mod, only: SHR_CONST_G, & + SHR_CONST_RHOFW, & + SHR_CONST_TKFRZ, & + SHR_CONST_CDAY, & + SHR_CONST_RGAS, & + SHR_CONST_PI, & + SHR_CONST_PDB + use clm_varpar , only: nlevgrnd, nlevdecomp_full, numrad, ngases + +! !PUBLIC TYPES: + implicit none + save +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! 27 February 2008: Keith Oleson; Add forcing height and aerodynamic parameters +! +!EOP +!----------------------------------------------------------------------- + + !------------------------------------------------------------------ + ! Initialize mathmatical constants + !------------------------------------------------------------------ + + real(r8) :: rpi = SHR_CONST_PI + + !------------------------------------------------------------------ + ! Initialize physical constants + !------------------------------------------------------------------ + + real(r8) :: grav = SHR_CONST_G !gravity constant [m/s2] + real(r8) :: denh2o = SHR_CONST_RHOFW !density of liquid water [kg/m3] + real(r8) :: rgas = SHR_CONST_RGAS !universal gas constant [J/K/kmole] + real(r8) :: tfrz = SHR_CONST_TKFRZ !freezing temperature [K] + real(r8), public, parameter :: secspday= SHR_CONST_CDAY ! Seconds per day + real(r8), public, parameter :: secsphr = 3600._r8 ! Seconds in an hour + real(r8), public, parameter :: spval = 1.e36_r8 ! special value for real data + integer , public, parameter :: ispval = -9999 ! special value for int data + integer, public, parameter :: fun_period = 1 ! A FUN parameter, and probably needs to be changed for testing + real(r8),public, parameter :: smallValue = 1.e-12_r8 ! A small values used by FUN + + + + !------------------------------------------------------------------ + ! Soil depths + !------------------------------------------------------------------ + + real(r8), pointer :: zsoi(:) !soil z (layers) + real(r8), pointer :: dzsoi(:) !soil dz (thickness) + real(r8), pointer :: zisoi(:) !soil zi (interfaces) + real(r8), pointer :: dzsoi_decomp(:) !soil dz (thickness) + real(r8), public, parameter :: zmin_bedrock = 0.4_r8 ! minimum soil depth [m] + + !------------------------------------------------------------------ + ! Set subgrid names + !------------------------------------------------------------------ + + character(len=16), public, parameter :: grlnd = 'lndgrid' ! name of lndgrid + character(len=16), public, parameter :: namea = 'gridcellatm' ! name of atmgrid + character(len=16), public, parameter :: nameg = 'gridcell' ! name of gridcells + character(len=16), public, parameter :: namel = 'landunit' ! name of landunits + character(len=16), public, parameter :: namec = 'column' ! name of columns + character(len=16), public, parameter :: namep = 'pft' ! name of patches + character(len=16), public, parameter :: nameCohort = 'cohort' ! name of cohorts (ED specific) + + !------------------------------------------------------------------ + ! Initialize miscellaneous radiation constants + !------------------------------------------------------------------ + + real(r8), public :: betads = 0.5_r8 ! two-stream parameter betad for snow + real(r8), public :: betais = 0.5_r8 ! two-stream parameter betai for snow + real(r8), public :: omegas(numrad) = (/0.8_r8, 0.4_r8/) ! two-stream parameter omega for snow by band + + integer, parameter, public :: max_lunit = 9 !maximum value that lun%itype can have + + ! typical del13C for C3 photosynthesis (permil, relative to PDB) + real(r8), public, parameter :: c3_del13c = -28._r8 + + ! typical del13C for C4 photosynthesis (permil, relative to PDB) + real(r8), public, parameter :: c4_del13c = -13._r8 + + ! isotope ratio (13c/12c) for C3 photosynthesis + real(r8), public, parameter :: c3_r1 = SHR_CONST_PDB + ((c3_del13c*SHR_CONST_PDB)/1000._r8) + + ! isotope ratio (13c/[12c+13c]) for C3 photosynthesis + real(r8), public, parameter :: c3_r2 = c3_r1/(1._r8 + c3_r1) + + real(r8), public :: c13ratio = 1. !jkolassa Jan 2023: dummy value since this is only needed to compile the code, but not used + real(r8), public :: c14ratio = 1. !jkolassa Jan 2023: dummy value since this is only needed to compile the code, but not used + + + real(r8), public, parameter :: nitrif_n2o_loss_frac = 6.e-4_r8 ! fraction of N lost as N2O in nitrification (Li et al., 2000) + + real(r8), public, parameter :: degpsec = 15._r8/3600.0_r8 ! Degree's earth rotates per second + integer, public, parameter :: isecspday= secspday ! Integer seconds per day + + real(r8), public, parameter :: c_to_b = 2.0_r8 ! conversion between mass carbon and total biomass (g biomass /g C) + + !------------------------------------------------------------------ + ! (Non-tunable) Constants for the CH4 submodel (Tuneable constants in ch4varcon) + !------------------------------------------------------------------ + ! Note some of these constants are also used in CNNitrifDenitrifMod + + integer, private :: i ! loop index + + real(r8), public :: d_con_w(ngases,3) ! water diffusivity constants (spp, #) (mult. by 10^-4) + data (d_con_w(1,i),i=1,3) /0.9798_r8, 0.02986_r8, 0.0004381_r8/ ! CH4 + data (d_con_w(2,i),i=1,3) /1.172_r8, 0.03443_r8, 0.0005048_r8/ ! O2 + data (d_con_w(3,i),i=1,3) /0.939_r8, 0.02671_r8, 0.0004095_r8/ ! CO2 + + real(r8), public :: d_con_g(ngases,2) ! gas diffusivity constants (spp, #) (cm^2/s) (mult. by 10^-9) + data (d_con_g(1,i),i=1,2) /0.1875_r8, 0.0013_r8/ ! CH4 + data (d_con_g(2,i),i=1,2) /0.1759_r8, 0.00117_r8/ ! O2 + data (d_con_g(3,i),i=1,2) /0.1325_r8, 0.0009_r8/ ! CO2 + + +! !PUBLIC MEMBER FUNCTIONS: + public clm_varcon_init ! Initialze constants that need to be initialized + +! !REVISION HISTORY: +! Created by Mariana Vertenstein + +!EOP +!----------------------------------------------------------------------- +contains +!------------------------------- + subroutine clm_varcon_init() +! +! !DESCRIPTION: +! This subroutine initializes constants in clm_varcon. MUST be called +! after the clm_varpar_init. +! +! !USES: +! +! !ARGUMENTS: + implicit none +! +! +!EOP +!------------------------------------------------------------------------------ + allocate( zsoi(1:nlevgrnd) ) + allocate( dzsoi(1:nlevgrnd) ) + allocate( zisoi(0:nlevgrnd) ) + allocate( dzsoi_decomp(1:nlevdecomp_full) ) + + ! jkolassa Aug 2022: This follows previous implementations of Catchment-CN and works as long as we use a single soil layer (for CN); we will have to update this if we increase the number of soil layers. + zsoi(1) = 0.5 + dzsoi(1) = 1. + zisoi(0) = 0. + zisoi(1) = 1. + dzsoi_decomp(1) = dzsoi(1) + + end subroutine clm_varcon_init +end module clm_varcon diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varctl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varctl.F90 new file mode 100755 index 000000000..1a88cf7aa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varctl.F90 @@ -0,0 +1,146 @@ +module clm_varctl + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: clm_varctl +! +! !DESCRIPTION: +! Module containing run control variables +! +! !USES: + use MAPL_ConstantsMod, ONLY: r8 => MAPL_R8 +! +! !PUBLIC MEMBER FUNCTIONS: + implicit none + + public :: init_clm_varctl ! set parameters + public :: cnallocate_carbon_only + public :: cnallocate_carbon_only_set + + logical, public :: use_nguardrail = .true. ! true => use precision control + + logical, public :: use_luna = .false. ! true => use LUNA + logical, public :: use_fates = .false. ! true => use fates + logical, public :: use_hydrstress = .true. ! true => use plant hydraulic stress calculation + + + ! If prognostic crops are turned on + logical, public :: use_crop = .false. + + logical, public :: use_lch4 = .false. + logical, public :: use_nitrif_denitrif = .true. + logical, public :: use_vertsoilc = .false. + logical, public :: use_century_decomp = .true. + logical, public :: use_cn = .true. + logical, public :: use_cndv = .false. + logical, public :: use_grainproduct = .false. + logical, public :: use_dynroot = .false. + logical, public :: use_bedrock = .true. ! true => use spatially variable soil depth + logical, public :: use_extralakelayers = .false. + logical, public :: use_biomass_heat_storage = .false. + logical, public :: use_fertilizer = .true. + + ! logical, public :: downreg_opt = .true. + logical, public :: downreg_opt = .false. + logical, public :: nscalar_opt = .true. + ! integer, public :: plant_ndemand_opt = 0 + integer, public :: plant_ndemand_opt = 3 + logical, public :: substrate_term_opt = .true. + logical, public :: temp_scalar_opt = .true. + ! integer, public :: CN_residual_opt = 0 + integer, public :: CN_residual_opt = 1 + ! integer, public :: CN_partition_opt = 0 + integer, public :: CN_partition_opt = 1 + + logical, public :: use_c13 = .false. ! true => use C-13 model + logical, public :: use_c14 = .false. ! true => use C-14 model + + ! use subgrid fluxes + logical, public :: use_subgrid_fluxes = .true. + + !---------------------------------------------------------- + ! SSRE diagnostic + !---------------------------------------------------------- + logical, public :: use_SSRE = .false. ! flag for SSRE diagnostic + + !---------------------------------------------------------- + ! CN matrix + !---------------------------------------------------------- + logical, public :: use_matrixcn = .false. !.false. ! true => use cn matrix + logical, public :: use_soil_matrixcn = .false.! true => use cn matrix + logical, public :: isspinup = .false. !.false. ! true => use acc spinup + logical, public :: is_outmatrix = .false.!.false. ! true => use acc spinup + integer, public :: nyr_forcing = 10 ! length of forcing years for the spin up. eg. if DATM_CLMNCEP_YR_START=1901;DATM_CLMNCEP_YR_END=1920, then nyr_forcing = 20 + integer, public :: nyr_SASU = 1 ! length of each semi-analytic solution. eg. nyr_SASU=5, analytic solutions will be calculated every five years. + ! nyr_SASU=1: the fastest SASU, but inaccurate; nyr_SASU=nyr_forcing(eg. 20): the lowest SASU but accurate + integer, public :: iloop_avg = -999 ! The restart file will be based on the average of all analytic solutions within the iloop_avg^th loop. + + real(r8), public :: nfix_timeconst = -1.2345_r8 + + !---------------------------------------------------------- + ! Unit Numbers + !---------------------------------------------------------- + ! + integer, public :: iulog = 6 ! "stdout" log file unit number, default is 6; jkolassa: This is following CTSM, iulog is not set to output_unit + + !---------------------------------------------------------- + ! flexibleCN + !---------------------------------------------------------- + !logical, public :: use_flexibleCN = .false. + logical, public :: use_flexibleCN = .true. + !logical, public :: CNratio_floating = .false. + logical, public :: CNratio_floating = .true. + !integer, public :: CN_evergreen_phenology_opt = 0 + integer, public :: CN_evergreen_phenology_opt = 1 + !logical, public :: lnc_opt = .false. + logical, public :: lnc_opt = .true. + logical, public :: reduce_dayl_factor = .false. + !integer, public :: vcmax_opt = 0 + integer, public :: vcmax_opt = 3 + + !---------------------------------------------------------- + ! BGC logic and datasets + !---------------------------------------------------------- + + ! true => anoxia is applied to heterotrophic respiration also considered in CH4 model + ! default value reset in controlMod + logical, public :: anoxia = .true. + + ! State of the model for the accelerated decomposition (AD) spinup. + ! 0 (default) = normal model; 1 = AD SPINUP + integer, public :: spinup_state = 0 + + logical, public :: use_snicar_frc = .false. + + integer, public :: carbon_resp_opt = 0 + + ! Set in CNAllocationInit (TODO - had to move it here to avoid circular dependency) + logical, private:: carbon_only +contains + +!--------------------------------------- + subroutine init_clm_varctl() + + !--- + if (nfix_timeconst == -1.2345_r8) then + if (use_nitrif_denitrif) then + nfix_timeconst = 10._r8 + else + nfix_timeconst = 0._r8 + end if + end if + + end subroutine init_clm_varctl + + ! Get module carbon_only flag + logical function CNAllocate_Carbon_only() + cnallocate_carbon_only = carbon_only + end function CNAllocate_Carbon_only + + ! Set module carbon_only flag + subroutine cnallocate_carbon_only_set(carbon_only_in) + logical, intent(in) :: carbon_only_in + carbon_only = carbon_only_in + end subroutine cnallocate_carbon_only_set +end module clm_varctl diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varpar.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varpar.F90 new file mode 100755 index 000000000..22eecb28e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varpar.F90 @@ -0,0 +1,213 @@ +module clm_varpar + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: clm_varpar +! +! !DESCRIPTION: +! Module containing CLM parameters +! +! !USES: +! + use clm_varpar_shared, only : VAR_COL =>VAR_COL_51, VAR_PFT => VAR_PFT_51, & + numpft => numpft_CN51, NUM_ZON => NUM_ZON_CN, & + NUM_VEG => NUM_VEG_CN51 + +! !PUBLIC TYPES: + implicit none + save + +! Define number of levels + + integer, parameter :: nlevsoi = 1 ! number of hydrologically active soil layers + integer, parameter :: nlevgrnd = 1 ! number of ground layers (includes lower layers that are hydrologically inactive) + integer, parameter :: nlevsno = 0 ! maximum number of snow layers + integer, public :: nlevurb = 0 ! number of urban layers; jk Oct 2021: using CTSM5.1 value of 5 for now; jkolassa Aug 2022: changed because having more urban than ground layers caused and issue with the initialization of the soil layers in column type + integer, public :: nlevmaxurbgrnd ! maximum of the number of ground and urban layers + integer, public, parameter :: nlayer = 3 ! number of VIC soil layer --Added by AWang + + integer, public :: nlevlak ! number of lake layers + integer, public :: nlevdecomp ! number of biogeochemically active soil layers + integer, public :: nlevdecomp_full ! number of biogeochemical layers + ! (includes lower layers that are biogeochemically inactive) + + integer, public :: ndecomp_pools + integer, public :: ndecomp_cascade_transitions + integer, public :: ndecomp_cascade_outtransitions + + ! for soil matrix + integer, public :: ndecomp_pools_vr !total number of pools ndecomp_pools*vertical levels + + integer, parameter :: mxpft = 15 ! + integer, public :: maxveg ! # of pfts + cfts + integer, public :: maxsoil_patches = numpft + 1 ! # of pfts + cfts + bare ground; replaces maxpatch_pft, which is obsolete + integer, public :: natpft_lb = 0 ! In PATCH arrays, lower bound of Patches on the natural veg landunit (i.e., bare ground index) + + integer, public, parameter :: nvariants = 2 ! number of variants of PFT constants + + integer, public, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir + integer, public, parameter :: ivis = 1 ! index for visible band + integer, public, parameter :: inir = 2 ! index for near-infrared band + integer, public, parameter :: nlevcan = 1 ! number of leaf layers in canopy layer + integer, public, parameter :: nvegwcs = 4 ! number of vegetation water conductance segments + + real, parameter, PUBLIC, dimension(NUM_ZON) :: CN_zone_weight = (/0.10,0.45,0.45/) ! gkw: tunable; must sum to 1 + integer, parameter, PUBLIC :: map_cat(0:numpft) = (/4,3,3,3,1,1,2,2,2,5,5,6,4,4,4,4/) + + ! constants for decomposition cascade + + integer, public, parameter :: i_met_lit = 1 + integer, public, parameter :: i_cel_lit = i_met_lit + 1 + integer, public, parameter :: i_lig_lit = i_cel_lit + 1 + integer, public :: i_cwd + + !Matrix index (when use_matrixcn) + integer, public, parameter :: ileaf = 1 ! leaf pool index + integer, public, parameter :: ileaf_st = 2 ! leaf storage pool index + integer, public, parameter :: ileaf_xf = 3 ! leaf transfer pool index + integer, public, parameter :: ifroot = 4 ! fine root pool index + integer, public, parameter :: ifroot_st = 5 ! fine root storage pool index + integer, public, parameter :: ifroot_xf = 6 ! fine root transfer pool index + integer, public, parameter :: ilivestem = 7 ! live stem pool index + integer, public, parameter :: ilivestem_st = 8 ! live stem storage pool index + integer, public, parameter :: ilivestem_xf = 9 ! live stem transfer pool index + integer, public, parameter :: ideadstem = 10 ! dead stem pool index + integer, public, parameter :: ideadstem_st = 11 ! dead stem storage pool index + integer, public, parameter :: ideadstem_xf = 12 ! dead stem transfer pool index + integer, public, parameter :: ilivecroot = 13 ! live coarse root pool index + integer, public, parameter :: ilivecroot_st = 14 ! live coarse root storage pool index + integer, public, parameter :: ilivecroot_xf = 15 ! live coarse root transfer pool index + integer, public, parameter :: ideadcroot = 16 ! dead coarse root pool index + integer, public, parameter :: ideadcroot_st = 17 ! dead coarse root storage pool index + integer, public, parameter :: ideadcroot_xf = 18 ! dead coarse root transfer pool index + integer, public, parameter :: igrain = 19 ! grain pool index + integer, public, parameter :: igrain_st = 20 ! grain storage pool index + integer, public, parameter :: igrain_xf = 21 ! grain transfer pool + + integer, public :: ncphtrans !maximum number of vegetation C transfers through phenology + integer, public :: ncphouttrans !maximum number of vegetation C transfers out of vegetation through phenology + integer, public :: ncgmtrans !maximum number of vegetation C transfers through gap mortality + integer, public :: ncgmouttrans !maximum number of vegetation C transfers out of vegetation through gap mortality + integer, public :: ncfitrans !maximum number of vegetation C transfers through fire + integer, public :: ncfiouttrans !maximum number of vegetation C transfers out of vegetation trhough fire + integer, public :: nnphtrans !maximum number of vegetation N transfers through phenology + integer, public :: nnphouttrans !maximum number of vegetation N transfers out of vegetation through phenology + integer, public :: nngmtrans !maximum number of vegetation N transfers through gap mortality + integer, public :: nngmouttrans !maximum number of vegetation N transfers out of vegetation through gap mortality + integer, public :: nnfitrans !maximum number of vegetation N transfers through fire + integer, public :: nnfiouttrans !maximum number of vegetation N transfers out of vegetation trhough fire + + integer, public :: iretransn ! retranslocation pool index + integer, public :: ioutc ! external C pool index + integer, public :: ioutn ! external N pool index + + + integer, public, parameter :: nvegpool_natveg = 18 ! number of vegetation matrix pool without crop + integer, public, parameter :: nvegpool_crop = 3 ! number of vegetation matrix pool with crop + integer, public, parameter :: nveg_retransn = 1 ! number of vegetation retranslocation pool + integer, public :: nvegcpool ! number of vegetation C pools + integer, public :: nvegnpool ! number of vegetation N pools + + + ! For CH4 code + integer, parameter :: ngases = 3 ! CH4, O2, & CO2 + + integer, public :: max_patch_per_col + + integer, public :: maxpatch_glcmec = 0 ! max number of elevation classes (set to 0 here, not specified in CLM clm_varpar.F90) + +contains + +!------------------------------------ + subroutine clm_varpar_init() +! +! !DESCRIPTION: +! This subroutine initializes parameters in clm_varpar +! + use clm_varctl, only : use_vertsoilc, use_extralakelayers, use_fates, & + use_century_decomp, use_crop +! +! !ARGUMENTS: + implicit none + +!---------------------------- + + nlevmaxurbgrnd = max0(nlevurb,nlevgrnd) + nlevmaxurbgrnd = nlevgrnd ! jkolassa: set this here, since we are not modelling urban tiles for now + max_patch_per_col = maxsoil_patches ! since we don't have CFTs or urban patches + maxveg = maxsoil_patches - 1 ! # of patches without bare ground + + ! here is a switch to set the number of soil levels for the biogeochemistry calculations. + ! currently it works on either a single level or on nlevsoi and nlevgrnd levels + if (use_vertsoilc) then + nlevdecomp = nlevsoi + nlevdecomp_full = nlevgrnd + ! nlevdecomp_full = nlevdecomp + 1 !jkolassa Nov 2024: nlevdecomp_full needs to be larger than nlevdecomp + ! when use_vertsoilc is true + else + nlevdecomp = 1 + nlevdecomp_full = 1 + end if + + if (.not. use_extralakelayers) then + nlevlak = 10 ! number of lake layers + else + nlevlak = 25 ! number of lake layers (Yields better results for site simulations) + end if + + if ( use_fates ) then + i_cwd = 0 + if (use_century_decomp) then + ndecomp_pools = 6 + ndecomp_cascade_transitions = 8 + else + ndecomp_pools = 7 + ndecomp_cascade_transitions = 7 + end if + else + i_cwd = 4 + if (use_century_decomp) then + ndecomp_pools = 7 + ndecomp_cascade_transitions = 10 + ndecomp_cascade_outtransitions = 0 + else + ndecomp_pools = 8 + ndecomp_cascade_transitions = 9 + ndecomp_cascade_outtransitions = 1 + end if + endif + ndecomp_pools_vr = ndecomp_pools * nlevdecomp + + if (use_crop)then + nvegcpool = nvegpool_natveg + nvegpool_crop + ncphtrans = 18 + nnphtrans = 37 + ncphouttrans = 4 + nnphouttrans = 5 + else + nvegcpool = nvegpool_natveg + ncphtrans = 17 + nnphtrans = 34 + ncphouttrans = 3 + nnphouttrans = 4 + end if + ncgmtrans = 18 + ncgmouttrans = 18 + ncfitrans = 20 + ncfiouttrans = 18 + nngmtrans = 19 + nngmouttrans = 19 + nnfitrans = 21 + nnfiouttrans = 19 + nvegnpool = nvegcpool + 1 + iretransn = nvegnpool + ioutc = nvegcpool + 1 + ioutn = nvegnpool + 1 + + + end subroutine clm_varpar_init + +end module clm_varpar +! + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/cmake/genf90_utils.cmake b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/cmake/genf90_utils.cmake new file mode 100755 index 000000000..870cf4e43 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/cmake/genf90_utils.cmake @@ -0,0 +1,91 @@ +# Utility for invoking genf90 on a template file. +# +# If ENABLE_GENF90 is set to a true value, the functions here will behave +# as described below. In this case, the variable GENF90 must be defined and +# contain the genf90.pl command. +# +# If ENABLE_GENF90 is not true, no source code generation or other side +# effects will occur, but output variables will be set as if the generation +# had occurred. +# +#========================================================================== +# +# process_genf90_source_list +# +# Arguments: +# genf90_file_list - A list of template files to process. +# output_directory - Directory where generated sources will be placed. +# fortran_list_name - The name of a list used as output. +# +# Produces generated sources for each of the input templates. Then +# this function *appends* the location of each generated file to the output +# list. +# +# As a side effect, this function will add a target for each generated +# file. For a generated file named "foo.F90", the target will be named +# "generate_foo". +# +# Limitations: +# This function adds targets to work around a deficiency in CMake (see +# "declare_generated_dependencies" in Sourcelist_utils). Unfortunately, +# this means that you cannot use this function to generate two files +# with the same name in a single project. +# +#========================================================================== + +#========================================================================== +# Copyright (c) 2013-2014, University Corporation for Atmospheric Research +# +# This software is distributed under a two-clause BSD license, with no +# warranties, express or implied. See the accompanying LICENSE file for +# details. +#========================================================================== + +#if(ENABLE_GENF90) +if(TRUE) + + # Notify CMake that a Fortran file can be generated from a genf90 + # template. + function(preprocess_genf90_template genf90_file fortran_file) + + add_custom_command(OUTPUT ${fortran_file} + COMMAND ${GENF90} ${genf90_file} >${fortran_file} + MAIN_DEPENDENCY ${genf90_file}) + + get_filename_component(stripped_name ${fortran_file} NAME_WE) + + add_custom_target(generate_${stripped_name} DEPENDS ${fortran_file}) + + endfunction(preprocess_genf90_template) + +else() + + # Stub if genf90 is off. + function(preprocess_genf90_template) + endfunction() + +endif() + +# Auto-generate source names. +function(process_genf90_source_list genf90_file_list output_directory + fortran_list_name) + + foreach(genf90_file IN LISTS genf90_file_list) + + # If a file is a relative path, expand it (relative to current source + # directory. + get_filename_component(genf90_file "${genf90_file}" ABSOLUTE) + + # Get extensionless base name from input. + get_filename_component(genf90_file_stripped "${genf90_file}" NAME_WE) + + # Add generated file to the test list. + set(fortran_file ${output_directory}/${genf90_file_stripped}.F90) + preprocess_genf90_template(${genf90_file} ${fortran_file}) + list(APPEND ${fortran_list_name} ${fortran_file}) + endforeach() + + # Export ${fortran_list_name} to the caller. + set(${fortran_list_name} "${${fortran_list_name}}" PARENT_SCOPE) + +endfunction(process_genf90_source_list) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/column_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/column_varcon.F90 new file mode 100755 index 000000000..4a69438a8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/column_varcon.F90 @@ -0,0 +1,170 @@ +module column_varcon + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing column indices and associated variables and routines. + ! + ! !USES: +#include "shr_assert.h" + use landunit_varcon, only : isturb_MIN + ! + ! !PUBLIC TYPES: + implicit none + save + private + + !------------------------------------------------------------------ + ! Initialize column type constants + !------------------------------------------------------------------ + + ! urban column types + + integer, parameter, public :: icol_roof = isturb_MIN*10 + 1 + integer, parameter, public :: icol_sunwall = isturb_MIN*10 + 2 + integer, parameter, public :: icol_shadewall = isturb_MIN*10 + 3 + integer, parameter, public :: icol_road_imperv = isturb_MIN*10 + 4 + integer, parameter, public :: icol_road_perv = isturb_MIN*10 + 5 + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: is_hydrologically_active ! returns true if the given column type is hydrologically active + public :: icemec_class_to_col_itype ! convert an icemec class (1..maxpatch_glcmec) into col%itype + public :: col_itype_to_icemec_class ! convert col%itype into an icemec class (1..maxpatch_glcmec) +! public :: write_coltype_metadata ! write column type metadata to a netcdf file + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + function is_hydrologically_active(col_itype, lun_itype) & + result(hydrologically_active) + ! + ! !DESCRIPTION: + ! Returns a logical value saying whether the given column type is hydrologically + ! active + ! + ! Note that calling this can be bad for performance, because it operates on a single + ! point rather than a loop. So in performance-critical parts of the code (or just + ! about anywhere, really), you should use the pre-set col%hydrologically_active(c). + ! + ! !USES: + use landunit_varcon, only : istsoil, istcrop + ! + ! !ARGUMENTS: + logical :: hydrologically_active ! function result + integer, intent(in) :: col_itype ! col%itype value + integer, intent(in) :: lun_itype ! lun%itype value for the landunit on which this column sits + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'is_hydrologically_active' + !----------------------------------------------------------------------- + + ! If we had an easy way to figure out which landunit a column was on based on + ! col_itype (which would be very helpful!), then we wouldn't need lun_itype. + + if (lun_itype == istsoil .or. lun_itype == istcrop) then + hydrologically_active = .true. + else if (col_itype == icol_road_perv) then + hydrologically_active = .true. + else + hydrologically_active = .false. + end if + + end function is_hydrologically_active + + + !----------------------------------------------------------------------- + function icemec_class_to_col_itype(icemec_class) result(col_itype) + ! + ! !DESCRIPTION: + ! Convert an icemec class (1..maxpatch_glcmec) into col%itype + ! + ! !USES: + use clm_varpar, only : maxpatch_glcmec + use landunit_varcon, only : istice_mec + ! + ! !ARGUMENTS: + integer :: col_itype ! function result + integer, intent(in) :: icemec_class ! icemec class, between 1 and maxpatch_glcmec + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'icemec_class_to_col_itype' + !----------------------------------------------------------------------- + + SHR_ASSERT_FL((1 <= icemec_class .and. icemec_class <= maxpatch_glcmec), sourcefile, __LINE__) + + col_itype = istice_mec*100 + icemec_class + + end function icemec_class_to_col_itype + + !----------------------------------------------------------------------- + function col_itype_to_icemec_class(col_itype) result(icemec_class) + ! + ! !DESCRIPTION: + ! Convert a col%itype value (for an icemec landunit) into an icemec class (1..maxpatch_glcmec) + ! + ! !USES: + use clm_varpar, only : maxpatch_glcmec + use landunit_varcon, only : istice_mec + ! + ! !ARGUMENTS: + integer :: icemec_class ! function result + integer, intent(in) :: col_itype ! col%itype value for an icemec landunit + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'col_itype_to_icemec_class' + !----------------------------------------------------------------------- + + icemec_class = col_itype - istice_mec*100 + + ! The following assertion is here to ensure that col_itype is really from an + ! istice_mec landunit + SHR_ASSERT_FL((1 <= icemec_class .and. icemec_class <= maxpatch_glcmec), sourcefile, __LINE__) + + end function col_itype_to_icemec_class + + !----------------------------------------------------------------------- +! subroutine write_coltype_metadata(att_prefix, ncid) +! ! +! ! !DESCRIPTION: +! ! Writes column type metadata to a netcdf file. +! ! +! ! Note that, unlike pft and landunit metadata, this column type metadata is NOT +! ! stored in an array. This is because of the trickiness of encoding column values for +! ! crop & icemec. So instead, other code must call this routine to do the work of +! ! adding the appropriate metadata directly to a netcdf file. +! ! +! ! !USES: +! use ncdio_pio, only : file_desc_t, ncd_global, ncd_putatt +! ! +! ! !ARGUMENTS: +! character(len=*) , intent(in) :: att_prefix ! prefix for attributes (e.g., 'icol_') +! type(file_desc_t) , intent(inout) :: ncid ! local file id +! ! +! ! !LOCAL VARIABLES: +! +! character(len=*), parameter :: subname = 'write_coltype_metadata' +! !----------------------------------------------------------------------- +! +! call ncd_putatt(ncid, ncd_global, att_prefix // 'vegetated_or_bare_soil', 1) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'crop' , 2) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'crop_noncompete' , '2*100+m, m=cft_lb,cft_ub') +! call ncd_putatt(ncid, ncd_global, att_prefix // 'landice' , 3) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'landice_multiple_elevation_classes', '4*100+m, m=1,glcnec') +! call ncd_putatt(ncid, ncd_global, att_prefix // 'deep_lake' , 5) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'wetland' , 6) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'urban_roof' , icol_roof) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'urban_sunwall' , icol_sunwall) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'urban_shadewall' , icol_shadewall) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'urban_impervious_road' , icol_road_imperv) +! call ncd_putatt(ncid, ncd_global, att_prefix // 'urban_pervious_road' , icol_road_perv) +! +! end subroutine write_coltype_metadata + + +end module column_varcon diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/fileutils.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/fileutils.F90 new file mode 100755 index 000000000..b74af4242 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/fileutils.F90 @@ -0,0 +1,179 @@ +module fileutils + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing file I/O utilities + ! + ! !USES: + use shr_sys_mod , only : shr_sys_abort + use clm_varctl , only : iulog + use spmdMod , only : masterproc + ! + ! !PUBLIC TYPES: + implicit none + save + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: get_filename !Returns filename given full pathname + public :: opnfil !Open local unformatted or formatted file + public :: getfil !Obtain local copy of file + public :: relavu !Close and release Fortran unit no longer in use + public :: getavu !Get next available Fortran unit number + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + character(len=256) function get_filename (fulpath) + ! + ! !DESCRIPTION: + ! Returns filename given full pathname + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: fulpath !full pathname + ! + ! !LOCAL VARIABLES: + integer i !loop index + integer klen !length of fulpath character string + !------------------------------------------------------------------------ + + klen = len_trim(fulpath) + do i = klen, 1, -1 + if (fulpath(i:i) == '/') go to 10 + end do + i = 0 +10 get_filename = fulpath(i+1:klen) + + return + end function get_filename + + !------------------------------------------------------------------------ + subroutine getfil (fulpath, locfn, iflag) + ! + ! !DESCRIPTION: + ! Obtain local copy of file + ! First check current working directory + ! Next check full pathname[fulpath] on disk + ! + ! !USES: + use shr_file_mod, only: shr_file_get + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: fulpath !Archival or permanent disk full pathname + character(len=*), intent(out) :: locfn !output local file name + integer, intent(in) :: iflag !0=>abort if file not found 1=>do not abort + ! + ! !LOCAL VARIABLES: + integer i !loop index + integer klen !length of fulpath character string + logical lexist !true if local file exists + !------------------------------------------------------------------------ + + ! get local file name from full name + + locfn = get_filename( fulpath ) + if (len_trim(locfn) == 0) then + if (masterproc) write(iulog,*)'(GETFIL): local filename has zero length' + call shr_sys_abort + else + if (masterproc) write(iulog,*)'(GETFIL): attempting to find local file ', & + trim(locfn) + endif + + ! first check if file is in current working directory. + + inquire (file=locfn,exist=lexist) + if (lexist) then + if (masterproc) write(iulog,*) '(GETFIL): using ',trim(locfn), & + ' in current working directory' + RETURN + endif + + ! second check for full pathname on disk + locfn = fulpath + + inquire (file=fulpath,exist=lexist) + if (lexist) then + if (masterproc) write(iulog,*) '(GETFIL): using ',trim(fulpath) + RETURN + else + if (masterproc) write(iulog,*)'(GETFIL): failed getting file from full path: ', fulpath + if (iflag==0) then + call shr_sys_abort ('GETFIL: FAILED to get '//trim(fulpath)) + else + RETURN + endif + endif + + end subroutine getfil + + !------------------------------------------------------------------------ + subroutine opnfil (locfn, iun, form) + ! + ! !DESCRIPTION: + ! Open file locfn in unformatted or formatted form on unit iun + ! + ! !ARGUMENTS: + character(len=*), intent(in):: locfn !file name + integer, intent(in):: iun !fortran unit number + character(len=1), intent(in):: form !file format: u = unformatted, f = formatted + ! + ! !LOCAL VARIABLES: + integer ioe !error return from fortran open + character(len=11) ft !format type: formatted. unformatted + !------------------------------------------------------------------------ + + if (len_trim(locfn) == 0) then + write(iulog,*)'(OPNFIL): local filename has zero length' + call shr_sys_abort + endif + if (form=='u' .or. form=='U') then + ft = 'unformatted' + else + ft = 'formatted ' + end if + open (unit=iun,file=locfn,status='unknown',form=ft,iostat=ioe) + if (ioe /= 0) then + write(iulog,*)'(OPNFIL): failed to open file ',trim(locfn), & + & ' on unit ',iun,' ierr=',ioe + call shr_sys_abort + else if ( masterproc )then + write(iulog,*)'(OPNFIL): Successfully opened file ',trim(locfn), & + & ' on unit= ',iun + end if + + end subroutine opnfil + + !------------------------------------------------------------------------ + integer function getavu() + ! + ! !DESCRIPTION: + ! Get next available Fortran unit number. + ! + ! !USES: + use shr_file_mod, only : shr_file_getUnit + !------------------------------------------------------------------------ + + getavu = shr_file_getunit() + + end function getavu + + !------------------------------------------------------------------------ + subroutine relavu (iunit) + ! + ! !DESCRIPTION: + ! Close and release Fortran unit no longer in use! + ! + ! !USES: + use shr_file_mod, only : shr_file_freeUnit + ! + ! !ARGUMENTS: + integer, intent(in) :: iunit !Fortran unit number + !------------------------------------------------------------------------ + + close(iunit) + call shr_file_freeUnit(iunit) + + end subroutine relavu + +end module fileutils diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/filterColMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/filterColMod.F90 new file mode 100755 index 000000000..345108588 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/filterColMod.F90 @@ -0,0 +1,443 @@ +module filterColMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Defines a type to hold column-level filters, along with factory methods to help create + ! a column-level filter + ! + ! To loop over the filter, use code like this: + ! do fc = 1, myfilter%num + ! c = myfilter%indices(fc) + ! ... + ! end do + ! + ! !USES: +#include "shr_assert.h" + use decompMod , only : bounds_type + use GridcellType , only : grc + use LandunitType , only : lun + use ColumnType , only : col + use clm_varcon , only : ispval + use clm_varctl , only : iulog + + ! !PUBLIC TYPES: + implicit none + private + save + + type, public :: filter_col_type + integer :: num ! number of points in the filter + integer, allocatable :: indices(:) ! column indices included in the filter + contains + procedure :: equals_filter + generic :: operator(==) => equals_filter + end type filter_col_type + + ! !PUBLIC ROUTINES: + + ! Create an empty filter + public :: col_filter_empty + + ! Create a filter from an array of indices. This is mainly useful for unit testing. + public :: col_filter_from_index_array + + ! Create a filter from a column-level logical array + public :: col_filter_from_logical_array + + ! Create a filter from a column-level logical array, but including only active points + public :: col_filter_from_logical_array_active_only + + ! Create a filter that contains one or more landunit type(s) of interest + public :: col_filter_from_ltypes + + ! Create a filter from a landunit-level logical array + public :: col_filter_from_lunflags + + ! Create a filter from a gridcell-level logical array and an array of landunit type(s) + ! of interest + public :: col_filter_from_grcflags_ltypes + + ! Create a filter from another filter subset by a column-level logical array + public :: col_filter_from_filter_and_logical_array + + ! !PRIVATE ROUTINES: + + ! Whether a given column should be included in the filter based on the active flag + private :: include_based_on_active + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + ! TODO(wjs, 2016-04-07) If repeated reallocation of the indices arrays (every time a + ! filter is recreated - each time through the run loop) is a performance issue, then we + ! could rewrite the creation functions to instead be subroutines that act on an existing + ! filter object: I think this would involve replacing calls to col_filter_empty with + ! something like filter%reset_filter; this would only allocate the indices array if it + ! is not already allocated. + + !----------------------------------------------------------------------- + function col_filter_empty(bounds) result(filter) + ! + ! !DESCRIPTION: + ! Initialize a filter object + ! + ! !ARGUMENTS: + type(filter_col_type) :: filter ! function result + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'col_filter_empty' + !----------------------------------------------------------------------- + + filter%num = 0 + allocate(filter%indices(bounds%endc - bounds%begc + 1)) + + end function col_filter_empty + + !----------------------------------------------------------------------- + function col_filter_from_index_array(bounds, indices_col) result(filter) + ! + ! !DESCRIPTION: + ! Create a filter from an array of indices. + ! + ! This is mainly useful for unit testing. + ! + ! !ARGUMENTS: + type(filter_col_type) :: filter ! function result + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: indices_col(:) ! column-level array of indices to include in filter + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'col_filter_from_index_array' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL(indices_col >= bounds%begc, sourcefile, __LINE__) + SHR_ASSERT_ALL_FL(indices_col <= bounds%endc, sourcefile, __LINE__) + + filter = col_filter_empty(bounds) + + filter%num = size(indices_col) + filter%indices(1:filter%num) = indices_col + + end function col_filter_from_index_array + + + !----------------------------------------------------------------------- + function col_filter_from_logical_array(bounds, logical_col) result(filter) + ! + ! !DESCRIPTION: + ! Create a column-level filter from a column-level logical array. + ! + ! This version does not consider whether a column is active: it simply includes any + ! column 'c' for which logical_col(c) is .true. + ! + ! !ARGUMENTS: + type(filter_col_type) :: filter ! function result + type(bounds_type), intent(in) :: bounds + logical, intent(in) :: logical_col(bounds%begc:) ! column-level logical array + ! + ! !LOCAL VARIABLES: + integer :: c + + character(len=*), parameter :: subname = 'col_filter_from_logical_array' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(logical_col) == (/bounds%endc/)), sourcefile, __LINE__) + + filter = col_filter_empty(bounds) + + do c = bounds%begc, bounds%endc + if (logical_col(c)) then + filter%num = filter%num + 1 + filter%indices(filter%num) = c + end if + end do + + end function col_filter_from_logical_array + + !----------------------------------------------------------------------- + function col_filter_from_logical_array_active_only(bounds, logical_col) result(filter) + ! + ! !DESCRIPTION: + ! Create a column-level filter from a column-level logical array. Only include active + ! points in the filter: even if the logical array is true for a given column, that + ! column is excluded if it is inactive. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(filter_col_type) :: filter ! function result + type(bounds_type), intent(in) :: bounds + logical, intent(in) :: logical_col(bounds%begc:) ! column-level logical array + ! + ! !LOCAL VARIABLES: + integer :: c + + character(len=*), parameter :: subname = 'col_filter_from_logical_array_active_only' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(logical_col) == (/bounds%endc/)), sourcefile, __LINE__) + + filter = col_filter_empty(bounds) + + do c = bounds%begc, bounds%endc + if (col%active(c)) then + if (logical_col(c)) then + filter%num = filter%num + 1 + filter%indices(filter%num) = c + end if + end if + end do + + end function col_filter_from_logical_array_active_only + + + !----------------------------------------------------------------------- + function col_filter_from_ltypes(bounds, ltypes, include_inactive) & + result(filter) + ! + ! !DESCRIPTION: + ! Create a column-level filter that includes one or more landunit type(s) of interest + ! + ! !USES: + ! + ! !ARGUMENTS: + type(filter_col_type) :: filter ! function result + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: ltypes(:) ! landunit type(s) of interest + logical, intent(in) :: include_inactive ! whether inactive points should be included in the filter + ! + ! !LOCAL VARIABLES: + integer :: c + integer :: l + + character(len=*), parameter :: subname = 'col_filter_from_ltypes' + !----------------------------------------------------------------------- + + filter = col_filter_empty(bounds) + + do c = bounds%begc, bounds%endc + if (include_based_on_active(c, include_inactive)) then + l = col%landunit(c) + if (any(ltypes(:) == lun%itype(l))) then + filter%num = filter%num + 1 + filter%indices(filter%num) = c + end if + end if + end do + + end function col_filter_from_ltypes + + !----------------------------------------------------------------------- + function col_filter_from_lunflags(bounds, lunflags, include_inactive) & + result(filter) + ! + ! !DESCRIPTION: + ! Create a column-level filter from a landunit-level logical array. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(filter_col_type) :: filter ! function result + type(bounds_type), intent(in) :: bounds + logical, intent(in) :: lunflags(bounds%begl:) ! landunit-level logical array + logical, intent(in) :: include_inactive ! whether inactive points should be included in the filter + ! + ! !LOCAL VARIABLES: + integer :: c + integer :: l + + character(len=*), parameter :: subname = 'col_filter_from_lunflags' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(lunflags) == (/bounds%endl/)), sourcefile, __LINE__) + + filter = col_filter_empty(bounds) + + do c = bounds%begc, bounds%endc + if (include_based_on_active(c, include_inactive)) then + l = col%landunit(c) + if (lunflags(l)) then + filter%num = filter%num + 1 + filter%indices(filter%num) = c + end if + end if + end do + + end function col_filter_from_lunflags + + + !----------------------------------------------------------------------- + function col_filter_from_grcflags_ltypes(bounds, grcflags, ltypes, include_inactive) & + result(filter) + ! + ! !DESCRIPTION: + ! Create a column-level filter from a gridcell-level logical array and an array of + ! landunit type(s) of interest. The filter will contain all columns for which (a) + ! grcflags is true for the gridcell containing this column, and (b) the landunit type + ! for the landunit containing this column is one of the types in ltypes. + ! + ! !ARGUMENTS: + type(filter_col_type) :: filter ! function result + type(bounds_type), intent(in) :: bounds + logical, intent(in) :: grcflags(bounds%begg:) ! gridcell-level logical array + integer, intent(in) :: ltypes(:) ! landunit type(s) of interest + logical, intent(in) :: include_inactive ! whether inactive points should be included in the filter + ! + ! !LOCAL VARIABLES: + integer :: g ! gridcell index + integer :: l ! landunit index + integer :: c ! column index + integer :: i ! array index + integer :: ltype ! landunit type + + character(len=*), parameter :: subname = 'col_filter_from_grcflags_ltypes' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(grcflags) == (/bounds%endg/)), sourcefile, __LINE__) + + filter = col_filter_empty(bounds) + + ! This loops over g then l then c rather than just looping over all columns, because + ! this is likely more efficient for sparse filters (e.g., sparse grcflags or uncommon + ! ltypes). + do g = bounds%begg, bounds%endg + if (grcflags(g)) then + do i = 1, size(ltypes) + ltype = ltypes(i) + l = grc%landunit_indices(ltype, g) + if (l == ispval) then + cycle + end if + + do c = lun%coli(l), lun%colf(l) + if (include_based_on_active(c, include_inactive)) then + filter%num = filter%num + 1 + filter%indices(filter%num) = c + end if + end do ! c + end do ! i = 1, size(ltypes) + end if ! grcflags(g) + end do ! g + + end function col_filter_from_grcflags_ltypes + + !----------------------------------------------------------------------- + function col_filter_from_filter_and_logical_array(bounds, num_orig, filter_orig, logical_col) & + result(filter) + ! + ! !DESCRIPTION: + ! Create a filter from another filter subset by a column-level logical array + ! + ! !ARGUMENTS: + type(filter_col_type) :: filter ! function result + + ! Accepts separate num & indices arguments rather than a filter of filter_col_type so + ! that this function can be called with old-style filters, where these were stored + ! separately rather than being bundled together. + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: num_orig ! number of points in original filter + integer, intent(in) :: filter_orig(:) ! column indices in original filter + logical, intent(in) :: logical_col(bounds%begc:) ! column-level logical array + ! + ! !LOCAL VARIABLES: + integer :: fc, c + + character(len=*), parameter :: subname = 'col_filter_from_filter_and_logical_array' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(logical_col) == (/bounds%endc/)), sourcefile, __LINE__) + + filter = col_filter_empty(bounds) + + do fc = 1, num_orig + c = filter_orig(fc) + if (logical_col(c)) then + filter%num = filter%num + 1 + filter%indices(filter%num) = c + end if + end do + + end function col_filter_from_filter_and_logical_array + + + !----------------------------------------------------------------------- + pure function include_based_on_active(c, include_inactive) result(include_point) + ! + ! !DESCRIPTION: + ! Returns true if the given column should be included in a filter based on its active + ! flag + ! + ! !ARGUMENTS: + logical :: include_point ! function result + integer, intent(in) :: c ! column index + logical, intent(in) :: include_inactive ! whether inactive points are included in this filter + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'include_based_on_active' + !----------------------------------------------------------------------- + + ! This code is written to avoid the check of col%active if include_inactive is true. + ! This is needed in the case of filters that are created in initialization, before + ! the active flags are set. + if (include_inactive) then + include_point = .true. + else if (col%active(c)) then + include_point = .true. + else + include_point = .false. + end if + + end function include_based_on_active + + + !----------------------------------------------------------------------- + function equals_filter(this, other) result(equal) + ! + ! !DESCRIPTION: + ! Returns true if the two filters are equal. + ! + ! If they differ, prints some information about how they differ. + ! + ! !USES: + ! + ! !ARGUMENTS: + logical :: equal ! function result + class(filter_col_type), intent(in) :: this + class(filter_col_type), intent(in) :: other + ! + ! !LOCAL VARIABLES: + integer :: i + + character(len=*), parameter :: subname = 'equals_filter' + !----------------------------------------------------------------------- + + equal = .true. + + if (this%num /= other%num) then + equal = .false. + write(iulog,*) ' ' + write(iulog,'(a, i0, a, i0)') 'equals_filter false: Sizes differ: ', & + this%num, ' /= ', other%num + else + do i = 1, this%num + if (this%indices(i) /= other%indices(i)) then + equal = .false. + write(iulog,*) ' ' + write(iulog,'(a, i0, a, i0, a, i0)') & + 'equals_filter false: Values differ; first difference at ', & + i, ': ', this%indices(i), ' /= ', other%indices(i) + exit + end if + end do + end if + + end function equals_filter + + +end module filterColMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/genf90.pl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/genf90.pl new file mode 100755 index 000000000..5d35112e9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/genf90.pl @@ -0,0 +1,387 @@ +#!/usr/bin/env perl +use strict; +my $outfile; +# Beginning with F90, Fortran has strict typing of variables based on "TKR" +# (type, kind, and rank). In many cases we want to write subroutines that +# provide the same functionality for different variable types and ranks. In +# order to do this without cut-and-paste duplication of code, we create a +# template file with the extension ".F90.in", which can be parsed by this script +# to generate F90 code for all of the desired specific types. +# +# Keywords are delimited by curly brackets: {} +# +# {TYPE} and {DIMS} are used to generate the specific subroutine names from the +# generic template +# {TYPE} : Variable type name; implemented types are character, 4 or 8 byte real, +# and 4 or 8 byte integer. +# allowed values: text, real, double, int, long, logical +# default values: text, real, double, int +# {VTYPE} : Used to generate variable declarations to match the specific type. +# if {TYPE}=double then {VTYPE} is "real(r8)" +# {ITYPE}, {ITYPENAME} : Used to generate CPP statements for the specific type. +# {MPITYPE} : Used to generate MPI types corresponding to the specific type. +# +# {DIMS} : Rank of arrays, "0" for scalar. +# allowed values: 0-7 +# default values : 0-5 +# {DIMSTR} : Generates the parenthesis and colons used for a variable +# declaration of {DIMS} dimensions. +# if {DIMS}=3 then {DIMSTR} is (:,:,:) +# {REPEAT} : Repeats an expression for each number from 1 to {DIMS}, with each +# iteration separated by commas. +# {REPEAT: foo(#, bar)} +# expands to this: +# foo(1, bar), foo(2, bar), foo(3, bar), ... + +# defaults +my @types = qw(text real double int); +my $vtype = {'text' => 'character(len=*)', + 'real' => 'real(r4)', + 'double' => 'real(r8)', + 'int' => 'integer(i4)', + 'long' => 'integer(i8)', + 'logical' => 'logical' }; +my $itype = {'text' => 100, + 'real' => 101, + 'double' => 102, + 'int' => 103, + 'long' => 104, + 'logical' => 105}; +my $itypename = {'text' => 'TYPETEXT', + 'real' => 'TYPEREAL', + 'double' => 'TYPEDOUBLE', + 'int' => 'TYPEINT', + 'long' => 'TYPELONG', + 'logical' => 'TYPELOGICAL'}; +my $mpitype = {'text' => 'MPI_CHARACTER', + 'real' => 'MPI_REAL4', + 'double' => 'MPI_REAL8', + 'int' => 'MPI_INTEGER'}; +# Netcdf C datatypes +my $nctype = {'text' => 'text', + 'real' => 'float', + 'double' => 'double', + 'int' => 'int'}; +# C interoperability types +my $ctype = {'text' => 'character(C_CHAR)', + 'real' => 'real(C_FLOAT)', + 'double' => 'real(C_DOUBLE)', + 'int' => 'integer(C_INT)'}; + + + +my @dims =(0..5); + +my $write_dtypes = "no"; +# begin + +foreach(@ARGV){ + my $infile = $_; + usage() unless($infile =~ /(.*.F90).in/); + $outfile = $1; + open(F,"$infile") || die "$0 Could not open $infile to read"; + my @parsetext; + my $cnt=0; + foreach(){ + $cnt++; + if(/^\s*contains/i){ + push(@parsetext,"# $cnt \"$infile\"\n"); + } + if(/^\s*interface/i){ + push(@parsetext,"# $cnt \"$infile\"\n"); + } + if(/^[^!]*subroutine/i){ + push(@parsetext,"# $cnt \"$infile\"\n"); + } + if(/^[^!]*function/i){ + push(@parsetext,"# $cnt \"$infile\"\n"); + } + + push(@parsetext,$_); + } + + close(F); + + my $end; + my $contains=0; + my $in_type_block=0; + my @unit; + my $unitcnt=0; + my $date = localtime(); + my $preamble = +"!=================================================== +! DO NOT EDIT THIS FILE, it was generated using $0 +! Any changes you make to this file may be lost +!===================================================\n"; + my @output ; + push(@output,$preamble); + + my $line; + my $dimmodifier; + my $typemodifier; + my $itypeflag; + my $block; + my $block_type; + my $cppunit; + foreach $line (@parsetext){ +# skip parser comments + next if($line =~ /\s*!pl/); + + $itypeflag=1 if($line =~ /{ITYPE}/); + $itypeflag=1 if($line =~ /TYPETEXT/); + $itypeflag=1 if($line =~ /TYPEREAL/); + $itypeflag=1 if($line =~ /TYPEDOUBLE/); + $itypeflag=1 if($line =~ /TYPEINT/); + $itypeflag=1 if($line =~ /TYPELONG/); + + + if($contains==0){ + if($line=~/\s*!\s*DIMS\s+[\d,]+!*/){ + $dimmodifier=$line; + next; + } + if($line=~/\s*!\s*TYPE\s+[^!]+!*$/){ + $typemodifier=$line; + next; + } + if ((defined $typemodifier or defined $dimmodifier) + and not defined $block and $line=~/^\s*#[^{]*$/) { + push(@output, $line); + next; + } + # Figure out the bounds of a type statement. + # Type blocks start with "type," "type foo" or "type::" but not + # "type(". + $in_type_block=1 if($line=~/^\s*type\s*[,:[:alpha:]]/i); + $in_type_block=0 if($line=~/^\s*end\s*type/i); + if(not defined $block) { + if ($line=~/^\s*type[^[:alnum:]_].*(\{TYPE\}|\{DIMS\})/i or + $line=~/^[^!]*(function|subroutine).*(\{TYPE\}|\{DIMS\})/i) { + $block=$line; + next; + } + if ($line=~/^\s*interface.*(\{TYPE\}|\{DIMS\})/i) { + $block_type="interface"; + $block=$line; + next; + } + } + if(not defined $block_type and + ($line=~/^\s*end\s+type\s+.*(\{TYPE\}|\{DIMS\})/i or + $line=~/^\s*end\s+(function|subroutine)\s+.*(\{TYPE\}|\{DIMS\})/i)){ + + $line = $block.$line; + undef $block; + } + if ($line=~/^\s*end\s*interface/i and + defined $block) { + $line = $block.$line; + undef $block; + undef $block_type; + } + if(defined $block){ + $block = $block.$line; + next; + } + if(defined $dimmodifier){ + $line = $dimmodifier.$line; + undef $dimmodifier; + } + if(defined $typemodifier){ + $line = $typemodifier.$line; + undef $typemodifier; + } + + push(@output, buildout($line)); + if(($line =~ /^\s*contains\s*!*/i && ! $in_type_block) or + ($line =~ /^\s*!\s*Not a module/i)){ + $contains=1; + next; + } + } + if($line=~/^\s*end module\s*/){ + $end = $line; + last; + } + + if($contains==1){ + # first parse into functions or subroutines + if($cppunit || !(defined($unit[$unitcnt]))){ + # Make cpp lines and blanks between routines units. + if($line =~ /^\s*\#(?!\s[[:digit:]]+)/ || $line =~/^\s*$/ || $line=~/^\s*!(?!\s*(TYPE|DIMS))/){ + push(@{$unit[$unitcnt]},$line); + $cppunit=1; + next; + } else { + $cppunit=0; + $unitcnt++; + } + } + + + push(@{$unit[$unitcnt]},$line); + if ($line=~/^\s*interface/i) { + $block_type="interface"; + $block=$line; + } + if ($line=~/^\s*end\s*interface/i) { + undef $block_type; + undef $block; + } + unless(defined $block){ + if($line =~ /\s*end function/i or $line =~ /\s*end subroutine/i){ + $unitcnt++; + } + } + } + } + my $i; + + + for($i=0;$i<$unitcnt;$i++){ + if(defined($unit[$i])){ + my $func = join('',@{$unit[$i]}); + push(@output, buildout($func)); + } + } + push(@output,@{$unit[$#unit]}) if($unitcnt==$#unit); + push(@output, $end); + if($itypeflag==1){ + my $str; + $str.="#include \"dtypes.h\"\n"; + $write_dtypes = "yes"; + print $str; + } + print @output; + writedtypes() if(!(-e "dtypes.h") && $write_dtypes == "yes"); + + +} + + +sub usage{ + die("$0 Expected input filename of the form .*.F90.in"); +} + +sub build_repeatstr{ + my($dims) = @_; + # Create regex to repeat expression DIMS times. + my $repeatstr; + for(my $i=1;$i<=$dims;$i++){ + $repeatstr .="\$\{1\}$i\$\{2\},&\n"; + } + if(defined $repeatstr){ + $repeatstr="\"$repeatstr"; + chop $repeatstr; + chop $repeatstr; + chop $repeatstr; + $repeatstr.="\""; + }else{ + $repeatstr=''; + } +} + +sub writedtypes{ + open(F,">dtypes.h"); + print F +"#define TYPETEXT 100 +#define TYPEREAL 101 +#define TYPEDOUBLE 102 +#define TYPEINT 103 +#define TYPELONG 104 +#define TYPELOGICAL 105 +"; + close(F); +} + +sub buildout{ + my ($func) = @_; + + my $outstr; + my(@ldims, @ltypes); + + if($func=~/\s*!\s*DIMS\s+([\d,]+)\s*/){ + @ldims = split(/,/,$1); + }else{ + @ldims = @dims; + } + if($func=~/\s*!\s*TYPE\s+([^!\s]+)\s*/){ + @ltypes = split(/,/,$1); +# print ">$func<>@ltypes<\n"; + }else{ + @ltypes = @types; + } + + + if(($func =~ /{TYPE}/ && $func =~ /{DIMS}/) ){ + my ($type, $dims); + foreach $type (@ltypes){ + foreach $dims (@ldims){ + my $dimstr; + for(my $i=1;$i<=$dims;$i++){ + $dimstr .=':,'; + } + if(defined $dimstr){ + $dimstr="($dimstr"; + chop $dimstr; + $dimstr.=')'; + }else{ + $dimstr=''; + } + + my $repeatstr = build_repeatstr($dims); + + my $str = $func; + $str =~ s/{TYPE}/$type/g; + $str =~ s/{VTYPE}/$vtype->{$type}/g; + $str =~ s/{ITYPE}/$itype->{$type}/g; + $str =~ s/{MPITYPE}/$mpitype->{$type}/g; + $str =~ s/{NCTYPE}/$nctype->{$type}/g; + $str =~ s/{CTYPE}/$ctype->{$type}/g; + $str =~ s/{DIMS}/$dims/g; + $str =~ s/{DIMSTR}/$dimstr/g; + $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; + $outstr .= $str; + } + } + }elsif($func =~ /{DIMS}/){ + my $dims; + foreach $dims (@ldims){ + my $dimstr; + for(my $i=1;$i<=$dims;$i++){ + $dimstr .=':,'; + } + if(defined $dimstr){ + $dimstr="($dimstr"; + chop $dimstr; + $dimstr.=')'; + }else{ + $dimstr=''; + } + + my $repeatstr = build_repeatstr($dims); + + my $str = $func; + $str =~ s/{DIMS}/$dims/g; + $str =~ s/{DIMSTR}/$dimstr/g; + $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; + $outstr .= $str; + } + }elsif($func =~ /{TYPE}/){ + my ($type); + foreach $type (@ltypes){ + my $str = $func; + $str =~ s/{TYPE}/$type/g; + $str =~ s/{VTYPE}/$vtype->{$type}/g; + $str =~ s/{ITYPE}/$itype->{$type}/g; + $str =~ s/{MPITYPE}/$mpitype->{$type}/g; + $str =~ s/{NCTYPE}/$nctype->{$type}/g; + $str =~ s/{CTYPE}/$ctype->{$type}/g; + $outstr.=$str; + } + }else{ + $outstr=$func; + } + + return $outstr; +} diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/initSubgridMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/initSubgridMod.F90 new file mode 100755 index 000000000..43851c337 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/initSubgridMod.F90 @@ -0,0 +1,477 @@ +module initSubgridMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Lower-level routines for initializing the subgrid structure. This module is shared + ! between both the production code (via initGridCellsMod) and unit testing code. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc + use abortutils , only : endrun + use clm_varctl , only : iulog, use_fates + use clm_varcon , only : namep, namec, namel + use decompMod , only : bounds_type + use GridcellType , only : grc + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use column_varcon , only : is_hydrologically_active + ! + ! !PUBLIC TYPES: + implicit none + private + save + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: clm_ptrs_compdown ! fill in data pointing down + public :: clm_ptrs_check ! checks and writes out a summary of subgrid data + public :: add_landunit ! add an entry in the landunit-level arrays + public :: add_column ! add an entry in the column-level arrays + public :: add_patch ! add an entry in the patch-level arrays + ! + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------------ + subroutine clm_ptrs_compdown(bounds) + ! + ! !DESCRIPTION: + ! Assumes the part of the subgrid pointing up has been set. Fills + ! in the data pointing down. Up is p_c, p_l, p_g, c_l, c_g, and l_g. + ! + ! This algorithm assumes all indices besides grid cell are monotonically + ! increasing. (Note that grid cell index is NOT monotonically increasing, + ! hence we cannot set initial & final indices at the grid cell level - + ! grc%luni, grc%lunf, etc.) + ! + ! Algorithm works as follows. The p, c, and l loops march through + ! the full arrays (nump, numc, and numl) checking the "up" indexes. + ! As soon as the "up" index of the current (p,c,l) cell changes relative + ! to the previous (p,c,l) cell, the *i array will be set to point down + ! to that cell. The *f array follows the same logic, so it's always the + ! last "up" index from the previous cell when an "up" index changes. + ! + ! For example, a case where p_c(1:4) = 1 and p_c(5:12) = 2. This + ! subroutine will set c_pi(1) = 1, c_pf(1) = 4, c_pi(2) = 5, c_pf(2) = 12. + ! + ! !USES + use clm_varcon, only : ispval + ! + ! !ARGUMENTS + implicit none + type(bounds_type), intent(in) :: bounds ! bounds + ! + ! !LOCAL VARIABLES: + integer :: l,c,p ! loop counters + integer :: curg,curl,curc,curp ! tracks g,l,c,p indexes in arrays + integer :: ltype ! landunit type + !------------------------------------------------------------------------------ + + !--- Set the current c,l (curc, curl) to zero for initialization, + !--- these indices track the current "up" index. + !--- Take advantage of locality of l/c/p cells + !--- Loop p through full local begp:endp length + !--- Separately check the p_c, p_l, and p_g indexes for a change in + !--- the "up" index. + !--- If there is a change, verify that the current c,l,g is within the + !--- valid range, and set c_pi, l_pi, or g_pi to that current c,l,g + !--- Constantly update the c_pf, l_pf, and g_pf array. When the + !--- g, l, c index changes, the *_pf array will be set correctly + !--- Do the same for cols setting c_li, c_gi, c_lf, c_gf and + !--- lunits setting l_gi, l_gf. + + curc = 0 + curl = 0 + do p = bounds%begp,bounds%endp + if (patch%column(p) /= curc) then + curc = patch%column(p) + if (curc < bounds%begc .or. curc > bounds%endc) then + write(iulog,*) 'clm_ptrs_compdown ERROR: pcolumn ',p,curc,bounds%begc,bounds%endc + call endrun(decomp_index=p, clmlevel=namep, msg=errMsg(sourcefile, __LINE__)) + endif + col%patchi(curc) = p + endif + col%patchf(curc) = p + col%npatches(curc) = col%patchf(curc) - col%patchi(curc) + 1 + if (patch%landunit(p) /= curl) then + curl = patch%landunit(p) + if (curl < bounds%begl .or. curl > bounds%endl) then + write(iulog,*) 'clm_ptrs_compdown ERROR: plandunit ',p,curl,bounds%begl,bounds%endl + call endrun(decomp_index=p, clmlevel=namep, msg=errMsg(sourcefile, __LINE__)) + endif + lun%patchi(curl) = p + endif + lun%patchf(curl) = p + lun%npatches(curl) = lun%patchf(curl) - lun%patchi(curl) + 1 + enddo + + curl = 0 + do c = bounds%begc,bounds%endc + if (col%landunit(c) /= curl) then + curl = col%landunit(c) + if (curl < bounds%begl .or. curl > bounds%endl) then + write(iulog,*) 'clm_ptrs_compdown ERROR: clandunit ',c,curl,bounds%begl,bounds%endl + call endrun(decomp_index=c, clmlevel=namec, msg=errMsg(sourcefile, __LINE__)) + endif + lun%coli(curl) = c + endif + lun%colf(curl) = c + lun%ncolumns(curl) = lun%colf(curl) - lun%coli(curl) + 1 + enddo + + ! Determine landunit_indices: indices into landunit-level arrays for each grid cell. + ! Note that landunits not present in a given grid cell are set to ispval. + grc%landunit_indices(:,bounds%begg:bounds%endg) = ispval + do l = bounds%begl,bounds%endl + ltype = lun%itype(l) + curg = lun%gridcell(l) + if (curg < bounds%begg .or. curg > bounds%endg) then + write(iulog,*) 'clm_ptrs_compdown ERROR: landunit_indices ', l,curg,bounds%begg,bounds%endg + call endrun(decomp_index=l, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) + end if + + if (grc%landunit_indices(ltype, curg) == ispval) then + grc%landunit_indices(ltype, curg) = l + else + write(iulog,*) 'clm_ptrs_compdown ERROR: This landunit type has already been set for this gridcell' + write(iulog,*) 'l, ltype, curg = ', l, ltype, curg + call endrun(decomp_index=l, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) + end if + end do + + end subroutine clm_ptrs_compdown + + !------------------------------------------------------------------------------ + subroutine clm_ptrs_check(bounds) + ! + ! !DESCRIPTION: + ! Checks and writes out a summary of subgrid data + ! + ! !USES + use clm_varcon, only : ispval + use landunit_varcon, only : max_lunit + ! + ! !ARGUMENTS + implicit none + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g,l,c,p ! loop counters + integer :: l_prev ! l value of previous point + integer :: ltype ! landunit type + logical :: error ! error flag + !------------------------------------------------------------------------------ + + associate( & + begg => bounds%begg, & + endg => bounds%endg, & + begl => bounds%begl, & + endl => bounds%endl, & + begc => bounds%begc, & + endc => bounds%endc, & + begp => bounds%begp, & + endp => bounds%endp & + ) + + if (masterproc) write(iulog,*) ' ' + if (masterproc) write(iulog,*) '---clm_ptrs_check:' + + !--- check index ranges --- + error = .false. + do g = begg, endg + do ltype = 1, max_lunit + l = grc%landunit_indices(ltype, g) + if (l /= ispval) then + if (l < begl .or. l > endl) error = .true. + end if + end do + end do + if (error) then + write(iulog,*) ' clm_ptrs_check: g index ranges - ERROR' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (masterproc) write(iulog,*) ' clm_ptrs_check: g index ranges - OK' + + error = .false. + if (minval(lun%gridcell(begl:endl)) < begg .or. maxval(lun%gridcell(begl:endl)) > endg) error=.true. + if (minval(lun%coli(begl:endl)) < begc .or. maxval(lun%coli(begl:endl)) > endc) error=.true. + if (minval(lun%colf(begl:endl)) < begc .or. maxval(lun%colf(begl:endl)) > endc) error=.true. + if (minval(lun%patchi(begl:endl)) < begp .or. maxval(lun%patchi(begl:endl)) > endp) error=.true. + if (minval(lun%patchf(begl:endl)) < begp .or. maxval(lun%patchf(begl:endl)) > endp) error=.true. + if (error) then + write(iulog,*) ' clm_ptrs_check: l index ranges - ERROR' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + if (masterproc) write(iulog,*) ' clm_ptrs_check: l index ranges - OK' + + error = .false. + if (minval(col%gridcell(begc:endc)) < begg .or. maxval(col%gridcell(begc:endc)) > endg) error=.true. + if (minval(col%landunit(begc:endc)) < begl .or. maxval(col%landunit(begc:endc)) > endl) error=.true. + if (minval(col%patchi(begc:endc)) < begp .or. maxval(col%patchi(begc:endc)) > endp) error=.true. + if (minval(col%patchf(begc:endc)) < begp .or. maxval(col%patchf(begc:endc)) > endp) error=.true. + if (error) then + write(iulog,*) ' clm_ptrs_check: c index ranges - ERROR' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + if (masterproc) write(iulog,*) ' clm_ptrs_check: c index ranges - OK' + + error = .false. + if (minval(patch%gridcell(begp:endp)) < begg .or. maxval(patch%gridcell(begp:endp)) > endg) error=.true. + if (minval(patch%landunit(begp:endp)) < begl .or. maxval(patch%landunit(begp:endp)) > endl) error=.true. + if (minval(patch%column(begp:endp)) < begc .or. maxval(patch%column(begp:endp)) > endc) error=.true. + if (error) then + write(iulog,*) ' clm_ptrs_check: p index ranges - ERROR' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + if (masterproc) write(iulog,*) ' clm_ptrs_check: p index ranges - OK' + + !--- check that indices in arrays are monotonically increasing --- + error = .false. + do l=begl+1,endl + if ((lun%itype(l) == lun%itype(l-1)) .and. & + lun%gridcell(l) < lun%gridcell(l-1)) then + ! grid cell indices should be monotonically increasing for a given landunit type + error = .true. + end if + if (lun%coli(l) < lun%coli(l-1)) error = .true. + if (lun%colf(l) < lun%colf(l-1)) error = .true. + if (lun%patchi(l) < lun%patchi(l-1)) error = .true. + if (lun%patchf(l) < lun%patchf(l-1)) error = .true. + if (error) then + write(iulog,*) ' clm_ptrs_check: l mono increasing - ERROR' + call endrun(decomp_index=l, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) + endif + enddo + if (masterproc) write(iulog,*) ' clm_ptrs_check: l mono increasing - OK' + + error = .false. + do c=begc+1,endc + l = col%landunit(c) + l_prev = col%landunit(c-1) + if ((lun%itype(l) == lun%itype(l_prev)) .and. & + col%gridcell(c) < col%gridcell(c-1)) then + ! grid cell indices should be monotonically increasing for a given landunit type + error = .true. + end if + if (col%landunit(c) < col%landunit(c-1)) error = .true. + if (col%patchi(c) < col%patchi(c-1)) error = .true. + if (col%patchf(c) < col%patchf(c-1)) error = .true. + if (error) then + write(iulog,*) ' clm_ptrs_check: c mono increasing - ERROR' + call endrun(decomp_index=c, clmlevel=namec, msg=errMsg(sourcefile, __LINE__)) + endif + enddo + if (masterproc) write(iulog,*) ' clm_ptrs_check: c mono increasing - OK' + + error = .false. + do p=begp+1,endp + l = patch%landunit(p) + l_prev = patch%landunit(p-1) + if ((lun%itype(l) == lun%itype(l_prev)) .and. & + patch%gridcell(p) < patch%gridcell(p-1)) then + ! grid cell indices should be monotonically increasing for a given landunit type + error = .true. + end if + if (patch%landunit(p) < patch%landunit(p-1)) error = .true. + if (patch%column (p) < patch%column (p-1)) error = .true. + if (error) then + write(iulog,*) ' clm_ptrs_check: p mono increasing - ERROR' + call endrun(decomp_index=p, clmlevel=namep, msg=errMsg(sourcefile, __LINE__)) + endif + enddo + if (masterproc) write(iulog,*) ' clm_ptrs_check: p mono increasing - OK' + + !--- check that the tree is internally consistent --- + error = .false. + do g = begg, endg + do ltype = 1, max_lunit + l = grc%landunit_indices(ltype, g) + + ! skip l == ispval, which implies that this landunit type doesn't exist on this grid cell + if (l /= ispval) then + if (lun%itype(l) /= ltype) error = .true. + if (lun%gridcell(l) /= g) error = .true. + if (error) then + write(iulog,*) ' clm_ptrs_check: tree consistent - ERROR' + call endrun(decomp_index=l, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) + endif + do c = lun%coli(l),lun%colf(l) + if (col%gridcell(c) /= g) error = .true. + if (col%landunit(c) /= l) error = .true. + if (error) then + write(iulog,*) ' clm_ptrs_check: tree consistent - ERROR' + call endrun(decomp_index=c, clmlevel=namec, msg=errMsg(sourcefile, __LINE__)) + endif + do p = col%patchi(c),col%patchf(c) + if (patch%gridcell(p) /= g) error = .true. + if (patch%landunit(p) /= l) error = .true. + if (patch%column(p) /= c) error = .true. + if (error) then + write(iulog,*) ' clm_ptrs_check: tree consistent - ERROR' + call endrun(decomp_index=p, clmlevel=namep, msg=errMsg(sourcefile, __LINE__)) + endif + enddo ! p + enddo ! c + end if ! l /= ispval + enddo ! ltype + enddo ! g + if (masterproc) write(iulog,*) ' clm_ptrs_check: tree consistent - OK' + if (masterproc) write(iulog,*) ' ' + + end associate + + end subroutine clm_ptrs_check + + !----------------------------------------------------------------------- + subroutine add_landunit(li, gi, ltype, wtgcell) + ! + ! !DESCRIPTION: + ! Add an entry in the landunit-level arrays. li gives the index of the last landunit + ! added; the new landunit is added at li+1, and the li argument is incremented + ! accordingly. + ! + ! !USES: + use landunit_varcon , only : istice_mec, istdlak, isturb_MIN, isturb_MAX, landunit_is_special + ! + ! !ARGUMENTS: + integer , intent(inout) :: li ! input value is index of last landunit added; output value is index of this newly-added landunit + integer , intent(in) :: gi ! grid cell index on which this landunit should be placed + integer , intent(in) :: ltype ! landunit type + real(r8) , intent(in) :: wtgcell ! weight of the landunit relative to the grid cell + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'add_landunit' + !----------------------------------------------------------------------- + + li = li + 1 + + lun%gridcell(li) = gi + lun%wtgcell(li) = wtgcell + lun%itype(li) = ltype + + lun%ifspecial(li) = landunit_is_special(ltype) + + if (ltype == istice_mec) then + lun%glcmecpoi(li) = .true. + else + lun%glcmecpoi(li) = .false. + end if + + if (ltype == istdlak) then + lun%lakpoi(li) = .true. + else + lun%lakpoi(li) = .false. + end if + + if (ltype >= isturb_MIN .and. ltype <= isturb_MAX) then + lun%urbpoi(li) = .true. + else + lun%urbpoi(li) = .false. + end if + + end subroutine add_landunit + + !----------------------------------------------------------------------- + subroutine add_column(ci, li, ctype, wtlunit, type_is_dynamic) + ! + ! !DESCRIPTION: + ! Add an entry in the column-level arrays. ci gives the index of the last column + ! added; the new column is added at ci+1, and the ci argument is incremented + ! accordingly. + ! + ! !ARGUMENTS: + integer , intent(inout) :: ci ! input value is index of last column added; output value is index of this newly-added column + integer , intent(in) :: li ! landunit index on which this column should be placed (assumes this landunit has already been created) + integer , intent(in) :: ctype ! column type + real(r8) , intent(in) :: wtlunit ! weight of the column relative to the landunit + + ! whether this column's type can change at runtime; if not provided, assumed to be false + logical , intent(in), optional :: type_is_dynamic + ! + ! !LOCAL VARIABLES: + logical :: l_type_is_dynamic ! local version of type_is_dynamic + + character(len=*), parameter :: subname = 'add_column' + !----------------------------------------------------------------------- + + l_type_is_dynamic = .false. + if (present(type_is_dynamic)) then + l_type_is_dynamic = type_is_dynamic + end if + + ci = ci + 1 + + col%landunit(ci) = li + col%gridcell(ci) = lun%gridcell(li) + col%wtlunit(ci) = wtlunit + col%itype(ci) = ctype + col%lun_itype(ci) = lun%itype(li) + col%type_is_dynamic(ci) = l_type_is_dynamic + col%hydrologically_active(ci) = is_hydrologically_active( & + col_itype = ctype, & + lun_itype = lun%itype(li)) + col%urbpoi(ci) = lun%urbpoi(li) + + end subroutine add_column + + !----------------------------------------------------------------------- + subroutine add_patch(pi, ci, ptype, wtcol) + ! + ! !DESCRIPTION: + ! Add an entry in the patch-level arrays. pi gives the index of the last patch added; the + ! new patch is added at pi+1, and the pi argument is incremented accordingly. + ! + ! !USES: + use clm_varcon , only : ispval + use landunit_varcon , only : istsoil, istcrop + use clm_varpar , only : natpft_lb + ! + ! !ARGUMENTS: + integer , intent(inout) :: pi ! input value is index of last patch added; output value is index of this newly-added patch + integer , intent(in) :: ci ! column index on which this patch should be placed (assumes this column has already been created) + integer , intent(in) :: ptype ! patch type + real(r8) , intent(in) :: wtcol ! weight of the patch relative to the column + ! + ! !LOCAL VARIABLES: + integer :: li ! landunit index + integer :: lb_offset ! offset between natpft_lb and 1 + + character(len=*), parameter :: subname = 'add_patch' + !----------------------------------------------------------------------- + + pi = pi + 1 + + patch%column(pi) = ci + li = col%landunit(ci) + patch%landunit(pi) = li + patch%gridcell(pi) = col%gridcell(ci) + + patch%wtcol(pi) = wtcol + + ! TODO (MV, 10-17-14): The following must be commented out because + ! currently patch%itype is used in CanopyTemperatureMod to calculate + ! z0m(p) and displa(p) - and is still called even when fates is on + + !if (.not. use_fates) then + patch%itype(pi) = ptype + !end if + + if (lun%itype(li) == istsoil .or. lun%itype(li) == istcrop) then + lb_offset = 1 - natpft_lb + patch%mxy(pi) = ptype + lb_offset + else + patch%mxy(pi) = ispval + end if + + + end subroutine add_patch + + +end module initSubgridMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/landunit_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/landunit_varcon.F90 new file mode 100755 index 000000000..b6ddc7cf5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/landunit_varcon.F90 @@ -0,0 +1,133 @@ +module landunit_varcon + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing landunit indices and associated variables and routines. + ! + ! !USES: +#include "shr_assert.h" + ! + ! + ! !PUBLIC TYPES: + implicit none + private + + !------------------------------------------------------------------ + ! Initialize landunit type constants + !------------------------------------------------------------------ + + integer, parameter, public :: istsoil = 1 !soil landunit type (natural vegetation) + integer, parameter, public :: istcrop = 2 !crop landunit type + ! Landunit 3 currently unused (used to be non-multiple elevation class glacier type: istice) + integer, parameter, public :: istice_mec = 4 !land ice (multiple elevation classes) landunit type + integer, parameter, public :: istdlak = 5 !deep lake landunit type (now used for all lakes) + integer, parameter, public :: istwet = 6 !wetland landunit type (swamp, marsh, etc.) + + integer, parameter, public :: isturb_MIN = 7 !minimum urban type index + integer, parameter, public :: isturb_tbd = 7 !urban tbd landunit type + integer, parameter, public :: isturb_hd = 8 !urban hd landunit type + integer, parameter, public :: isturb_md = 9 !urban md landunit type + integer, parameter, public :: isturb_MAX = 9 !maximum urban type index + + integer, parameter, public :: max_lunit = 9 !maximum value that lun%itype can have + !(i.e., largest value in the above list) + + integer, parameter, public :: landunit_name_length = 40 ! max length of landunit names + character(len=landunit_name_length), public :: landunit_names(max_lunit) ! name of each landunit type + + ! parameters that depend on the above constants + + integer, parameter, public :: numurbl = isturb_MAX - isturb_MIN + 1 ! number of urban landunits + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: landunit_varcon_init ! initialize constants in this module + public :: landunit_is_special ! returns true if this is a special landunit + + ! + ! !PRIVATE MEMBER FUNCTIONS: + private :: set_landunit_names ! set the landunit_names vector +!----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine landunit_varcon_init() + ! + ! !DESCRIPTION: + ! Initialize constants in landunit_varcon + ! + ! !USES: + ! + ! !ARGUMENTS: + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'landunit_varcon_init' + !----------------------------------------------------------------------- + + call set_landunit_names() + + end subroutine landunit_varcon_init + + !----------------------------------------------------------------------- + function landunit_is_special(ltype) result(is_special) + ! + ! !DESCRIPTION: + ! Returns true if the landunit type ltype is a special landunit; returns false otherwise + ! + ! !USES: + ! + ! !ARGUMENTS: + logical :: is_special ! function result + integer :: ltype ! landunit type of interest + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'landunit_is_special' + !----------------------------------------------------------------------- + + SHR_ASSERT((ltype >= 1 .and. ltype <= max_lunit), subname//': ltype out of bounds') + + if (ltype == istsoil .or. ltype == istcrop) then + is_special = .false. + else + is_special = .true. + end if + + end function landunit_is_special + + + !----------------------------------------------------------------------- + subroutine set_landunit_names + ! + ! !DESCRIPTION: + ! Set the landunit_names vector + ! + ! !USES: + use shr_sys_mod, only : shr_sys_abort + ! + character(len=*), parameter :: not_set = 'NOT_SET' + character(len=*), parameter :: unused = 'UNUSED' + character(len=*), parameter :: subname = 'set_landunit_names' + !----------------------------------------------------------------------- + + landunit_names(:) = not_set + + landunit_names(istsoil) = 'vegetated_or_bare_soil' + landunit_names(istcrop) = 'crop' + landunit_names(istcrop+1) = unused + landunit_names(istice_mec) = 'landice_multiple_elevation_classes' + landunit_names(istdlak) = 'deep_lake' + landunit_names(istwet) = 'wetland' + landunit_names(isturb_tbd) = 'urban_tbd' + landunit_names(isturb_hd) = 'urban_hd' + landunit_names(isturb_md) = 'urban_md' + + if (any(landunit_names == not_set)) then + call shr_sys_abort(trim(subname)//': Not all landunit names set') + end if + + end subroutine set_landunit_names + +end module landunit_varcon diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/ncdio_pio.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/ncdio_pio.F90 new file mode 100755 index 000000000..e145c84a1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/ncdio_pio.F90 @@ -0,0 +1,635 @@ +#include "MAPL_Generic.h" + +module ncdio_pio + + !----------------------------------------------------------------------- + !BOP + ! + ! !MODULE: ncdio_pioMod + ! + ! !DESCRIPTION: + ! Generic interfaces to write fields to netcdf files for CLM + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8, i4=>shr_kind_i4, shr_kind_cl, r4 => shr_kind_r4 + !use shr_infnan_mod , only : nan => shr_infnan_nan, isnan => shr_infnan_isnan + use nanMod , only : nan + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : errMsg => shr_log_errMsg + use MAPL , only : file_desc_t => NetCDF4_FileFormatter, pFIO_READ + use MAPL_ExceptionHandling + + ! + ! !PUBLIC TYPES: + implicit none + private + save + ! + ! !PUBLIC MEMBER FUNCTIONS: + ! + public :: ncd_pio_openfile ! open a file + public :: ncd_pio_closefile ! close a file + public :: ncd_io ! write local data + + public file_desc_t + ! + + interface ncd_io + + module procedure ncd_io_char_0d + module procedure ncd_io_char_1d + ! module procedure ncd_io_log_1d + module procedure ncd_io_r4_0d + module procedure ncd_io_r4_1d + module procedure ncd_io_r4_2d + module procedure ncd_io_r4_3d + module procedure ncd_io_r4_4d + module procedure ncd_io_r8_0d + module procedure ncd_io_r8_1d + module procedure ncd_io_r8_2d + module procedure ncd_io_r8_3d + module procedure ncd_io_r8_4d + module procedure ncd_io_i4_0d + module procedure ncd_io_i4_1d + module procedure ncd_io_i4_2d + module procedure ncd_io_i4_3d + module procedure ncd_io_i4_4d + + end interface + + contains + + subroutine ncd_io_char_0d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*), intent(inout) :: data + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer,optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + ! call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_char_0d + + subroutine ncd_io_char_1d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*), intent(inout) :: data(:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer,optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + ! call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_char_1d + +! subroutine ncd_io_log_1d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) +! +! ! ARGUMENTS: +! !------------- +! type(file_desc_t), intent(inout) :: ncid ! netcdf file id +! logical, intent(inout) :: data(:) +! character(len=*), intent(in) :: flag ! 'read' or 'write' +! character(len=*), intent(in) :: varname ! variable name +! logical, intent(out) :: readvar +! integer,optional, intent(out) :: rc +! integer, optional , intent(in) :: nt ! time sample index +! logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file +! +! ! LOCAL: +! +! integer :: status +! +! !------------------------------------- +! +! if (flag == 'read') then +! readvar = .false. +! ! call ncid%get_var(varname, data, rc=status) +! ! call MAPL_VarRead(ncid,varname,data,status) +! if (status ==0) readvar = .true. +! endif +! +! end subroutine ncd_io_log_1d + +!---------------------------------------------------- + subroutine ncd_io_r4_0d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r4), intent(inout) :: data + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer,optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + ! call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r4_0d + +!---------------------------------------------------- + subroutine ncd_io_r4_1d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r4), intent(inout) :: data(:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer,optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + ! call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r4_1d + + !----------------------------------------------------------------------- + + subroutine ncd_io_r4_2d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r4), intent(inout) :: data(:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + ! call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r4_2d + + !----------------------------------------------------------------------- + + subroutine ncd_io_r4_3d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r4), intent(inout) :: data(:,:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r4_3d + + !----------------------------------------------------------------------- + + subroutine ncd_io_r4_4d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r4), intent(inout) :: data(:,:,:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + ! call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r4_4d + + !----------------------------------------------------------------------- + + subroutine ncd_io_r8_0d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r8), intent(inout) :: data + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r8_0d + + !----------------------------------------------------------------------- + + subroutine ncd_io_r8_1d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r8), intent(inout) :: data(:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r8_1d + + !----------------------------------------------------------------------- + + subroutine ncd_io_r8_2d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r8), intent(inout) :: data(:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + ! call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r8_2d + + !----------------------------------------------------------------------- + + + subroutine ncd_io_r8_3d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r8), intent(inout) :: data(:,:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r8_3d + + !----------------------------------------------------------------------- + + + subroutine ncd_io_r8_4d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + real(r8), intent(inout) :: data(:,:,:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_r8_4d + + !----------------------------------------------------------------------- + subroutine ncd_io_i4_0d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer(i4), intent(inout) :: data + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_i4_0d + + !----------------------------------------------------------------------- + + subroutine ncd_io_i4_1d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer(i4), intent(inout) :: data(:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_i4_1d + + !----------------------------------------------------------------------- + + subroutine ncd_io_i4_2d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer(i4), intent(inout) :: data(:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_i4_2d + + !----------------------------------------------------------------------- + subroutine ncd_io_i4_3d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer(i4), intent(inout) :: data(:,:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_i4_3d + + !----------------------------------------------------------------------- + subroutine ncd_io_i4_4d ( varname, data, flag, ncid, readvar, rc, nt, posNOTonfile) + + ! ARGUMENTS: + !------------- + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer(i4), intent(inout) :: data(:,:,:,:) + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + logical, intent(out) :: readvar + integer, optional, intent(out) :: rc + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + + ! LOCAL: + + integer :: status + + !------------------------------------- + + if (flag == 'read') then + readvar = .false. + call ncid%get_var(varname, data, rc=status) + !call MAPL_VarRead(ncid,varname,data,status) + if (status ==0) readvar = .true. + endif + + end subroutine ncd_io_i4_4d + + !----------------------------------------------------------------------- + + subroutine ncd_pio_openfile(file, fname, mode, rc) + ! + ! !DESCRIPTION: + ! Open a NetCDF PIO file + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: file ! Output PIO file handle + character(len=*) , intent(in) :: fname ! Input filename to open + integer , intent(in) :: mode ! file mode + integer, optional , intent(out) :: rc + + ! LOCAL: + + integer :: status + + ! + !----------------------------------------------------------------------- + + + if (mode==0) then + call file%open(trim(fname),pFIO_READ, rc=status) + else + _ASSERT(status==0, "Unrecognized netcdf opening mode") + end if + + end subroutine ncd_pio_openfile + + !----------------------------------------------------------------------- + subroutine ncd_pio_closefile(file) + ! + ! !DESCRIPTION: + ! Close a NetCDF PIO file + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: file ! PIO file handle to close + !----------------------------------------------------------------------- + + call file%close() + + end subroutine ncd_pio_closefile + +end module ncdio_pio diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/paramUtilMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/paramUtilMod.F90 new file mode 100755 index 000000000..76ca91c60 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/paramUtilMod.F90 @@ -0,0 +1,293 @@ +module paramUtilMod + ! + ! module that deals with reading parameter files + ! + use shr_kind_mod , only: r8 => shr_kind_r8 + use ncdio_pio , only : file_desc_t + use ncdio_pio , only : ncd_io + implicit none + save + private + + interface readNcdio + module procedure readNcdioScalar + module procedure readNcdioArray1d + module procedure readNcdioArray2d +! module procedure readNcdioScalarCheckDimensions +! module procedure readNcdioArray1dCheckDimensions +! module procedure readNcdioArray2dCheckDimensions + end interface + + public :: readNcdioScalar + public :: readNcdioArray1d + public :: readNcdioArray2d +! public :: readNcdioScalarCheckDimensions +! public :: readNcdioArray1dCheckDimensions +! public :: readNcdioArray2dCheckDimensions + + public :: readNcdio + +! private :: checkDimensions + +contains + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + subroutine readNcdioScalar(ncid, varName, callingName, retVal) + ! + ! read the netcdf file...generic, could be used for any parameter read + ! + use abortutils , only : endrun + use ncdio_pio , only : file_desc_t, ncd_io + + implicit none + + ! arguments + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + character(len=*), intent(in) :: varName ! variable we are reading + character(len=*), intent(in) :: callingName ! calling routine + real(r8), intent(inout) :: retVal + + ! local vars + character(len=32) :: subname = 'readNcdio::' + character(len=100) :: errCode = ' - Error reading. Var: ' + logical :: readv ! has variable been read in or not + + ! + ! netcdf read here + ! + + call ncd_io(varname=trim(varName),data=retVal, flag='read', ncid=ncid, readvar=readv) + + if ( .not. readv ) then + call endrun(trim(callingName)//trim(subname)//trim(errCode)//trim(varName)) + endif + + end subroutine readNcdioScalar + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + subroutine readNcdioArray1d(ncid, varName, callingName, retVal) + ! + ! read the netcdf file...generic, could be used for any parameter read + ! + use abortutils , only : endrun + use ncdio_pio , only : file_desc_t, ncd_io + + implicit none + + ! arguments + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + character(len=*), intent(in) :: varName ! variable we are reading + character(len=*), intent(in) :: callingName ! calling routine + real(r8), intent(inout) :: retVal( 1: ) + + ! local vars + character(len=32) :: subname = 'readNcdio::' + character(len=100) :: errCode = ' - Error reading. Var: ' + logical :: readv ! has variable been read in or not + + ! + ! netcdf read here + ! + + call ncd_io(varname=trim(varName),data=retVal, flag='read', ncid=ncid, readvar=readv) + + if ( .not. readv ) then + call endrun(trim(callingName)//trim(subname)//trim(errCode)//trim(varName)) + endif + + end subroutine readNcdioArray1d + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- + subroutine readNcdioArray2d(ncid, varName, callingName, retVal) + ! + ! read the netcdf file...generic, could be used for any parameter read + ! + use abortutils , only : endrun + use ncdio_pio , only : file_desc_t, ncd_io + + implicit none + + ! arguments + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + character(len=*), intent(in) :: varName ! variable we are reading + character(len=*), intent(in) :: callingName ! calling routine + real(r8), intent(inout) :: retVal( 1: , :) + + ! local vars + character(len=32) :: subname = 'readNcdio::' + character(len=100) :: errCode = ' - Error reading. Var: ' + logical :: readv ! has variable been read in or not + + ! + ! netcdf read here + ! + + call ncd_io(varname=trim(varName),data=retVal, flag='read', ncid=ncid, readvar=readv) + + if ( .not. readv ) then + call endrun(trim(callingName)//trim(subname)//trim(errCode)//trim(varName)) + endif + + end subroutine readNcdioArray2d + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! + !----------------------------------------------------------------------- +! subroutine readNcdioScalarCheckDimensions(ncid, varName, expected_numDims, expected_dimNames, & +! callingName, retVal) +! ! +! ! read the netcdf file...generic, could be used for any parameter read +! ! +! use abortutils , only : endrun +! use ncdio_pio , only : file_desc_t +! +! implicit none +! +! ! arguments +! type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id +! character(len=*), intent(in) :: varName ! variable we are reading +! integer, intent(in) :: expected_numDims +! character(len=*), intent(in) :: expected_dimNames(:) ! expected dimension name +! character(len=*), intent(in) :: callingName ! calling routine +! real(r8), intent(inout) :: retVal +! +! ! local vars +! character(len=32) :: subname = 'readNcdio::' +! character(len=100) :: errCode = ' - Error reading. Var: ' +! +! ! +! ! netcdf read here +! ! +! call checkDimensions(ncid, varName, expected_numDims, expected_dimNames, subname) +! call readNcdio(ncid, varName, callingName, retVal) +! +! end subroutine readNcdioScalarCheckDimensions +! !----------------------------------------------------------------------- +! +! !----------------------------------------------------------------------- +! ! +! !----------------------------------------------------------------------- +! subroutine readNcdioArray1dCheckDimensions(ncid, varName, expected_numDims, expected_dimNames, & +! callingName, retVal) +! ! +! ! read the netcdf file...generic, could be used for any parameter read +! ! +! use abortutils , only : endrun +! use ncdio_pio , only : file_desc_t +! +! implicit none +! +! ! arguments +! type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id +! character(len=*), intent(in) :: varName ! variable we are reading +! integer, intent(in) :: expected_numDims +! character(len=*), intent(in) :: expected_dimNames(:) ! expected dimension name +! character(len=*), intent(in) :: callingName ! calling routine +! real(r8), intent(inout) :: retVal( 1: ) +! +! ! local vars +! character(len=32) :: subname = 'readNcdio::' +! character(len=100) :: errCode = ' - Error reading. Var: ' +! ! +! ! netcdf read here +! ! +! call checkDimensions(ncid, varName, expected_numDims, expected_dimNames, subname) +! call readNcdio(ncid, varName, callingName, retVal) +! +! end subroutine readNcdioArray1dCheckDimensions +! !----------------------------------------------------------------------- +! +! !----------------------------------------------------------------------- +! ! +! !----------------------------------------------------------------------- +! subroutine readNcdioArray2dCheckDimensions(ncid, varName, expected_numDims, expected_dimNames, & +! callingName, retVal) +! ! +! ! read the netcdf file...generic, could be used for any parameter read +! ! +! use abortutils , only : endrun +! use ncdio_pio , only : file_desc_t +! +! implicit none +! +! ! arguments +! type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id +! character(len=*), intent(in) :: varName ! variable we are reading +! integer, intent(in) :: expected_numDims +! character(len=*), intent(in) :: expected_dimNames(:) ! expected dimension name +! character(len=*), intent(in) :: callingName ! calling routine +! real(r8), intent(inout) :: retVal(1:, : ) +! +! ! local vars +! character(len=32) :: subname = 'readNcdio::' +! character(len=100) :: errCode = ' - Error reading. Var: ' +! ! +! ! netcdf read here +! ! +! call checkDimensions(ncid, varName, expected_numDims, expected_dimNames, subname) +! call readNcdio(ncid, varName, callingName, retVal) +! +! end subroutine readNcdioArray2dCheckDimensions +! !----------------------------------------------------------------------- +! +! !----------------------------------------------------------------------- +! ! +! !----------------------------------------------------------------------- +! subroutine checkDimensions(ncid, varName, expected_numDims, expected_dimNames, callingName) +! ! +! ! Assert that the expected number of dimensions and dimension +! ! names for a variable match the actual names on the file. +! ! +! use abortutils , only : endrun +! use ncdio_pio , only : file_desc_t, var_desc_t, check_var, ncd_inqvdname, ncd_inqvdims +! +! implicit none +! +! ! arguments +! type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id +! character(len=*), intent(in) :: varName ! variable we are reading +! integer, intent(in) :: expected_numDims ! number of expected dimensions on the variable +! character(len=*), intent(in) :: expected_dimNames(:) ! expected dimension names +! character(len=*), intent(in) :: callingName ! calling routine +! integer :: error_num +! +! ! local vars +! character(len=32) :: subname = 'checkDimensions::' +! type(Var_desc_t) :: var_desc ! variable descriptor +! logical :: readvar ! whether the variable was found +! character(len=100) :: received_dimName +! integer :: d, num_dims +! character(len=256) :: msg +! +! call check_var(ncid, varName, readvar, vardesc=var_desc) +! if (readvar) then +! call ncd_inqvdims(ncid, num_dims, var_desc) +! if (num_dims /= expected_numDims) then +! write(msg, *) trim(callingName)//trim(subname)//trim(varname)//":: expected number of dimensions = ", & +! expected_numDims, " num dimensions received from file = ", num_dims +! call endrun(msg) +! end if +! do d = 1, num_dims +! received_dimName = '' +! call ncd_inqvdname(ncid, varname=trim(varName), dimnum=d, dname=received_dimName, err_code=error_num) +! if (trim(expected_dimNames(d)) /= trim(received_dimName)) then +! write(msg, *) trim(callingName)//trim(subname)//trim(varname)//":: dimension ", d, & +! " expected dimension name '"//trim(expected_dimNames(d))//& +! "' dimension name received from file '"//trim(received_dimName)//"'." +! call endrun(msg) +! end if +! end do +! end if +! +! end subroutine checkDimensions + !----------------------------------------------------------------------- + +end module paramUtilMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/perf_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/perf_mod.F90 new file mode 100755 index 000000000..4a94de41e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/perf_mod.F90 @@ -0,0 +1,98 @@ +module perf_mod + +!----------------------------------------------------------------------- +! +! Purpose: This module is responsible for controlling the performance +! timer logic. +! +! Author: P. Worley, January 2007 +! +! $Id$ +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!- Uses ---------------------------------------------------------------- +!----------------------------------------------------------------------- + + use shr_sys_mod, only: shr_sys_abort + use shr_kind_mod, only: SHR_KIND_CS, SHR_KIND_CM, SHR_KIND_CX, & + SHR_KIND_R8, SHR_KIND_I8 + +!----------------------------------------------------------------------- +!- module boilerplate -------------------------------------------------- +!----------------------------------------------------------------------- + implicit none + private ! Make the default access private + save + +!----------------------------------------------------------------------- +! Public interfaces ---------------------------------------------------- +!----------------------------------------------------------------------- + public t_startf + public t_stopf + +!======================================================================= +contains +!======================================================================= +!======================================================================== +! + subroutine t_startf(event, handle) +!----------------------------------------------------------------------- +! Purpose: Start an event timer +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer event name + character(len=*), intent(in) :: event +! +!---------------------------Input/Output arguments---------------------- +! + ! GPTL event handle + integer, optional :: handle +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return + integer str_length, i ! support for adding + ! detail prefix + character(len=2) cdetail ! char variable for detail +! +!----------------------------------------------------------------------- +! + + return + end subroutine t_startf +! +!======================================================================== +! + subroutine t_stopf(event, handle) +!----------------------------------------------------------------------- +! Purpose: Stop an event timer +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer event name + character(len=*), intent(in) :: event +! +!---------------------------Input/Output arguments---------------------- +! + ! GPTL event handle + integer, optional :: handle +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return + integer str_length, i ! support for adding + ! detail prefix + character(len=2) cdetail ! char variable for detail +! +!----------------------------------------------------------------------- +! + + return + end subroutine t_stopf +! +end module perf_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/quadraticMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/quadraticMod.F90 new file mode 100755 index 000000000..87bb25094 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/quadraticMod.F90 @@ -0,0 +1,76 @@ +module quadraticMod + + use abortutils , only: endrun + use shr_kind_mod, only: r8 => shr_kind_r8 + use shr_log_mod , only: errMsg => shr_log_errMsg + use clm_varctl , only: iulog + + implicit none + + public :: quadratic + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + subroutine quadratic (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 + ! + ! !USES: + implicit none + ! + ! !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 + real(r8) :: root ! Term that will have a square root taken + character(len=*), parameter :: subname = 'quadratic' + !------------------------------------------------------------------------------ + + if (a == 0._r8) then + write (iulog,*) subname//' ERROR: Quadratic solution error: a = ',a + write (iulog,*) errmsg(sourcefile, __LINE__) + call endrun(msg=subname//' ERROR: Quadratic solution error' ) + return + end if + + root = b*b - 4._r8*a*c + if ( root < 0.0 )then + if ( -root < 3.0_r8*epsilon(b) )then + root = 0.0_r8 + else + write (iulog,*) subname//' ERROR: Quadratic solution error: b^2 - 4ac is negative = ', root + write (iulog,*) errmsg(sourcefile, __LINE__) + call endrun( msg=subname//' ERROR: Quadratic solution error: b^2 - 4ac is negative' ) + return + end if + end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(root)) + else + q = -0.5_r8 * (b - sqrt(root)) + end if + + r1 = q / a + if (q /= 0._r8) then + r2 = c / q + else + r2 = 1.e36_r8 + end if + + end subroutine quadratic + +end module quadraticMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_abort_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_abort_mod.F90 new file mode 100755 index 000000000..bc97791a4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_abort_mod.F90 @@ -0,0 +1,166 @@ +#include "MAPL_Generic.h" + +module shr_abort_mod + ! This module defines procedures that can be used to abort the model cleanly in a + ! system-specific manner + ! + ! The public routines here are only meant to be used directly by shr_sys_mod. Other code + ! that wishes to use these routines should use the republished names from shr_sys_mod + ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from + ! when these routines were defined in shr_sys_mod.) + + use, intrinsic :: iso_fortran_env, only: output_unit, error_unit + + use MAPL_ExceptionHandling + use shr_kind_mod, only : shr_kind_in, shr_kind_cx +! use shr_mpi_mod , only : shr_mpi_initialized, shr_mpi_abort + use shr_log_mod , only : s_logunit => shr_log_Unit + +!#ifdef CPRNAG +! ! NAG does not provide this as an intrinsic, but it does provide modules +! ! that implement commonly used POSIX routines. +! use f90_unix_proc, only: abort +!#endif + + implicit none + + ! PUBLIC: Public interfaces + + private + + ! The public routines here are only meant to be used directly by shr_sys_mod. Other code + ! that wishes to use these routines should use the republished names from shr_sys_mod + ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from + ! when these routines were defined in shr_sys_mod.) + public :: shr_abort_abort ! abort a program + ! public :: shr_abort_backtrace ! print a backtrace, if possible + +contains + + !=============================================================================== + subroutine shr_abort_abort(string,ec,rc) + ! Consistent stopping mechanism + + !----- arguments ----- + character(len=*) , intent(in) , optional :: string ! error message string + integer(shr_kind_in), intent(in) , optional :: ec ! error code + integer(shr_kind_in), intent(out), optional :: rc ! error code + + !----- local ----- + !logical :: flag + + ! Local version of the string. + ! (Gets a default value if string is not present.) + character(len=shr_kind_cx) :: local_string + !------------------------------------------------------------------------------- + + if (present(string)) then + local_string = trim(string) + else + local_string = "Unknown error submitted to shr_abort_abort." + end if + + call print_error_to_logs("ERROR", local_string) + + ! call shr_abort_backtrace() + +! call shr_mpi_initialized(flag) + + if (present(ec)) then + _ASSERT(.FALSE.,trim(local_string)) + else + _ASSERT(.FALSE.,trim(local_string)) + endif + + ! A compiler's abort method may print a backtrace or do other nice + ! things, but in fact we can rarely leverage this, because MPI_Abort + ! usually sends SIGTERM to the process, and we don't catch that signal. + !call abort() + + end subroutine shr_abort_abort + !=============================================================================== + + !=============================================================================== +! subroutine shr_abort_backtrace() +! ! This routine uses compiler-specific facilities to print a backtrace to +! ! error_unit (standard error, usually unit 0). +! +!#if defined(CPRIBM) +! +! ! This theoretically should be in xlfutility, but using it from that +! ! module doesn't seem to always work. +! interface +! subroutine xl_trbk() +! end subroutine xl_trbk +! end interface +! +! call xl__trbk() +! +!#elif defined(CPRGNU) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8 )) +! +! ! gfortran 4.8 and later implement this intrinsic. We explicitly call it +! ! out as such to make sure that it really is available, just in case the +! ! CPP logic above screws up. +! intrinsic :: backtrace +! +! call backtrace() +! +!#elif defined(CPRINTEL) +! +! ! tracebackqq uses optional arguments, so *must* have an explicit +! ! interface. +! use ifcore, only: tracebackqq +! +! ! An exit code of -1 is a special value that prevents this subroutine +! ! from aborting the run. +! call tracebackqq(user_exit_code=-1) +! +!#else +! +! ! Currently we have no means to request a backtrace from the NAG runtime, +! ! even though it is capable of emitting backtraces itself, if you use the +! ! "-gline" option. +! +! ! Similarly, PGI has a -traceback option, but no user interface for +! ! requesting a backtrace to be printed. +! +!#endif +! +! flush(error_unit) +! +! end subroutine shr_abort_backtrace + !=============================================================================== + + !=============================================================================== + subroutine print_error_to_logs(error_type, message) + ! This routine prints error messages to s_logunit (which is standard output + ! for most tasks in CESM) and also to standard error if s_logunit is a + ! file. + ! + ! It also flushes these output units. + + character(len=*), intent(in) :: error_type, message + + integer, allocatable :: log_units(:) + + integer :: i + + if (s_logunit == output_unit .or. s_logunit == error_unit) then + ! If the log unit number is standard output or standard error, just + ! print to that. + allocate(log_units(1), source=[s_logunit]) + else + ! Otherwise print the same message to both the log unit and standard + ! error. + allocate(log_units(2), source=[error_unit, s_logunit]) + end if + + do i = 1, size(log_units) + write(log_units(i),*) trim(error_type), ": ", trim(message) + flush(log_units(i)) + end do + + end subroutine print_error_to_logs + !=============================================================================== + +end module shr_abort_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_assert.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_assert.h new file mode 100755 index 000000000..4595e98e4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_assert.h @@ -0,0 +1,10 @@ +use shr_assert_mod +#define SHR_ASSERT(assert, my_msg) call shr_assert(assert, msg=my_msg) +#define SHR_ASSERT_FL(assert, my_file, my_line) call shr_assert(assert, file=my_file, line=my_line) +#define SHR_ASSERT_MFL(assert, my_msg, my_file, my_line) call shr_assert(assert, msg=my_msg, file=my_file, line=my_line) +#define SHR_ASSERT_ALL(assert, my_msg) call shr_assert_all(assert, msg=my_msg) +#define SHR_ASSERT_ALL_FL(assert, my_file, my_line) call shr_assert_all(assert, file=my_file, line=my_line) +#define SHR_ASSERT_ALL_MFL(assert, my_msg, my_file, my_line) call shr_assert_all(assert, msg=my_msg, file=my_file, line=my_line) +#define SHR_ASSERT_ANY(assert, my_msg) call shr_assert_any(assert, msg=my_msg) +#define SHR_ASSERT_ANY_FL(assert, my_file, my_line) call shr_assert_any(assert, file=my_file, line=my_line) +#define SHR_ASSERT_ANY_MFL(assert, my_msg, my_file, my_line) call shr_assert_any(assert, msg=my_msg, file=my_file, line=my_line) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_assert_mod.F90.in b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_assert_mod.F90.in new file mode 100755 index 000000000..d683193dc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_assert_mod.F90.in @@ -0,0 +1,437 @@ +module shr_assert_mod + +! Assert subroutines for common debugging operations. + +use shr_kind_mod, only: & + r4 => shr_kind_r4, & + r8 => shr_kind_r8, & + i4 => shr_kind_i4, & + i8 => shr_kind_i8 + +use shr_sys_mod, only: & + shr_sys_abort + +use shr_log_mod, only: & + shr_log_Unit + +use shr_infnan_mod, only: shr_infnan_isnan + +!use shr_strconvert_mod, only: toString + +implicit none +private +save + +! Assert that a logical is true. +public :: shr_assert +public :: shr_assert_all +public :: shr_assert_any + +! Assert that a numerical value satisfies certain constraints. +public :: shr_assert_in_domain + +interface shr_assert_all + module procedure shr_assert + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_{DIMS}d +end interface + +interface shr_assert_any + module procedure shr_assert + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_{DIMS}d +end interface + +interface shr_assert_in_domain + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_{DIMS}d_{TYPE} +end interface + +! Private utilities. + +interface print_bad_loc + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_{DIMS}d_{TYPE} +end interface + +interface find_first_loc + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_{DIMS}d +end interface + +interface within_tolerance + ! TYPE double,real,int,long + module procedure within_tolerance_{TYPE} +end interface + +contains + +subroutine shr_assert(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + character(len=40) :: line_str + character(len=:), allocatable :: full_msg + + if (.not. var) then + full_msg = 'ERROR' + if (present(file)) then + full_msg = full_msg // ' in ' // trim(file) + if (present(line)) then + write(line_str, '(i40)') line + full_msg = full_msg // ' at line ' // trim(line_str) + end if + end if + if (present(msg)) then + full_msg = full_msg // ': ' // msg + end if + call shr_sys_abort(full_msg) + end if + +end subroutine shr_assert + +! DIMS 1,2,3,4,5,6,7 +subroutine shr_assert_all_{DIMS}d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var{DIMSTR} + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(all(var), msg=msg, file=file, line=line) + +end subroutine shr_assert_all_{DIMS}d + +! DIMS 1,2,3,4,5,6,7 +subroutine shr_assert_any_{DIMS}d(var, msg, file, line) + + ! Logical being asserted + logical, intent(in) :: var{DIMSTR} + ! Optional error message if assert fails + character(len=*), intent(in), optional :: msg + ! Optional file and line of the caller, written out if given + ! (line is ignored if file is absent) + character(len=*), intent(in), optional :: file + integer , intent(in), optional :: line + + call shr_assert(any(var), msg=msg, file=file, line=line) + +end subroutine shr_assert_any_{DIMS}d + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +subroutine shr_assert_in_domain_{DIMS}d_{TYPE}(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if ({ITYPE} == TYPEREAL) || ({ITYPE} == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if ({DIMS} != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + {VTYPE}, intent(in) :: var{DIMSTR} + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + {VTYPE}, intent(in), optional :: lt + {VTYPE}, intent(in), optional :: gt + {VTYPE}, intent(in), optional :: le + {VTYPE}, intent(in), optional :: ge + {VTYPE}, intent(in), optional :: eq + {VTYPE}, intent(in), optional :: ne + {VTYPE}, intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec({DIMS}) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + {VTYPE} :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,{DIMS}) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +end subroutine shr_assert_in_domain_{DIMS}d_{TYPE} + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +subroutine print_bad_loc_{DIMS}d_{TYPE}(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + {VTYPE}, intent(in) :: var{DIMSTR} + integer, intent(in) :: loc_vec({DIMS}) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if ({DIMS} != 0) + var({REPEAT:loc_vec(#)}), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +end subroutine print_bad_loc_{DIMS}d_{TYPE} + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! DIMS 0,1,2,3,4,5,6,7 +pure function find_first_loc_{DIMS}d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask{DIMSTR} + integer :: loc_vec({DIMS}) + +#if ({DIMS} != 0) + integer :: flags({REPEAT:size(mask,#)}) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +end function find_first_loc_{DIMS}d + +! TYPE double,real,int,long +elemental function within_tolerance_{TYPE}(expected, actual, tolerance) & + result(is_in_tol) + ! Precondition: tolerance must be >= 0. + {VTYPE}, intent(in) :: expected + {VTYPE}, intent(in) :: actual + {VTYPE}, intent(in) :: tolerance + logical :: is_in_tol + + ! The following conditionals are to ensure that we don't overflow. + + ! This takes care of two identical infinities. + if (actual == expected) then + is_in_tol = .true. + else if (actual > expected) then + if (expected >= 0) then + is_in_tol = (actual - expected) <= tolerance + else + is_in_tol = actual <= (expected + tolerance) + end if + else + if (expected < 0) then + is_in_tol = (expected - actual) <= tolerance + else + is_in_tol = actual >= (expected - tolerance) + end if + end if + +end function within_tolerance_{TYPE} + +end module shr_assert_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_const_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_const_mod.F90 new file mode 100755 index 000000000..7131aee5e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_const_mod.F90 @@ -0,0 +1,24 @@ +!=============================================================================== +! SVN $Id: shr_const_mod.F90,v 1.1.1.1 2015/11/13 19:45:25 bmauer Exp $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/ccsm4_0_rel_tags/ccsm4_0_rel_02_share3_100228/shr/shr_const_mod.F90 $ +!=============================================================================== + +MODULE shr_const_mod + + use MAPL_ConstantsMod ! use GEOS5 constants + + !---------------------------------------------------------------------------- + ! physical constants (all data public) + !---------------------------------------------------------------------------- + public + + real,parameter :: SHR_CONST_PI = MAPL_PI ! pi + real,parameter :: SHR_CONST_CDAY = 86400.0 ! sec in calendar day ~ sec + real,parameter :: SHR_CONST_G = MAPL_GRAV ! acceleration of gravity ~ m/s^2 + real,parameter :: SHR_CONST_RGAS = MAPL_RUNIV ! Universal gas constant ~ J/K/kmole + real,parameter :: SHR_CONST_TKFRZ = MAPL_TICE ! freezing T of fresh water ~ K + real,parameter :: SHR_CONST_RHOFW = MAPL_RHOWTR ! density of fresh water ~ kg/m^3 + real,parameter :: SHR_CONST_PDB = 0.0112372 ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) + + +END MODULE shr_const_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_file_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_file_mod.F90 new file mode 100755 index 000000000..167d67978 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_file_mod.F90 @@ -0,0 +1,1010 @@ +! !MODULE: shr_file_mod.F90 --- Module to handle various file utilily functions. +! +! !DESCRIPTION: +! +! Miscilaneous methods to handle file and directory utilities as well as FORTRAN +! unit control. Also put/get local files into/from archival location +! +! File utilites used with CCSM Message passing: +! +! shr_file_stdio is the main example here, it changes the working directory, +! changes stdin and stdout to a given filename. +! +! This is needed because some implementations of MPI with MPMD so that +! each executable can run in a different working directory and redirect +! output to different files. +! +! File name archival convention, eg. +! call shr_file_put(rcode,"foo","mss:/USER/foo",rtpd=3650) +! is extensible -- the existence of the option file name prefix, eg. "mss:", +! and optional arguments, eg. rtpd-3650 can be used to access site-specific +! storage devices. Based on CCM (atmosphere) getfile & putfile routines, but +! intended to be a more extensible, shared code. +! +! !REVISION HISTORY: +! 2006-05-08 E. Kluzek, Add in shr_file_mod and getUnit, freeUnif methods. +! 2000-??-?? B. Kauffman, original version circa 2000 +! +! !INTERFACE: ------------------------------------------------------------------ + +MODULE shr_file_mod + + ! !USES: + + use shr_kind_mod ! defines kinds + use shr_sys_mod ! system calls + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + IMPLICIT none + + PRIVATE ! By default everything is private to this module + + ! !PUBLIC TYPES: + + ! no public types + + ! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_file_put ! Put a file to an archive location + public :: shr_file_get ! Get a file from an archive location + public :: shr_file_queryPrefix ! Get prefix type for a filename + public :: shr_file_getUnit ! Get a logical unit for reading or writing + public :: shr_file_freeUnit ! Free a logical unit + public :: shr_file_stdio ! change dir and stdin and stdout + public :: shr_file_chDir ! change current working directory + public :: shr_file_dirio ! change stdin and stdout + public :: shr_file_chStdIn ! change stdin (attach to a file) + public :: shr_file_chStdOut ! change stdout (attach to a file) + public :: shr_file_setIO ! open a log file from namelist + public :: shr_file_setLogUnit ! Reset the log unit number + public :: shr_file_setLogLevel ! Reset the logging debug level + public :: shr_file_getLogUnit ! Get the log unit number + public :: shr_file_getLogLevel ! Get the logging debug level +#if defined NEMO_IN_CCSM + public :: shr_file_maxUnit ! Max unit number to give +#endif + + ! !PUBLIC DATA MEMBERS: + + ! Integer flags for recognized prefixes on file get/put operations + integer(SHR_KIND_IN), parameter, public :: shr_file_noPrefix = 0 ! no recognized prefix + integer(SHR_KIND_IN), parameter, public :: shr_file_nullPrefix = 1 ! null: + integer(SHR_KIND_IN), parameter, public :: shr_file_cpPrefix = 2 ! cp: + integer(SHR_KIND_IN), parameter, public :: shr_file_mssPrefix = 3 ! mss: + integer(SHR_KIND_IN), parameter, public :: shr_file_hpssPrefix = 4 ! hpss: + + !EOP + !--- unit numbers, users can ask for unit numbers from 0 to min, but getUnit + !--- won't give a unit below min, users cannot ask for unit number above max + !--- for backward compatability. + !--- eventually, recommend min as hard lower limit (tcraig, 9/2007) + integer(SHR_KIND_IN),parameter :: shr_file_minUnit = 10 ! Min unit number to give + integer(SHR_KIND_IN),parameter :: shr_file_maxUnit = 99 ! Max unit number to give + logical, save :: UnitTag(0:shr_file_maxUnit) = .false. ! Logical units in use + + !=============================================================================== +CONTAINS + !=============================================================================== + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_put -- Put a file to an archival location. + ! + ! !DESCRIPTION: + ! a generic, extensible put-local-file-into-archive routine + ! USAGE: + ! call shr_file_put(rcode,"foo","/home/user/foo") + ! if ( rcode /= 0 ) call shr_sys_abort( "error copying foo" ) + ! call shr_file_put(rcode,"foo","cp:/home/user/foo",remove=.true.) + ! if ( rcode /= 0 ) call shr_sys_abort( "error copying foo" ) + ! call shr_file_put(rcode,"foo","mss:/USER/foo",rtpd=3650) + ! if ( rcode /= 0 ) call shr_sys_abort( "error archiving foo to MSS" ) + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_put(rcode,loc_fn,rem_fn,passwd,rtpd,async,remove) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(out) :: rcode ! return code (non-zero -- error) + character(*), intent(in) :: loc_fn ! local filename + character(*), intent(in) :: rem_fn ! remote filename + character(*), intent(in),optional :: passwd ! password + integer(SHR_KIND_IN),intent(in),optional :: rtpd ! MSS retention period + logical, intent(in),optional :: async ! true <=> asynchronous put + logical, intent(in),optional :: remove ! true <=> rm after put + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: rtpd2 ! MSS retention period + logical :: remove2 ! true <=> rm after put + logical :: async2 ! true <=> asynchronous put + character(SHR_KIND_CL) :: passwd2 ! password + character(SHR_KIND_CL) :: rfn ! rem_fn without the destination prefix + character(SHR_KIND_CL) :: cmd ! command sent to system call + integer(SHR_KIND_IN) :: prefix ! remote file prefix type + + !----- formats ----- + character(*),parameter :: subName = '(shr_file_put) ' + character(*),parameter :: F00 = "('(shr_file_put) ',4a)" + character(*),parameter :: F01 = "('(shr_file_put) ',a,i3,2a)" + character(*),parameter :: F02 = "(a,i4)" + + !------------------------------------------------------------------------------- + ! Notes: + ! - On some machines the system call will not return a valid error code + ! - when things are sent asynchronously, there probably won't be a error code + ! returned. + !------------------------------------------------------------------------------- + + remove2 =.false. ; if ( PRESENT(remove )) remove2 = remove + async2 =.true. ; if ( PRESENT(async )) async2 = async + passwd2 = " " ; if ( PRESENT(passwd )) passwd2 = passwd + rtpd2 = 365 ; if ( PRESENT(rtpd )) rtpd2 = rtpd + rcode = 0 + prefix = shr_file_queryPrefix( rem_fn ) + + if ( trim(rem_fn) == trim(loc_fn) ) then + !------------------------------------------------------ + ! (remote file name) == (local file name) => do nothing + !------------------------------------------------------ + cmd = 'do nothing: remote file = local file = '//trim(loc_fn) + rcode = 0 + else if ( prefix == shr_file_cpPrefix .or. prefix == shr_file_noPrefix )then + !------------------------------------------------------ + ! put via unix cp + !------------------------------------------------------ + rfn = rem_fn + if ( rem_fn(1:3) == "cp:") rfn = rem_fn(4:len_trim(rem_fn)) + cmd = '/bin/cp -f '//trim(loc_fn)//' '//trim(rfn) + if (remove2) cmd = trim(cmd)//' && /bin/rm -f '//trim(loc_fn) + if (async2 ) cmd = trim(cmd)//' & ' + call shr_sys_system(trim(cmd),rcode) + else if ( prefix == shr_file_mssPrefix )then + !------------------------------------------------------ + ! put onto NCAR's MSS + !------------------------------------------------------ + if (rtpd2 > 9999) rtpd2 = 9999 + write(cmd,F02) '/usr/local/bin/msrcp -period ',rtpd2 + if (async2 .and. (.not. remove2) ) cmd = trim(cmd)//' -async ' + if (len_trim(passwd2) > 0 ) cmd = trim(cmd)//' -wpwd '//trim(passwd) + cmd = trim(cmd)//' '//trim(loc_fn)//' '//trim(rem_fn) + if (remove2) cmd = trim(cmd)//' && /bin/rm -f '//trim(loc_fn) + if (async2 .and. remove2 ) cmd = trim(cmd)//' & ' + call shr_sys_system(trim(cmd),rcode) + else if ( prefix == shr_file_hpssPrefix )then + !------------------------------------------------------ + ! put onto LANL's hpss + !------------------------------------------------------ + rcode = -1 + cmd = 'rem_fn='//trim(rem_fn)//' loc_fn='//trim(loc_fn) + write(s_logunit,F00) 'ERROR: hpss option not yet implemented' + call shr_sys_abort( subName//'ERROR: hpss option not yet implemented' ) + else if ( prefix == shr_file_nullPrefix )then + ! do nothing + cmd = "null prefix => no file archival, do nothing" + rcode = 0 + end if + + if (s_loglev > 0) write(s_logunit,F01) 'rcode =',rcode,' cmd = ', trim(cmd) + + END SUBROUTINE shr_file_put + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_get -- Get a file from archival location. + ! + ! !DESCRIPTION: + ! a generic, extensible get-local-file-from-archive routine + ! + ! USAGE: + ! call shr_file_get(rcode,"foo","/home/user/foo") + ! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo" ) + ! call shr_file_get(rcode,"foo","cp:/home/user/foo",remove=.true.) + ! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo" ) + ! call shr_file_get(rcode,"foo","mss:/USER/foo",clobber=.true.) + ! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo from MSS" ) + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_get(rcode,loc_fn,rem_fn,passwd,async,clobber) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(out) :: rcode ! return code (non-zero means error) + character(*) ,intent(in) :: loc_fn ! local filename + character(*) ,intent(in) :: rem_fn ! remote filename + character(*) ,intent(in),optional :: passwd ! password + logical ,intent(in),optional :: async ! true <=> asynchronous get + logical ,intent(in),optional :: clobber ! true <=> clobber existing file + + !EOP + + !----- local ----- + logical :: async2 ! true <=> asynchronous get + logical :: clobber2 ! true <=> clobber existing file + logical :: exists ! true <=> local file a ready exists + character(SHR_KIND_CL) :: passwd2 ! password + character(SHR_KIND_CL) :: rfn ! rem_fn without the destination prefix + character(SHR_KIND_CL) :: cmd ! command sent to system call + integer(SHR_KIND_IN) :: prefix ! remote file prefix type + + !----- formats ----- + character(*),parameter :: subName = '(shr_file_get) ' + character(*),parameter :: F00 = "('(shr_file_get) ',4a)" + character(*),parameter :: F01 = "('(shr_file_get) ',a,i3,2a)" + + !------------------------------------------------------------------------------- + ! Notes: + ! - On some machines the system call will not return a valid error code + ! - When things are sent asynchronously, there probably won't be a error code + ! returned. + !------------------------------------------------------------------------------- + + passwd2 = " " ; if (PRESENT(passwd )) passwd2 = passwd + async2 = .false. ; if (PRESENT(async )) async2 = async + clobber2 = .false. ; if (PRESENT(clobber)) clobber2 = clobber + rcode = 0 + + inquire(file=trim(loc_fn),exist=exists) + prefix = shr_file_queryPrefix( rem_fn ) + + if ( exists .and. .not. clobber2 ) then + !------------------------------------------------------ + ! (file exists) and (don't clobber) => do nothing + !------------------------------------------------------ + cmd = 'do nothing: file exists & no-clobber for '//trim(loc_fn) + rcode = 0 + else if ( trim(rem_fn) == trim(loc_fn) ) then + !------------------------------------------------------ + ! (remote file name) == (local file name) => do nothing + !------------------------------------------------------ + cmd = 'do nothing: remote file = local file for '//trim(loc_fn) + rcode = 0 + else if ( prefix == shr_file_cpPrefix .or. prefix == shr_file_noPrefix )then + !------------------------------------------------------ + ! get via unix cp + !------------------------------------------------------ + rfn = rem_fn ! remove prefix from this temp file name + if (rem_fn(1:3) == "cp:") rfn = rem_fn(4:len_trim(rem_fn)) + cmd = '/bin/cp -f '//trim(rfn)//' '//trim(loc_fn) + if (async2) cmd = trim(cmd)//' & ' + call shr_sys_system(trim(cmd),rcode) + else if ( prefix == shr_file_mssPrefix )then + !------------------------------------------------------ + ! get from NCAR's MSS + !------------------------------------------------------ + cmd = '/usr/local/bin/msrcp ' + if (async2) cmd = trim(cmd)//' -async ' + cmd = trim(cmd)//' '//trim(rem_fn)//' '//trim(loc_fn) + call shr_sys_system(trim(cmd),rcode) + else if ( prefix == shr_file_hpssPrefix )then + !------------------------------------------------------ + ! get from LANL's hpss + !------------------------------------------------------ + rcode = -1 + cmd = 'rem_fn='//trim(rem_fn)//' loc_fn='//trim(loc_fn) + write(s_logunit,F00) 'ERROR: hpss option not yet implemented' + call shr_sys_abort( subName//'ERROR: hpss option not yet implemented' ) + else if ( prefix == shr_file_nullPrefix )then + ! do nothing + cmd = "null prefix => no file retrieval, do nothing" + rcode = 0 + end if + + if (s_loglev > 0) write(s_logunit,F01) 'rcode =',rcode,' cmd = ', trim(cmd) + + END SUBROUTINE shr_file_get + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_queryPrefix -- Get the prefix type from a filepath. + ! + ! !DESCRIPTION: + ! + ! !INTERFACE: ------------------------------------------------------------------ + + integer(SHR_KIND_IN) FUNCTION shr_file_queryPrefix( filepath, prefix ) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*), intent(in) :: filepath ! Input filepath + character(*), intent(out), optional :: prefix ! Output prefix description + + !EOP + + !----- local ----- + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if ( filepath(1:5) == "null:" )then + shr_file_queryPrefix = shr_file_nullPrefix + if ( present(prefix) ) prefix = "null:" + else if( filepath(1:3) == "cp:" )then + shr_file_queryPrefix = shr_file_cpPrefix + if ( present(prefix) ) prefix = "cp:" + else if( filepath(1:4) == "mss:" )then + shr_file_queryPrefix = shr_file_mssPrefix + if ( present(prefix) ) prefix = "mss:" + else if( filepath(1:5) == "hpss:" )then + shr_file_queryPrefix = shr_file_hpssPrefix + if ( present(prefix) ) prefix = "hpss:" + else + shr_file_queryPrefix = shr_file_noPrefix + if ( present(prefix) ) prefix = "" + end if + + END FUNCTION shr_file_queryPrefix + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_getUnit -- Get a free FORTRAN unit number + ! + ! !DESCRIPTION: Get the next free FORTRAN unit number. + ! + ! !REVISION HISTORY: + ! 2005-Dec-14 - E. Kluzek - creation + ! + ! !INTERFACE: ------------------------------------------------------------------ + + INTEGER FUNCTION shr_file_getUnit ( unit ) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in),optional :: unit ! desired unit number + + !EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n ! loop index + logical :: opened ! If unit opened or not + + !----- formats ----- + character(*),parameter :: subName = '(shr_file_getUnit) ' + character(*),parameter :: F00 = "('(shr_file_getUnit) ',A,I4,A)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + shr_file_getUnit = -1 + if (present (unit)) then + inquire( unit, opened=opened ) + if (unit < 0 .or. unit > shr_file_maxUnit) then + write(s_logunit,F00) 'invalid unit number request:', unit + call shr_sys_abort( 'ERROR: bad input unit number' ) + else if (opened .or. UnitTag(unit) .or. unit == 0 .or. unit == 5 & + .or. unit == 6) then + write(s_logunit,F00) 'unit number ', unit, ' is already in use' + call shr_sys_abort( 'ERROR: Input unit number already in use' ) + else + shr_file_getUnit = unit + UnitTag (unit) = .true. + return + end if + + else + ! --- Choose first available unit other than 0, 5, or 6 ------ + do n=shr_file_maxUnit, shr_file_minUnit, -1 + inquire( n, opened=opened ) + if (n == 5 .or. n == 6 .or. opened) then + cycle + end if + if ( .not. UnitTag(n) ) then + shr_file_getUnit = n + UnitTag(n) = .true. + return + end if + end do + end if + + call shr_sys_abort( subName//': Error: no available units found' ) + + END FUNCTION shr_file_getUnit + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_freeUnit -- Free up a FORTRAN unit number + ! + ! !DESCRIPTION: Free up the given unit number + ! + ! !REVISION HISTORY: + ! 2005-Dec-14 - E. Kluzek - creation + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_freeUnit ( unit) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: unit ! unit number to be freed + + !EOP + + !----- local ----- + + !----- formats ----- + character(*), parameter :: subName = '(shr_file_freeUnit) ' + character(*), parameter :: F00 = "('(shr_file_freeUnit) ',A,I4,A)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (unit < 0 .or. unit > shr_file_maxUnit) then + if (s_loglev > 0) write(s_logunit,F00) 'invalid unit number request:', unit + else if (unit == 0 .or. unit == 5 .or. unit == 6) then + call shr_sys_abort( subName//': Error: units 0, 5, and 6 must not be freed' ) + else if (UnitTag(unit)) then + UnitTag (unit) = .false. + else + if (s_loglev > 0) write(s_logunit,F00) 'unit ', unit, ' was not in use' + end if + + return + + END SUBROUTINE shr_file_freeUnit + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_stdio -- Change working directory, and redirect stdin/stdout + ! + ! !DESCRIPTION: + ! 1) change the cwd (current working directory) and + ! 2) redirect stdin & stdout (units 5 & 6) to named files, + ! where the desired cwd & files are specified by namelist file. + ! + ! Normally this is done to work around limitations in the execution syntax + ! of common MPI implementations. For example, SGI's mpirun syntax is not + ! flexible enough to allow MPMD models to select different execution + ! directories or to redirect stdin & stdout on the command line. + ! Such functionality is highly desireable for CCSM purposes. + ! ie. mpirun can't handle this: + ! unix> cd /usr/tmp/jdoe/csm/case01/atm ; atm < atm.parm > atm.log & + ! unix> cd /usr/tmp/jdoe/csm/case01/cpl ; cpl < cpl.parm > cpl.log & + ! etc. + ! + ! ASSUMPTIONS: + ! o if the cwd, stdin, or stdout are to be changed, there must be a namelist + ! file in the cwd named _stdio.nml where is provided via + ! subroutine dummy argument. + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_stdio(model) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: model ! used to construct env varible name + + !EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_stdio) ' + character(*),parameter :: F00 = "('(shr_file_stdio) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + call shr_file_chdir (model) ! changes cwd + call shr_file_chStdOut(model) ! open units 5 & 6 to named files + call shr_file_chStdIn (model) ! open units 5 & 6 to named files + + END SUBROUTINE shr_file_stdio + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_chdir -- Change working directory. + ! + ! !DESCRIPTION: + ! change the cwd (current working directory), see shr_file_stdio for notes + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_chdir(model, rcodeOut) + + ! !USES: + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: model ! used to construct env varible name + integer(SHR_KIND_IN),intent(out),optional :: rcodeOut ! Return error code + + !EOP + + !--- local --- + character(SHR_KIND_CL) :: dir ! directory to cd to + integer (SHR_KIND_IN) :: rcode ! Return error code + character(SHR_KIND_CL) :: filename ! namelist file to read + + !--- formats --- + character(*),parameter :: subName = '(shr_file_chdir) ' + character(*),parameter :: F00 = "('(shr_file_chdir) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + call shr_file_stdioReadNL( model, filename, dirOut=dir, rcodeOut=rcode ) + if (dir /= "nochange") then + call shr_sys_chdir(dir ,rcode) + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", changed cwd to ",trim(dir) + else + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", cwd has *not* been changed" + rcode = 1 + endif + if ( present(rcodeOut) ) rcodeOut = rcode + + END SUBROUTINE shr_file_chdir + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_dirio --- Change stdin and stdout. + ! + ! !DESCRIPTION: + ! change the stdin & stdout (units 5 & 6), see shr_file_stdio for notes + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_dirio(model) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: model ! used to construct env varible name + + !EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = '(shr_file_dirio) ' + + !------------------------------------------------------------------------------- + ! Notes: + ! + !------------------------------------------------------------------------------- + + call shr_file_chStdIn (model) + call shr_file_chStdOut(model) + + END SUBROUTINE shr_file_dirio + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_chStdIn -- Change stdin + ! + ! !DESCRIPTION: + ! change the stdin (unit 5), see shr_file_stdio for notes + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_chStdIn( model, NLFilename, rcodeOut ) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: model ! used to construct env var name + character(SHR_KIND_CL),intent(out),optional :: NLFilename ! open unit 5 to this + integer (SHR_KIND_IN),intent(out),optional :: rcodeOut ! return code + + !EOP + + !--- local --- + character(SHR_KIND_CL) :: stdin ! open unit 5 to this file + character(SHR_KIND_CL) :: nlfile ! Namelist filename for model to read from + character(SHR_KIND_CL) :: filename ! namelist file to read + integer (SHR_KIND_IN) :: rcode ! return code + + !--- formats --- + character(*),parameter :: subName = '(shr_file_chStdIn) ' + character(*),parameter :: F00 = "('(shr_file_chStdIn) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + call shr_file_stdioReadNL( model, filename, stdinOut=stdin, & + nlfileOut=nlfile, rcodeOut=rcode ) + if (stdin /= "nochange") then + open(unit=5,file=stdin ,status='UNKNOWN',iostat=rcode) + if ( rcode /= 0 )then + if (s_loglev > 0) & + write(s_logunit,F00) "read ",trim(filename),': error opening file as unit 5:', & + trim(nlfile) + else + if (s_loglev > 0) & + write(s_logunit,F00) "read ",trim(filename),': unit 5 connected to ', & + trim(stdin) + end if + else + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), & + ': unit 5 has *not* been redirected' + endif + if ( len_trim(nlfile) > 0) then + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), & + ': read namelist from file:',trim(nlfile) + if ( .not. present(NLFilename) )then + if (s_loglev > 0) write(s_logunit,F00) "error: namelist filename NOT present" + rcode = 7 + end if + else + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", " + if ( present(NLFilename) )then + if (s_loglev > 0) write(s_logunit,F00) "error: namelist filename present, but null" + rcode = 8 + end if + endif + if ( present(NLFilename) ) NLFilename = nlfile + if ( present(rcodeOut) ) rcodeOut = rcode + + END SUBROUTINE shr_file_chStdIn + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_stdout -- Change stdout + ! + ! !DESCRIPTION: + ! change the stdout (unit 6), see shr_file_stdio for notes + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_chStdOut(model,rcodeOut) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + !--- arguments --- + character(*) ,intent(in) :: model ! used to construct env varible name + integer(SHR_KIND_IN),intent(out),optional :: rcodeOut ! Return error code + !EOP + + !--- local --- + character(SHR_KIND_CL) :: filename ! namelist file to read + character(SHR_KIND_CL) :: stdout ! open unit 6 to this file + integer (SHR_KIND_IN) :: rcode ! return code + + !--- formats --- + character(*),parameter :: subName = '(shr_file_chStdOut) ' + character(*),parameter :: F00 = "('(shr_file_chStdOut) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + call shr_file_stdioReadNL( model, filename, stdoutOut=stdout, & + rcodeOut=rcode ) + if (stdout /= "nochange") then + close(6) + open(unit=6,file=stdout,position='APPEND') + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), & + ': unit 6 connected to ',trim(stdout) + call shr_sys_flush(s_logunit) + else + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), & + ': unit 6 has *not* been redirected' + rcode = 1 + endif + + if ( present(rcodeOut) ) rcodeOut = rcode + + END SUBROUTINE shr_file_chStdOut + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_stdioReadNL -- read in stdio namelist + ! + ! !DESCRIPTION: + ! Read in the stdio namelist for any given model type. Return any of the + ! needed input namelist variables as optional arguments. Return "nochange" in + ! dir, stdin, or stdout if shouldn't change. + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_stdioReadNL( model, filename, dirOut, stdinOut, stdoutOut, & + NLFileOut, rcodeOut ) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: model ! used to construct env varible name + character(SHR_KIND_CL),intent(out) :: filename ! nml file to read from unit 5 + character(SHR_KIND_CL),intent(out),optional :: NLFileOut ! open unit 6 to this file + character(SHR_KIND_CL),intent(out),optional :: dirOut ! directory to cd to + character(SHR_KIND_CL),intent(out),optional :: stdinOut ! open unit 5 to this file + character(SHR_KIND_CL),intent(out),optional :: stdoutOut ! open unit 6 to this file + integer (SHR_KIND_IN),intent(out),optional :: rcodeOut ! return code + + !EOP + + !--- local --- + logical :: exists ! true iff file exists + character(SHR_KIND_CL) :: dir ! directory to cd to + character(SHR_KIND_CL) :: stdin ! open unit 5 to this file + character(SHR_KIND_CL) :: stdout ! open unit 6 to this file + character(SHR_KIND_CL) :: NLFile ! namelist file to read seperately + integer (SHR_KIND_IN) :: rcode ! return code + integer (SHR_KIND_IN) :: unit ! Unit to read from + + namelist / stdio / dir,stdin,stdout,NLFile + + !--- formats --- + character(*),parameter :: subName = '(shr_file_stdioReadNL) ' + character(*),parameter :: F00 = "('(shr_file_stdioReadNL) ',4a)" + character(*),parameter :: F01 = "('(shr_file_stdioReadNL) ',3a,i6)" + + !------------------------------------------------------------------------------- + ! Notes: + ! + !------------------------------------------------------------------------------- + + rcode = 0 + dir = "nochange" + stdin = "nochange" + stdout = "nochange" + NLFile = " " + + filename = trim(model)//"_stdio.nml" ! eg. file="cpl_stdio.nml" + inquire(file=filename,exist=exists) + + if (.not. exists) then + if (s_loglev > 0) write(s_logunit,F00) "file ",trim(filename),& + & " doesn't exist, can not read stdio namelist from it" + rcode = 9 + else + unit = shr_file_getUnit() + open (unit,file=filename,action="READ") + read (unit,nml=stdio,iostat=rcode) + close(unit) + call shr_file_freeUnit( unit ) + if (rcode /= 0) then + write(s_logunit,F01) 'ERROR: reading ',trim(filename),': iostat=',rcode + call shr_sys_abort(subName//" ERROR reading "//trim(filename) ) + end if + endif + if ( len_trim(NLFile) > 0 .and. trim(stdin) /= "nochange" )then + write(s_logunit,F00) "Error: input namelist:" + write(s_logunit,nml=stdio) + call shr_sys_abort(subName//" ERROR trying to both redirect AND "// & + "open namelist filename" ) + end if + if ( present(NLFileOut) ) NLFileOut = NLFile + if ( present(dirOut) ) dirOut = dir + if ( present(stdinOut) ) stdinOut = stdin + if ( present(stdoutOut) ) stdoutOut = stdout + if ( present(rcodeOut) ) rcodeOut = rcode + + END SUBROUTINE shr_file_stdioReadNL + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_setIO -- read in stdio namelist + ! + ! !DESCRIPTION: + ! This opens a namelist file specified as an argument and then opens + ! a log file associated with the unit argument. This may be extended + ! in the future. + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_setIO( nmlfile, funit) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + character(len=*) ,intent(in) :: nmlfile ! namelist filename + integer(SHR_KIND_IN),intent(in) :: funit ! unit number for log file + + !EOP + + !--- local --- + logical :: exists ! true if file exists + character(SHR_KIND_CL) :: diri ! directory to cd to + character(SHR_KIND_CL) :: diro ! directory to cd to + character(SHR_KIND_CL) :: logfile ! open unit 6 to this file + integer(SHR_KIND_IN) :: unit ! unit number + integer(SHR_KIND_IN) :: rcode ! error code + + namelist / modelio / diri,diro,logfile + + !--- formats --- + character(*),parameter :: subName = '(shr_file_setIO) ' + character(*),parameter :: F00 = "('(shr_file_setIO) ',4a)" + character(*),parameter :: F01 = "('(shr_file_setIO) ',3a,i6)" + + !------------------------------------------------------------------------------- + ! Notes: + ! + !------------------------------------------------------------------------------- + + diri = "." + diro = "." + logfile = "" + + inquire(file=nmlfile,exist=exists) + + if (.not. exists) then + if (s_loglev > 0) write(s_logunit,F00) "file ",trim(nmlfile)," nonexistent" + return + else + unit = shr_file_getUnit() + open (unit,file=nmlfile,action="READ") + read (unit,nml=modelio,iostat=rcode) + close(unit) + call shr_file_freeUnit( unit ) + if (rcode /= 0) then + write(s_logunit,F01) 'ERROR: reading ',trim(nmlfile),': iostat=',rcode + call shr_sys_abort(subName//" ERROR reading "//trim(nmlfile) ) + end if + endif + + if (len_trim(logfile) > 0) then + open(funit,file=trim(diro)//"/"//trim(logfile)) + else + if (s_loglev > 0) write(s_logunit,F00) "logfile not opened" + endif + + END SUBROUTINE shr_file_setIO + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_setLogUnit -- Set the Log I/O Unit number + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_setLogUnit(unit) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: unit ! new unit number + + !EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_setLogUnit) ' + character(*),parameter :: F00 = "('(shr_file_setLogUnit) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: Caller must be sure it's a valid unit number + !------------------------------------------------------------------------------- +#if DEBUG + if (s_loglev > 2 .and. s_logunit-unit /= 0) then + write(s_logunit,*) subName,': reset log unit number from/to ',s_logunit, unit + write( unit,*) subName,': reset log unit number from/to ',s_logunit, unit + endif +#endif + s_logunit = unit + + END SUBROUTINE shr_file_setLogUnit + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_setLogLevel -- Set the Log I/O Unit number + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_setLogLevel(newlevel) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: newlevel ! new log level + + !EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_setLogLevel) ' + character(*),parameter :: F00 = "('(shr_file_setLogLevel) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + if (s_loglev+newlevel > 2 .and. s_loglev-newlevel /= 0) & + write(s_logunit,*) subName,': reset log level from/to ',s_loglev, newlevel + + s_loglev = newlevel + + END SUBROUTINE shr_file_setLogLevel + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_getLogUnit -- Set the Log I/O Unit number + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_getLogUnit(unit) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(out) :: unit ! new unit number + + !EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_getLogUnit) ' + character(*),parameter :: F00 = "('(shr_file_getLogUnit) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + unit = s_logunit + + END SUBROUTINE shr_file_getLogUnit + + !=============================================================================== + !BOP =========================================================================== + ! + ! !IROUTINE: shr_file_getLogLevel -- Set the Log I/O Unit number + ! + ! !INTERFACE: ------------------------------------------------------------------ + + SUBROUTINE shr_file_getLogLevel(curlevel) + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(out) :: curlevel ! new log level + + !EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_getLogLevel) ' + character(*),parameter :: F00 = "('(shr_file_getLogLevel) ',4a)" + + !------------------------------------------------------------------------------- + ! Notes: + !------------------------------------------------------------------------------- + + curlevel = s_loglev + + END SUBROUTINE shr_file_getLogLevel + + !=============================================================================== + !=============================================================================== + +END MODULE shr_file_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_fire_emis_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_fire_emis_mod.F90 new file mode 100755 index 000000000..4243d580b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_fire_emis_mod.F90 @@ -0,0 +1,299 @@ +!================================================================================ +! Coordinates carbon emissions fluxes from CLM fires for use as sources of +! chemical constituents in CAM +! +! This module reads fire_emis_nl namelist which specifies the compound fluxes +! that are to be passed through the model coupler. +!================================================================================ +module shr_fire_emis_mod + + use shr_kind_mod,only : r8 => shr_kind_r8 + use shr_kind_mod,only : CL => SHR_KIND_CL, CX => SHR_KIND_CX, CS => SHR_KIND_CS + use shr_sys_mod, only : shr_sys_abort + use shr_log_mod, only : loglev => shr_log_Level + + implicit none + save + private + + ! public :: shr_fire_emis_readnl ! reads fire_emis_nl namelist + public :: shr_fire_emis_mechcomps ! points to an array of chemical compounds (in CAM-Chem mechanism) than have fire emissions + public :: shr_fire_emis_mechcomps_n ! number of unique compounds in the CAM chemical mechanism that have fire emissions + public :: shr_fire_emis_comps_n ! number of unique emissions components + public :: shr_fire_emis_linkedlist ! points to linked list of shr_fire_emis_comp_t objects + public :: shr_fire_emis_elevated ! elevated emissions in ATM + public :: shr_fire_emis_comp_ptr ! user defined type that points to fire emis data obj (shr_fire_emis_comp_t) + public :: shr_fire_emis_comp_t ! emission component data type + public :: shr_fire_emis_mechcomp_t ! data type for chemical compound in CAM mechanism than has fire emissions + + logical :: shr_fire_emis_elevated = .true. + + character(len=CS), public :: shr_fire_emis_fields_token = '' ! emissions fields token + character(len=CL), public :: shr_fire_emis_factors_file = '' ! a table of basic fire emissions compounds + character(len=CS), public :: shr_fire_emis_ztop_token = 'Sl_fztop' ! token for emissions top of vertical distribution + integer, parameter :: name_len=16 + ! fire emissions component data structure (or user defined type) + type shr_fire_emis_comp_t + character(len=name_len) :: name ! emissions component name (in fire emissions input table) + integer :: index + real(r8), pointer :: emis_factors(:) ! function of plant-function-type (PFT) + real(r8) :: coeff ! emissions component coeffecient + real(r8) :: molec_weight ! molecular weight of the fire emissions compound (g/mole) + type(shr_fire_emis_comp_t), pointer :: next_emiscomp ! points to next member in the linked list + endtype shr_fire_emis_comp_t + + type shr_fire_emis_comp_ptr + type(shr_fire_emis_comp_t), pointer :: ptr ! points to fire emis data obj (shr_fire_emis_comp_t) + endtype shr_fire_emis_comp_ptr + + ! chemical compound in CAM mechanism that has fire emissions + type shr_fire_emis_mechcomp_t + character(len=name_len) :: name ! compound name + type(shr_fire_emis_comp_ptr), pointer :: emis_comps(:) ! an array of pointers to fire emis components + integer :: n_emis_comps ! number of fire emis compounds that make up the emissions for this mechanis compound + end type shr_fire_emis_mechcomp_t + + type(shr_fire_emis_mechcomp_t), pointer :: shr_fire_emis_mechcomps(:) ! array of chemical compounds (in CAM mechanism) that have fire emissions + type(shr_fire_emis_comp_t), pointer :: shr_fire_emis_linkedlist ! points to linked list top + + integer :: shr_fire_emis_comps_n = 0 ! number of unique fire components + integer :: shr_fire_emis_mechcomps_n = 0 ! number of unique compounds in the CAM chemical mechanism that have fire emissions + +contains + + !------------------------------------------------------------------------- + ! + ! This reads the fire_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + ! + ! Namelist variables: + ! fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated + ! + ! fire_emis_specifier (array of strings) -- Each array element specifies + ! how CAM-Chem constituents are mapped to basic smoke compounds in + ! the fire emissions factors table (fire_emis_factors_file). Each + ! chemistry constituent name (left of '=' sign) is mapped to one or more + ! smoke compound (separated by + sign if more than one), which can be + ! proceeded by a multiplication factor (separated by '*'). + ! Example: + ! fire_emis_specifier = 'bc_a1 = BC','pom_a1 = 1.4*OC','SO2 = SO2' + ! + ! fire_emis_factors_file (string) -- Input file that contains the table + ! of basic compounds that make up the smoke from the CLM fires. This is + ! used in CLM module FireEmisFactorsMod. + ! + ! fire_emis_elevated (locical) -- If true then CAM-Chem treats the fire + ! emission sources as 3-D vertically distributed forcings for the + ! corresponding chemical tracers. + ! + !------------------------------------------------------------------------- +! subroutine shr_fire_emis_readnl( NLFileName, ID, emis_fields ) +! +! use shr_nl_mod, only : shr_nl_find_group_name +! use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit +! use seq_comm_mct, only : seq_comm_iamroot, seq_comm_setptrs, logunit +! use shr_mpi_mod, only : shr_mpi_bcast +! +! character(len=*), intent(in) :: NLFileName ! name of namelist file +! integer , intent(in) :: ID ! seq_comm ID +! character(len=*), intent(out) :: emis_fields ! emis flux fields +! +! integer :: unitn ! namelist unit number +! integer :: ierr ! error code +! logical :: exists ! if file exists or not +! integer :: mpicom ! MPI communicator +! +! integer, parameter :: maxspc = 100 +! +! character(len=2*CX) :: fire_emis_specifier(maxspc) = ' ' +! character(len=CL) :: fire_emis_factors_file = ' ' +! +! character(*),parameter :: F00 = "('(shr_fire_emis_readnl) ',2a)" +! +! logical :: fire_emis_elevated = .true. +! +! namelist /fire_emis_nl/ fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated +! +! call seq_comm_setptrs(ID,mpicom=mpicom) +! if (seq_comm_iamroot(ID)) then +! +! inquire( file=trim(NLFileName), exist=exists) +! +! if ( exists ) then +! +! unitn = shr_file_getUnit() +! open( unitn, file=trim(NLFilename), status='old' ) +! if ( loglev > 0 ) write(logunit,F00) & +! 'Read in fire_emis_readnl namelist from: ', trim(NLFilename) +! +! call shr_nl_find_group_name(unitn, 'fire_emis_nl', status=ierr) +! ! If ierr /= 0, no namelist present. +! +! if (ierr == 0) then +! read(unitn, fire_emis_nl, iostat=ierr) +! +! if (ierr > 0) then +! call shr_sys_abort( 'problem on read of fire_emis_nl namelist in shr_fire_emis_readnl' ) +! endif +! endif +! +! close( unitn ) +! call shr_file_freeUnit( unitn ) +! end if +! end if +! call shr_mpi_bcast( fire_emis_specifier, mpicom) +! call shr_mpi_bcast( fire_emis_factors_file, mpicom) +! call shr_mpi_bcast( fire_emis_elevated, mpicom) +! +! shr_fire_emis_factors_file = fire_emis_factors_file +! shr_fire_emis_elevated = fire_emis_elevated +! +! ! parse the namelist info and initialize the module data +! call shr_fire_emis_init( fire_emis_specifier, emis_fields ) +! +! end subroutine shr_fire_emis_readnl + + !----------------------------------------------------------------------- + ! module data initializer + !------------------------------------------------------------------------ +! subroutine shr_fire_emis_init( specifier, emis_fields ) +! +! use shr_expr_parser_mod, only : shr_exp_parse, shr_exp_item_t, shr_exp_list_destroy +! +! character(len=*), intent(in) :: specifier(:) +! character(len=*), intent(out) :: emis_fields +! +! integer :: n_entries +! integer :: i, j, k +! +! type(shr_exp_item_t), pointer :: items_list, item +! character(len=12) :: token ! fire emis field name to add +! +! nullify(shr_fire_emis_linkedlist) +! +! items_list => shr_exp_parse( specifier, nitems=n_entries ) +! +! allocate(shr_fire_emis_mechcomps(n_entries)) +! shr_fire_emis_mechcomps(:)%n_emis_comps = 0 +! +! emis_fields = '' +! +! item => items_list +! i = 1 +! do while(associated(item)) +! +! do k=1,shr_fire_emis_mechcomps_n +! if ( trim(shr_fire_emis_mechcomps(k)%name) == trim(item%name) ) then +! call shr_sys_abort( 'shr_fire_emis_init : multiple emissions definitions specified for : '//trim(item%name)) +! endif +! enddo +! if (len_trim(item%name) .le. name_len) then +! shr_fire_emis_mechcomps(i)%name = item%name(1:name_len) +! else +! call shr_sys_abort("shr_file_emis_init : name too long for data structure :"//trim(item%name)) +! endif +! shr_fire_emis_mechcomps(i)%n_emis_comps = item%n_terms +! allocate(shr_fire_emis_mechcomps(i)%emis_comps(item%n_terms)) +! +! do j = 1,item%n_terms +! shr_fire_emis_mechcomps(i)%emis_comps(j)%ptr => add_emis_comp( item%vars(j), item%coeffs(j) ) +! enddo +! shr_fire_emis_mechcomps_n = shr_fire_emis_mechcomps_n+1 +! +! write(token,333) shr_fire_emis_mechcomps_n +! +! if ( shr_fire_emis_mechcomps_n == 1 ) then +! ! do not prepend ":" to the string for the first token +! emis_fields = trim(token) +! shr_fire_emis_fields_token = token +! else +! emis_fields = trim(emis_fields)//':'//trim(token) +! endif +! +! item => item%next_item +! i = i+1 +! enddo +! if (associated(items_list)) call shr_exp_list_destroy(items_list) +! +! ! Need to explicitly add Fl_ based on naming convention +!333 format ('Fall_fire',i3.3) +! +! end subroutine shr_fire_emis_init + + !------------------------------------------------------------------------- + ! private methods... + + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + function add_emis_comp( name, coeff ) result(emis_comp) + + character(len=*), intent(in) :: name + real(r8), intent(in) :: coeff + type(shr_fire_emis_comp_t), pointer :: emis_comp + + emis_comp => get_emis_comp_by_name(shr_fire_emis_linkedlist, name) + if(associated(emis_comp)) then + ! already in the list so return... + return + endif + + ! create new emissions component and add it to the list + allocate(emis_comp) + + ! element%index = lookup_element( name ) + ! element%emis_factors = get_factors( list_elem%index ) + + emis_comp%index = shr_fire_emis_comps_n+1 + + emis_comp%name = trim(name) + emis_comp%coeff = coeff + nullify(emis_comp%next_emiscomp) + + call add_emis_comp_to_list(emis_comp) + + end function add_emis_comp + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + recursive function get_emis_comp_by_name(list_comp, name) result(emis_comp) + + type(shr_fire_emis_comp_t), pointer :: list_comp + character(len=*), intent(in) :: name ! variable name + type(shr_fire_emis_comp_t), pointer :: emis_comp ! returned object + + if(associated(list_comp)) then + if(list_comp%name .eq. name) then + emis_comp => list_comp + else + emis_comp => get_emis_comp_by_name(list_comp%next_emiscomp, name) + end if + else + nullify(emis_comp) + end if + + end function get_emis_comp_by_name + + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + subroutine add_emis_comp_to_list( new_emis_comp ) + + type(shr_fire_emis_comp_t), target, intent(in) :: new_emis_comp + + type(shr_fire_emis_comp_t), pointer :: list_comp + + if(associated(shr_fire_emis_linkedlist)) then + list_comp => shr_fire_emis_linkedlist + do while(associated(list_comp%next_emiscomp)) + list_comp => list_comp%next_emiscomp + end do + list_comp%next_emiscomp => new_emis_comp + else + shr_fire_emis_linkedlist => new_emis_comp + end if + + shr_fire_emis_comps_n = shr_fire_emis_comps_n + 1 + + end subroutine add_emis_comp_to_list + +endmodule shr_fire_emis_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_infnan_mod.F90.in b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_infnan_mod.F90.in new file mode 100755 index 000000000..eef3e607d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_infnan_mod.F90.in @@ -0,0 +1,406 @@ +! Flag representing compiler support of Fortran 2003's +! ieee_arithmetic intrinsic module. +!if defined CPRIBM || defined CPRPGI || defined CPRINTEL || defined CPRCRAY || defined CPRNAG +#define HAVE_IEEE_ARITHMETIC +!endif + +module shr_infnan_mod +!--------------------------------------------------------------------- +! Module to test for IEEE Inf and NaN values, which also provides a +! method of setting +/-Inf and signaling or quiet NaN. +! +! All functions are elemental, and thus work on arrays. +!--------------------------------------------------------------------- +! To test for these values, just call the corresponding function, e.g: +! +! var_is_nan = shr_infnan_isnan(x) +! +! You can also use it on arrays: +! +! array_contains_nan = any(shr_infnan_isnan(my_array)) +! +!--------------------------------------------------------------------- +! To generate these values, assign one of the provided derived-type +! variables to a real: +! +! use shr_infnan_mod, only: nan => shr_infnan_nan, & +! inf => shr_infnan_inf, & +! assignment(=) +! real(r4) :: my_nan +! real(r8) :: my_inf_array(2,2) +! my_nan = nan +! my_inf_array = inf +! +! Keep in mind that "shr_infnan_nan" and "shr_infnan_inf" cannot be +! passed to functions that expect real arguments. To pass a real +! NaN, you will have to use shr_infnan_nan to set a local real of +! the correct kind. +!--------------------------------------------------------------------- + +use shr_kind_mod, only: & + r4 => SHR_KIND_R4, & + r8 => SHR_KIND_R8 + +#ifdef HAVE_IEEE_ARITHMETIC + +! If we have IEEE_ARITHMETIC, the NaN test is provided for us. +use, intrinsic :: ieee_arithmetic, only: & + shr_infnan_isnan => ieee_is_nan + +#else + +! Integers of correct size for bit patterns below. +use shr_kind_mod, only: i4 => shr_kind_i4, i8 => shr_kind_i8 + +#endif + +implicit none +private +save + +! Test functions for NaN/Inf values. +public :: shr_infnan_isnan +public :: shr_infnan_isinf +public :: shr_infnan_isposinf +public :: shr_infnan_isneginf + +! Locally defined isnan. +#ifndef HAVE_IEEE_ARITHMETIC +interface shr_infnan_isnan + ! TYPE double,real + module procedure shr_infnan_isnan_{TYPE} +end interface +#endif + +interface shr_infnan_isinf + ! TYPE double,real + module procedure shr_infnan_isinf_{TYPE} +end interface + +interface shr_infnan_isposinf + ! TYPE double,real + module procedure shr_infnan_isposinf_{TYPE} +end interface + +interface shr_infnan_isneginf + ! TYPE double,real + module procedure shr_infnan_isneginf_{TYPE} +end interface + +! Derived types for generation of NaN/Inf +! Even though there's no reason to "use" the types directly, some compilers +! might have trouble with an object being used without its type. +public :: shr_infnan_nan_type +public :: shr_infnan_inf_type +public :: assignment(=) +public :: shr_infnan_to_r4 +public :: shr_infnan_to_r8 + +! Type representing Not A Number. +type :: shr_infnan_nan_type + logical :: quiet = .false. +end type shr_infnan_nan_type + +! Type representing +/-Infinity. +type :: shr_infnan_inf_type + logical :: positive = .true. +end type shr_infnan_inf_type + +! Allow assigning reals to NaN or Inf. +interface assignment(=) + ! TYPE double,real + ! DIMS 0,1,2,3,4,5,6,7 + module procedure set_nan_{DIMS}d_{TYPE} + ! TYPE double,real + ! DIMS 0,1,2,3,4,5,6,7 + module procedure set_inf_{DIMS}d_{TYPE} +end interface + +! Conversion functions. +interface shr_infnan_to_r8 + module procedure nan_r8 + module procedure inf_r8 +end interface + +interface shr_infnan_to_r4 + module procedure nan_r4 + module procedure inf_r4 +end interface + +! Initialize objects of NaN/Inf type for other modules to use. + +! Default NaN is signaling, but also provide snan and qnan to choose +! explicitly. +type(shr_infnan_nan_type), public, parameter :: shr_infnan_nan = & + shr_infnan_nan_type(.false.) +type(shr_infnan_nan_type), public, parameter :: shr_infnan_snan = & + shr_infnan_nan_type(.false.) +type(shr_infnan_nan_type), public, parameter :: shr_infnan_qnan = & + shr_infnan_nan_type(.true.) + +! Default Inf is positive, but provide posinf to go with neginf. +type(shr_infnan_inf_type), public, parameter :: shr_infnan_inf = & + shr_infnan_inf_type(.true.) +type(shr_infnan_inf_type), public, parameter :: shr_infnan_posinf = & + shr_infnan_inf_type(.true.) +type(shr_infnan_inf_type), public, parameter :: shr_infnan_neginf = & + shr_infnan_inf_type(.false.) + +! Bit patterns for implementation without ieee_arithmetic. +! Note that in order to satisfy gfortran's range check, we have to use +! ibset to set the sign bit from a BOZ pattern. +#ifndef HAVE_IEEE_ARITHMETIC +! Single precision. +integer(i4), parameter :: ssnan_pat = int(Z'7FA00000',i4) +integer(i4), parameter :: sqnan_pat = int(Z'7FC00000',i4) +integer(i4), parameter :: sposinf_pat = int(Z'7F800000',i4) +integer(i4), parameter :: sneginf_pat = ibset(sposinf_pat,bit_size(1_i4)-1) +! Double precision. +integer(i8), parameter :: dsnan_pat = int(Z'7FF4000000000000',i8) +integer(i8), parameter :: dqnan_pat = int(Z'7FF8000000000000',i8) +integer(i8), parameter :: dposinf_pat = int(Z'7FF0000000000000',i8) +integer(i8), parameter :: dneginf_pat = ibset(dposinf_pat,bit_size(1_i8)-1) +#endif + +contains + +!--------------------------------------------------------------------- +! TEST FUNCTIONS +!--------------------------------------------------------------------- +! The "isinf" function simply calls "isposinf" and "isneginf". +!--------------------------------------------------------------------- + +! TYPE double,real +elemental function shr_infnan_isinf_{TYPE}(x) result(isinf) + {VTYPE}, intent(in) :: x + logical :: isinf + + isinf = shr_infnan_isposinf(x) .or. shr_infnan_isneginf(x) + +end function shr_infnan_isinf_{TYPE} + +#ifdef HAVE_IEEE_ARITHMETIC + +!--------------------------------------------------------------------- +! The "isposinf" and "isneginf" functions get the IEEE class of a +! real, and test to see if the class is equal to ieee_positive_inf +! or ieee_negative_inf. +!--------------------------------------------------------------------- + +! TYPE double,real +elemental function shr_infnan_isposinf_{TYPE}(x) result(isposinf) + use, intrinsic :: ieee_arithmetic, only: & + ieee_class, & + ieee_positive_inf, & + operator(==) + {VTYPE}, intent(in) :: x + logical :: isposinf + + isposinf = (ieee_positive_inf == ieee_class(x)) + +end function shr_infnan_isposinf_{TYPE} + +! TYPE double,real +elemental function shr_infnan_isneginf_{TYPE}(x) result(isneginf) + use, intrinsic :: ieee_arithmetic, only: & + ieee_class, & + ieee_negative_inf, & + operator(==) + {VTYPE}, intent(in) :: x + logical :: isneginf + + isneginf = (ieee_negative_inf == ieee_class(x)) + +end function shr_infnan_isneginf_{TYPE} + +#else +! Don't have ieee_arithmetic. + +#ifdef CPRGNU +! NaN testing on gfortran. +! TYPE double,real +elemental function shr_infnan_isnan_{TYPE}(x) result(is_nan) + {VTYPE}, intent(in) :: x + logical :: is_nan + + is_nan = isnan(x) + +end function shr_infnan_isnan_{TYPE} +! End GNU section. +#endif + +!--------------------------------------------------------------------- +! The "isposinf" and "isneginf" functions just test against a known +! bit pattern if we don't have ieee_arithmetic. +!--------------------------------------------------------------------- + +! TYPE double,real +elemental function shr_infnan_isposinf_{TYPE}(x) result(isposinf) + {VTYPE}, intent(in) :: x + logical :: isposinf +#if ({ITYPE} == TYPEREAL) + integer(i4), parameter :: posinf_pat = sposinf_pat +#else + integer(i8), parameter :: posinf_pat = dposinf_pat +#endif + + isposinf = (x == transfer(posinf_pat,x)) + +end function shr_infnan_isposinf_{TYPE} + +! TYPE double,real +elemental function shr_infnan_isneginf_{TYPE}(x) result(isneginf) + {VTYPE}, intent(in) :: x + logical :: isneginf +#if ({ITYPE} == TYPEREAL) + integer(i4), parameter :: neginf_pat = sneginf_pat +#else + integer(i8), parameter :: neginf_pat = dneginf_pat +#endif + + isneginf = (x == transfer(neginf_pat,x)) + +end function shr_infnan_isneginf_{TYPE} + +! End ieee_arithmetic conditional. +#endif + +!--------------------------------------------------------------------- +! GENERATION FUNCTIONS +!--------------------------------------------------------------------- +! Two approaches for generation of NaN and Inf values: +! 1. With Fortran 2003, use the ieee_value intrinsic to get a value +! from the corresponding class. These are: +! - ieee_signaling_nan +! - ieee_quiet_nan +! - ieee_positive_inf +! - ieee_negative_inf +! 2. Without Fortran 2003, set the IEEE bit patterns directly. +! Use BOZ literals to get an integer with the correct bit +! pattern, then use "transfer" to transfer those bits into a +! real. +!--------------------------------------------------------------------- + +! TYPE double,real +! DIMS 0,1,2,3,4,5,6,7 +pure subroutine set_nan_{DIMS}d_{TYPE}(output, nan) +#ifdef HAVE_IEEE_ARITHMETIC + use, intrinsic :: ieee_arithmetic, only: & + ieee_signaling_nan, & + ieee_quiet_nan, & + ieee_value +#else +#if ({ITYPE} == TYPEREAL) + integer(i4), parameter :: snan_pat = ssnan_pat + integer(i4), parameter :: qnan_pat = sqnan_pat +#else + integer(i8), parameter :: snan_pat = dsnan_pat + integer(i8), parameter :: qnan_pat = dqnan_pat +#endif +#endif + {VTYPE}, intent(out) :: output{DIMSTR} + type(shr_infnan_nan_type), intent(in) :: nan + + ! Use scalar temporary for performance reasons, to reduce the cost of + ! the ieee_value call. + {VTYPE} :: tmp + +#ifdef HAVE_IEEE_ARITHMETIC + if (nan%quiet) then + tmp = ieee_value(tmp, ieee_quiet_nan) + else + tmp = ieee_value(tmp, ieee_signaling_nan) + end if +#else + if (nan%quiet) then + tmp = transfer(qnan_pat, tmp) + else + tmp = transfer(snan_pat, tmp) + end if +#endif + + output = tmp + +end subroutine set_nan_{DIMS}d_{TYPE} + +! TYPE double,real +! DIMS 0,1,2,3,4,5,6,7 +pure subroutine set_inf_{DIMS}d_{TYPE}(output, inf) +#ifdef HAVE_IEEE_ARITHMETIC + use, intrinsic :: ieee_arithmetic, only: & + ieee_positive_inf, & + ieee_negative_inf, & + ieee_value +#else +#if ({ITYPE} == TYPEREAL) + integer(i4), parameter :: posinf_pat = sposinf_pat + integer(i4), parameter :: neginf_pat = sneginf_pat +#else + integer(i8), parameter :: posinf_pat = dposinf_pat + integer(i8), parameter :: neginf_pat = dneginf_pat +#endif +#endif + {VTYPE}, intent(out) :: output{DIMSTR} + type(shr_infnan_inf_type), intent(in) :: inf + + ! Use scalar temporary for performance reasons, to reduce the cost of + ! the ieee_value call. + {VTYPE} :: tmp + +#ifdef HAVE_IEEE_ARITHMETIC + if (inf%positive) then + tmp = ieee_value(tmp,ieee_positive_inf) + else + tmp = ieee_value(tmp,ieee_negative_inf) + end if +#else + if (inf%positive) then + tmp = transfer(posinf_pat, tmp) + else + tmp = transfer(neginf_pat, tmp) + end if +#endif + + output = tmp + +end subroutine set_inf_{DIMS}d_{TYPE} + +!--------------------------------------------------------------------- +! CONVERSION INTERFACES. +!--------------------------------------------------------------------- +! Function methods to get reals from nan/inf types. +!--------------------------------------------------------------------- + +pure function nan_r8(nan) result(output) + class(shr_infnan_nan_type), intent(in) :: nan + real(r8) :: output + + output = nan + +end function nan_r8 + +pure function nan_r4(nan) result(output) + class(shr_infnan_nan_type), intent(in) :: nan + real(r4) :: output + + output = nan + +end function nan_r4 + +pure function inf_r8(inf) result(output) + class(shr_infnan_inf_type), intent(in) :: inf + real(r8) :: output + + output = inf + +end function inf_r8 + +pure function inf_r4(inf) result(output) + class(shr_infnan_inf_type), intent(in) :: inf + real(r4) :: output + + output = inf + +end function inf_r4 + +end module shr_infnan_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_kind_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_kind_mod.F90 new file mode 100755 index 000000000..5536ddc73 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_kind_mod.F90 @@ -0,0 +1,21 @@ +MODULE shr_kind_mod + + use MAPL_ConstantsMod + + !---------------------------------------------------------------------------- + ! precision/kind constants add data public + !---------------------------------------------------------------------------- + public + integer,parameter :: SHR_KIND_R8 = MAPL_R8 ! 8 byte real + integer,parameter :: SHR_KIND_R4 = MAPL_R4 ! 4 byte real + integer,parameter :: SHR_KIND_RN = MAPL_RN ! native real + integer,parameter :: SHR_KIND_I8 = MAPL_I8 ! 8 byte integer + integer,parameter :: SHR_KIND_I4 = MAPL_I4 ! 4 byte integer + integer,parameter :: SHR_KIND_IN = MAPL_IN ! native integer + integer,parameter :: SHR_KIND_CS = 80 ! short char + integer,parameter :: SHR_KIND_CM = 160 ! mid-sized char + integer,parameter :: SHR_KIND_CL = 256 ! long char + integer,parameter :: SHR_KIND_CX = 512 ! extra-long char + integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char + +END MODULE shr_kind_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_log_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_log_mod.F90 new file mode 100755 index 000000000..8a3153562 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_log_mod.F90 @@ -0,0 +1,105 @@ +!BOP =========================================================================== +! +! !MODULE: shr_log_mod -- variables and methods for logging +! +! !DESCRIPTION: +! Low-level shared variables for logging. +! +! Also, routines for generating log file messages. +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_log_mod + +! !USES: + + use shr_kind_mod +! use shr_strconvert_mod, only: toString + + use, intrinsic :: iso_fortran_env, only: output_unit + + implicit none + private + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_log_errMsg +! public :: shr_log_OOBMsg + +! !PUBLIC DATA MEMBERS: + + public :: shr_log_Level + public :: shr_log_Unit + +!EOP + + ! low-level shared variables for logging, these may not be parameters + integer(SHR_KIND_IN) :: shr_log_Level = 0 + integer(SHR_KIND_IN) :: shr_log_Unit = output_unit + +contains + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_log_errMsg -- Return an error message containing file & line info +! +! !DESCRIPTION: +! Return an error message containing file & line info +! \newline +! errMsg = shr\_log\_errMsg(__FILE__, __LINE__) +! +! This is meant to be used when a routine expects a string argument for some message, +! but you want to provide file and line information. +! +! However: Note that the performance of this function can be very bad. It is currently +! maintained because it is used by old code, but you should probably avoid using this +! in new code if possible. +! +! !REVISION HISTORY: +! 2013-July-23 - Bill Sacks +! +! !INTERFACE: ------------------------------------------------------------------ + +pure function shr_log_errMsg(file, line) + +! !INPUT/OUTPUT PARAMETERS: + + character(len=SHR_KIND_CX) :: shr_log_errMsg + character(len=*), intent(in) :: file + integer , intent(in) :: line + character(len=40) :: line_str + +!EOP + write(line_str, '(i40)') line + shr_log_errMsg = 'ERROR in '//trim(file)//' at line '//trim(line_str) + +end function shr_log_errMsg + +!! Create a message for an out of bounds error. +!pure function shr_log_OOBMsg(operation, bounds, idx) result(OOBMsg) +! +! ! A name for the operation being attempted when the bounds error +! ! occurred. A string containing the subroutine name is ideal, but more +! ! generic descriptions such as "read", "modify", or "insert" could be used. +! character(len=*), intent(in) :: operation +! +! ! Upper and lower bounds allowed for the operation. +! integer, intent(in) :: bounds(2) +! +! ! Index at which access was attempted. +! integer, intent(in) :: idx +! +! ! Output message +! character(len=:), allocatable :: OOBMsg +! +! allocate(OOBMsg, source=(operation//": "//toString(idx)//" not in range ["//& +! toString(bounds(1))//", "//toString(bounds(2))//"].")) +! +!end function shr_log_OOBMsg + +end module shr_log_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_mpi_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_mpi_mod.F90 new file mode 100755 index 000000000..7da4182c3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_mpi_mod.F90 @@ -0,0 +1,2217 @@ +Module shr_mpi_mod + + !------------------------------------------------------------------------------- + ! PURPOSE: general layer on MPI functions + !------------------------------------------------------------------------------- + + use shr_kind_mod + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + implicit none + private + + ! PUBLIC: Public interfaces + + public :: shr_mpi_chkerr + public :: shr_mpi_send + public :: shr_mpi_recv + public :: shr_mpi_bcast + public :: shr_mpi_gathScatVInit + public :: shr_mpi_gatherV + public :: shr_mpi_scatterV + public :: shr_mpi_sum + public :: shr_mpi_min + public :: shr_mpi_max + public :: shr_mpi_commsize + public :: shr_mpi_commrank + public :: shr_mpi_initialized + public :: shr_mpi_abort + public :: shr_mpi_barrier + public :: shr_mpi_init + public :: shr_mpi_finalize + + interface shr_mpi_send ; module procedure & + shr_mpi_sendi0, & + shr_mpi_sendi1, & + shr_mpi_sendr0, & + shr_mpi_sendr1, & + shr_mpi_sendr3 + end interface shr_mpi_send + interface shr_mpi_recv ; module procedure & + shr_mpi_recvi0, & + shr_mpi_recvi1, & + shr_mpi_recvr0, & + shr_mpi_recvr1, & + shr_mpi_recvr3 + end interface shr_mpi_recv + interface shr_mpi_bcast ; module procedure & + shr_mpi_bcastc0, & + shr_mpi_bcastc1, & + shr_mpi_bcastl0, & + shr_mpi_bcastl1, & + shr_mpi_bcasti0, & + shr_mpi_bcasti1, & + shr_mpi_bcasti80, & + shr_mpi_bcasti81, & + shr_mpi_bcasti2, & + shr_mpi_bcastr0, & + shr_mpi_bcastr1, & + shr_mpi_bcastr2, & + shr_mpi_bcastr3 + end interface shr_mpi_bcast + interface shr_mpi_gathScatVInit ; module procedure & + shr_mpi_gathScatVInitr1 + end interface shr_mpi_gathScatVInit + interface shr_mpi_gatherv ; module procedure & + shr_mpi_gatherVr1 + end interface shr_mpi_gatherv + interface shr_mpi_scatterv ; module procedure & + shr_mpi_scatterVr1 + end interface shr_mpi_scatterv + interface shr_mpi_sum ; module procedure & + shr_mpi_sumi0, & + shr_mpi_sumi1, & + shr_mpi_sumb0, & + shr_mpi_sumb1, & + shr_mpi_sumr0, & + shr_mpi_sumr1, & + shr_mpi_sumr2, & + shr_mpi_sumr3 + end interface shr_mpi_sum + interface shr_mpi_min ; module procedure & + shr_mpi_mini0, & + shr_mpi_mini1, & + shr_mpi_minr0, & + shr_mpi_minr1 + end interface shr_mpi_min + interface shr_mpi_max ; module procedure & + shr_mpi_maxi0, & + shr_mpi_maxi1, & + shr_mpi_maxr0, & + shr_mpi_maxr1 + end interface shr_mpi_max + +!#include ! mpi library include file + include 'mpif.h' ! mpi library include file + !=============================================================================== +CONTAINS + !=============================================================================== + + SUBROUTINE shr_mpi_chkerr(rcode,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: rcode ! input MPI error code + character(*), intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_chkerr) ' + character(MPI_MAX_ERROR_STRING) :: lstring + integer(SHR_KIND_IN) :: len + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: layer on MPI error checking + !------------------------------------------------------------------------------- + + if (rcode /= MPI_SUCCESS) then + call MPI_ERROR_STRING(rcode,lstring,len,ierr) + write(s_logunit,*) trim(subName),":",lstring(1:len) + call shr_mpi_abort(string,rcode) + endif + + END SUBROUTINE shr_mpi_chkerr + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sendi0(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec ! send value + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendi0) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Send a single integer + !------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_sendi0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sendi1(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendi1) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Send a vector of integers + !------------------------------------------------------------------------------- + + lsize = size(lvec) + + call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_sendi1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sendr0(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendr0) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Send a real scalar + !------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_sendr0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sendr1(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendr1) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Send a vector of reals + !------------------------------------------------------------------------------- + + lsize = size(lvec) + + call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_sendr1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sendr3(array,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real (SHR_KIND_R8), intent(in) :: array(:,:,:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendr3) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Send a vector of reals + !------------------------------------------------------------------------------- + + lsize = size(array) + + call MPI_SEND(array,lsize,MPI_REAL8,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_sendr3 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_recvi0(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(out):: lvec ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvi0) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Recv a vector of reals + !------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_recvi0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_recvi1(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(out):: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvi1) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Recv a vector of reals + !------------------------------------------------------------------------------- + + lsize = size(lvec) + + call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_recvi1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_recvr0(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(out):: lvec ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvr0) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Recv a vector of reals + !------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_recvr0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_recvr1(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(out):: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvr1) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Recv a vector of reals + !------------------------------------------------------------------------------- + + lsize = size(lvec) + + call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_recvr1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_recvr3(array,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real (SHR_KIND_R8), intent(out):: array(:,:,:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvr3) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Recv a vector of reals + !------------------------------------------------------------------------------- + + lsize = size(array) + + call MPI_RECV(array,lsize,MPI_REAL8,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_recvr3 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcasti0(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast an integer + !------------------------------------------------------------------------------- + + lsize = 1 + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcasti0 + + SUBROUTINE shr_mpi_bcasti80(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_I8), intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast an integer + !------------------------------------------------------------------------------- + + lsize = 1 + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcasti80 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcastl0(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + logical, intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastl0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a logical + !------------------------------------------------------------------------------- + + lsize = 1 + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcastl0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcastc0(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + character(len=*), intent(inout) :: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastc0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a character string + !------------------------------------------------------------------------------- + + lsize = len(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcastc0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcastc1(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + character(len=*), intent(inout) :: vec(:) ! 1D vector + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastc1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a character string + !------------------------------------------------------------------------------- + + lsize = size(vec)*len(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcastc1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcastr0(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastr0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a real + !------------------------------------------------------------------------------- + + lsize = 1 + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcastr0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcasti1(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(inout):: vec(:) ! vector + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a vector of integers + !------------------------------------------------------------------------------- + + lsize = size(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcasti1 + + SUBROUTINE shr_mpi_bcasti81(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_I8), intent(inout):: vec(:) ! vector + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a vector of integers + !------------------------------------------------------------------------------- + + lsize = size(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcasti81 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcastl1(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + logical, intent(inout):: vec(:) ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastl1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a logical + !------------------------------------------------------------------------------- + + lsize = size(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcastl1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcastr1(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(inout):: vec(:) ! vector + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastr1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a vector of reals + !------------------------------------------------------------------------------- + + lsize = size(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcastr1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcastr2(arr,comm,string,pebcast) + + IMPLICIT none + + !----- arguments ----- + real(SHR_KIND_R8), intent(inout):: arr(:,:) ! array, 2d + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local ----- + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_bcastr2) ' + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a 2d array of reals + !------------------------------------------------------------------------------- + + lsize = size(arr) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcastr2 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcasti2(arr,comm,string,pebcast) + + IMPLICIT none + + !----- arguments ----- + integer, intent(inout):: arr(:,:) ! array, 2d + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local ----- + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_bcasti2) ' + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a 2d array of integers + !------------------------------------------------------------------------------- + + lsize = size(arr) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(arr,lsize,MPI_INTEGER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcasti2 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_bcastr3(arr,comm,string,pebcast) + + IMPLICIT none + + !----- arguments ----- + real(SHR_KIND_R8), intent(inout):: arr(:,:,:) ! array, 3d + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local ----- + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_bcastr3) ' + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a 3d array of reals + !------------------------------------------------------------------------------- + + lsize = size(arr) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_bcastr3 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_gathScatvInitr1(comm, rootid, locArr, glob1DArr, globSize, & + displs, string ) + + IMPLICIT none + + !----- arguments ----- + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather/scatter on + real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array of distributed data + real(SHR_KIND_R8), pointer :: glob1DArr(:) ! Global 1D array of gathered data + integer(SHR_KIND_IN), pointer :: globSize(:) ! Size of each distributed piece + integer(SHR_KIND_IN), pointer :: displs(:) ! Displacements for receive + character(*),optional,intent(in) :: string ! message + + !----- local ----- + integer(SHR_KIND_IN) :: npes ! Number of MPI tasks + integer(SHR_KIND_IN) :: locSize ! Size of local distributed data + integer(SHR_KIND_IN), pointer :: sendSize(:) ! Size to send for initial gather + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: rank ! Rank of this MPI task + integer(SHR_KIND_IN) :: nSize ! Maximum size to send + integer(SHR_KIND_IN) :: ierr ! Error code + integer(SHR_KIND_IN) :: nSiz1D ! Size of 1D global array + integer(SHR_KIND_IN) :: maxSize ! Maximum size + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_gathScatvInitr1) ' + + !------------------------------------------------------------------------------- + ! PURPOSE: Setup arrays for a gatherv/scatterv operation + !------------------------------------------------------------------------------- + + locSize = size(locarr) + call shr_mpi_commsize( comm, npes ) + call shr_mpi_commrank( comm, rank ) + allocate( globSize(npes) ) + ! + ! --- Gather the send global sizes from each MPI task ----------------------- + ! + allocate( sendSize(npes) ) + sendSize(:) = 1 + globSize(:) = 1 + call MPI_GATHER( locSize, 1, MPI_INTEGER, globSize, sendSize, & + MPI_INTEGER, rootid, comm, ierr ) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + deallocate( sendSize ) + ! + ! --- Prepare the displacement and allocate arrays ------------------------- + ! + allocate( displs(npes) ) + displs(1) = 0 + if ( rootid /= rank )then + maxSize = 1 + globSize = 1 + else + maxSize = maxval(globSize) + end if + nsiz1D = min(maxSize,globSize(1)) + do i = 2, npes + nSize = min(maxSize,globSize(i-1)) + displs(i) = displs(i-1) + nSize + nsiz1D = nsiz1D + min(maxSize,globSize(i)) + end do + allocate( glob1DArr(nsiz1D) ) + !----- Do some error checking for the root task arrays computed ---- + if ( rootid == rank )then + if ( nsiz1D /= sum(globSize) ) & + call shr_mpi_abort( subName//" : Error, size of global array not right" ) + if ( any(displs < 0) .or. any(displs >= nsiz1D) ) & + call shr_mpi_abort( subName//" : Error, displacement array not right" ) + if ( (displs(npes)+globSize(npes)) /= nsiz1D ) & + call shr_mpi_abort( subName//" : Error, displacement array values too big" ) + end if + + END SUBROUTINE shr_mpi_gathScatvInitr1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, & + comm, string ) + + IMPLICIT none + + !----- arguments ----- + real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array + real(SHR_KIND_R8), intent(inout):: glob1DArr(:) ! Global 1D array to receive in on + integer(SHR_KIND_IN), intent(in) :: locSize ! Number to send this PE + integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to receive each PE + integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for receive + integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather on + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local ----- + integer(SHR_KIND_IN) :: ierr ! Error code + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_gathervr1) ' + + !------------------------------------------------------------------------------- + ! PURPOSE: Gather a 1D array of reals + !------------------------------------------------------------------------------- + + call MPI_GATHERV( locarr, locSize, MPI_REAL8, glob1Darr, globSize, displs, & + MPI_REAL8, rootid, comm, ierr ) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_gathervr1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, & + comm, string ) + + IMPLICIT none + + !----- arguments ----- + real(SHR_KIND_R8), intent(out) :: locarr(:) ! Local array + real(SHR_KIND_R8), intent(in) :: glob1Darr(:) ! Global 1D array to send from + integer(SHR_KIND_IN), intent(in) :: locSize ! Number to receive this PE + integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to send to each PE + integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for send + integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to scatter on + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local ----- + integer(SHR_KIND_IN) :: ierr ! Error code + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_scattervr1) ' + + !------------------------------------------------------------------------------- + ! PURPOSE: Scatter a 1D array of reals + !------------------------------------------------------------------------------- + + + call MPI_SCATTERV( glob1Darr, globSize, displs, MPI_REAL8, locarr, locSize, & + MPI_REAL8, rootid, comm, ierr ) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_scattervr1 + + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sumi0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumi0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds sum of a distributed vector of values, assume local sum + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_sumi0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sumi1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumi1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds sum of a distributed vector of values, assume local sum + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_sumi1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sumb0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_I8), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_I8), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumb0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds sum of a distributed vector of values, assume local sum + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_sumb0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sumb1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_I8), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_I8), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumb1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds sum of a distributed vector of values, assume local sum + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_sumb1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sumr0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumr0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds sum of a distributed vector of values, assume local sum + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_sumr0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sumr1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumr1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds sum of a distributed vector of values, assume local sum + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_sumr1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sumr2(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:,:)! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:,:)! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumr2) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds sum of a distributed vector of values, assume local sum + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_sumr2 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_sumr3(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:,:,:) ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:,:,:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumr3) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds sum of a distributed vector of values, assume local sum + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_sumr3 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_mini0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_mini0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds min of a distributed vector of values, assume local min + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_MIN + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_mini0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_mini1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_mini1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds min of a distributed vector of values, assume local min + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_MIN + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_mini1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_minr0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_minr0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds min of a distributed vector of values, assume local min + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_MIN + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_minr0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_minr1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_minr1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds min of a distributed vector of values, assume local min + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_MIN + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_minr1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_maxi0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_maxi0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds max of a distributed vector of values, assume local max + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_MAX + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_maxi0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_maxi1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_maxi1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds max of a distributed vector of values, assume local max + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_MAX + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_maxi1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_maxr0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_maxr0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds max of a distributed vector of values, assume local max + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_MAX + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_maxr0 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_maxr1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_maxr1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: Finds max of a distributed vector of values, assume local max + ! already computed + !------------------------------------------------------------------------------- + + reduce_type = MPI_MAX + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + + END SUBROUTINE shr_mpi_maxr1 + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_commsize(comm,size,string) + + IMPLICIT none + + !----- arguments --- + integer,intent(in) :: comm + integer,intent(out) :: size + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_commsize) ' + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: MPI commsize + !------------------------------------------------------------------------------- + + call MPI_COMM_SIZE(comm,size,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_commsize + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_commrank(comm,rank,string) + + IMPLICIT none + + !----- arguments --- + integer,intent(in) :: comm + integer,intent(out) :: rank + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_commrank) ' + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: MPI commrank + !------------------------------------------------------------------------------- + + call MPI_COMM_RANK(comm,rank,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_commrank + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_initialized(flag,string) + + IMPLICIT none + + !----- arguments --- + logical,intent(out) :: flag + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_initialized) ' + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: MPI initialized + !------------------------------------------------------------------------------- + + call MPI_INITIALIZED(flag,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_initialized + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_abort(string,rcode) + + IMPLICIT none + + !----- arguments --- + character(*),optional,intent(in) :: string ! message + integer,optional,intent(in) :: rcode ! optional code + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_abort) ' + integer(SHR_KIND_IN) :: ierr + integer :: rc ! return code + + !------------------------------------------------------------------------------- + ! PURPOSE: MPI abort + !------------------------------------------------------------------------------- + + if ( present(string) .and. present(rcode) ) then + write(s_logunit,*) trim(subName),":",trim(string),rcode + endif + if ( present(rcode) )then + rc = rcode + else + rc = 1001 + end if + call MPI_ABORT(MPI_COMM_WORLD,rc,ierr) + + END SUBROUTINE shr_mpi_abort + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_barrier(comm,string) + + IMPLICIT none + + !----- arguments --- + integer,intent(in) :: comm + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_barrier) ' + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: MPI barrier + !------------------------------------------------------------------------------- + + call MPI_BARRIER(comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_barrier + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_init(string) + + IMPLICIT none + + !----- arguments --- + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_init) ' + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: MPI init + !------------------------------------------------------------------------------- + + call MPI_INIT(ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_init + + !=============================================================================== + !=============================================================================== + + SUBROUTINE shr_mpi_finalize(string) + + IMPLICIT none + + !----- arguments --- + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_finalize) ' + integer(SHR_KIND_IN) :: ierr + + !------------------------------------------------------------------------------- + ! PURPOSE: MPI finalize + !------------------------------------------------------------------------------- + + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + call MPI_FINALIZE(ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + + END SUBROUTINE shr_mpi_finalize + + !=============================================================================== + !=============================================================================== + +END MODULE shr_mpi_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_nl_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_nl_mod.F90 new file mode 100755 index 000000000..c3121534a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_nl_mod.F90 @@ -0,0 +1,136 @@ +module shr_nl_mod + +! Utilities for namelist reading +! Adapted Fall 2012 from CAM's namelist_utils. + +implicit none +private + +save + +public :: & + shr_nl_find_group_name ! seek through a file to find a specified namelist +public :: shr_string_toLower ! Convert string to lower-case + +contains + +! This routine probably discards more error code information than it needs to. + +subroutine shr_nl_find_group_name(unit, group, status) + + +!--------------------------------------------------------------------------------------- +! Purpose: +! Search a file that contains namelist input for the specified namelist group name. +! Leave the file positioned so that the current record is the first record of the +! input for the specified group. +! +! Method: +! Read the file line by line. Each line is searched for an '&' which may only +! be preceded by blanks, immediately followed by the group name which is case +! insensitive. If found then backspace the file so the current record is the +! one containing the group name and return success. Otherwise return -1. +! +! Author: B. Eaton, August 2007 +!--------------------------------------------------------------------------------------- + + integer, intent(in) :: unit ! fortran unit attached to file + character(len=*), intent(in) :: group ! namelist group name + integer, intent(out) :: status ! 0 for success, -1 if group name not found + + ! Local variables + + integer :: len_grp + integer :: ios ! io status + character(len=80) :: inrec ! first 80 characters of input record + character(len=80) :: inrec2 ! left adjusted input record + character(len=len(group)) :: lc_group + + !--------------------------------------------------------------------------- + + len_grp = len_trim(group) + lc_group = shr_string_toLower(group) + + ios = 0 + do while (ios <= 0) + + read(unit, '(a)', iostat=ios, end=100) inrec + + if (ios <= 0) then ! ios < 0 indicates an end of record condition + + ! look for group name in this record + + ! remove leading blanks + inrec2 = adjustl(inrec) + + ! check for leading '&' + if (inrec2(1:1) == '&') then + + ! check for case insensitive group name + if (trim(lc_group) == shr_string_toLower(inrec2(2:len_grp+1))) then + + ! found group name. backspace to leave file position at this record + backspace(unit) + status = 0 + return + + end if + end if + end if + + end do + + 100 continue ! end of file processing + status = -1 + +end subroutine shr_nl_find_group_name + + !=============================================================================== + !BOP =========================================================================== + ! !IROUTINE: shr_string_toLower -- Convert string to lower case + ! + ! !DESCRIPTION: + ! Convert the input string to lower-case. + ! Use achar and iachar intrinsics to ensure use of ascii collating sequence. + ! + ! !REVISION HISTORY: + ! 2006-Apr-20 - Creation + ! + ! !INTERFACE: ------------------------------------------------------------------ + function shr_string_toLower(str) + + use shr_kind_mod ! F90 kinds + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: str ! String to convert to lower case + character(len=len(str)) :: shr_string_toLower + + !----- local ----- + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: aseq ! ascii collating sequence + integer(SHR_KIND_IN) :: UpperToLower ! integer to convert case + character(len=1) :: ctmp ! Character temporary + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_toLower) " + character(*),parameter :: F00 = "('(shr_string_toLower) ',4a)" + + !------------------------------------------------------------------------------- + ! + !------------------------------------------------------------------------------- + + UpperToLower = iachar("a") - iachar("A") + + do i = 1, len(str) + ctmp = str(i:i) + aseq = iachar(ctmp) + if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) & + ctmp = achar(aseq + UpperToLower) + shr_string_toLower(i:i) = ctmp + end do + + end function shr_string_toLower + +end module shr_nl_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_sys_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_sys_mod.F90 new file mode 100755 index 000000000..e0daed629 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_sys_mod.F90 @@ -0,0 +1,332 @@ +!=============================================================================== +! SVN $Id: shr_sys_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_sys_mod.F90 $ +!=============================================================================== + +! Currently supported by all compilers +!#define HAVE_GET_ENVIRONMENT +!#define HAVE_SLEEP +! +!! Except this combination? +!#if defined CPRPGI && defined CNL +!#undef HAVE_GET_ENVIRONMENT +!#endif +! +!#if defined CPRNAG +!#define HAVE_EXECUTE +!#endif + +MODULE shr_sys_mod + + use shr_kind_mod ! defines real & integer kinds + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + use shr_abort_mod, only: shr_sys_abort => shr_abort_abort +! use shr_abort_mod, only: shr_sys_backtrace => shr_abort_backtrace + +!#ifdef CPRNAG + ! ! NAG does not provide these as intrinsics, but it does provide modules + ! ! that implement commonly used POSIX routines. + ! use f90_unix_dir, only: chdir + ! use f90_unix_proc, only: abort, sleep +!#endif + + implicit none + +! PUBLIC: Public interfaces + + private + +! public :: shr_sys_system ! make a system call +! public :: shr_sys_chdir ! change current working dir +! public :: shr_sys_getenv ! get an environment variable +! public :: shr_sys_irtc ! returns real-time clock tick +! public :: shr_sys_sleep ! have program sleep for a while +! public :: shr_sys_flush ! flush an i/o buffer + + ! Imported from shr_abort_mod and republished with renames. Other code that wishes to + ! use these routines should use these shr_sys names rather than directly using the + ! routines from shr_abort_abort. (This is for consistency with older code, from when + ! these routines were defined in shr_sys_mod.) + public :: shr_sys_abort ! abort a program +! public :: shr_sys_backtrace ! print a backtrace, if possible + +!=============================================================================== +CONTAINS +!=============================================================================== + +!=============================================================================== +!=============================================================================== + +!SUBROUTINE shr_sys_system(str,rcode) +! +! IMPLICIT none +! +! !----- arguments --- +! character(*) ,intent(in) :: str ! system/shell command string +! integer(SHR_KIND_IN),intent(out) :: rcode ! function return error code +! +! !----- functions ----- +!#if (defined LINUX && !defined CPRGNU) +! integer(SHR_KIND_IN),external :: system ! function to envoke shell command +!#endif +! +! !----- formats ----- +! character(*),parameter :: subName = '(shr_sys_system) ' +! character(*),parameter :: F00 = "('(shr_sys_system) ',4a)" +! +!!------------------------------------------------------------------------------- +!! PURPOSE: an architecture independent system call +!!------------------------------------------------------------------------------- +! rcode = 0 +!#ifdef HAVE_EXECUTE +! call execute_command_line(str,exitstat=rcode) ! Intrinsic as of F2008 +!#else +!#if (defined AIX) +! +! call system(str,rcode) +! +!#elif (defined CPRGNU || defined LINUX) +! +! rcode = system(str) +! +!#else +! +! write(s_logunit,F00) 'ERROR: no implementation of system call for this architecture' +! call shr_sys_abort(subName//'no implementation of system call for this architecture') +!#endif +!#endif +! +!END SUBROUTINE shr_sys_system +! +!!=============================================================================== +!!=============================================================================== +! +!SUBROUTINE shr_sys_chdir(path, rcode) +! +! IMPLICIT none +! +! !----- arguments ----- +! character(*) ,intent(in) :: path ! chdir to this dir +! integer(SHR_KIND_IN),intent(out) :: rcode ! return code +! +! !----- local ----- +! integer(SHR_KIND_IN) :: lenpath ! length of path +!#if (defined AIX || (defined LINUX && !defined CPRGNU && !defined CPRNAG) || defined CPRINTEL) +! integer(SHR_KIND_IN),external :: chdir ! AIX system call +!#endif +! +! !----- formats ----- +! character(*),parameter :: subName = '(shr_sys_chdir) ' +! character(*),parameter :: F00 = "('(shr_sys_chdir) ',4a)" +! +!!------------------------------------------------------------------------------- +!! PURPOSE: an architecture independent system call +!!------------------------------------------------------------------------------- +! +! lenpath=len_trim(path) +! +!#if (defined AIX) +! +! rcode = chdir(%ref(path(1:lenpath)//'\0')) +! +!#elif (defined Darwin || (defined LINUX && !defined CPRNAG)) +! +! rcode=chdir(path(1:lenpath)) +! +!#elif (defined CPRNAG) +! +! call chdir(path(1:lenpath), errno=rcode) +! +!#else +! +! write(s_logunit,F00) 'ERROR: no implementation of chdir for this architecture' +! call shr_sys_abort(subname//'no implementation of chdir for this machine') +! +!#endif +! +!END SUBROUTINE shr_sys_chdir +! +!!=============================================================================== +!!=============================================================================== +! +!SUBROUTINE shr_sys_getenv(name, val, rcode) +! +! IMPLICIT none +! +! !----- arguments ----- +! character(*) ,intent(in) :: name ! env var name +! character(*) ,intent(out) :: val ! env var value +! integer(SHR_KIND_IN),intent(out) :: rcode ! return code +! +! !----- local ----- +!#ifndef HAVE_GET_ENVIRONMENT +! integer(SHR_KIND_IN) :: lenname ! length of env var name +! integer(SHR_KIND_IN) :: lenval ! length of env var value +! character(SHR_KIND_CL) :: tmpval ! temporary env var value +!#endif +! !----- formats ----- +! character(*),parameter :: subName = '(shr_sys_getenv) ' +! character(*),parameter :: F00 = "('(shr_sys_getenv) ',4a)" +! +!!------------------------------------------------------------------------------- +!! PURPOSE: an architecture independent system call +!!------------------------------------------------------------------------------- +! +!!$OMP master +! +! +!#ifdef HAVE_GET_ENVIRONMENT +! call get_environment_variable(name=name,value=val,status=rcode) ! Intrinsic in F2003 +!#else +! lenname=len_trim(name) +!#if (defined AIX || defined LINUX) +! +! call getenv(trim(name),tmpval) +! val=trim(tmpval) +! rcode = 0 +! if (len_trim(val) == 0 ) rcode = 1 +! if (len_trim(val) > SHR_KIND_CL) rcode = 2 +! +!#else +! +! write(s_logunit,F00) 'ERROR: no implementation of getenv for this architecture' +! call shr_sys_abort(subname//'no implementation of getenv for this machine') +! +!#endif +!#endif +!!$OMP end master +! +!END SUBROUTINE shr_sys_getenv +! +!!=============================================================================== +!!=============================================================================== +! +!integer(SHR_KIND_I8) FUNCTION shr_sys_irtc( rate ) +! +! IMPLICIT none +! +! !----- arguments ----- +! integer(SHR_KIND_I8), optional :: rate +! +! !----- local ----- +! integer(SHR_KIND_IN) :: count +! integer(SHR_KIND_IN) :: count_rate +! integer(SHR_KIND_IN) :: count_max +! +! integer(SHR_KIND_IN),save :: last_count = -1 +! integer(SHR_KIND_I8),save :: count_offset = 0 +!!$OMP THREADPRIVATE (last_count, count_offset) +! +! !----- formats ----- +! character(*),parameter :: subName = '(shr_sys_irtc) ' +! character(*),parameter :: F00 = "('(shr_sys_irtc) ',4a)" +! +!!------------------------------------------------------------------------------- +!! emulates Cray/SGI irtc function (returns clock tick since last reboot) +!! +!! This function is not intended to measure elapsed time between +!! multi-threaded regions with different numbers of threads. However, +!! use of the threadprivate declaration does guarantee accurate +!! measurement per thread within a single multi-threaded region as +!! long as the number of threads is not changed dynamically during +!! execution within the multi-threaded region. +!! +!!------------------------------------------------------------------------------- +! +! call system_clock(count=count,count_rate=count_rate, count_max=count_max) +! if ( present(rate) ) rate = count_rate +! shr_sys_irtc = count +! +! !--- adjust for clock wrap-around --- +! if ( last_count /= -1 ) then +! if ( count < last_count ) count_offset = count_offset + count_max +! end if +! shr_sys_irtc = shr_sys_irtc + count_offset +! last_count = count +! +!END FUNCTION shr_sys_irtc +! +!!=============================================================================== +!!=============================================================================== +! +!SUBROUTINE shr_sys_sleep(sec) +! +! IMPLICIT none +! +! !----- arguments ----- +! real (SHR_KIND_R8),intent(in) :: sec ! number of seconds to sleep +! +! !----- local ----- +! integer(SHR_KIND_IN) :: isec ! integer number of seconds +!#ifndef HAVE_SLEEP +! integer(SHR_KIND_IN) :: rcode ! return code +! character(90) :: str ! system call string +!#endif +! !----- formats ----- +! character(*),parameter :: subName = '(shr_sys_sleep) ' +! character(*),parameter :: F00 = "('(shr_sys_sleep) ',4a)" +! character(*),parameter :: F10 = "('sleep ',i8 )" +! +!!------------------------------------------------------------------------------- +!! PURPOSE: Sleep for approximately sec seconds +!!------------------------------------------------------------------------------- +! +! isec = nint(sec) +! +! if (isec < 0) then +! if (s_loglev > 0) write(s_logunit,F00) 'ERROR: seconds must be > 0, sec=',sec +! else if (isec == 0) then +! ! Don't consider this an error and don't call system sleep +! else +!#ifdef HAVE_SLEEP +! call sleep(isec) +!#else +! write(str,FMT=F10) isec +! call shr_sys_system( str, rcode ) +!#endif +! endif +! +!END SUBROUTINE shr_sys_sleep +! +!!=============================================================================== +!!=============================================================================== +! +!SUBROUTINE shr_sys_flush(unit) +! +! IMPLICIT none +! +! !----- arguments ----- +! integer(SHR_KIND_IN) :: unit ! flush output buffer for this unit +! +! !----- local ----- +! !----- formats ----- +! character(*),parameter :: subName = '(shr_sys_flush) ' +! character(*),parameter :: F00 = "('(shr_sys_flush) ',4a)" +! +!!------------------------------------------------------------------------------- +!! PURPOSE: an architecture independent system call +!! +!! This is probably no longer needed; the "flush" statement is supported by +!! all compilers that CESM supports for years now. +!! +!!------------------------------------------------------------------------------- +!!$OMP SINGLE +! flush(unit) +!!$OMP END SINGLE +!! +!! The following code was originally present, but there's an obvious issue. +!! Since shr_sys_flush is usually used to flush output to a log, when it +!! returns an error, does it do any good to print that error to the log? +!! +!! if (ierr > 0) then +!! write(s_logunit,*) subname,' Flush reports error: ',ierr +!! endif +!! +! +!END SUBROUTINE shr_sys_flush +! +!!=============================================================================== +!!=============================================================================== + +END MODULE shr_sys_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/spmdMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/spmdMod.F90 new file mode 100755 index 000000000..948066e84 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/spmdMod.F90 @@ -0,0 +1,126 @@ + +module spmdMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: spmdMod +! +! !DESCRIPTION: +! SPMD initialization +! +! !REVISION HISTORY: +! Author: Mariana Vertenstein +! +!EOP +!----------------------------------------------------------------------- + + use ESMF + use MAPL + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varctl , only: iulog + implicit none + + private + +#include + + save + + ! Default settings valid even if there is no spmd + + logical, public :: masterproc ! proc 0 logical for printing msgs + integer, public :: iam ! processor number + integer, public :: npes ! number of processors for clm + integer, public :: mpicom ! communicator group for clm + integer, public :: comp_id ! component id + + ! + ! Public methods + ! + public :: spmd_init ! Initialization + + ! + ! Values from mpif.h that can be used + ! + public :: MPI_INTEGER + public :: MPI_REAL8 + public :: MPI_LOGICAL + public :: MPI_SUM + public :: MPI_MIN + public :: MPI_MAX + public :: MPI_LOR + public :: MPI_STATUS_SIZE + public :: MPI_ANY_SOURCE + public :: MPI_CHARACTER + public :: MPI_COMM_WORLD + public :: MPI_MAX_PROCESSOR_NAME + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: spmd_init( clm_mpicom ) +! +! !INTERFACE: + subroutine spmd_init() +! +! !DESCRIPTION: +! MPI initialization (number of cpus, processes, tids, etc) +! +! !USES +! +! !ARGUMENTS: + implicit none + type(ESMF_VM) :: vm + integer :: status ! Error code +! integer, intent(in) :: clm_mpicom +! integer, intent(in) :: LNDID +! +! !REVISION HISTORY: +! Author: Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: i ! indices + integer :: npes ! MPI size + integer :: MYID ! MPI Rank +!----------------------------------------------------------------------- + + call ESMF_VmGetCurrent(VM, rc=status) + + ! Get MPI communicator + + call ESMF_VmGet(VM, mpicommunicator=mpicom, RC=status) + + ! Get my processor id and number of processors + + call ESMF_VmGet(VM, localPet=MYID, petCount=npes, RC=status) + + ! determine master process + if (MAPL_Am_I_Root(vm)) then + masterproc = .true. + else + masterproc = .false. + end if + + if (masterproc) then + write(iulog,100)npes + write(iulog,200) + write(iulog,220) + do i=0,npes-1 + write(iulog,250)i,MYID + end do + endif + + +100 format(//,i3," pes participating in computation for CLM") +200 format(/,35('-')) +220 format(/,"NODE#",2x,"NAME") +250 format("(",i5,")",2x,100a1,//) + + end subroutine spmd_init + +end module spmdMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/subgridAveMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/subgridAveMod.F90 new file mode 100755 index 000000000..310e772ff --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/subgridAveMod.F90 @@ -0,0 +1,1363 @@ +module subgridAveMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Utilities to perfrom subgrid averaging + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall + use column_varcon , only : icol_road_perv , icol_road_imperv + use clm_varcon , only : grlnd, nameg, namel, namec, namep,spval + use clm_varcon , only : namec, spval + use clm_varctl , only : iulog + use abortutils , only : endrun + use decompMod , only : bounds_type + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + ! + ! !PUBLIC TYPES: + implicit none + save + private ! By default make everything private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: p2c ! Perform an average patches to columns + ! public :: p2l ! Perform an average patches to landunits + public :: p2g ! Perform an average patches to gridcells + ! public :: c2l ! Perform an average columns to landunits + public :: c2g ! Perform an average columns to gridcells + ! public :: l2g ! Perform an average landunits to gridcells + + interface p2c + module procedure p2c_1d + module procedure p2c_2d + module procedure p2c_1d_filter + module procedure p2c_2d_filter + end interface +! interface p2l +! module procedure p2l_1d +! module procedure p2l_2d +! end interface + interface p2g + module procedure p2g_1d + module procedure p2g_2d + end interface +! interface c2l +! module procedure c2l_1d +! module procedure c2l_2d +! end interface + interface c2g + module procedure c2g_1d + module procedure c2g_2d + end interface +! interface l2g +! module procedure l2g_1d +! module procedure l2g_2d +! end interface + ! + ! !PRIVATE MEMBER FUNCTIONS: + private :: build_scale_l2g + private :: create_scale_l2g_lookup + + ! Note about the urban scaling types used for c2l_scale_type (urbanf / urbans), from + ! Bill Sacks and Keith Oleson: These names originally meant to distinguish between + ! fluxes and states. However, that isn't the right distinction. In general, urbanf + ! should be used for variables that are expressed as something-per-m^2 ('extensive' + ! state or flux variables), whereas urbans should be used for variables that are not + ! expressed as per-m^2 ('intensive' state variables; an example is temperature). The + ! urbanf scaling converts from per-m^2 of vertical wall area to per-m^2 of ground area. + ! One way to think about this is: In the extreme case of a near-infinite canyon_hwr due + ! to massively tall walls, do you want a near-infinite multiplier for the walls for the + ! variable in question? If so, you want urbanf; if not, you want urbans. + ! + ! However, there may be some special cases, including some hydrology variables that + ! don't apply for urban walls. + + ! WJS (10-14-11): TODO: + ! + ! - I believe that scale_p2c, scale_c2l and scale_l2g should be included in the sumwt + ! accumulations (e.g., sumwt = sumwt + wtgcell * scale_p2c * scale_c2l * scale_l2g), but + ! that requires some more thought to (1) make sure that is correct, and (2) make sure it + ! doesn't break the urban scaling. (See also my notes in create_scale_l2g_lookup.) + ! - Once that is done, you could use a scale of 0, avoiding the need for the use of + ! spval and the special checks that requires. + ! + ! - Currently, there is a lot of repeated code to calculate scale_c2l. This should be + ! cleaned up. + ! - At a minimum, should collect the repeated code into a subroutine to eliminate this + ! repitition + ! - The best thing might be to use a lookup array, as is done for scale_l2g + + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! ----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine p2c_1d (bounds, parr, carr, p2c_scale_type) + ! + ! !DESCRIPTION: + ! Perfrom subgrid-average from patches to columns. + ! Averaging is only done for points that are not equal to "spval". + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + real(r8), intent(in) :: parr( bounds%begp: ) ! patch array + real(r8), intent(out) :: carr( bounds%begc: ) ! column array + character(len=*), intent(in) :: p2c_scale_type ! scale type + ! + ! !LOCAL VARIABLES: + integer :: p,c,index ! indices + real(r8) :: scale_p2c(bounds%begp:bounds%endp) ! scale factor for column->landunit mapping + logical :: found ! temporary for error check + real(r8) :: sumwt(bounds%begc:bounds%endc) ! sum of weights + !------------------------------------------------------------------------ + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(parr) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(carr) == (/bounds%endc/)), sourcefile, __LINE__) + + if (p2c_scale_type == 'unity') then + do p = bounds%begp,bounds%endp + scale_p2c(p) = 1.0_r8 + end do + else + write(iulog,*)'p2c_1d error: scale type ',p2c_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + carr(bounds%begc:bounds%endc) = spval + sumwt(bounds%begc:bounds%endc) = 0._r8 + do p = bounds%begp,bounds%endp + if (patch%active(p) .and. patch%wtcol(p) /= 0._r8) then + if (parr(p) /= spval) then + c = patch%column(p) + if (sumwt(c) == 0._r8) carr(c) = 0._r8 + carr(c) = carr(c) + parr(p) * scale_p2c(p) * patch%wtcol(p) + sumwt(c) = sumwt(c) + patch%wtcol(p) + end if + end if + end do + found = .false. + do c = bounds%begc,bounds%endc + if (sumwt(c) > 1.0_r8 + 1.e-6_r8) then + found = .true. + index = c + else if (sumwt(c) /= 0._r8) then + carr(c) = carr(c)/sumwt(c) + end if + end do + if (found) then + write(iulog,*)'p2c_1d error: sumwt is greater than 1.0' + call endrun(decomp_index=index, clmlevel=namec, msg=errMsg(sourcefile, __LINE__)) + end if + + end subroutine p2c_1d + + !----------------------------------------------------------------------- + subroutine p2c_2d (bounds, num2d, parr, carr, p2c_scale_type) + ! + ! !DESCRIPTION: + ! Perfrom subgrid-average from landunits to gridcells. + ! Averaging is only done for points that are not equal to "spval". + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num2d ! size of second dimension + real(r8) , intent(in) :: parr( bounds%begp: , 1: ) ! patch array + real(r8) , intent(out) :: carr( bounds%begc: , 1: ) ! column array + character(len=*) , intent(in) :: p2c_scale_type ! scale type + ! + ! !LOCAL VARIABLES: + integer :: j,p,c,index ! indices + real(r8) :: scale_p2c(bounds%begp:bounds%endp) ! scale factor for column->landunit mapping + logical :: found ! temporary for error check + real(r8) :: sumwt(bounds%begc:bounds%endc) ! sum of weights + !------------------------------------------------------------------------ + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(parr) == (/bounds%endp, num2d/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(carr) == (/bounds%endc, num2d/)), sourcefile, __LINE__) + + if (p2c_scale_type == 'unity') then + do p = bounds%begp,bounds%endp + scale_p2c(p) = 1.0_r8 + end do + else + write(iulog,*)'p2c_2d error: scale type ',p2c_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + carr(bounds%begc : bounds%endc, :) = spval + do j = 1,num2d + sumwt(bounds%begc : bounds%endc) = 0._r8 + do p = bounds%begp,bounds%endp + if (patch%active(p) .and. patch%wtcol(p) /= 0._r8) then + if (parr(p,j) /= spval) then + c = patch%column(p) + if (sumwt(c) == 0._r8) carr(c,j) = 0._r8 + carr(c,j) = carr(c,j) + parr(p,j) * scale_p2c(p) * patch%wtcol(p) + sumwt(c) = sumwt(c) + patch%wtcol(p) + end if + end if + end do + found = .false. + do c = bounds%begc,bounds%endc + if (sumwt(c) > 1.0_r8 + 1.e-6_r8) then + found = .true. + index = c + else if (sumwt(c) /= 0._r8) then + carr(c,j) = carr(c,j)/sumwt(c) + end if + end do + if (found) then + write(iulog,*)'p2c_2d error: sumwt is greater than 1.0 at c= ',index,' lev= ',j + call endrun(decomp_index=index, clmlevel=namec, msg=errMsg(sourcefile, __LINE__)) + end if + end do + end subroutine p2c_2d + + !----------------------------------------------------------------------- + subroutine p2c_1d_filter (bounds, numfc, filterc, patcharr, colarr) + ! + ! !DESCRIPTION: + ! perform patch to column averaging for single level patch arrays + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer , intent(in) :: numfc + integer , intent(in) :: filterc(numfc) + real(r8), intent(in) :: patcharr( bounds%begp: ) + real(r8), intent(out) :: colarr( bounds%begc: ) + ! + ! !LOCAL VARIABLES: + integer :: fc,c,p ! indices + !----------------------------------------------------------------------- + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(patcharr) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(colarr) == (/bounds%endc/)), sourcefile, __LINE__) + + do fc = 1,numfc + c = filterc(fc) + colarr(c) = 0._r8 + do p = col%patchi(c), col%patchf(c) + if (patch%active(p)) colarr(c) = colarr(c) + patcharr(p) * patch%wtcol(p) + end do + end do + + end subroutine p2c_1d_filter + + !----------------------------------------------------------------------- + subroutine p2c_2d_filter (lev, numfc, filterc, patcharr, colarr) + ! + ! !DESCRIPTION: + ! perform patch to column averaging for multi level patch arrays + ! + ! !ARGUMENTS: + integer , intent(in) :: lev + integer , intent(in) :: numfc + integer , intent(in) :: filterc(numfc) + real(r8), pointer :: patcharr(:,:) + real(r8), pointer :: colarr(:,:) + ! + ! !LOCAL VARIABLES: + integer :: fc,c,p,j ! indices + !----------------------------------------------------------------------- + + do j = 1,lev + do fc = 1,numfc + c = filterc(fc) + colarr(c,j) = 0._r8 + do p = col%patchi(c), col%patchf(c) + if (patch%active(p)) colarr(c,j) = colarr(c,j) + patcharr(p,j) * patch%wtcol(p) + end do + end do + end do + + end subroutine p2c_2d_filter + +! !----------------------------------------------------------------------- +! subroutine p2l_1d (bounds, parr, larr, p2c_scale_type, c2l_scale_type) +! ! +! ! !DESCRIPTION: +! ! Perfrom subgrid-average from patches to landunits +! ! Averaging is only done for points that are not equal to "spval". +! ! +! ! !ARGUMENTS: +! type(bounds_type), intent(in) :: bounds +! real(r8), intent(in) :: parr( bounds%begp: ) ! input column array +! real(r8), intent(out) :: larr( bounds%begl: ) ! output landunit array +! character(len=*), intent(in) :: p2c_scale_type ! scale factor type for averaging +! character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) +! ! +! ! !LOCAL VARIABLES: +! integer :: p,c,l,index ! indices +! logical :: found ! temporary for error check +! real(r8) :: sumwt(bounds%begl:bounds%endl) ! sum of weights +! real(r8) :: scale_p2c(bounds%begp:bounds%endp) ! scale factor for patch->column mapping +! real(r8) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor for column->landunit mapping +! !------------------------------------------------------------------------ +! +! ! Enforce expected array sizes +! SHR_ASSERT_ALL_FL((ubound(parr) == (/bounds%endp/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl/)), sourcefile, __LINE__) +! +! if (c2l_scale_type == 'unity') then +! do c = bounds%begc,bounds%endc +! scale_c2l(c) = 1.0_r8 +! end do +! else if (c2l_scale_type == 'urbanf') then +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%urbpoi(l)) then +! if (col%itype(c) == icol_sunwall) then +! scale_c2l(c) = 3.0 * lun%canyon_hwr(l) +! else if (col%itype(c) == icol_shadewall) then +! scale_c2l(c) = 3.0 * lun%canyon_hwr(l) +! else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then +! scale_c2l(c) = 3.0_r8 +! else if (col%itype(c) == icol_roof) then +! scale_c2l(c) = 1.0_r8 +! end if +! else +! scale_c2l(c) = 1.0_r8 +! end if +! end do +! else if (c2l_scale_type == 'urbans') then +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%urbpoi(l)) then +! if (col%itype(c) == icol_sunwall) then +! scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_shadewall) then +! scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then +! scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_roof) then +! scale_c2l(c) = 1.0_r8 +! end if +! else +! scale_c2l(c) = 1.0_r8 +! end if +! end do +! else +! write(iulog,*)'p2l_1d error: scale type ',c2l_scale_type,' not supported' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if +! +! if (p2c_scale_type == 'unity') then +! do p = bounds%begp,bounds%endp +! scale_p2c(p) = 1.0_r8 +! end do +! else +! write(iulog,*)'p2l_1d error: scale type ',p2c_scale_type,' not supported' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if +! +! larr(bounds%begl : bounds%endl) = spval +! sumwt(bounds%begl : bounds%endl) = 0._r8 +! do p = bounds%begp,bounds%endp +! if (patch%active(p) .and. patch%wtlunit(p) /= 0._r8) then +! c = patch%column(p) +! if (parr(p) /= spval .and. scale_c2l(c) /= spval) then +! l = patch%landunit(p) +! if (sumwt(l) == 0._r8) larr(l) = 0._r8 +! larr(l) = larr(l) + parr(p) * scale_p2c(p) * scale_c2l(c) * patch%wtlunit(p) +! sumwt(l) = sumwt(l) + patch%wtlunit(p) +! end if +! end if +! end do +! found = .false. +! do l = bounds%begl,bounds%endl +! if (sumwt(l) > 1.0_r8 + 1.e-6_r8) then +! found = .true. +! index = l +! else if (sumwt(l) /= 0._r8) then +! larr(l) = larr(l)/sumwt(l) +! end if +! end do +! if (found) then +! write(iulog,*)'p2l_1d error: sumwt is greater than 1.0 at l= ',index +! call endrun(decomp_index=index, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) +! end if +! +! end subroutine p2l_1d +! +! !----------------------------------------------------------------------- +! subroutine p2l_2d(bounds, num2d, parr, larr, p2c_scale_type, c2l_scale_type) +! ! +! ! !DESCRIPTION: +! ! Perfrom subgrid-average from patches to landunits +! ! Averaging is only done for points that are not equal to "spval". +! ! +! ! !ARGUMENTS: +! type(bounds_type), intent(in) :: bounds +! integer , intent(in) :: num2d ! size of second dimension +! real(r8), intent(in) :: parr( bounds%begp: , 1: ) ! input patch array +! real(r8), intent(out) :: larr( bounds%begl: , 1: ) ! output gridcell array +! character(len=*), intent(in) :: p2c_scale_type ! scale factor type for averaging +! character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) +! ! +! ! !LOCAL VARIABLES: +! integer :: j,p,c,l,index ! indices +! logical :: found ! temporary for error check +! real(r8) :: sumwt(bounds%begl:bounds%endl) ! sum of weights +! real(r8) :: scale_p2c(bounds%begc:bounds%endc) ! scale factor for patch->column mapping +! real(r8) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor for column->landunit mapping +! !------------------------------------------------------------------------ +! +! ! Enforce expected array sizes +! SHR_ASSERT_ALL_FL((ubound(parr) == (/bounds%endp, num2d/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl, num2d/)), sourcefile, __LINE__) +! +! if (c2l_scale_type == 'unity') then +! do c = bounds%begc,bounds%endc +! scale_c2l(c) = 1.0_r8 +! end do +! else if (c2l_scale_type == 'urbanf') then +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%urbpoi(l)) then +! if (col%itype(c) == icol_sunwall) then +! scale_c2l(c) = 3.0 * lun%canyon_hwr(l) +! else if (col%itype(c) == icol_shadewall) then +! scale_c2l(c) = 3.0 * lun%canyon_hwr(l) +! else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then +! scale_c2l(c) = 3.0_r8 +! else if (col%itype(c) == icol_roof) then +! scale_c2l(c) = 1.0_r8 +! end if +! else +! scale_c2l(c) = 1.0_r8 +! end if +! end do +! else if (c2l_scale_type == 'urbans') then +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%urbpoi(l)) then +! if (col%itype(c) == icol_sunwall) then +! scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_shadewall) then +! scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then +! scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_roof) then +! scale_c2l(c) = 1.0_r8 +! end if +! else +! scale_c2l(c) = 1.0_r8 +! end if +! end do +! else +! write(iulog,*)'p2l_2d error: scale type ',c2l_scale_type,' not supported' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if +! +! if (p2c_scale_type == 'unity') then +! do p = bounds%begp,bounds%endp +! scale_p2c(p) = 1.0_r8 +! end do +! else +! write(iulog,*)'p2l_2d error: scale type ',p2c_scale_type,' not supported' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if +! +! larr(bounds%begl : bounds%endl, :) = spval +! do j = 1,num2d +! sumwt(bounds%begl : bounds%endl) = 0._r8 +! do p = bounds%begp,bounds%endp +! if (patch%active(p) .and. patch%wtlunit(p) /= 0._r8) then +! c = patch%column(p) +! if (parr(p,j) /= spval .and. scale_c2l(c) /= spval) then +! l = patch%landunit(p) +! if (sumwt(l) == 0._r8) larr(l,j) = 0._r8 +! larr(l,j) = larr(l,j) + parr(p,j) * scale_p2c(p) * scale_c2l(c) * patch%wtlunit(p) +! sumwt(l) = sumwt(l) + patch%wtlunit(p) +! end if +! end if +! end do +! found = .false. +! do l = bounds%begl,bounds%endl +! if (sumwt(l) > 1.0_r8 + 1.e-6_r8) then +! found = .true. +! index = l +! else if (sumwt(l) /= 0._r8) then +! larr(l,j) = larr(l,j)/sumwt(l) +! end if +! end do +! if (found) then +! write(iulog,*)'p2l_2d error: sumwt is greater than 1.0 at l= ',index,' j= ',j +! call endrun(decomp_index=index, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) +! end if +! end do +! +! end subroutine p2l_2d +! +! !----------------------------------------------------------------------- + subroutine p2g_1d(bounds, parr, garr, p2c_scale_type, c2l_scale_type, l2g_scale_type) + ! + ! !DESCRIPTION: + ! Perfrom subgrid-average from patches to gridcells. + ! Averaging is only done for points that are not equal to "spval". + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + real(r8), intent(in) :: parr( bounds%begp: ) ! input patch array + real(r8), intent(out) :: garr( bounds%begg: ) ! output gridcell array + character(len=*), intent(in) :: p2c_scale_type ! scale factor type for averaging + character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) + character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging + ! + ! !LOCAL VARIABLES: + integer :: p,c,l,g,index ! indices + logical :: found ! temporary for error check + real(r8) :: scale_p2c(bounds%begp:bounds%endp) ! scale factor + real(r8) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor + real(r8) :: scale_l2g(bounds%begl:bounds%endl) ! scale factor + real(r8) :: sumwt(bounds%begg:bounds%endg) ! sum of weights + !------------------------------------------------------------------------ + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(parr) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(garr) == (/bounds%endg/)), sourcefile, __LINE__) + + call build_scale_l2g(bounds, l2g_scale_type, & + scale_l2g(bounds%begl:bounds%endl)) + + if (c2l_scale_type == 'unity') then + do c = bounds%begc,bounds%endc + scale_c2l(c) = 1.0_r8 + end do + else if (c2l_scale_type == 'urbanf') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0_r8 + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else if (c2l_scale_type == 'urbans') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else + write(iulog,*)'p2g_1d error: scale type ',c2l_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (p2c_scale_type == 'unity') then + do p = bounds%begp,bounds%endp + scale_p2c(p) = 1.0_r8 + end do + else + write(iulog,*)'p2g_1d error: scale type ',c2l_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + garr(bounds%begg : bounds%endg) = spval + sumwt(bounds%begg : bounds%endg) = 0._r8 + do p = bounds%begp,bounds%endp + if (patch%active(p) .and. patch%wtgcell(p) /= 0._r8) then + c = patch%column(p) + l = patch%landunit(p) + if (parr(p) /= spval .and. scale_c2l(c) /= spval .and. scale_l2g(l) /= spval) then + g = patch%gridcell(p) + if (sumwt(g) == 0._r8) garr(g) = 0._r8 + garr(g) = garr(g) + parr(p) * scale_p2c(p) * scale_c2l(c) * scale_l2g(l) * patch%wtgcell(p) + sumwt(g) = sumwt(g) + patch%wtgcell(p) + end if + end if + end do + found = .false. + do g = bounds%begg, bounds%endg + if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then + found = .true. + index = g + else if (sumwt(g) /= 0._r8) then + garr(g) = garr(g)/sumwt(g) + end if + end do + if (found) then + write(iulog,*)'p2g_1d error: sumwt is greater than 1.0 at g= ',index + call endrun(decomp_index=index, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) + end if + + end subroutine p2g_1d + + !----------------------------------------------------------------------- + subroutine p2g_2d(bounds, num2d, parr, garr, p2c_scale_type, c2l_scale_type, l2g_scale_type) + ! + ! !DESCRIPTION: + ! Perfrom subgrid-average from patches to gridcells. + ! Averaging is only done for points that are not equal to "spval". + ! + ! !USES: + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer , intent(in) :: num2d ! size of second dimension + real(r8), intent(in) :: parr( bounds%begp: , 1: ) ! input patch array + real(r8), intent(out) :: garr( bounds%begg: , 1: ) ! output gridcell array + character(len=*), intent(in) :: p2c_scale_type ! scale factor type for averaging + character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) + character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging + ! + ! !LOCAL VARIABLES: + integer :: j,p,c,l,g,index ! indices + logical :: found ! temporary for error check + real(r8) :: scale_p2c(bounds%begp:bounds%endp) ! scale factor + real(r8) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor + real(r8) :: scale_l2g(bounds%begl:bounds%endl) ! scale factor + real(r8) :: sumwt(bounds%begg:bounds%endg) ! sum of weights + !------------------------------------------------------------------------ + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(parr) == (/bounds%endp, num2d/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(garr) == (/bounds%endg, num2d/)), sourcefile, __LINE__) + + call build_scale_l2g(bounds, l2g_scale_type, & + scale_l2g(bounds%begl:bounds%endl)) + + if (c2l_scale_type == 'unity') then + do c = bounds%begc,bounds%endc + scale_c2l(c) = 1.0_r8 + end do + else if (c2l_scale_type == 'urbanf') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0_r8 + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else if (c2l_scale_type == 'urbans') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else + write(iulog,*)'p2g_2d error: scale type ',c2l_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (p2c_scale_type == 'unity') then + do p = bounds%begp,bounds%endp + scale_p2c(p) = 1.0_r8 + end do + else + write(iulog,*)'p2g_2d error: scale type ',c2l_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + garr(bounds%begg : bounds%endg, :) = spval + do j = 1,num2d + sumwt(bounds%begg : bounds%endg) = 0._r8 + do p = bounds%begp,bounds%endp + if (patch%active(p) .and. patch%wtgcell(p) /= 0._r8) then + c = patch%column(p) + l = patch%landunit(p) + if (parr(p,j) /= spval .and. scale_c2l(c) /= spval .and. scale_l2g(l) /= spval) then + g = patch%gridcell(p) + if (sumwt(g) == 0._r8) garr(g,j) = 0._r8 + garr(g,j) = garr(g,j) + parr(p,j) * scale_p2c(p) * scale_c2l(c) * scale_l2g(l) * patch%wtgcell(p) + sumwt(g) = sumwt(g) + patch%wtgcell(p) + end if + end if + end do + found = .false. + do g = bounds%begg, bounds%endg + if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then + found = .true. + index = g + else if (sumwt(g) /= 0._r8) then + garr(g,j) = garr(g,j)/sumwt(g) + end if + end do + if (found) then + write(iulog,*)'p2g_2d error: sumwt gt 1.0 at g/sumwt = ',index,sumwt(index) + call endrun(decomp_index=index, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) + end if + end do + + end subroutine p2g_2d +! +! !----------------------------------------------------------------------- +! subroutine c2l_1d (bounds, carr, larr, c2l_scale_type, include_inactive) +! ! +! ! !DESCRIPTION: +! ! Perfrom subgrid-average from columns to landunits +! ! Averaging is only done for points that are not equal to "spval". +! ! +! ! !ARGUMENTS: +! type(bounds_type), intent(in) :: bounds +! real(r8), intent(in) :: carr( bounds%begc: ) ! input column array +! real(r8), intent(out) :: larr( bounds%begl: ) ! output landunit array +! character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) +! +! ! If include_inactive is present and .true., then include inactive as well as active +! ! columns in the averages. The purpose of this is to produce valid landunit-level +! ! output for inactive landunits. This should only be set if carr has no NaN values, +! ! even for inactive columns. +! logical, intent(in), optional :: include_inactive +! +! ! +! ! !LOCAL VARIABLES: +! logical :: l_include_inactive +! integer :: c,l,index ! indices +! logical :: found ! temporary for error check +! real(r8) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor for column->landunit mapping +! real(r8) :: sumwt(bounds%begl:bounds%endl) ! sum of weights +! !------------------------------------------------------------------------ +! +! ! Enforce expected array sizes +! SHR_ASSERT_ALL_FL((ubound(carr) == (/bounds%endc/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl/)), sourcefile, __LINE__) +! +! if (present(include_inactive)) then +! l_include_inactive = include_inactive +! else +! l_include_inactive = .false. +! end if +! +! if (c2l_scale_type == 'unity') then +! do c = bounds%begc,bounds%endc +! scale_c2l(c) = 1.0_r8 +! end do +! else if (c2l_scale_type == 'urbanf') then +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%urbpoi(l)) then +! if (col%itype(c) == icol_sunwall) then +! scale_c2l(c) = 3.0 * lun%canyon_hwr(l) +! else if (col%itype(c) == icol_shadewall) then +! scale_c2l(c) = 3.0 * lun%canyon_hwr(l) +! else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then +! scale_c2l(c) = 3.0_r8 +! else if (col%itype(c) == icol_roof) then +! scale_c2l(c) = 1.0_r8 +! end if +! else +! scale_c2l(c) = 1.0_r8 +! end if +! end do +! else if (c2l_scale_type == 'urbans') then +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%urbpoi(l)) then +! if (col%itype(c) == icol_sunwall) then +! scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_shadewall) then +! scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then +! scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_roof) then +! scale_c2l(c) = 1.0_r8 +! end if +! else +! scale_c2l(c) = 1.0_r8 +! end if +! end do +! else +! write(iulog,*)'c2l_1d error: scale type ',c2l_scale_type,' not supported' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if +! +! larr(bounds%begl : bounds%endl) = spval +! sumwt(bounds%begl : bounds%endl) = 0._r8 +! do c = bounds%begc,bounds%endc +! if ((col%active(c) .or. l_include_inactive) .and. col%wtlunit(c) /= 0._r8) then +! if (carr(c) /= spval .and. scale_c2l(c) /= spval) then +! l = col%landunit(c) +! if (sumwt(l) == 0._r8) larr(l) = 0._r8 +! larr(l) = larr(l) + carr(c) * scale_c2l(c) * col%wtlunit(c) +! sumwt(l) = sumwt(l) + col%wtlunit(c) +! end if +! end if +! end do +! found = .false. +! do l = bounds%begl,bounds%endl +! if (sumwt(l) > 1.0_r8 + 1.e-6_r8) then +! found = .true. +! index = l +! else if (sumwt(l) /= 0._r8) then +! larr(l) = larr(l)/sumwt(l) +! end if +! end do +! if (found) then +! write(iulog,*)'c2l_1d error: sumwt is greater than 1.0 at l= ',index +! call endrun(decomp_index=index, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) +! end if +! +! end subroutine c2l_1d +! +! !----------------------------------------------------------------------- +! subroutine c2l_2d (bounds, num2d, carr, larr, c2l_scale_type) +! ! +! ! !DESCRIPTION: +! ! Perfrom subgrid-average from columns to landunits +! ! Averaging is only done for points that are not equal to "spval". +! ! +! ! !ARGUMENTS: +! type(bounds_type), intent(in) :: bounds +! integer , intent(in) :: num2d ! size of second dimension +! real(r8), intent(in) :: carr( bounds%begc: , 1: ) ! input column array +! real(r8), intent(out) :: larr( bounds%begl: , 1: ) ! output landunit array +! character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) +! ! +! ! !LOCAL VARIABLES: +! integer :: j,l,c,index ! indices +! logical :: found ! temporary for error check +! real(r8) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor for column->landunit mapping +! real(r8) :: sumwt(bounds%begl:bounds%endl) ! sum of weights +! !------------------------------------------------------------------------ +! +! ! Enforce expected array sizes +! SHR_ASSERT_ALL_FL((ubound(carr) == (/bounds%endc, num2d/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl, num2d/)), sourcefile, __LINE__) +! +! if (c2l_scale_type == 'unity') then +! do c = bounds%begc,bounds%endc +! scale_c2l(c) = 1.0_r8 +! end do +! else if (c2l_scale_type == 'urbanf') then +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%urbpoi(l)) then +! if (col%itype(c) == icol_sunwall) then +! scale_c2l(c) = 3.0 * lun%canyon_hwr(l) +! else if (col%itype(c) == icol_shadewall) then +! scale_c2l(c) = 3.0 * lun%canyon_hwr(l) +! else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then +! scale_c2l(c) = 3.0_r8 +! else if (col%itype(c) == icol_roof) then +! scale_c2l(c) = 1.0_r8 +! end if +! else +! scale_c2l(c) = 1.0_r8 +! end if +! end do +! else if (c2l_scale_type == 'urbans') then +! do c = bounds%begc,bounds%endc +! l = col%landunit(c) +! if (lun%urbpoi(l)) then +! if (col%itype(c) == icol_sunwall) then +! scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_shadewall) then +! scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then +! scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) +! else if (col%itype(c) == icol_roof) then +! scale_c2l(c) = 1.0_r8 +! end if +! else +! scale_c2l(c) = 1.0_r8 +! end if +! end do +! else +! write(iulog,*)'c2l_2d error: scale type ',c2l_scale_type,' not supported' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if +! +! larr(bounds%begl : bounds%endl, :) = spval +! do j = 1,num2d +! sumwt(bounds%begl : bounds%endl) = 0._r8 +! do c = bounds%begc,bounds%endc +! if (col%active(c) .and. col%wtlunit(c) /= 0._r8) then +! if (carr(c,j) /= spval .and. scale_c2l(c) /= spval) then +! l = col%landunit(c) +! if (sumwt(l) == 0._r8) larr(l,j) = 0._r8 +! larr(l,j) = larr(l,j) + carr(c,j) * scale_c2l(c) * col%wtlunit(c) +! sumwt(l) = sumwt(l) + col%wtlunit(c) +! end if +! end if +! end do +! found = .false. +! do l = bounds%begl,bounds%endl +! if (sumwt(l) > 1.0_r8 + 1.e-6_r8) then +! found = .true. +! index = l +! else if (sumwt(l) /= 0._r8) then +! larr(l,j) = larr(l,j)/sumwt(l) +! end if +! end do +! if (found) then +! write(iulog,*)'c2l_2d error: sumwt is greater than 1.0 at l= ',index,' lev= ',j +! call endrun(decomp_index=index, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) +! end if +! end do +! +! end subroutine c2l_2d +! +! !----------------------------------------------------------------------- + subroutine c2g_1d(bounds, carr, garr, c2l_scale_type, l2g_scale_type) + ! + ! !DESCRIPTION: + ! Perfrom subgrid-average from columns to gridcells. + ! Averaging is only done for points that are not equal to "spval". + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + real(r8), intent(in) :: carr( bounds%begc: ) ! input column array + real(r8), intent(out) :: garr( bounds%begg: ) ! output gridcell array + character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) + character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging + ! + ! !LOCAL VARIABLES: + integer :: c,l,g,index ! indices + logical :: found ! temporary for error check + real(r8) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor + real(r8) :: scale_l2g(bounds%begl:bounds%endl) ! scale factor + real(r8) :: sumwt(bounds%begg:bounds%endg) ! sum of weights + !------------------------------------------------------------------------ + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(carr) == (/bounds%endc/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(garr) == (/bounds%endg/)), sourcefile, __LINE__) + + call build_scale_l2g(bounds, l2g_scale_type, & + scale_l2g(bounds%begl:bounds%endl)) + + if (c2l_scale_type == 'unity') then + do c = bounds%begc,bounds%endc + scale_c2l(c) = 1.0_r8 + end do + else if (c2l_scale_type == 'urbanf') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0_r8 + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else if (c2l_scale_type == 'urbans') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else + write(iulog,*)'c2l_1d error: scale type ',c2l_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + garr(bounds%begg : bounds%endg) = spval + sumwt(bounds%begg : bounds%endg) = 0._r8 + do c = bounds%begc,bounds%endc + if (col%active(c) .and. col%wtgcell(c) /= 0._r8) then + l = col%landunit(c) + if (carr(c) /= spval .and. scale_c2l(c) /= spval .and. scale_l2g(l) /= spval) then + g = col%gridcell(c) + if (sumwt(g) == 0._r8) garr(g) = 0._r8 + garr(g) = garr(g) + carr(c) * scale_c2l(c) * scale_l2g(l) * col%wtgcell(c) + sumwt(g) = sumwt(g) + col%wtgcell(c) + end if + end if + end do + found = .false. + do g = bounds%begg, bounds%endg + if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then + found = .true. + index = g + else if (sumwt(g) /= 0._r8) then + garr(g) = garr(g)/sumwt(g) + end if + end do + if (found) then + write(iulog,*)'c2g_1d error: sumwt is greater than 1.0 at g= ',index + call endrun(decomp_index=index, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) + end if + + end subroutine c2g_1d + + !----------------------------------------------------------------------- + subroutine c2g_2d(bounds, num2d, carr, garr, c2l_scale_type, l2g_scale_type) + ! + ! !DESCRIPTION: + ! Perfrom subgrid-average from columns to gridcells. + ! Averaging is only done for points that are not equal to "spval". + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer , intent(in) :: num2d ! size of second dimension + real(r8), intent(in) :: carr( bounds%begc: , 1: ) ! input column array + real(r8), intent(out) :: garr( bounds%begg: , 1: ) ! output gridcell array + character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging (see note at top of module) + character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging + ! + ! !LOCAL VARIABLES: + integer :: j,c,g,l,index ! indices + logical :: found ! temporary for error check + real(r8) :: scale_c2l(bounds%begc:bounds%endc) ! scale factor + real(r8) :: scale_l2g(bounds%begl:bounds%endl) ! scale factor + real(r8) :: sumwt(bounds%begg:bounds%endg) ! sum of weights + !------------------------------------------------------------------------ + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(carr) == (/bounds%endc, num2d/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(garr) == (/bounds%endg, num2d/)), sourcefile, __LINE__) + + call build_scale_l2g(bounds, l2g_scale_type, & + scale_l2g(bounds%begl:bounds%endl)) + + if (c2l_scale_type == 'unity') then + do c = bounds%begc,bounds%endc + scale_c2l(c) = 1.0_r8 + end do + else if (c2l_scale_type == 'urbanf') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = 3.0 * lun%canyon_hwr(l) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0_r8 + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else if (c2l_scale_type == 'urbans') then + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_sunwall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_shadewall) then + scale_c2l(c) = (3.0 * lun%canyon_hwr(l)) / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + scale_c2l(c) = 3.0 / (2.*lun%canyon_hwr(l) + 1.) + else if (col%itype(c) == icol_roof) then + scale_c2l(c) = 1.0_r8 + end if + else + scale_c2l(c) = 1.0_r8 + end if + end do + else + write(iulog,*)'c2g_2d error: scale type ',c2l_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + garr(bounds%begg : bounds%endg,:) = spval + do j = 1,num2d + sumwt(bounds%begg : bounds%endg) = 0._r8 + do c = bounds%begc,bounds%endc + if (col%active(c) .and. col%wtgcell(c) /= 0._r8) then + l = col%landunit(c) + if (carr(c,j) /= spval .and. scale_c2l(c) /= spval .and. scale_l2g(l) /= spval) then + g = col%gridcell(c) + if (sumwt(g) == 0._r8) garr(g,j) = 0._r8 + garr(g,j) = garr(g,j) + carr(c,j) * scale_c2l(c) * scale_l2g(l) * col%wtgcell(c) + sumwt(g) = sumwt(g) + col%wtgcell(c) + end if + end if + end do + found = .false. + do g = bounds%begg, bounds%endg + if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then + found = .true. + index = g + else if (sumwt(g) /= 0._r8) then + garr(g,j) = garr(g,j)/sumwt(g) + end if + end do + if (found) then + write(iulog,*)'c2g_2d error: sumwt is greater than 1.0 at g= ',index + call endrun(decomp_index=index, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) + end if + end do + + end subroutine c2g_2d +! +! !----------------------------------------------------------------------- +! subroutine l2g_1d(bounds, larr, garr, l2g_scale_type) +! ! +! ! !DESCRIPTION: +! ! Perfrom subgrid-average from landunits to gridcells. +! ! Averaging is only done for points that are not equal to "spval". +! ! +! ! !ARGUMENTS: +! type(bounds_type), intent(in) :: bounds +! real(r8), intent(in) :: larr( bounds%begl: ) ! input landunit array +! real(r8), intent(out) :: garr( bounds%begg: ) ! output gridcell array +! character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging +! ! +! ! !LOCAL VARIABLES: +! integer :: l,g,index ! indices +! logical :: found ! temporary for error check +! real(r8) :: scale_l2g(bounds%begl:bounds%endl) ! scale factor +! real(r8) :: sumwt(bounds%begg:bounds%endg) ! sum of weights +! !------------------------------------------------------------------------ +! +! ! Enforce expected array sizes +! SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(garr) == (/bounds%endg/)), sourcefile, __LINE__) +! +! call build_scale_l2g(bounds, l2g_scale_type, & +! scale_l2g(bounds%begl:bounds%endl)) +! +! garr(bounds%begg : bounds%endg) = spval +! sumwt(bounds%begg : bounds%endg) = 0._r8 +! do l = bounds%begl,bounds%endl +! if (lun%active(l) .and. lun%wtgcell(l) /= 0._r8) then +! if (larr(l) /= spval .and. scale_l2g(l) /= spval) then +! g = lun%gridcell(l) +! if (sumwt(g) == 0._r8) garr(g) = 0._r8 +! garr(g) = garr(g) + larr(l) * scale_l2g(l) * lun%wtgcell(l) +! sumwt(g) = sumwt(g) + lun%wtgcell(l) +! end if +! end if +! end do +! found = .false. +! do g = bounds%begg, bounds%endg +! if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then +! found = .true. +! index = g +! else if (sumwt(g) /= 0._r8) then +! garr(g) = garr(g)/sumwt(g) +! end if +! end do +! if (found) then +! write(iulog,*)'l2g_1d error: sumwt is greater than 1.0 at g= ',index +! call endrun(decomp_index=index, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) +! end if +! +! end subroutine l2g_1d +! +! !----------------------------------------------------------------------- +! subroutine l2g_2d(bounds, num2d, larr, garr, l2g_scale_type) +! ! +! ! !DESCRIPTION: +! ! Perfrom subgrid-average from landunits to gridcells. +! ! Averaging is only done for points that are not equal to "spval". +! ! +! ! !ARGUMENTS: +! type(bounds_type), intent(in) :: bounds +! integer , intent(in) :: num2d ! size of second dimension +! real(r8), intent(in) :: larr( bounds%begl: , 1: ) ! input landunit array +! real(r8), intent(out) :: garr( bounds%begg: , 1: ) ! output gridcell array +! character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging +! ! +! ! !LOCAL VARIABLES: +! integer :: j,g,l,index ! indices +! integer :: max_lu_per_gcell ! max landunits per gridcell; on the fly +! logical :: found ! temporary for error check +! real(r8) :: scale_l2g(bounds%begl:bounds%endl) ! scale factor +! real(r8) :: sumwt(bounds%begg:bounds%endg) ! sum of weights +! !------------------------------------------------------------------------ +! +! ! Enforce expected array sizes +! SHR_ASSERT_ALL_FL((ubound(larr) == (/bounds%endl, num2d/)), sourcefile, __LINE__) +! SHR_ASSERT_ALL_FL((ubound(garr) == (/bounds%endg, num2d/)), sourcefile, __LINE__) +! +! call build_scale_l2g(bounds, l2g_scale_type, & +! scale_l2g(bounds%begl:bounds%endl)) +! +! garr(bounds%begg : bounds%endg, :) = spval +! do j = 1,num2d +! sumwt(bounds%begg : bounds%endg) = 0._r8 +! do l = bounds%begl,bounds%endl +! if (lun%active(l) .and. lun%wtgcell(l) /= 0._r8) then +! if (larr(l,j) /= spval .and. scale_l2g(l) /= spval) then +! g = lun%gridcell(l) +! if (sumwt(g) == 0._r8) garr(g,j) = 0._r8 +! garr(g,j) = garr(g,j) + larr(l,j) * scale_l2g(l) * lun%wtgcell(l) +! sumwt(g) = sumwt(g) + lun%wtgcell(l) +! end if +! end if +! end do +! found = .false. +! do g = bounds%begg,bounds%endg +! if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then +! found = .true. +! index= g +! else if (sumwt(g) /= 0._r8) then +! garr(g,j) = garr(g,j)/sumwt(g) +! end if +! end do +! if (found) then +! write(iulog,*)'l2g_2d error: sumwt is greater than 1.0 at g= ',index,' lev= ',j +! call endrun(decomp_index=index, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) +! end if +! end do +! +! end subroutine l2g_2d +! +! !----------------------------------------------------------------------- + subroutine build_scale_l2g(bounds, l2g_scale_type, scale_l2g) + ! + ! !DESCRIPTION: + ! Fill the scale_l2g(bounds%begl:bounds%endl) array with appropriate values for the given l2g_scale_type. + ! This array can later be used to scale each landunit in forming grid cell averages. + ! + ! !USES: + use landunit_varcon, only : max_lunit + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging + real(r8) , intent(out) :: scale_l2g( bounds%begl: ) ! scale factor + ! + ! !LOCAL VARIABLES: + real(r8) :: scale_lookup(max_lunit) ! scale factor for each landunit type + integer :: l ! index + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(scale_l2g) == (/bounds%endl/)), sourcefile, __LINE__) + + ! TODO(wjs, 2017-03-09) If this routine is a performance problem (which it may be, + ! because I think it's called a lot), then a simple optimization would be to treat + ! l2g_scale_type = 'unity' specially, rather than using the more general-purpose code + ! for this special case. + + call create_scale_l2g_lookup(l2g_scale_type, scale_lookup) + + do l = bounds%begl,bounds%endl + scale_l2g(l) = scale_lookup(lun%itype(l)) + end do + + end subroutine build_scale_l2g +! +! !----------------------------------------------------------------------- + subroutine create_scale_l2g_lookup(l2g_scale_type, scale_lookup) + ! + ! DESCRIPTION: + ! Create a lookup array, scale_lookup(1..max_lunit), which gives the scale factor for + ! each landunit type depending on l2g_scale_type + ! + ! !USES: + use landunit_varcon, only : istsoil, istcrop, istice_mec, istdlak + use landunit_varcon, only : isturb_MIN, isturb_MAX, max_lunit + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging + real(r8) , intent(out) :: scale_lookup(max_lunit) ! scale factor for each landunit type + !----------------------------------------------------------------------- + + ! ------------ WJS (10-14-11): IMPORTANT GENERAL NOTES ------------ + ! + ! Since scale_l2g is not currently included in the sumwt accumulations, you need to + ! be careful about the scale values you use. Values of 1 and spval are safe + ! (including having multiple landunits with value 1), but only use other values if + ! you know what you are doing! For example, using a value of 0 is NOT the correct way + ! to exclude a landunit from the average, because the normalization will be done + ! incorrectly in this case: instead, use spval to exclude a landunit from the + ! average. Similarly, using a value of 2 is NOT the correct way to give a landunit + ! double relative weight in general, because the normalization won't be done + ! correctly in this case, either. + ! + ! In the longer-term, I believe that the correct solution to this problem is to + ! include scale_l2g (and the other scale factors) in the sumwt accumulations + ! (e.g., sumwt = sumwt + wtgcell * scale_p2c * scale_c2l * scale_l2g), but that + ! requires some more thought to (1) make sure that is correct, and (2) make sure it + ! doesn't break the urban scaling. + ! + ! ----------------------------------------------------------------- + + + ! Initialize scale_lookup to spval for all landunits. Thus, any landunit that keeps + ! the default value will be excluded from grid cell averages. + scale_lookup(:) = spval + + if (l2g_scale_type == 'unity') then + scale_lookup(:) = 1.0_r8 + else if (l2g_scale_type == 'natveg') then + scale_lookup(istsoil) = 1.0_r8 + else if (l2g_scale_type == 'veg') then + scale_lookup(istsoil) = 1.0_r8 + scale_lookup(istcrop) = 1.0_r8 + else if (l2g_scale_type == 'ice') then + scale_lookup(istice_mec) = 1.0_r8 + else if (l2g_scale_type == 'nonurb') then + scale_lookup(:) = 1.0_r8 + scale_lookup(isturb_MIN:isturb_MAX) = spval + else if (l2g_scale_type == 'lake') then + scale_lookup(istdlak) = 1.0_r8 + else if (l2g_scale_type == 'veg_plus_lake') then + scale_lookup(istsoil) = 1.0_r8 + scale_lookup(istcrop) = 1.0_r8 + scale_lookup(istdlak) = 1.0_r8 + else + write(iulog,*)'scale_l2g_lookup_array error: scale type ',l2g_scale_type,' not supported' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end subroutine create_scale_l2g_lookup + +end module subgridAveMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/update_model_para4cn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/update_model_para4cn.F90 new file mode 100755 index 000000000..59b81ef68 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/update_model_para4cn.F90 @@ -0,0 +1,59 @@ +MODULE update_model_para4cn + + implicit none + + private + INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: LocalTileID + INTEGER, PUBLIC :: curr_year,curr_month,curr_day,curr_dofyr,curr_hour,curr_min,curr_sec + INTEGER, PUBLIC :: prev_year,prev_month,prev_day,prev_dofyr,prev_hour,prev_min,prev_sec + + SAVE curr_year,curr_month,curr_day,curr_dofyr,curr_hour,curr_min,curr_sec, & + prev_year,prev_month,prev_day,prev_dofyr,prev_hour,prev_min,prev_sec, & + LocalTileID + + public :: upd_curr_date_time, upd_tileid + + contains + + ! --------------------------------------- + + subroutine upd_tileid (tileid) + + implicit none + integer :: NT + integer, intent (in) :: tileid (:) + + NT = size (tileid) + allocate (LocalTileID(1:NT)) + LocalTileID = tileid + + end subroutine upd_tileid + + ! --------------------------------------- + + subroutine upd_curr_date_time( year,month,day,dofyr,hour,min,sec ) + + ! Return the current date_time. + + implicit none + integer, intent(in) :: year,month,day,dofyr,hour,min,sec + + prev_year = curr_year + prev_month = curr_month + prev_day = curr_day + prev_dofyr = curr_dofyr + prev_hour = curr_hour + prev_min = curr_min + prev_sec = curr_sec + + curr_year = year + curr_month = month + curr_day = day + curr_dofyr = dofyr + curr_hour = hour + curr_min = min + curr_sec = sec + + end subroutine upd_curr_date_time + + end MODULE update_model_para4cn diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CMakeLists.txt new file mode 100755 index 000000000..c212ee058 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CMakeLists.txt @@ -0,0 +1,19 @@ +esma_set_this () + +string (REPLACE GEOScatchCNCLM51_GridComp_ "" is_openmp ${this}) + +esma_add_subdirectories (CLM51) + +set (srcs + GEOS_CatchCNCLM51GridComp.F90 + ) + +esma_add_library (${this} + SRCS ${srcs} + DEPENDENCIES MAPL GEOS_Shared GEOS_LandShared CLM51 GEOS_CatchCNShared esmf NetCDF::NetCDF_Fortran + TYPE SHARED) + +if (is_openmp) + target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) +endif () + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/GEOS_CatchCNCLM51GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/GEOS_CatchCNCLM51GridComp.F90 new file mode 100755 index 000000000..eb7a5d959 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/GEOS_CatchCNCLM51GridComp.F90 @@ -0,0 +1,8682 @@ +! $Id$ + +#include "MAPL_Generic.h" +#define DEALLOC_(A) if(associated(A))then;A=0;if(MAPL_ShmInitialized)then; call MAPL_DeAllocNodeArray(A,rc=STATUS);else; deallocate(A,stat=STATUS);endif;_VERIFY(STATUS);NULLIFY(A);endif + +!============================================================================= +module GEOS_CatchCNCLM51GridCompMod + +!BOP +! !MODULE: GEOS_CatchCN --- ESMF gridded component implementing CatchmentCN LSM + +! !DESCRIPTION: +! +! {\tt Catch} is a gridded component to compute the energy and water +! fluxes due to land-surface processes, using the Catchment LSM +! of Koster et al. (2014). +! Koster, R. D., G. Walker, G. J. Collatz, and P. E. Thornton, 2014. +! Hydroclimatic controls on the means and variability of vegetation +! phenology and carbon uptake. J. Climate, 27, 5632-5652. doi: +! 10.1175/JCLI-D-13-00477.1. +! All of its calculations are done +! in a tile space defined by the inherited location stream. +! It has a two-stage run method. The first stage obtains +! drag coefficients at all the subtiles and defines +! effective tile-mean surface quantities. The second +! stage calls the Catchment-CN LSM. {\tt CatchCN} has no children. + +! +! !USES: + + use, intrinsic :: iso_fortran_env, only: INT64 + use sfclayer ! using module that contains sfc layer code + use ESMF + use GEOS_Mod + use GEOS_UtilsMod + use DragCoefficientsMod + use CATCHMENT_CN_MODEL + use CNCLM_DriverMod + use CNCLM_Photosynthesis + use CN_initMod + USE STIEGLITZSNOW, ONLY : & + StieglitzSnow_snow_albedo, StieglitzSnow_calc_tpsnow, N_CONSTIT, & + NUM_DUDP, NUM_DUSV, NUM_DUWT, NUM_DUSD, & + NUM_BCDP, NUM_BCSV, NUM_BCWT, NUM_BCSD, & + NUM_OCDP, NUM_OCSV, NUM_OCWT, NUM_OCSD, & + NUM_SUDP, NUM_SUSV, NUM_SUWT, NUM_SUSD, & + NUM_SSDP, NUM_SSSV, NUM_SSWT, NUM_SSSD, & + StieglitzSnow_calc_asnow + + USE CATCH_CONSTANTS, ONLY : & + N_GT => CATCH_N_GT, & + N_SNOW => CATCH_N_SNOW, & + RHOFS => CATCH_SNOW_RHOFS, & + SNWALB_VISMAX => CATCH_SNOW_VISMAX, & + SNWALB_NIRMAX => CATCH_SNOW_NIRMAX, & + SLOPE => CATCH_SNOW_SLOPE, & + PEATCLSM_POROS_THRESHOLD + + + USE clm_varpar, ONLY : & + NUM_ZON, NUM_VEG, VAR_COL, VAR_PFT, & + CN_zone_weight, map_cat, numpft + + USE MAPL + use MAPL_ConstantsMod,only: Tzero => MAPL_TICE, pi => MAPL_PI + use clm_time_manager, only: get_days_per_year, get_step_size, get_nstep, is_first_step + use pftconMod, only: noveg + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & + catch_calc_zbar, catch_calc_peatclsm_waterlevel, irrigation_rate, & + gndtmp + + use update_model_para4cn, only : upd_curr_date_time + use WaterType + use CNVegetationFacade + use catch_wrap_stateMod + +implicit none +private + + include "netcdf.inc" + +! !PUBLIC MEMBER FUNCTIONS: + +public SetServices + +! +!EOP + +integer,parameter :: FSAT=1 ! Saturated subtile +integer,parameter :: FTRN=2 ! Transition subtile +integer,parameter :: FWLT=3 ! Wilting subtile +integer,parameter :: FSNW=4 ! Snowcover subtile + +integer,parameter :: NUM_SUBTILES=4 + +! Vegetation type as follows: +! 1: BROADLEAF EVERGREEN TREES +! 2: BROADLEAF DECIDUOUS TREES +! 3: NEEDLELEAF TREES +! 4: GROUND COVER +! 5: BROADLEAF SHRUBS +! 6: DWARF TREES (TUNDRA) +!=================================================== +!ALT: we currently use only 6 types (see above) +! in the legacy code we used to have 8 +! (or 10 with the sea and land ice) with +! these additional entries +! 7: BARE SOIL +! 8: DESERT + +integer :: NUM_ENSEMBLE +integer,parameter :: NTYPS = MAPL_NUMVEGTYPES + +real, parameter :: HPBL = 1000. +real, parameter :: MIN_VEG_HEIGHT = 0.01 +real, parameter :: Z0_BY_ZVEG = 0.13 +real, parameter :: D0_BY_ZVEG = 0.66 + +! Emissivity values from Wilber et al (1999, NATA-TP-1999-209362) +! Fu-Liou bands have been combined to Chou bands (though these are broadband only) +! IGBP veg types have been mapped to Sib-Mosaic types +! Details in ~suarez/Emiss on cerebus + +real, parameter :: EMSVEG(NTYPS) = (/ 0.99560, 0.99000, 0.99560, 0.99320, & + 0.99280, 0.99180 /) +real, parameter :: EMSBARESOIL = 0.94120 +real, parameter :: EMSSNO = 0.99999 + +! moved SURFLAY from catchment.F90 to enable run-time changes for off-line system +! - reichle, 29 Oct 2010 + +! ROOTL import from GEOS_VegdynGridComp was disabled and brought the look up table +! in order to obtain ROOTL for primary and secondary types. + +! map catchment type into PFT +! --------------------------- +!PFT Description +! 0 bare +! 1 needleleaf evergreen temperate tree +! 2 needleleaf evergreen boreal tree +! 3 needleleaf deciduous boreal tree +! 4 broadleaf evergreen tropical tree +! 5 broadleaf evergreen temperate tree +! 6 broadleaf deciduous tropical tree +! 7 broadleaf deciduous temperate tree +! 8 broadleaf deciduous boreal tree +! 9 broadleaf evergreen temperate shrub +! 10 broadleaf deciduous temperate shrub [moisture + deciduous] +! 11 broadleaf deciduous temperate shrub [moisture stress only] +! 12 broadleaf deciduous boreal shrub +! 13 arctic c3 grass +! 14 cool c3 grass [moisture + deciduous] +! 15 cool c3 grass [moisture stress only] +! 16 warm c4 grass [moisture + deciduous] +! 17 warm c4 grass [moisture stress only] +! 18 crop [moisture + deciduous] +! 19 crop [moisture stress only] + +! Catchment types and PFT mapping: +! +! 1: BROADLEAF EVERGREEN TREES => 4,5 +! 2: BROADLEAF DECIDUOUS TREES => 6,7,8 +! 3: NEEDLELEAF TREES => 1,2,3 +! 4: GROUND COVER => 13-19 +! 5: BROADLEAF SHRUBS => 9,10,11 +! 6: DWARF TREES (TUNDRA) => 12 +! 7: BARE SOIL => 0 +! 8: DESERT => 0 +! 9: ICE => n/a + +! index map for CLM PFTs --> catchment veg types + +contains + +!BOP + +! !IROUTINE: SetServices -- Sets ESMF services for component +! !INTERFACE: + +subroutine SetServices ( GC, RC ) + +! !ARGUMENTS: + + type(ESMF_GridComp),intent(INOUT) :: GC + integer, optional, intent( OUT) :: RC + +! !DESCRIPTION: +! This version uses GEOS\_GenericSetServices, overriding +! only the run method. It also relies on MAPL\_Generic to +! handle data services. + +!EOP +! +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: Iam + character(len=ESMF_MAXSTR) :: COMP_NAME + integer :: STATUS + +! Local Variables + + type(MAPL_MetaComp), pointer :: MAPL=>null() + integer :: OFFLINE_MODE, RUN_IRRIG, ATM_CO2, N_CONST_LAND4SNWALB + integer :: RESTART, SNOW_ALBEDO_INFO + +! Begin... +! -------- + +! Get my name and set-up traceback handle +! ------------------------------------------------------------------------------ + + Iam='SetServices' + call ESMF_GridCompGet ( GC, NAME=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam=trim(COMP_NAME)//trim(Iam) + +! pchakrab: Read CATCHMENT_OFFLINE from resource file and save +! it in the private internal state of the GridComp. It is a little +! unusual to read resource file in SetServices, but we need to know +! at this stage where we are running Catch in the offline mode or not + + call MAPL_GetObjectFromGC(gc, MAPL, rc=status) + VERIFY_(status) + + call MAPL_GetResource ( MAPL, NUM_ENSEMBLE, Label="NUM_LDAS_ENSEMBLE:", DEFAULT=1, _RC) + call MAPL_GetResource ( MAPL, OFFLINE_MODE, Label="CATCHMENT_OFFLINE:", DEFAULT=0, _RC) + call MAPL_GetResource ( MAPL, ATM_CO2, Label="ATM_CO2:", _RC) + call MAPL_GetResource ( MAPL, N_CONST_LAND4SNWALB, Label="N_CONST_LAND4SNWALB:", _RC) + call MAPL_GetResource ( MAPL, RUN_IRRIG, Label="RUN_IRRIG:", _RC) + call MAPL_GetResource ( MAPL, SNOW_ALBEDO_INFO, Label="SNOW_ALBEDO_INFO:", _RC) + +! Set the Run entry points +! ------------------------ + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN1, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN2, RC=STATUS ) + VERIFY_(STATUS) + + +! Set the state variable specs. +! ----------------------------- + +!BOS + +! !IMPORT STATE: + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_pressure' ,& + UNITS = 'Pa' ,& + SHORT_NAME = 'PS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_air_temperature' ,& + UNITS = 'K' ,& + SHORT_NAME = 'TA' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_air_specific_humidity',& + UNITS = 'kg kg-1' ,& + SHORT_NAME = 'QA' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_wind_speed' ,& + UNITS = 'm s-1' ,& + SHORT_NAME = 'UU' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'levellm_uwind', & + UNITS = 'm s-1', & + SHORT_NAME = 'UWINDLMTILE', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'levellm_vwind', & + UNITS = 'm s-1', & + SHORT_NAME = 'VWINDLMTILE', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'liquid_water_convective_precipitation',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'PCU' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'liquid_water_large_scale_precipitation',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'PLS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'snowfall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'SNO' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'icefall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'ICE' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'freezing_rain_fall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'FRZR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_downwelling_par_beam_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'DRPAR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_downwelling_par_diffuse_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'DFPAR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_downwelling_nir_beam_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'DRNIR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_downwelling_nir_diffuse_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'DFNIR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_downwelling_uvr_beam_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'DRUVR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_downwelling_uvr_diffuse_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'DFUVR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_absorbed_longwave_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'LWDNSRF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'linearization_of_surface_emitted_longwave_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'ALW' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'linearization_of_surface_emitted_longwave_flux',& + UNITS = 'W_m-2 K-1' ,& + SHORT_NAME = 'BLW' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + IF (ATM_CO2 == 4) THEN + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CO2SC', & + LONG_NAME = 'CO2 Surface Concentration Bin 001', & + UNITS = '1e-6', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + ENDIF + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'leaf_area_index' ,& + UNITS = '1' ,& + SHORT_NAME = 'LAI' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'greeness_fraction' ,& + UNITS = '1' ,& + SHORT_NAME = 'GRN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'evaporation' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'EVAP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'derivative_of_evaporation_wrt_QS',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'DEVAP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'upward_sensible_heat_flux' ,& + UNITS = 'W m-2' ,& + SHORT_NAME = 'SH' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'derivative_of_sensible_heat_wrt_Ts',& + UNITS = 'W m-2 K-1' ,& + SHORT_NAME = 'DSH' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'surface_layer_height' ,& + UNITS = 'm' ,& + SHORT_NAME = 'DZ' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'vegetation_root_length' ,& + UNITS = 'm' ,& + SHORT_NAME = 'ROOTL' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + LONG_NAME = 'canopy_height' ,& + UNITS = 'm' ,& + SHORT_NAME = 'Z2CH' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'THATM', & + LONG_NAME = 'effective_surface_skin_temperature',& + UNITS = 'K', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'QHATM', & + LONG_NAME = 'effective_surface_specific_humidity',& + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CTATM', & + LONG_NAME = 'surface_exchange_coefficient_for_heat', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'CQATM', & + LONG_NAME = 'surface_exchange_coefficient_for_moisture', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + SHORT_NAME = 'ASCATZ0' ,& + LONG_NAME = 'ASCAT_roughness_length' ,& + UNITS = 'm' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC ,& + SHORT_NAME = 'NDVI' ,& + LONG_NAME = 'normalized_difference_vegetation_index' ,& + UNITS = '1' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'dust_dry_depos_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'DUDP', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_DUDP/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'dust_wet_depos_conv_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'DUSV', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_DUSV/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'dust_wet_depos_ls_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'DUWT', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_DUWT/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'dust_gravity_sett_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'DUSD', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_DUSD/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'black_carbon_dry_depos_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'BCDP', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_BCDP/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'black_carbon_wet_depos_conv_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'BCSV', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_BCSV/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'black_carbon_wet_depos_ls_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'BCWT', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_BCWT/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'black_carbon_gravity_sett_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'BCSD', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_BCSD/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'organic_carbon_dry_depos_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'OCDP', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_OCDP/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'organic_carbon_wet_depos_conv_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'OCSV', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_OCSV/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'organic_carbon_wet_depos_ls_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'OCWT', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_OCWT/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'organic_carbon_gravity_sett_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'OCSD', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_OCSD/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'sulfate_dry_depos_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'SUDP', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_SUDP/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'sulfate_wet_depos_conv_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'SUSV', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_SUSV/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'sulfate_wet_depos_ls_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'SUWT', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_SUWT/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'sulfate_gravity_sett_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'SUSD', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_SUSD/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'sea_salt_dry_depos_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'SSDP', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_SSDP/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'sea_salt_wet_depos_conv_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'SSSV', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_SSSV/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'sea_salt_wet_depos_ls_scav_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'SSWT', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_SSWT/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddImportSpec(GC, & + LONG_NAME = 'sea_salt_gravity_sett_all_bins', & + UNITS = 'kg m-2 s-1', & + SHORT_NAME = 'SSSD', & + DIMS = MAPL_DimsTileOnly, & + UNGRIDDED_DIMS = (/NUM_SSSD/), & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + +! !INTERNAL STATE: + +! if is_offline, some variables ( in the last) are not required + if ( OFFLINE_MODE == 1 ) then + RESTART = MAPL_RestartSkip + elseif ( OFFLINE_MODE == 2 ) then + RESTART = MAPL_RestartOptional + elseif ( OFFLINE_MODE == 0 ) then + RESTART = MAPL_RestartRequired + else + ASSERT_(.FALSE.) + endif + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'topo_baseflow_param_1' ,& + UNITS = 'kg m-4' ,& + SHORT_NAME = 'BF1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'topo_baseflow_param_2' ,& + UNITS = 'm' ,& + SHORT_NAME = 'BF2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'topo_baseflow_param_3' ,& + UNITS = 'log(m)' ,& + SHORT_NAME = 'BF3' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'max_rootzone_water_content',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'VGWMAX' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'moisture_threshold' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CDCR1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'max_soil_water_content_above_wilting_point' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CDCR2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'saturated_matric_potential',& + UNITS = 'm' ,& + SHORT_NAME = 'PSIS' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'clapp_hornberger_b' ,& + UNITS = '1' ,& + SHORT_NAME = 'BEE' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'soil_porosity' ,& + UNITS = '1' ,& + SHORT_NAME = 'POROS' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'wetness_at_wilting_point' ,& + UNITS = '1' ,& + SHORT_NAME = 'WPWET' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'sfc_sat_hydraulic_conduct' ,& + UNITS = 'm s-1' ,& + SHORT_NAME = 'COND' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'vertical_transmissivity' ,& + UNITS = 'm-1' ,& + SHORT_NAME = 'GNU' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'wetness_param_1' ,& + UNITS = 'm+2 kg-1' ,& + SHORT_NAME = 'ARS1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'wetness_param_2' ,& + UNITS = 'm+2 kg-1' ,& + SHORT_NAME = 'ARS2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'wetness_param_3' ,& + UNITS = 'm+4 kg-2' ,& + SHORT_NAME = 'ARS3' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'shape_param_1' ,& + UNITS = 'm+2 kg-1' ,& + SHORT_NAME = 'ARA1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'shape_param_2' ,& + UNITS = '1' ,& + SHORT_NAME = 'ARA2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'shape_param_3' ,& + UNITS = 'm+2 kg-1' ,& + SHORT_NAME = 'ARA3' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'shape_param_4' ,& + UNITS = '1' ,& + SHORT_NAME = 'ARA4' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'min_theta_param_1' ,& + UNITS = 'm+2 kg-1' ,& + SHORT_NAME = 'ARW1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'min_theta_param_2' ,& + UNITS = 'm+2 kg-1' ,& + SHORT_NAME = 'ARW2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'min_theta_param_3' ,& + UNITS = 'm+4 kg-2' ,& + SHORT_NAME = 'ARW3' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'min_theta_param_4' ,& + UNITS = '1' ,& + SHORT_NAME = 'ARW4' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'water_transfer_param_1' ,& + UNITS = '1' ,& + SHORT_NAME = 'TSA1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'water_transfer_param_2' ,& + UNITS = '1' ,& + SHORT_NAME = 'TSA2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'water_transfer_param_3' ,& + UNITS = '1' ,& + SHORT_NAME = 'TSB1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'water_transfer_param_4' ,& + UNITS = '1' ,& + SHORT_NAME = 'TSB2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'water_transfer_param_5' ,& + UNITS = '1' ,& + SHORT_NAME = 'ATAU' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'water_transfer_param_6' ,& + UNITS = '1' ,& + SHORT_NAME = 'BTAU' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'vegetation_type' ,& + UNITS = '1' ,& + SHORT_NAME = 'ITY' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_VEG/) ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'vegetation_fraction' ,& + UNITS = '1' ,& + SHORT_NAME = 'FVG' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_VEG/) ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'canopy_temperature' ,& + UNITS = 'K' ,& + SHORT_NAME = 'TC' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'canopy_specific_humidity' ,& + UNITS = 'kg kg-1' ,& + SHORT_NAME = 'QC' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'ground_temperature' ,& + UNITS = '1' ,& + SHORT_NAME = 'TG' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'interception_reservoir_capac',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CAPAC' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'catchment_deficit' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CATDEF' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'root_zone_excess' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RZEXC' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'surface_excess' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'SRFEXC' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'soil_heat_content_layer_1' ,& + UNITS = 'J m-2' ,& + SHORT_NAME = 'GHTCNT1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'soil_heat_content_layer_2' ,& + UNITS = 'J_m-2' ,& + SHORT_NAME = 'GHTCNT2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'soil_heat_content_layer_3' ,& + UNITS = 'J m-2' ,& + SHORT_NAME = 'GHTCNT3' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'soil_heat_content_layer_4' ,& + UNITS = 'J m-2' ,& + SHORT_NAME = 'GHTCNT4' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'soil_heat_content_layer_5' ,& + UNITS = 'J m-2' ,& + SHORT_NAME = 'GHTCNT5' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'soil_heat_content_layer_6' ,& + UNITS = 'J m-2' ,& + SHORT_NAME = 'GHTCNT6' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'mean_catchment_temp_incl_snw',& + UNITS = 'K' ,& + SHORT_NAME = 'TSURF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = RESTART ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'snow_mass_layer_1' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'WESNN1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'snow_mass_layer_2' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'WESNN2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'snow_mass_layer_3' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'WESNN3' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'heat_content_snow_layer_1' ,& + UNITS = 'J m-2' ,& + SHORT_NAME = 'HTSNNN1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'heat_content_snow_layer_2' ,& + UNITS = 'J m-2' ,& + SHORT_NAME = 'HTSNNN2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'heat_content_snow_layer_3' ,& + UNITS = 'J m-2' ,& + SHORT_NAME = 'HTSNNN3' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'snow_depth_layer_1' ,& + UNITS = 'm' ,& + SHORT_NAME = 'SNDZN1' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'snow_depth_layer_2' ,& + UNITS = 'm' ,& + SHORT_NAME = 'SNDZN2' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'snow_depth_layer_3' ,& + UNITS = 'm' ,& + SHORT_NAME = 'SNDZN3' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + if (SNOW_ALBEDO_INFO == 1) then + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'effective_snow_albedo' ,& + UNITS = '1' ,& + SHORT_NAME = 'SNOWALB' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + endif + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'surface_heat_exchange_coefficient',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CH' ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = RESTART ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'surface_momentum_exchange_coefficient',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CM' ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = RESTART ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'surface_moisture_exchange_coffiecient',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CQ' ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = RESTART ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'subtile_fractions' ,& + UNITS = '1' ,& + SHORT_NAME = 'FR' ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = RESTART ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'WW', & + LONG_NAME = 'vertical_velocity_scale_squared', & + UNITS = 'm+2 s-2', & + DIMS = MAPL_DimsTileTile, & + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone, & + RESTART = RESTART ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'DCH', & + LONG_NAME = 'ch difference, optional in louissurface', & + UNITS = '1', & + DIMS = MAPL_DimsTileTile, & + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'DCQ', & + LONG_NAME = 'cq difference, optional in louissurface', & + UNITS = '1', & + DIMS = MAPL_DimsTileTile, & + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartSkip ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'catchment_tile_id' ,& + UNITS = '1' ,& + SHORT_NAME = 'TILE_ID' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_nitrogen_deposition' ,& + UNITS = 'g m-2 s-1' ,& + SHORT_NAME = 'NDEP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_peak_month_agricultural_fire',& + UNITS = '1' ,& + SHORT_NAME = 'ABM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_peatland_fraction' ,& + UNITS = '1' ,& + SHORT_NAME = 'PEATF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_gross_domestic_product',& + UNITS = 'K 1995US$/capita' ,& + SHORT_NAME = 'GDP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_human_density_2010' ,& + UNITS = 'individual/km2' ,& + SHORT_NAME = 'HDM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'field_capacity' ,& + UNITS = 'm3/m3' ,& + SHORT_NAME = 'FIELDCAP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'cli_2m_T_(MERRA2)' ,& + UNITS = 'K' ,& + SHORT_NAME = 'CLI_T2M' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'MODIS soil albedo vis dir' ,& + UNITS = '1' ,& + SHORT_NAME = 'BGALBVR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'MODIS soil albedo vis dif' ,& + UNITS = '1' ,& + SHORT_NAME = 'BGALBVF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'MODIS soil albedo nir dir' ,& + UNITS = '1' ,& + SHORT_NAME = 'BGALBNR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'MODIS soil albedo nir dif' ,& + UNITS = '1' ,& + SHORT_NAME = 'BGALBNF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'column_rst_vars' ,& + UNITS = '1' ,& + SHORT_NAME = 'CNCOL' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_ZON*VAR_COL/) ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'PFT_rst_vars' ,& + UNITS = '1' ,& + SHORT_NAME = 'CNPFT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_ZON*NUM_VEG*VAR_PFT/) ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for ground temp' ,& + UNITS = 'K' ,& + SHORT_NAME = 'TGWM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for soil moisture' ,& + UNITS = '1' ,& + SHORT_NAME = 'RZMM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for sfc soil moist' ,& + UNITS = '1' ,& + SHORT_NAME = 'SFMM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for baseflow' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'BFLOWM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for total water' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'TOTWATM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for air temperature',& + UNITS = 'K' ,& + SHORT_NAME = 'TAIRM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for relative humidity',& + UNITS = '%' ,& + SHORT_NAME = 'RHM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for wind speed' ,& + UNITS = 'm s-1' ,& + SHORT_NAME = 'WINDM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for rainfall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RAINFM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for snow fall' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'SNOWFM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for surface runoff' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RUNSRFM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for frac saturated area',& + UNITS = '1' ,& + SHORT_NAME = 'AR1M' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for soil temp' ,& + UNITS = 'K' ,& + SHORT_NAME = 'TPM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN summing counter' ,& + UNITS = '1' ,& + SHORT_NAME = 'CNSUM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for sunlit photosyn',& + UNITS = 'umol m-2 s-1' ,& + SHORT_NAME = 'PSNSUNM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_VEG,NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for shaded photosyn',& + UNITS = 'umol m-2 s-1' ,& + SHORT_NAME = 'PSNSHAM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_VEG,NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for sunlit leaf maintenance respiration',& + UNITS = 'umol CO2 m-2 s-1' ,& + SHORT_NAME = 'LMRSUNM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_VEG,NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for shaded leaf maintenance respiration',& + UNITS = 'umol CO2 m-2 s-1' ,& + SHORT_NAME = 'LMRSHAM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_VEG,NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for sunlit leaf area index',& + UNITS = '1' ,& + SHORT_NAME = 'LAISUNM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_VEG,NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for shaded leaf area index',& + UNITS = '1' ,& + SHORT_NAME = 'LAISHAM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + UNGRIDDED_DIMS = (/NUM_VEG,NUM_ZON/) ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for snow depth' ,& + UNITS = 'm' ,& + SHORT_NAME = 'SNDZM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '5-day running mean of CN sum for snow depth',& + UNITS = 'm' ,& + SHORT_NAME = 'SNDZM5D' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CN sum for area snow cover',& + UNITS = '1' ,& + SHORT_NAME = 'ASNOWM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '10-day running mean of 2-m temperature',& + UNITS = 'K' ,& + SHORT_NAME = 'T2M10D' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '10-day running mean of ground temperature',& + UNITS = 'K' ,& + SHORT_NAME = 'TG10D' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '5-day running mean of daily minimum 2-m temperature',& + UNITS = 'K' ,& + SHORT_NAME = 'T2MMIN5D' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '30-day running mean of surface relative humidity',& + UNITS = '%' ,& + SHORT_NAME = 'RH30D' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '10-day running mean of total precipitation',& + UNITS = 'mm H2O/s' ,& + SHORT_NAME = 'TPREC10D' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '60-day running mean of total precipitation',& + UNITS = 'mm H2O/s' ,& + SHORT_NAME = 'TPREC60D' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '365-day running mean of total ET',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'ET365D' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddInternalSpec(GC, & + LONG_NAME = 'overland_runoff_including_throughflow' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RUNSURF' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + !---------- GOSWIM snow impurity related variables ---------- + + if (N_CONST_LAND4SNWALB /= 0) then + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'dust_mass_in_snow_bin_1' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RDU001' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'dust_mass_in_snow_bin_2' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RDU002' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'dust_mass_in_snow_bin_3' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RDU003' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'dust_mass_in_snow_bin_4' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RDU004' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'dust_mass_in_snow_bin_5' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RDU005' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'hydrophobic_black_carbon_mass_in_snow_bin_1',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RBC001' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'hydrophilic_black_carbon_mass_in_snow_bin_2',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RBC002' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'hydrophobic_organic_carbon_mass_in_snow_bin_1',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'ROC001' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'hydrophilic_organic_carbon_mass_in_snow_bin_2',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'ROC002' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + UNGRIDDED_DIMS = (/N_SNOW/) ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartOptional ,& + RC=STATUS ) + VERIFY_(STATUS) + + endif + +! IRRIGATION MODEL INTERNAL + + IF (RUN_IRRIG /= 0) THEN + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'fraction_of_irrigated_cropland',& + UNITS = '1' ,& + SHORT_NAME = 'IRRIGFRAC' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'fraction_of_paddy_cropland',& + UNITS = '1' ,& + SHORT_NAME = 'PADDYFRAC' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'Maximum_LAI' ,& + UNITS = '1' ,& + SHORT_NAME = 'LAIMAX' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'Minimum_LAI' ,& + UNITS = '1' ,& + SHORT_NAME = 'LAIMIN' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_primary_type' ,& + UNITS = '1' ,& + SHORT_NAME = 'CLMPT' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_secondary_type' ,& + UNITS = '1' ,& + SHORT_NAME = 'CLMST' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_primary_fraction' ,& + UNITS = '1' ,& + SHORT_NAME = 'CLMPF' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'CLM_secondary_fraction' ,& + UNITS = '1' ,& + SHORT_NAME = 'CLMSF' ,& + FRIENDLYTO = trim(COMP_NAME) ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartRequired ,& + RC=STATUS ) + VERIFY_(STATUS) + + ENDIF + + +!EOS + + ! EXPORT STATE: + + IF (RUN_IRRIG /= 0) THEN + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'irrigation_rate' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'IRRIGRATE' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + ENDIF + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'evaporation' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'EVAPOUT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'sublimation' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'SUBLIM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'upward_sensible_heat_flux' ,& + UNITS = 'W m-2' ,& + SHORT_NAME = 'SHOUT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'runoff_flux' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RUNOFF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'interception_loss_energy_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'EVPINT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'baresoil_evap_energy_flux' ,& + UNITS = 'W m-2' ,& + SHORT_NAME = 'EVPSOI' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'transpiration_energy_flux' ,& + UNITS = 'W m-2' ,& + SHORT_NAME = 'EVPVEG' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_ice_evaporation_energy_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'EVPICE' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'soil moisture in Upper 10cm' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'WAT10CM' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'totoal soil moisture' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'WATSOI' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'soil frozen water content' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'ICESOI' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snowpack_evaporation_energy_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'EVPSNO' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'baseflow_flux' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'BASEFLOW' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snowmelt_flux' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'SMELT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_1' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE1' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_2' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_frozen_fraction_layer_3' ,& + UNITS = '1' ,& + SHORT_NAME = 'FICE3' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_emitted_longwave_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'HLWUP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'surface_net_downward_longwave_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'LWNDSRF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'surface_net_downward_shortwave_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'SWNDSRF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'total_latent_energy_flux' ,& + UNITS = 'W m-2' ,& + SHORT_NAME = 'HLATN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'rainwater_infiltration_flux',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'QINFIL' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'areal_fraction_saturated_zone',& + UNITS = '1' ,& + SHORT_NAME = 'AR1' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'areal_fraction_transpiration_zone',& + UNITS = '1' ,& + SHORT_NAME = 'AR2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'root_zone_equilibrium_moisture',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'RZEQ' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'ground_energy_flux' ,& + UNITS = 'W m-2' ,& + SHORT_NAME = 'GHFLX' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'ave_catchment_temp_incl_snw',& + UNITS = 'K' ,& + SHORT_NAME = 'TPSURF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'temperature_top_snow_layer',& + UNITS = 'K' ,& + SHORT_NAME = 'TPSNOW' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'temperature_unsaturated_zone',& + UNITS = 'K' ,& + SHORT_NAME = 'TPUNST' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'temperature_saturated_zone',& + UNITS = 'K' ,& + SHORT_NAME = 'TPSAT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'temperature_wilted_zone' ,& + UNITS = 'K' ,& + SHORT_NAME = 'TPWLT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'fractional_area_of_land_snowcover',& + UNITS = '1' ,& + SHORT_NAME = 'ASNOW' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'downward_heat_flux_into_snow',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'SHSNOW' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'averaged_snow_temperature' ,& + UNITS = 'K' ,& + SHORT_NAME = 'AVETSNOW' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'fractional_area_of_saturated_zone',& + UNITS = '1' ,& + SHORT_NAME = 'FRSAT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'fractional_area_of_unsaturated_zone',& + UNITS = '1' ,& + SHORT_NAME = 'FRUST' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'fractional_area_of_wilting_zone',& + UNITS = '1' ,& + SHORT_NAME = 'FRWLT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_mass' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'SNOWMASS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'snow_depth_within_snow_covered_area_fraction' ,& + UNITS = 'm' ,& + SHORT_NAME = 'SNOWDP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_soil_wetness' ,& + UNITS = '1' ,& + SHORT_NAME = 'WET1' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'root_zone_soil_wetness' ,& + UNITS = '1' ,& + SHORT_NAME = 'WET2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'ave_prof_soil__moisture' ,& + UNITS = '1' ,& + SHORT_NAME = 'WET3' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'water_surface_layer' ,& + UNITS = 'm3 m-3' ,& + SHORT_NAME = 'WCSF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'water_root_zone' ,& + UNITS = 'm3 m-3' ,& + SHORT_NAME = 'WCRZ' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'water_ave_prof' ,& + UNITS = 'm3 m-3' ,& + SHORT_NAME = 'WCPR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'soil_temperatures_layer_1' ,& + UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 + SHORT_NAME = 'TP1' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'soil_temperatures_layer_2' ,& + UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 + SHORT_NAME = 'TP2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'soil_temperatures_layer_3' ,& + UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 + SHORT_NAME = 'TP3' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'soil_temperatures_layer_4' ,& + UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 + SHORT_NAME = 'TP4' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'soil_temperatures_layer_5' ,& + UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 + SHORT_NAME = 'TP5' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'soil_temperatures_layer_6' ,& + UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 + SHORT_NAME = 'TP6' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_emissivity' ,& + UNITS = '1' ,& + SHORT_NAME = 'EMIS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_albedo_visible_beam',& + UNITS = '1' ,& + SHORT_NAME = 'ALBVR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_albedo_visible_diffuse',& + UNITS = '1' ,& + SHORT_NAME = 'ALBVF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_albedo_near_infrared_beam',& + UNITS = '1' ,& + SHORT_NAME = 'ALBNR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_albedo_near_infrared_diffuse',& + UNITS = '1' ,& + SHORT_NAME = 'ALBNF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'change_surface_skin_temperature',& + UNITS = 'K' ,& + SHORT_NAME = 'DELTS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'change_surface_specific_humidity',& + UNITS = 'kg kg-1' ,& + SHORT_NAME = 'DELQS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'change_evaporation' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'DELEVAP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'change_upward_sensible_energy_flux',& + UNITS = 'W m-2' ,& + SHORT_NAME = 'DELSH' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_skin_temperature' ,& + UNITS = 'K' ,& + SHORT_NAME = 'TST' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'land_surface_skin_temperature' ,& + UNITS = 'K' ,& + SHORT_NAME = 'LST' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_specific_humidity' ,& + UNITS = 'kg kg-1' ,& + SHORT_NAME = 'QST' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulence_surface_skin_temperature',& + UNITS = 'K' ,& + SHORT_NAME = 'TH' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'turbulence_surface_skin_specific_hum',& + UNITS = 'kg kg-1' ,& + SHORT_NAME = 'QH' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_heat_exchange_coefficient',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CHT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_momentum_exchange_coefficient',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CMT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_moisture_exchange_coefficient',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CQT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'neutral_drag_coefficient' ,& + UNITS = '1' ,& + SHORT_NAME = 'CNT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_bulk_richardson_number',& + UNITS = '1' ,& + SHORT_NAME = 'RIT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_roughness' ,& + UNITS = 'm' ,& + SHORT_NAME = 'Z0' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOT2M', & + LONG_NAME = 'temperature 2m wind from MO sfc', & + UNITS = 'K', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOQ2M', & + LONG_NAME = 'humidity 2m wind from MO sfc', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOU2M', & + LONG_NAME = 'zonal 2m wind from MO sfc',& + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOV2M', & + LONG_NAME = 'meridional 2m wind from MO sfc', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOT10M', & + LONG_NAME = 'temperature 10m wind from MO sfc', & + UNITS = 'K', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOQ10M', & + LONG_NAME = 'humidity 10m wind from MO sfc', & + UNITS = 'kg kg-1', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOU10M', & + LONG_NAME = 'zonal 10m wind from MO sfc',& + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOV10M', & + LONG_NAME = 'meridional 10m wind from MO sfc', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOU50M', & + LONG_NAME = 'zonal 50m wind from MO sfc',& + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'MOV50M', & + LONG_NAME = 'meridional 50m wind from MO sfc', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'surface_roughness_for_heat',& + UNITS = 'm' ,& + SHORT_NAME = 'Z0H' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + LONG_NAME = 'zero_plane_displacement_height',& + UNITS = 'm' ,& + SHORT_NAME = 'D0' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'GUST', & + LONG_NAME = 'gustiness', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'VENT', & + LONG_NAME = 'surface_ventilation_velocity',& + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ACCUM', & + LONG_NAME = 'net_ice_accumulation_rate', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'EVLAND', & + LONG_NAME = 'Evaporation_land', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'PRLAND', & + LONG_NAME = 'Total_precipitation_land', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SNOLAND', & + LONG_NAME = 'snowfall_land', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DRPARLAND', & + LONG_NAME = 'surface_downwelling_par_beam_flux', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DFPARLAND', & + LONG_NAME = 'surface_downwelling_par_diffuse_flux', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LHSNOW', & + LONG_NAME = 'Latent_heat_flux_snow', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SWNETSNOW', & + LONG_NAME = 'Net_shortwave_snow', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LWUPSNOW', & + LONG_NAME = 'surface_emitted_longwave_flux_snow', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LWDNSNOW', & + LONG_NAME = 'surface_absorbed_longwave_flux_snow', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TCSORIG', & + LONG_NAME = 'Input_tc_for_snow', & + UNITS = 'K', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TPSN1IN', & + LONG_NAME = 'Input_temp_of_top_snow_lev',& + UNITS = 'K', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TPSN1OUT', & + LONG_NAME = 'Output_temp_of_top_snow_lev',& + UNITS = 'K', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'GHSNOW', & + LONG_NAME = 'Ground_heating_snow', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LHLAND', & + LONG_NAME = 'Latent_heat_flux_land', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SHLAND', & + LONG_NAME = 'Sensible_heat_flux_land', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SWLAND', & + LONG_NAME = 'Net_shortwave_land', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SWDOWNLAND', & + LONG_NAME = 'Incident_shortwave_land', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'LWLAND', & + LONG_NAME = 'Net_longwave_land', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'GHLAND', & + LONG_NAME = 'Ground_heating_land', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'GHTSKIN', & + LONG_NAME = 'Ground_heating_skin_temp', & + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SMLAND', & + LONG_NAME = 'Snowmelt_flux_land', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TWLAND', & + LONG_NAME = 'Avail_water_storage_land', & + UNITS = 'kg m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TELAND', & + LONG_NAME = 'Total_energy_storage_land', & + UNITS = 'J m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'TSLAND', & + LONG_NAME = 'Total_snow_storage_land', & + UNITS = 'kg m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DWLAND', & + LONG_NAME = 'rate_of_change_of_total_land_water',& + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'DHLAND', & + LONG_NAME = 'rate_of_change_of_total_land_energy',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SPLAND', & + LONG_NAME = 'rate_of_spurious_land_energy_source',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SPWATR', & + LONG_NAME = 'rate_of_spurious_land_water_source',& + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SPSNOW', & + LONG_NAME = 'rate_of_spurious_snow_energy',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'vegetation_type' ,& + UNITS = '1' ,& + SHORT_NAME = 'ITY' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_exposed_leaf-area_index',& + UNITS = '1' ,& + SHORT_NAME = 'CNLAI' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_leaf-area_index' ,& + UNITS = '1' ,& + SHORT_NAME = 'CNTLAI' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_exposed_stem-area_index',& + UNITS = '1' ,& + SHORT_NAME = 'CNSAI' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_carbon' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNTOTC' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_vegetation_carbon',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNVEGC' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_fine_root_carbon' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNFROOTC' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_net_primary_production' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNNPP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_gross_primary_production',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNGPP' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_soil_respiration' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNSR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_autotrophic_respiration' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNAR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_heterotrophic_respiration' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNHR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_net_ecosystem_exchange' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNNEE' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'abstract_C_pool_to_meet_excess_MR_demand' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNXSMR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_added_to_maintain_positive_C' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNADD' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_carbon_loss_to_fire' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNLOSS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_fractional_area_burn_rate' ,& + UNITS = 's-1' ,& + SHORT_NAME = 'CNBURN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_fire_count' ,& + UNITS = 'count km-2 s-1' ,& + SHORT_NAME = 'CNFIRE_CNT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_peat_C_loss_to_fire' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNSOM_CLOSS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_N_deployed_to_growth_storage',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNNDEPLOY' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_denitrification_rate ' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNDENIT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_soil_min_N_loss_to_leaching',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNSMINN_LEACHED' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_soil_mineral_N' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNSMINN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_N_loss_to_fire' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNFIRE_NLOSS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_leaf_N' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNLEAFN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_leaf_C' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNLEAFC' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_gross_N_mineralization_rate',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNGROSS_NMIN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_net_N_mineralization_rate',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNNET_NMIN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_N_fixation_to_soil_min_N',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNNFIX_TO_SMINN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_actual_N_immobilization',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNACTUAL_IMMOB' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_fraction_potential_gpp' ,& + UNITS = '1' ,& + SHORT_NAME = 'CNFPG' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_fraction_potential_immobilization',& + UNITS = '1' ,& + SHORT_NAME = 'CNFPI' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_soil_min_N_plant_uptake',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNSMINN_TO_PLANT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_deployment_soil_min_N_uptake' ,& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNSMINN_TO_NPOOL' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_atm_N_dep_to_soil_min_N',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNNDEP_TO_SMINN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_vegetation_N' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNTOTVEGN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_litter_N' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNTOTLITN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_soil_organic_N' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNTOTSOMN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_plant_retranslocated_N' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNRETRANSN' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_deployment_retranslocated_N',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'CNRETRANSN_TO_NPOOL' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_fuel_C' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNFUELC' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_litter_C' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNTOTLITC' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_coarse_woody_debris_C' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNCWDC' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_root_C' ,& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'CNROOT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'fire season length' ,& + UNITS = 'days' ,& + SHORT_NAME = 'CNFSEL' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'absorbed_PAR' ,& + UNITS = 'W m-2' ,& + SHORT_NAME = 'PARABS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'incident_PAR' ,& + UNITS = 'W m-2' ,& + SHORT_NAME = 'PARINC' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'saturated_stomatal_conductance' ,& + UNITS = 'm s-1' ,& + SHORT_NAME = 'SCSAT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'unstressed_stomatal_conductance' ,& + UNITS = 'm s-1' ,& + SHORT_NAME = 'SCUNS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'transpiration coefficient' ,& + UNITS = '1' ,& + SHORT_NAME = 'BTRANT' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'solar induced fluorescence',& + UNITS = 'umol m-2 sm s-1' ,& + SHORT_NAME = 'SIF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CO2 Surface Concentration used' ,& + UNITS = '1e-6' ,& + SHORT_NAME = 'CNCO2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_1',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTDU001' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_2',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTDU002' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_3',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTDU003' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_4',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTDU004' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_5',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTDU005' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_black_carbon_mass_flux_from_the_bottom_layer_bin_1',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTBC001' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_black_carbon_mass_flux_from_the_bottom_layer_bin_2',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTBC002' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_organic_carbon_mass_flux_from_the_bottom_layer_bin_1',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTOC001' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'flushed_out_organic_carbon_mass_flux_from_the_bottom_layer_bin_2',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'RMELTOC002' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'depth_to_water_table_from_surface_in_peat',& + UNITS = 'm' ,& + SHORT_NAME = 'PEATCLSM_WATERLEVEL' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'change_in_free_surface_water_reservoir_on_peat',& + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'PEATCLSM_FSWCHANGE' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + +!EOS + + call MAPL_TimerAdd(GC, name="RUN1" ,RC=STATUS) + VERIFY_(STATUS) + if (OFFLINE_MODE /=0) then + call MAPL_TimerAdd(GC, name="-RUN0" ,RC=STATUS) + VERIFY_(status) + end if + call MAPL_TimerAdd(GC, name="-SURF" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="RUN2" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="-CATCHCNCLM51" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="-ALBEDO" ,RC=STATUS) + VERIFY_(STATUS) + +! Set generic init and final method +! --------------------------------- + + call MAPL_GenericSetServices ( GC, RC=STATUS ) + VERIFY_(STATUS) + + RETURN_(ESMF_SUCCESS) + +end subroutine SetServices + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!BOP +! !IROUTINE: RUN1 -- First Run stage for the catchment component +! !INTERFACE: + +subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) + +! !ARGUMENTS: + + type(ESMF_GridComp),intent(inout) :: GC !Gridded component + type(ESMF_State), intent(inout) :: IMPORT !Import state + type(ESMF_State), intent(inout) :: EXPORT !Export state + type(ESMF_Clock), intent(inout) :: CLOCK !The clock + integer,optional, intent(out ) :: RC !Error code: + +! !DESCRIPTION: Does the cds computation and roughness length +!EOP +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + + character(len=ESMF_MAXSTR) :: COMP_NAME + +! Locals + + type(MAPL_MetaComp),pointer :: MAPL + type(ESMF_State) :: INTERNAL + type(ESMF_Alarm) :: ALARM + type(ESMF_Config) :: CF + type(ESMF_VM) :: VM + +! ----------------------------------------------------- +! IMPORT Pointers +! ---------------------------------------------------- - + + real, dimension(:), pointer :: PS + real, dimension(:), pointer :: TA + real, dimension(:), pointer :: QA + real, dimension(:), pointer :: UU + real, pointer, dimension(:) :: UWINDLMTILE + real, pointer, dimension(:) :: VWINDLMTILE + real, dimension(:), pointer :: DZ + real, dimension(:), pointer :: LAI + real, dimension(:), pointer :: Z2CH + real, dimension(:), pointer :: PCU + real, dimension(:), pointer :: ASCATZ0 + real, dimension(:), pointer :: NDVI + +! ----------------------------------------------------- +! INTERNAL Pointers +! ----------------------------------------------------- + + real, dimension(:,:), pointer :: ITY + real, dimension(:,:), pointer :: FVG + real, dimension(:,:), pointer :: TC + real, dimension(:,:), pointer :: QC + real, dimension(:,:), pointer :: CH + real, dimension(:,:), pointer :: CM + real, dimension(:,:), pointer :: CQ + real, dimension(:,:), pointer :: FR + real, dimension(:,:), pointer :: WW + real, dimension(:,:), pointer :: cncol + real, dimension(:,:), pointer :: cnpft + real, dimension(:,:), pointer :: DCH + real, dimension(:,:), pointer :: DCQ + +! ----------------------------------------------------- +! EXPORT Pointers +! ----------------------------------------------------- + + real, dimension(:), pointer :: TH + real, dimension(:), pointer :: QH + real, dimension(:), pointer :: CHT + real, dimension(:), pointer :: CMT + real, dimension(:), pointer :: CQT + real, dimension(:), pointer :: CNT + real, dimension(:), pointer :: RIT + real, dimension(:), pointer :: Z0 + real, dimension(:), pointer :: Z0H + real, dimension(:), pointer :: D0 + real, dimension(:), pointer :: GST + real, dimension(:), pointer :: VNT + real, pointer, dimension(: ) :: MOT2M + real, pointer, dimension(: ) :: MOQ2M + real, pointer, dimension(: ) :: MOU2M + real, pointer, dimension(: ) :: MOV2M + real, pointer, dimension(: ) :: MOT10M + real, pointer, dimension(: ) :: MOQ10M + real, pointer, dimension(: ) :: MOU10M + real, pointer, dimension(: ) :: MOV10M + real, pointer, dimension(: ) :: MOU50M + real, pointer, dimension(: ) :: MOV50M + real, dimension(:), pointer :: ITYO + + +! From old bucket version of CDS calculation +! ------------------------------------------ + + integer :: N + integer :: NT + real, allocatable :: UCN(:) + real, allocatable :: TVA(:) + real, allocatable :: TVS(:) + real, allocatable :: URA(:) + real, allocatable :: UUU(:) + real, allocatable :: ZVG(:) + real, allocatable :: DZE(:) + real, allocatable :: D0T(:) + real, allocatable :: CHX(:) + real, allocatable :: CQX(:) + real, allocatable :: CN(:) + real, allocatable :: RE(:) + real, allocatable :: ZT(:) + real, allocatable :: ZQ(:) + integer,allocatable :: VEG1(:) + integer,allocatable :: VEG2(:) + real, allocatable :: FVG1(:) + real, allocatable :: FVG2(:) + real, allocatable :: Z0T(:,:) + real, allocatable :: U50M (:) + real, allocatable :: V50M (:) + real, allocatable :: T10M (:) + real, allocatable :: Q10M (:) + real, allocatable :: U10M (:) + real, allocatable :: V10M (:) + real, allocatable :: T2M (:) + real, allocatable :: Q2M (:) + real, allocatable :: U2M (:) + real, allocatable :: V2M (:) + real, allocatable :: RHOH(:) + real, allocatable :: VKH(:) + real, allocatable :: VKM(:) + real, allocatable :: USTAR(:) + real, allocatable :: XX(:) + real, allocatable :: YY(:) + real, allocatable :: CU(:) + real, allocatable :: CT(:) + real, allocatable :: RIB(:) + real, allocatable :: ZETA(:) + real, allocatable :: WS(:) + integer, allocatable :: IWATER(:) + real, allocatable :: PSMB(:) + real, allocatable :: PSL(:) + integer :: niter + real :: SCALE4Z0 + +! gkw: for CN model +! ----------------- + integer, parameter :: nveg = num_veg ! number of vegetation types + integer, parameter :: nzone = num_zon ! number of stress zones + + integer, allocatable :: ityp(:,:,:) + real, allocatable :: fveg(:,:,:), elai(:,:,:), esai(:,:,:), tlai(:,:,:), wtzone(:,:), lai1(:), lai2(:), wght(:) + + real,pointer,dimension(:) :: lats + real,pointer,dimension(:) :: lons + + integer :: nv, nz, ib + real :: bare + logical, save :: first = .true. + integer(INT64), save :: istep_cn = 0 ! gkw: legacy variable from offline + real :: ndt + integer(INT64) :: nstep_cn + + ! Offline mode + + type(CATCHCN_WRAP) :: wrap + type(T_CATCHCN_STATE), pointer :: catchcn_internal + integer :: OFFLINE_MODE, CHOOSEZ0 + +!============================================================================= +! Begin... +! ------------------------------------------------------------------------------ + + +! ------------------------------------------------------------------------------ +! Get the target component's name and set-up traceback handle. +! ------------------------------------------------------------------------------ + + call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam=trim(COMP_NAME)//"::RUN1" + + ! Get component's offline mode from its pvt internal state + call ESMF_UserCompGetInternalState(gc, 'CatchcnInternal', wrap, status) + VERIFY_(status) + catchcn_internal=>wrap%ptr + OFFLINE_MODE = catchcn_internal%CATCH_OFFLINE + + call ESMF_VMGetCurrent ( VM, RC=STATUS ) + ! if (MAPL_AM_I_Root(VM)) print *, trim(Iam)//'::OFFLINE mode: ', is_OFFLINE + +! Get my internal MAPL_Generic state +! ---------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) + VERIFY_(STATUS) + +! Start timers +! ------------ + + call MAPL_TimerOn(MAPL,"TOTAL") + call MAPL_TimerOn(MAPL,"RUN1") + +! Get parameters from generic state +! --------------------------------- + + call MAPL_Get ( MAPL ,& + TILELATS = LATS ,& + TILELONS = LONS ,& + INTERNAL_ESMF_STATE = INTERNAL ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, CHOOSEZ0, Label="CHOOSEZ0:", DEFAULT=3, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, SCALE4Z0, Label="SCALE4Z0:", DEFAULT=0.5, RC=STATUS) + VERIFY_(STATUS) + +! Pointers to inputs +!------------------- + + call MAPL_GetPointer(IMPORT,UU , 'UU' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,UWINDLMTILE , 'UWINDLMTILE' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,VWINDLMTILE , 'VWINDLMTILE' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DZ , 'DZ' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,TA , 'TA' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,QA , 'QA' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,PS , 'PS' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,LAI , 'LAI' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,Z2CH , 'Z2CH' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,PCU , 'PCU' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,ASCATZ0, 'ASCATZ0', RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,NDVI , 'NDVI' , RC=STATUS) + VERIFY_(STATUS) + +! Pointers to internals +!---------------------- + + call MAPL_GetPointer(INTERNAL,ITY , 'ITY' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,FVG , 'FVG' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TC , 'TC' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,QC , 'QC' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,FR , 'FR' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CH , 'CH' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CM , 'CM' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CQ , 'CQ' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,WW , 'WW' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CNCOL ,'CNCOL' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CNPFT ,'CNPFT' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,DCH , 'DCH' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,DCQ , 'DCQ' , RC=STATUS) + VERIFY_(STATUS) + +! Pointers to outputs +!-------------------- + + call MAPL_GetPointer(EXPORT,QH , 'QH' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TH , 'TH' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CHT , 'CHT' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CMT , 'CMT' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CQT , 'CQT' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNT , 'CNT' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RIT , 'RIT' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,Z0 , 'Z0' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,Z0H , 'Z0H' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,D0 , 'D0' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,GST , 'GUST' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,VNT , 'VENT' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOT2M, 'MOT2M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOQ2M, 'MOQ2M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOU2M, 'MOU2M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOV2M, 'MOV2M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOT10M, 'MOT10M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOQ10M, 'MOQ10M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOU10M, 'MOU10M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOV10M, 'MOV10M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOU50M, 'MOU50M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,MOV50M, 'MOV50M' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ITYO , 'ITY' , RC=STATUS) + VERIFY_(STATUS) + + NT = size(TA) + + allocate(TVA(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(TVS(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(URA(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(UUU(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(VEG1(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(VEG2(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(FVG1(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(FVG2(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(DZE(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(ZVG(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(Z0T(NT,NUM_SUBTILES),STAT=STATUS) + VERIFY_(STATUS) + allocate(D0T(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(CHX(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(CQX(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(RE (NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(CN (NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(ZT (NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(ZQ (NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(UCN(NT),STAT=STATUS) + VERIFY_(STATUS) + allocate(T2M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(Q2M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(U2M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(v2M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(T10M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(Q10M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(U10M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(v10M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(U50M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(v50M (NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(RHOH(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(PSMB(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(PSL(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(VKH(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(VKM(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(USTAR(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(XX(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(YY(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(CU(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(CT(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(RIB(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(ZETA(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(WS(NT) ,STAT=STATUS) + VERIFY_(STATUS) + allocate(IWATER(NT),STAT=STATUS) + VERIFY_(STATUS) + + allocate( ityp(nt,nveg,nzone) ) + allocate( fveg(nt,nveg,nzone) ) + allocate( wtzone(nt,nzone) ) + allocate( elai(nt,nveg,nzone) ) + allocate( esai(nt,nveg,nzone) ) + allocate( tlai(nt,nveg,nzone) ) + + allocate ( lai1(nt) ) + allocate ( lai2(nt) ) + allocate ( wght(nt) ) + +! Vegetation types used to index into tables +!-------------------------------------------- + + where(ITY(:,1) > 0.) + VEG1 = map_cat(nint(ITY(:,1))) ! gkw: primary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 + endwhere + where(ITY(:,2) > 0.) + VEG2 = map_cat(nint(ITY(:,2))) ! gkw: secondary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 + endwhere + _ASSERT((count(VEG1>NTYPS.or.VEG1<1)==0),'needs informative message') + _ASSERT((count(VEG2>NTYPS.or.VEG2<1)==0),'needs informative message') + + ! At this point, bare soil is not allowed in CatchCN. FVEG in BCs + ! files do not have bare soil either. However, at times, tiny bare + ! fractions appear due to truncation. We add that tiny fraction to the + ! largest of the 4 fractions and ensure bare is zero. (Sarith 3/3/16) + + DO N = 1, NT + BARE = 1. + + DO NV = 1, NVEG + BARE = BARE - FVG(N,NV)! subtract vegetated fractions + END DO + + if (BARE /= 0.) THEN + IB = MAXLOC(FVG(N,:),1) + FVG (N,IB) = FVG(N,IB) + BARE ! This also corrects cases sum gt 1. + ENDIF + + END DO + + FVG1 = fvg(:,1) + FVG2 = fvg(:,2) + +! set CLM CN PFT & fraction, set carbon zone weights +! -------------------------------------------------- + do nz = 1,nzone + ityp(:,:,nz) = nint(ity(:,:)) + fveg(:,:,nz) = fvg(:,:) + wtzone(:,nz) = CN_zone_weight(nz) + end do + +! call to set CN time step before any other CN routines are called (jkolassa May 2023) +! ------------------------------------------------------------------------------------------ + catchcn_internal%DTCN = min(catchcn_internal%DTCN,14400.) + ndt = get_step_size( nint(catchcn_internal%DTCN) ) ! gkw: get_step_size must be called here to set CN model time step + +! update CN time step number +! -------------------------- + nstep_cn = get_nstep(istep_cn) + +! initialize CN model and transfer restart variables on startup +! ------------------------------------------------------------- + if(first) then + call CN_init(nt,ityp,fveg,cncol,cnpft,lats,lons,catchcn_internal%DTCN,water_inst,bgc_vegetation_inst,.true.) + call get_CN_LAI(nt,ityp,fveg,elai,esai=esai) + first = .false. + endif + + ! For the OFFLINE case, first update some diagnostic vars + if (OFFLINE_MODE /=0) then + call MAPL_TimerOn(MAPL, "-RUN0") + call RUN0(gc, import, export, clock, rc) + call MAPL_TimerOff(MAPL, "-RUN0") + end if + +! obtain LAI from previous time step (from CN model) +! -------------------------------------------------- + + call get_CN_LAI(nt,ityp,fveg,elai,esai=esai,tlai=tlai) + + lai1 = 0. + wght = 0. + do nz = 1,nzone + nv = 1 + lai1(:) = lai1(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) + wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) + end do + lai1 = lai1 / max(wght,1.e-8) ! LAI for primary vegetation type + + lai2 = 0. + wght = 0. + do nz = 1,nzone + nv = 2 + lai2(:) = lai2(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) + wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) + end do + lai2 = lai2 / max(wght,1.e-8) ! LAI for secondary vegetation type + + lai = fvg1*lai1 + fvg2*lai2 ! gkw: this is a VEGDYN import + + deallocate ( ityp ) + deallocate ( fveg ) + deallocate ( elai ) + deallocate ( esai ) + deallocate ( wtzone ) + deallocate ( tlai ) + +! Clear the output tile accumulators +!------------------------------------ + + CHX = 0.0 + CQX = 0.0 + + if(associated(TH )) TH = 0.0 + if(associated(QH )) QH = 0.0 + if(associated(CMT)) CMT = 0.0 + if(associated(CNT)) CNT = 0.0 + if(associated(RIT)) RIT = 0.0 + if(associated(Z0H)) Z0H = 0.0 + if(associated(GST)) GST = 0.0 + if(associated(VNT)) VNT = 0.0 + if(associated(MOU50M)) MOU50M = 0.0 + if(associated(MOV50M)) MOV50M = 0.0 + if(associated(MOT10M)) MOT10M = 0.0 + if(associated(MOQ10M)) MOQ10M = 0.0 + if(associated(MOU10M)) MOU10M = 0.0 + if(associated(MOV10M)) MOV10M = 0.0 + if(associated( MOT2M)) MOT2M = 0.0 + if(associated( MOQ2M)) MOQ2M = 0.0 + if(associated( MOU2M)) MOU2M = 0.0 + if(associated( MOV2M)) MOV2M = 0.0 + + SUBTILES: do N=1,NUM_SUBTILES + +! Effective vegetation height. In catchment, LAI dependence +! includes the effect of partially vegetated areas, +! as well as the phenology of the deciduous types. These +! effects will be separated in future formulations. + + ZVG = fvg1*(Z2CH - SCALE4Z0*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI1)) + & + fvg2*(Z2CH - SCALE4Z0*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI2)) + + +! For now roughnesses and displacement heights +! are the same for all subtiles. + + Z0T(:,N) = Z0_BY_ZVEG*ZVG + IF (catchcn_internal%USE_ASCATZ0 == 1) THEN + WHERE (NDVI <= 0.2) + Z0T(:,N) = ASCATZ0 + END WHERE + ENDIF + D0T = D0_BY_ZVEG*ZVG + + DZE = max(DZ - D0T, 10.) + + if(associated(Z0 )) Z0 = Z0T(:,N) + if(associated(D0 )) D0 = D0T + +! Compute the three surface exchange coefficients +!------------------------------------------------- + + call MAPL_TimerOn(MAPL,"-SURF") + if(catchcn_internal%CHOOSEMOSFC.eq.0) then + WW(:,N) = 0. + CM(:,N) = 0. + + call louissurface(3,N,UU,WW,PS,TA,TC,QA,QC,PCU,LAI,Z0T,DZE,CM,CN,RIB,ZT,ZQ,CH,CQ,UUU,UCN,RE,DCH,DCQ) + + elseif (catchcn_internal%CHOOSEMOSFC.eq.1)then + + niter = 6 ! number of internal iterations in the helfand MO surface layer routine + IWATER = 3 + + PSMB = PS * 0.01 ! convert to MB +! Approximate pressure at top of surface layer: hydrostatic, eqn of state using avg temp and press + PSL = PSMB * (1. - (DZE*MAPL_GRAV)/(MAPL_RGAS*(TA+TC(:,N)) ) ) / & + (1. + (DZE*MAPL_GRAV)/(MAPL_RGAS*(TA+TC(:,N)) ) ) + + CALL helfsurface( UWINDLMTILE,VWINDLMTILE,TA,TC(:,N),QA,QC(:,N),PSL,PSMB,Z0T(:,N),lai, & + IWATER,DZE,niter,nt,RHOH,VKH,VKM,USTAR,XX,YY,CU,CT,RIB,ZETA,WS, & + t2m,q2m,u2m,v2m,t10m,q10m,u10m,v10m,u50m,v50m,CHOOSEZ0) + + CM(:,N) = VKM + CH(:,N) = VKH + CQ(:,N) = VKH + + CN = (MAPL_KARMAN/ALOG(DZE/Z0T(:,N) + 1.0)) * (MAPL_KARMAN/ALOG(DZE/Z0T(:,N) + 1.0)) + ZT = Z0T(:,N) + ZQ = Z0T(:,N) + RE = 0. + UUU = UU + UCN = 0. + +! Aggregate to tiles for MO only diagnostics +!-------------------------------------------- + if(associated(MOU50M))MOU50M = MOU50M + U50M(:)*FR(:,N) + if(associated(MOV50M))MOV50M = MOV50M + V50M(:)*FR(:,N) + if(associated(MOT10M))MOT10M = MOT10M + T10M(:)*FR(:,N) + if(associated(MOQ10M))MOQ10M = MOQ10M + Q10M(:)*FR(:,N) + if(associated(MOU10M))MOU10M = MOU10M + U10M(:)*FR(:,N) + if(associated(MOV10M))MOV10M = MOV10M + V10M(:)*FR(:,N) + if(associated(MOT2M))MOT2M = MOT2M + T2M(:)*FR(:,N) + if(associated(MOQ2M))MOQ2M = MOQ2M + Q2M(:)*FR(:,N) + if(associated(MOU2M))MOU2M = MOU2M + U2M(:)*FR(:,N) + if(associated(MOV2M))MOV2M = MOV2M + V2M(:)*FR(:,N) + + endif + call MAPL_TimerOff(MAPL,"-SURF") + +! Aggregate to tile +!------------------- + + CHX = CHX + CH(:,N)*FR(:,N) + CQX = CQX + CQ(:,N)*FR(:,N) + + if(associated(CMT)) CMT = CMT + CM(:,N) *FR(:,N) + if(associated(CNT)) CNT = CNT + CN(: ) *FR(:,N) + if(associated(RIT)) RIT = RIT + RIB(: ) *FR(:,N) + if(associated( TH)) TH = TH + CH(:,N)*TC(:,N)*FR(:,N) + if(associated( QH)) QH = QH + CQ(:,N)*QC(:,N)*FR(:,N) + if(associated(Z0H)) Z0H = Z0H + ZT *FR(:,N) + if(associated(VNT)) VNT = VNT + UUU *FR(:,N) + + WW(:,N) = max(CH(:,N)*(TC(:,N)-TA-(MAPL_GRAV/MAPL_CP)*DZE)/TA + MAPL_VIREPS*CQ(:,N)*(QC(:,N)-QA),0.0) + WW(:,N) = (HPBL*MAPL_GRAV*WW(:,N))**(2./3.) + if(associated(GST)) GST = GST + WW(:,N) *FR(:,N) + + end do SUBTILES + + if(associated( TH)) TH = TH /CHX + if(associated( QH)) QH = QH /CQX + if(associated(CHT)) CHT = CHX + if(associated(CQT)) CQT = CQX + if(associated(GST)) GST = sqrt(max(GST+UCN,0.0)) + if(associated(ITYO)) ITYO = real(VEG1) ! gkw: primary type exported... where it is used? + + deallocate ( lai1 ) + deallocate ( lai2 ) + deallocate ( wght ) + + deallocate(TVA) + deallocate(TVS) + deallocate(URA) + deallocate(UUU) + deallocate(ZVG) + deallocate(DZE) + deallocate(Z0T) + deallocate(D0T) + deallocate(CHX) + deallocate(CQX) + deallocate(VEG1) + deallocate(VEG2) + deallocate(FVG1) + deallocate(FVG2) + deallocate(RE ) + deallocate(CN ) + deallocate(ZT ) + deallocate(ZQ ) + deallocate(UCN) + deallocate(U50M ) + deallocate(V50M ) + deallocate(T10M ) + deallocate(Q10M ) + deallocate(U10M ) + deallocate(V10M ) + deallocate(T2M ) + deallocate(Q2M ) + deallocate(U2M ) + deallocate(V2M ) + deallocate(RHOH) + deallocate(VKH) + deallocate(VKM) + deallocate(USTAR) + deallocate(XX) + deallocate(YY) + deallocate(CU) + deallocate(CT) + deallocate(RIB) + deallocate(ZETA) + deallocate(WS) + deallocate(IWATER) + deallocate(PSMB) + deallocate(PSL) + +! All done +! ------------------------------------------------------------------------------ + + call MAPL_TimerOff ( MAPL, "RUN1" ) + call MAPL_TimerOff ( MAPL, "TOTAL" ) + + RETURN_(ESMF_SUCCESS) + +end subroutine RUN1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + +subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) + +! ------------------------------------------------------------------------------ +! !ARGUMENTS: +! ------------------------------------------------------------------------------ + + type(ESMF_GridComp),intent(inout) :: GC + type(ESMF_State), intent(inout) :: IMPORT + type(ESMF_State), intent(inout) :: EXPORT + type(ESMF_Clock), intent(inout) :: CLOCK + integer,optional, intent(out ) :: RC + +! ------------------------------------------------------------------------------ +! ErrLog Variables +! ------------------------------------------------------------------------------ + + character(len=ESMF_MAXSTR) :: Iam="RUN2" + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + +! ------------------------------------------------------------------------------ +! Local derived type aliases +! ------------------------------------------------------------------------------ + + type(MAPL_MetaComp),pointer :: MAPL + type(ESMF_Alarm) :: ALARM + + integer :: IM,JM + integer :: incl_Louis_extra_derivs + + real :: SCALE4Z0 + +! ------------------------------------------------------------------------------ +! Begin: Get the target components name and +! set-up traceback handle. +! ------------------------------------------------------------------------------ + + call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam=trim(COMP_NAME)//trim(Iam) + +! Get my internal MAPL_Generic state +!----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + +! Get parameters from generic state. +!----------------------------------- + + call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_GetResource ( MAPL, incl_Louis_extra_derivs, Label="INCL_LOUIS_EXTRA_DERIVS:", DEFAULT=1, RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetResource ( MAPL, SCALE4Z0, Label="SCALE4Z0:", DEFAULT=0.5, RC=STATUS) + VERIFY_(STATUS) + +! ------------------------------------------------------------------------------ +! If its time, recalculate the LSM tile routine +! ------------------------------------------------------------------------------ + + call MAPL_TimerOn ( MAPL,"TOTAL" ) + call MAPL_TimerOn ( MAPL,"RUN2" ) + + if(ESMF_AlarmIsRinging(ALARM, RC=STATUS))then + call ESMF_AlarmRingerOff(ALARM, RC=STATUS) + VERIFY_(STATUS) + call Driver ( RC=STATUS ) + VERIFY_(STATUS) + endif + + call MAPL_TimerOff ( MAPL, "RUN2" ) + call MAPL_TimerOff ( MAPL, "TOTAL" ) + + RETURN_(ESMF_SUCCESS) + + contains + +! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ + + subroutine Driver ( RC ) + integer,optional,intent(OUT) :: RC + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + + ! -------------------------------------------------------------------------- + ! Local derived type aliases + ! -------------------------------------------------------------------------- + + type(ESMF_STATE) :: INTERNAL + + ! ----------------------------------------------------- + ! IMPORT Pointers + ! ----------------------------------------------------- + + real, dimension(:), pointer :: PS + real, dimension(:), pointer :: TA + real, dimension(:), pointer :: QA + real, dimension(:), pointer :: UU + real, dimension(:), pointer :: DZ + real, dimension(:), pointer :: PCU + real, dimension(:), pointer :: PLS + real, dimension(:), pointer :: SNO + + real, dimension(:), pointer :: THATM + real, dimension(:), pointer :: QHATM + real, dimension(:), pointer :: CTATM + real, dimension(:), pointer :: CQATM + real, dimension(:), pointer :: ICE + real, dimension(:), pointer :: FRZR + real, dimension(:), pointer :: drpar + real, dimension(:), pointer :: dfpar + real, dimension(:), pointer :: drnir + real, dimension(:), pointer :: dfnir + real, dimension(:), pointer :: druvr + real, dimension(:), pointer :: dfuvr + real, dimension(:), pointer :: lwdnsrf + real, dimension(:), pointer :: alw + real, dimension(:), pointer :: blw + real, dimension(:), pointer :: CO2SC + + real, dimension(:), pointer :: evap + real, dimension(:), pointer :: devap + real, dimension(:), pointer :: sh + real, dimension(:), pointer :: dsh + + real, dimension(:), pointer :: ROOTL + real, dimension(:), pointer :: Z2CH + real, dimension(:), pointer :: LAI + real, dimension(:), pointer :: GRN + real, dimension(:), pointer :: ASCATZ0 + real, dimension(:), pointer :: NDVI + + real, dimension(:,:), pointer :: DUDP + real, dimension(:,:), pointer :: DUSV + real, dimension(:,:), pointer :: DUWT + real, dimension(:,:), pointer :: DUSD + real, dimension(:,:), pointer :: BCDP + real, dimension(:,:), pointer :: BCSV + real, dimension(:,:), pointer :: BCWT + real, dimension(:,:), pointer :: BCSD + real, dimension(:,:), pointer :: OCDP + real, dimension(:,:), pointer :: OCSV + real, dimension(:,:), pointer :: OCWT + real, dimension(:,:), pointer :: OCSD + real, dimension(:,:), pointer :: SUDP + real, dimension(:,:), pointer :: SUSV + real, dimension(:,:), pointer :: SUWT + real, dimension(:,:), pointer :: SUSD + real, dimension(:,:), pointer :: SSDP + real, dimension(:,:), pointer :: SSSV + real, dimension(:,:), pointer :: SSWT + real, dimension(:,:), pointer :: SSSD + + ! ----------------------------------------------------- + ! INTERNAL Pointers + ! ----------------------------------------------------- + + real, dimension(:), pointer :: bf1 + real, dimension(:), pointer :: bf2 + real, dimension(:), pointer :: bf3 + real, dimension(:), pointer :: vgwmax + real, dimension(:), pointer :: cdcr1 + real, dimension(:), pointer :: cdcr2 + real, dimension(:), pointer :: psis + real, dimension(:), pointer :: bee + real, dimension(:), pointer :: poros + real, dimension(:), pointer :: snowalb + real, dimension(:), pointer :: wpwet + real, dimension(:), pointer :: cond + real, dimension(:), pointer :: gnu + real, dimension(:), pointer :: ars1 + real, dimension(:), pointer :: ars2 + real, dimension(:), pointer :: ars3 + real, dimension(:), pointer :: ara1 + real, dimension(:), pointer :: ara2 + real, dimension(:), pointer :: ara3 + real, dimension(:), pointer :: ara4 + real, dimension(:), pointer :: arw1 + real, dimension(:), pointer :: arw2 + real, dimension(:), pointer :: arw3 + real, dimension(:), pointer :: arw4 + real, dimension(:), pointer :: tsa1 + real, dimension(:), pointer :: tsa2 + real, dimension(:), pointer :: tsb1 + real, dimension(:), pointer :: tsb2 + real, dimension(:), pointer :: atau + real, dimension(:), pointer :: btau + real, dimension(:,:), pointer :: ity + real, dimension(:,:), pointer :: fvg + real, dimension(:), pointer :: capac + real, dimension(:), pointer :: catdef + real, dimension(:), pointer :: rzexc + real, dimension(:), pointer :: srfexc + real, dimension(:), pointer :: ghtcnt1 + real, dimension(:), pointer :: ghtcnt2 + real, dimension(:), pointer :: ghtcnt3 + real, dimension(:), pointer :: ghtcnt4 + real, dimension(:), pointer :: ghtcnt5 + real, dimension(:), pointer :: ghtcnt6 + real, dimension(:), pointer :: tsurf + real, dimension(:), pointer :: wesnn1 + real, dimension(:), pointer :: wesnn2 + real, dimension(:), pointer :: wesnn3 + real, dimension(:), pointer :: htsnnn1 + real, dimension(:), pointer :: htsnnn2 + real, dimension(:), pointer :: htsnnn3 + real, dimension(:), pointer :: sndzn1 + real, dimension(:), pointer :: sndzn2 + real, dimension(:), pointer :: sndzn3 + real, dimension(:,:), pointer :: tc + real, dimension(:,:), pointer :: tg + real, dimension(:,:), pointer :: qc + real, dimension(:,:), pointer :: ch + real, dimension(:,:), pointer :: cm + real, dimension(:,:), pointer :: cq + real, dimension(:,:), pointer :: fr + real, dimension(:,:), pointer :: dcq + real, dimension(:,:), pointer :: dch + real, dimension(:), pointer :: tile_id + real, dimension(:), pointer :: ndep + real, dimension(:), pointer :: abm + real, dimension(:), pointer :: peatf + real, dimension(:), pointer :: gdp + real, dimension(:), pointer :: hdm + real, dimension(:), pointer :: fieldcap + real, dimension(:), pointer :: cli_t2m + real, dimension(:), pointer :: bgalbvr + real, dimension(:), pointer :: bgalbvf + real, dimension(:), pointer :: bgalbnr + real, dimension(:), pointer :: bgalbnf + real, dimension(:,:), pointer :: cncol + real, dimension(:,:), pointer :: cnpft + real, dimension(:,:), pointer :: tgwm + real, dimension(:,:), pointer :: rzmm + real, dimension(:,:), pointer :: sfmm + real, dimension(:), pointer :: bflowm + real, dimension(:), pointer :: totwatm + real, dimension(:), pointer :: tairm + real, dimension(:), pointer :: rhm + real, dimension(:), pointer :: windm + real, dimension(:), pointer :: rainfm + real, dimension(:), pointer :: snowfm + real, dimension(:), pointer :: runsrfm + real, dimension(:), pointer :: ar1m + real, dimension(:), pointer :: tpm + real, dimension(:), pointer :: cnsum + real, dimension(:,:,:), pointer :: psnsunm + real, dimension(:,:,:), pointer :: psnsham + real, dimension(:,:,:), pointer :: lmrsunm + real, dimension(:,:,:), pointer :: lmrsham + real, dimension(:,:,:), pointer :: laisunm + real, dimension(:,:,:), pointer :: laisham + real, dimension(:), pointer :: sndzm + real, dimension(:), pointer :: sndzm5d + real, dimension(:), pointer :: asnowm + real, dimension(:,:), pointer :: RDU001 + real, dimension(:,:), pointer :: RDU002 + real, dimension(:,:), pointer :: RDU003 + real, dimension(:,:), pointer :: RDU004 + real, dimension(:,:), pointer :: RDU005 + real, dimension(:,:), pointer :: RBC001 + real, dimension(:,:), pointer :: RBC002 + real, dimension(:,:), pointer :: ROC001 + real, dimension(:,:), pointer :: ROC002 + real, dimension(:), pointer :: IRRIGFRAC + real, dimension(:), pointer :: PADDYFRAC + real, dimension(:), pointer :: LAIMAX + real, dimension(:), pointer :: LAIMIN + real, dimension(:), pointer :: CLMPT + real, dimension(:), pointer :: CLMST + real, dimension(:), pointer :: CLMPF + real, dimension(:), pointer :: CLMSF + real, dimension(:), pointer :: T2M10D + real, dimension(:), pointer :: TG10D + real, dimension(:), pointer :: T2MMIN5D + real, dimension(:), pointer :: RH30D + real, dimension(:), pointer :: TPREC10D + real, dimension(:), pointer :: TPREC60D + real, dimension(:), pointer :: ET365D + + ! ----------------------------------------------------- + ! EXPORT Pointers + ! ----------------------------------------------------- + + real, dimension(:), pointer :: evapout + real, dimension(:), pointer :: sublim + real, dimension(:), pointer :: shout + real, dimension(:), pointer :: runoff + real, dimension(:), pointer :: evpint + real, dimension(:), pointer :: evpsoi + real, dimension(:), pointer :: evpveg + real, dimension(:), pointer :: evpice + real, dimension(:), pointer :: evpsno + real, dimension(:), pointer :: bflow + real, dimension(:), pointer :: runsurf + real, dimension(:), pointer :: smelt + real, dimension(:), pointer :: fice1 + real, dimension(:), pointer :: fice2 + real, dimension(:), pointer :: fice3 + real, dimension(:), pointer :: accum + real, dimension(:), pointer :: hlwup + real, dimension(:), pointer :: swndsrf + real, dimension(:), pointer :: lwndsrf + real, dimension(:), pointer :: hlatn + real, dimension(:), pointer :: qinfil + real, dimension(:), pointer :: ar1 + real, dimension(:), pointer :: ar2 + real, dimension(:), pointer :: rzeq + real, dimension(:), pointer :: ghflx + real, dimension(:), pointer :: tpsurf + real, dimension(:), pointer :: tpsn1 + real, dimension(:), pointer :: tpust + real, dimension(:), pointer :: tpsat + real, dimension(:), pointer :: tpwlt + real, dimension(:), pointer :: asnow + real, dimension(:), pointer :: frsat + real, dimension(:), pointer :: frust + real, dimension(:), pointer :: frwlt + real, dimension(:), pointer :: tp1 + real, dimension(:), pointer :: tp2 + real, dimension(:), pointer :: tp3 + real, dimension(:), pointer :: tp4 + real, dimension(:), pointer :: tp5 + real, dimension(:), pointer :: tp6 + real, dimension(:), pointer :: emis + real, dimension(:), pointer :: albvr + real, dimension(:), pointer :: albvf + real, dimension(:), pointer :: albnr + real, dimension(:), pointer :: albnf + real, dimension(:), pointer :: delts + real, dimension(:), pointer :: delqs + real, dimension(:), pointer :: delevap + real, dimension(:), pointer :: delsh + real, dimension(:), pointer :: tst + real, dimension(:), pointer :: lst + real, dimension(:), pointer :: qst + + real, dimension(:), pointer :: WET1 + real, dimension(:), pointer :: WET2 + real, dimension(:), pointer :: WET3 + real, dimension(:), pointer :: WCSF + real, dimension(:), pointer :: WCRZ + real, dimension(:), pointer :: WCPR + real, dimension(:), pointer :: SNOMAS + real, dimension(:), pointer :: SNOWDP + + real, dimension(:), pointer :: EVLAND + real, dimension(:), pointer :: PRLAND + real, dimension(:), pointer :: SNOLAND + real, dimension(:), pointer :: DRPARLAND + real, dimension(:), pointer :: DFPARLAND + real, dimension(:), pointer :: LHSNOW + real, dimension(:), pointer :: SWNETSNOW1 + real, dimension(:), pointer :: LWUPSNOW + real, dimension(:), pointer :: LWDNSNOW + real, dimension(:), pointer :: TCSORIG + real, dimension(:), pointer :: TPSN1IN + real, dimension(:), pointer :: TPSN1OUT + real, dimension(:), pointer :: GHSNOW + real, dimension(:), pointer :: LHLAND + real, dimension(:), pointer :: SHLAND + real, dimension(:), pointer :: SWLAND + real, dimension(:), pointer :: SWDOWNLAND + real, dimension(:), pointer :: LWLAND + real, dimension(:), pointer :: GHLAND + real, dimension(:), pointer :: GHTSKIN + real, dimension(:), pointer :: SMLAND + real, dimension(:), pointer :: TWLAND + real, dimension(:), pointer :: TELAND + real, dimension(:), pointer :: TSLAND + real, dimension(:), pointer :: DWLAND + real, dimension(:), pointer :: DHLAND + real, dimension(:), pointer :: SPLAND + real, dimension(:), pointer :: SPWATR + real, dimension(:), pointer :: SPSNOW + + real, dimension(:), pointer :: CNLAI + real, dimension(:), pointer :: CNTLAI + real, dimension(:), pointer :: CNSAI + real, dimension(:), pointer :: CNTOTC + real, dimension(:), pointer :: CNVEGC + real, dimension(:), pointer :: CNFROOTC + real, dimension(:), pointer :: CNNPP + real, dimension(:), pointer :: CNGPP + real, dimension(:), pointer :: CNSR + real, dimension(:), pointer :: CNAR + real, dimension(:), pointer :: CNHR + real, dimension(:), pointer :: CNNEE + real, dimension(:), pointer :: CNXSMR + real, dimension(:), pointer :: CNADD + real, dimension(:), pointer :: CNLOSS + real, dimension(:), pointer :: CNBURN + real, dimension(:), pointer :: PARABS + real, dimension(:), pointer :: PARINC + real, dimension(:), pointer :: SCSAT + real, dimension(:), pointer :: SCUNS + real, dimension(:), pointer :: BTRANT + real, dimension(:), pointer :: SIF + real, dimension(:), pointer :: CNCO2 + real, dimension(:), pointer :: CNFIRE_CNT + real, dimension(:), pointer :: CNSOM_CLOSS + real, dimension(:), pointer :: CNNDEPLOY + real, dimension(:), pointer :: CNDENIT + real, dimension(:), pointer :: CNSMINN_LEACHED + real, dimension(:), pointer :: CNSMINN + real, dimension(:), pointer :: CNFIRE_NLOSS + real, dimension(:), pointer :: CNLEAFN + real, dimension(:), pointer :: CNLEAFC + real, dimension(:), pointer :: CNGROSS_NMIN + real, dimension(:), pointer :: CNNET_NMIN + real, dimension(:), pointer :: CNNFIX_TO_SMINN + real, dimension(:), pointer :: CNACTUAL_IMMOB + real, dimension(:), pointer :: CNFPG + real, dimension(:), pointer :: CNFPI + real, dimension(:), pointer :: CNSMINN_TO_PLANT + real, dimension(:), pointer :: CNSMINN_TO_NPOOL + real, dimension(:), pointer :: CNNDEP_TO_SMINN + real, dimension(:), pointer :: CNTOTVEGN + real, dimension(:), pointer :: CNTOTLITN + real, dimension(:), pointer :: CNTOTSOMN + real, dimension(:), pointer :: CNRETRANSN + real, dimension(:), pointer :: CNRETRANSN_TO_NPOOL + real, dimension(:), pointer :: CNFUELC + real, dimension(:), pointer :: CNTOTLITC + real, dimension(:), pointer :: CNCWDC + real, dimension(:), pointer :: CNROOT + real, dimension(:), pointer :: CNFSEL + + real, dimension(:), pointer :: WAT10CM + real, dimension(:), pointer :: WATSOI + real, dimension(:), pointer :: ICESOI + real, dimension(:), pointer :: SHSNOW + real, dimension(:), pointer :: AVETSNOW + real, pointer, dimension(:) :: RMELTDU001 + real, pointer, dimension(:) :: RMELTDU002 + real, pointer, dimension(:) :: RMELTDU003 + real, pointer, dimension(:) :: RMELTDU004 + real, pointer, dimension(:) :: RMELTDU005 + real, pointer, dimension(:) :: RMELTBC001 + real, pointer, dimension(:) :: RMELTBC002 + real, pointer, dimension(:) :: RMELTOC001 + real, pointer, dimension(:) :: RMELTOC002 + real, pointer, dimension(:) :: IRRIGRATE + real, pointer, dimension(:) :: PEATCLSM_WATERLEVEL + real, pointer, dimension(:) :: PEATCLSM_FSWCHANGE + + ! -------------------------------------------------------------------------- + ! Local pointers for tile variables + ! -------------------------------------------------------------------------- + + INTEGER,pointer,dimension(:) :: CAT_ID + real,pointer,dimension(:) :: dzsf + real,pointer,dimension(:) :: swnetfree + real,pointer,dimension(:) :: swnetsnow + real,pointer,dimension(:) :: qa1 + real,pointer,dimension(:) :: qa2 + real,pointer,dimension(:) :: qa4 + real,pointer,dimension(:) :: tilezero + real,pointer,dimension(:) :: zth + real,pointer,dimension(:) :: lats + real,pointer,dimension(:) :: lons + real,pointer,dimension(:) :: slr + real,pointer,dimension(:) :: rdc + real,pointer,dimension(:) :: PRECU + real,pointer,dimension(:) :: PRELS + real,pointer,dimension(:) :: SNOW + real,pointer,dimension(:) :: UUU, RHO + real,pointer,dimension(:) :: LAI0,GRN0,ZVG + real,pointer,dimension(:) :: Z0, D0 + real,pointer,dimension(:) :: sfmc, rzmc, prmc, entot, wtot + real,pointer,dimension(:) :: ghflxsno, ghflxtskin + real,pointer,dimension(:) :: SHSNOW1, AVETSNOW1, WAT10CM1, WATSOI1, ICESOI1 + real,pointer,dimension(:) :: LHSNOW1, LWUPSNOW1, LWDNSNOW1, NETSWSNOW + real,pointer,dimension(:) :: TCSORIG1, TPSN1IN1, TPSN1OUT1, FSW_CHANGE + real,pointer,dimension(:) :: WCHANGE, ECHANGE, HSNACC, EVACC, SHACC + real,pointer,dimension(:) :: SNOVR, SNOVF, SNONR, SNONF + real,pointer,dimension(:) :: VSUVR, VSUVF + real,pointer,dimension(:) :: ALWX, BLWX + real,pointer,dimension(:) :: LHACC, SUMEV + real,pointer,dimension(:) :: fveg1, fveg2 + real,pointer,dimension(:) :: FICE1TMP + real,pointer,dimension(:) :: SLDTOT + +! real*8,pointer,dimension(:) :: fsum + + real,pointer,dimension(:,:) :: ghtcnt + real,pointer,dimension(:,:) :: wesnn + real,pointer,dimension(:,:) :: htsnnn + real,pointer,dimension(:,:) :: sndzn + real,pointer,dimension(:,:) :: ficesout + real,pointer,dimension(:,:) :: shsbt + real,pointer,dimension(:,:) :: dshsbt + real,pointer,dimension(:,:) :: evsbt + real,pointer,dimension(:,:) :: devsbt + real,pointer,dimension(:,:) :: DEDTC + real,pointer,dimension(:,:) :: DHSDQA + real,pointer,dimension(:,:) :: CFT + real,pointer,dimension(:,:) :: RA + real,pointer,dimension(:,:) :: CFQ + real,pointer,dimension(:,:) :: TCO + real,pointer,dimension(:,:) :: QCO + real,pointer,dimension(:,:) :: DQS + real,pointer,dimension(:,:) :: QSAT + + integer,dimension(:),pointer :: veg1 + integer,dimension(:),pointer :: veg2 + + real,pointer,dimension(:) :: RCSAT + real,pointer,dimension(:) :: DRCSDT + real,pointer,dimension(:) :: DRCSDQ + real,pointer,dimension(:) :: RCUNS + real,pointer,dimension(:) :: DRCUDT + real,pointer,dimension(:) :: DRCUDQ + + real,pointer,dimension(:,:,:) :: RCONSTIT + real,pointer,dimension(:,:) :: TOTDEPOS + real,pointer,dimension(:,:) :: RMELT + + ! -------------------------------------------------------------------------- + ! Locals for parameter lookup + ! -------------------------------------------------------------------------- + + ! vegetation calculations + + real,dimension(NTYPS) :: VGRF11 + real,dimension(NTYPS) :: VGRF12 + real,dimension(NTYPS) :: VGTR11 + real,dimension(NTYPS) :: VGTR12 + real,dimension(NTYPS) :: VGROCA + real,dimension(NTYPS) :: VGROTD + real,dimension(NTYPS) :: VGRDRS + real,dimension(NTYPS) :: VGDDA, VGDDB, VGDDC + real,dimension(NTYPS) :: VGRDA, VGRDB + + real,dimension(:),allocatable :: RSL1, RSL2 + real,dimension(:),allocatable :: SQSCAT + real,allocatable,dimension(:) :: rdc_tmp_1, rdc_tmp_2 + + ! albedo calculation stuff + + type(ESMF_Config) :: CF + type(MAPL_SunOrbit) :: ORBIT + type(ESMF_Time) :: CURRENT_TIME, StopTime, NextTime, NextRecordTime + type(ESMF_Time) :: BEFORE + type(ESMF_Time) :: NOW + type(ESMF_Time) :: MODELSTART + type(ESMF_Time) :: AFTER + type(ESMF_TimeInterval) :: DELT + type(ESMF_TimeInterval) :: TINT + real :: DT_SOLAR + type(ESMF_Alarm) :: SOLALARM + logical :: solalarmison + logical :: debugzth + real :: FAC + real :: DT + integer :: NTILES + integer :: I, J, K, N + + ! dummy variables for call to get snow temp + + real :: FICE + logical :: DUMFLAG1,DUMFLAG2 + integer :: nmax + type(ESMF_VM) :: VM + +#ifdef DBG_CNLSM_INPUTS + ! vars for debugging purposes + type(ESMF_Grid) :: TILEGRID + type (MAPL_LocStream) :: LOCSTREAM + integer, pointer :: mask(:) + integer :: nt + integer, save :: unit_i=0 + logical, save :: firsttime=.true. + integer :: unit + integer :: NT_GLOBAL + +#endif + + ! Offline case + + type(CATCHCN_WRAP) :: wrap + type(T_CATCHCN_STATE), pointer :: catchcn_internal + integer :: OFFLINE_MODE + real,dimension(:,:),allocatable :: ALWN, BLWN + ! unadulterated TC's and QC's + real, pointer :: TC1_0(:), TC2_0(:), TC4_0(:) + real, pointer :: QA1_0(:), QA2_0(:), QA4_0(:) + real, pointer :: PLSIN(:) + + ! CATCHMENT_SPINUP + integer :: CurrMonth, CurrDay, CurrHour, CurrMin, CurrSec + + ! -------------------------------------------------------------------------- + ! Lookup tables + ! -------------------------------------------------------------------------- + + data VGRF11 / 0.100, 0.100, 0.070, 0.105, 0.100, 0.100 / + data VGRF12 / 0.160, 0.160, 0.160, 0.360, 0.160, 0.160 / + data VGTR11 / 0.050, 0.050, 0.050, 0.070, 0.050, 0.050 / + data VGTR12 / 0.001, 0.001, 0.001, 0.220, 0.001, 0.001 / + data VGROTD / 1.000, 1.000, 0.500, 0.500, 0.500, 0.200 / + + data VGROCA / 0.384E-6, 0.384E-6, 0.384E-6, 0.384E-6, 0.384E-6, 0.384E-6/ + data VGRDRS / 0.750E13, 0.750E13, 0.750E13, 0.400E13, 0.750E13, 0.750E13/ + +! Correction to RDC formulation -Randy Koster, 4/1/2011 +! data VGRDA / 285.9, 294.9, 652.9, 25.8, 100.7, 22.9, 23.8, 23.8/ +! data VGRDB / 5.1 , 7.2, 10.8, 4.8, 1.8, 5.1, .000, .000/ + + data VGRDA / 285.9, 355.18, 660.24, 30.06, 100.7, 24.36/ + data VGRDB / 5.1 , 7.2, 10.5, 4.8, 1.8, 5.1/ + +! gkw: following is for CN model +! ------------------------------ + integer, parameter :: nveg = num_veg ! number of vegetation types + integer, parameter :: nzone = num_zon ! number of stress zones + + real, allocatable, dimension(:) :: wgt, wpp, fwet, wet_in + real, allocatable, dimension(:,:) :: sm ! soil water as frac of WHC for the 3 dydrological zones at root depth + real, allocatable, dimension(:) :: SWSRF1, SWSRF2, SWSRF4 ! soil water as frac of WHC for the 3 dydrological zones at surface soil + real, allocatable, dimension(:,:) :: tcx, qax + real, allocatable, dimension(:,:) :: tgw, rzm, sfm,rc00, rcdt,rcdq, totcolc, wtzone + real, allocatable, dimension(:,:) :: btran_fire, bt + real, allocatable, dimension(:,:,:) :: btran,elai,esai,fveg,tlai,psnsun,psnsha,laisun,laisha,lmrsun,lmrsha + integer, allocatable, dimension(:,:,:) :: ityp + real, allocatable, dimension(:) :: car1, car2, car4 + real, allocatable, dimension(:) :: para + real, allocatable, dimension(:) :: rcxdt, rcxdq + real, allocatable, dimension(:) :: dayl, dayl_fac + real, allocatable, dimension(:), save :: nee, npp, gpp, sr, aresp, hresp, padd, frootc, vegc, xsmr,burn, closs + real, allocatable, dimension(:) :: nfire, som_closs, fsnow + real, allocatable, dimension(:) :: ndeploy, denit, sminn_leached, sminn, fire_nloss + real, allocatable, dimension(:) :: leafn, leafc, gross_nmin, net_nmin, nfix_to_sminn, actual_immob + real, allocatable, dimension(:) :: fpg, fpi, sminn_to_plant, sminn_to_npool, ndep_to_sminn + real, allocatable, dimension(:) :: totvegn, totlitn, totsomn, retransn, retransn_to_npool + real, allocatable, dimension(:) :: fuelc, totlitc, cwdc, rootc + + ! *************************************************************************************************************************************************************** + ! Begin Carbon Tracker variables + ! + ! use EEA global average CO2 to scale 2001-2014 CarbonTracker CO2 monthly mean diurnal cycle to obtain CO2 for 1850-2000. + ! extended from the last cycle when carbon reaches equilibrium with the 2001-2014 CarbonTracker CO2 monthly mean diurnal + ! cycle * 280ppm/389.8899ppm, fzeng, Apr 2017. + ! EEA global average CO2 is from http://www.eea.europa.eu/data-and-maps/figures/atmospheric-concentration-of-co2-ppm-1 + ! -------------------------------------------------------------------------------------------------------------------- + + real :: co2g ! global average atmospheric carbon dioxide concentration, varies after 1850 + integer, parameter :: byr_co2g = 1851 ! year global average atmospheric CO2 concentration began to increase from 280.e-6 + integer, parameter :: myr_co2g = 1950 ! year global average atmospheric CO2 concentration reached 311.e-6 + integer, parameter :: eyr_co2g = 2012 ! year global average atmospheric CO2 concentration reached 391.e-6 + real, parameter :: co2g_byr = 280.e-6 ! pre-industrial global average atmospheric carbon dioxide concentration (i.e. before byr_co2g) + real, parameter :: co2g_myr = 311.e-6 ! global average atmospheric CO2 concentration in myr_co2g + real, parameter :: co2g_eyr = 391.e-6 ! global average atmospheric CO2 concentration in eyr_co2g + real, parameter :: dco2g_1 = (co2g_myr-co2g_byr)/(myr_co2g-byr_co2g) ! yearly atmospheric CO2 concentration increment for period 1 (byr_co2g to myr_co2g) + real, parameter :: dco2g_2 = (co2g_eyr-co2g_myr)/(eyr_co2g-myr_co2g) ! yearly atmospheric CO2 concentration increment for period 2 (myr_co2g to eyr_co2g) + real, parameter :: CTco2g = 389.8899e-6 ! Spatial (tile area weighted) and temporal average of 2001-2014 CarbonTracker CO2 + real, allocatable, dimension(:) :: co2v ! spatial varying atmospheric carbon dioxide concentration + + ! parameters for calculating CT indices for tiles + ! ----------------------------------------------- + integer, parameter :: CT_grid_N_lon = 120 ! lon dimension CarbonTracker CO2 data + integer, parameter :: CT_grid_N_lat = 90 ! lat dimension CarbonTracker CO2 data + real, parameter :: CT_grid_dlon = 360./real(CT_grid_N_lon), CT_grid_dlat = 180./real(CT_grid_N_lat) + INTEGER :: info, comm, CTfile, Y1, M1, This3H, ThisCO2_Year, NUNQ, CO2_YEAR + logical, allocatable, dimension (:) :: unq_mask + integer, allocatable, dimension (:,:) :: CT_index + integer, allocatable, dimension (:) :: ct2cat, ThisIndex, loc_int + integer, allocatable, dimension (:), save :: ct_tid + real, dimension (:,:,:,:), allocatable :: CTCO2_TMP + real, dimension (:,:,:), save, allocatable :: CT_CO2V + logical, save :: first_ct = .true. + integer, save :: FIRST_YY + + ! End Carbon Tracker variables + ! ************************************************************************************************************************************************************* + + ! prescribe DYNVEG parameters + ! --------------------------- + + real, parameter :: dtc = 0.03 ! canopy temperature perturbation (K) [approx 1:10000] + real, parameter :: dea = 0.10 ! vapor pressure perturbation (Pa) [approx 1:10000] + + real, allocatable, dimension(:) :: totwat ! total soil liquid water (kg/m2) + real, save :: ashift = 0. ! for baseflow. gkw: this should match value in routine "base" in catchment + real :: Qair_sat ! saturated specific humidity (kg/kg) + real, allocatable, dimension(:) :: Qair_relative ! relative humidity (%) + + integer :: nz, iv + real :: cn1, cn2, cn3, cn12, cn23, ar, ax1, ax2, ax4 + real, dimension(fsat:fwlt) :: f1, f2, f3, f4 + + real, allocatable, dimension(:,:,:,:) :: albdir, albdif + integer, allocatable, dimension(:) :: ityp_tmp + + ! static summing arrays for CN + ! ---------------------------- + real, allocatable, dimension(:) :: ht, tp, soilice + real :: zbar, frice + + real, allocatable, dimension(:,:) :: col + real, allocatable, dimension(:,:,:) :: pft + + real, allocatable, dimension(:) :: lnfm + character(len=ESMF_MAXSTR) :: LNFMFile, CO2_CycleFile + + integer :: ntile, nv, dpy, ierr, iok, ndt + integer, save :: year_prev = -9999 + + integer, save :: n1d ! number of land model steps in a 1-day period + integer, save :: n5d ! number of land model steps in a 5-day period + integer, save :: n10d ! number of land model steps in a 10-day period + integer, save :: n30d ! number of land model steps in a 30-day period + integer, save :: n60d ! number of land model steps in a 60-day period + integer, save :: n365d ! number of land model steps in a 365-day period + + ! For accumulated fields + ! NOTE: In CNPhenologyMod.F90, init_gdd20 is always set to .false. as well. For GEOS-5 runs, need to discard at least the first 2 years. + ! This is not a problem for offline runs because we always spin up the model whenever we change meterology. fzeng, July 2017 + ! -------------------------------------------------------------------------------------------------------------------------------------- + logical, parameter :: init_accum = .true.! jkolassa May 2023: needs to be set to true if no CNCLM51 restart is available + logical, parameter :: init_accum_365 = .true.! jkolassa May 2023: needs to be set to true if no CNCLM51 restart is available + integer, save :: istep ! model time step index + integer, save :: istep_365 ! model time step index + integer :: accper ! number of time steps accumulated in a period of XX days, increases from 1 to nXXd in the first XX days, + ! and remains as nXXd thereafter + integer, allocatable, dimension(:) :: ta_count + real, allocatable, dimension(:) :: TA_MIN + + integer :: AGCM_YY, AGCM_MM, AGCM_DD, AGCM_MI, AGCM_S, AGCM_HH, dofyr, AGCM_S_ofday + logical, save :: first = .true. + integer(INT64), save :: istep_cn = 1 ! gkw: legacy variable from offline + + ! solar declination related + real :: ob, declin, zs, zc, max_decl, max_dayl + integer :: year, iday, idayp1 + + ! real :: co2 + real, external :: getco2 + + ! temporaries for call to SIBALB for each type + ! -------------------------------------------- + real, allocatable, dimension(:) :: lai1, lai2, wght + real, allocatable, dimension(:) :: ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp + real, allocatable, dimension(:) :: SNOVR_tmp, SNONR_tmp, SNOVF_tmp, SNONF_tmp + + logical :: record + type(ESMF_Alarm) :: RecordAlarm + + ! Variables for FPAR + real , allocatable, dimension (:,:,:) :: parzone + + integer :: cn_count = 0 + logical :: first_cn + + IAm=trim(COMP_NAME)//"::RUN2::Driver" + + ! Begin + + IAm=trim(COMP_NAME)//"Driver" + + ! -------------------------------------------------------------------------- + ! Get time step from configuration + ! -------------------------------------------------------------------------- + + call ESMF_GridCompGet ( GC, CONFIG=CF, RC=STATUS ) + VERIFY_(STATUS) + + ! -------------------------------------------------------------------------- + ! Get my internal MAPL_Generic state + ! -------------------------------------------------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_Get(MAPL, HEARTBEAT = DT, RC=STATUS) + VERIFY_(STATUS) + + call ESMF_ConfigGetAttribute ( CF, DT ,& + Label = trim(COMP_NAME)//"_DT:" ,& + Default = DT ,& + RC=STATUS ) + VERIFY_(STATUS) + + ! Get component's private internal state + call ESMF_UserCompGetInternalState(gc, 'CatchcnInternal', wrap, status) + VERIFY_(status) + catchcn_internal => wrap%ptr + OFFLINE_MODE = catchcn_internal%CATCH_OFFLINE + ! if (MAPL_AM_I_Root(VM)) print *, trim(Iam)//'::OFFLINE mode: ', is_OFFLINE + + call ESMF_VMGetCurrent ( VM, RC=STATUS ) + + ! -------------------------------------------------------------------------- + ! Get parameters from generic state. + ! -------------------------------------------------------------------------- + + call MAPL_Get ( MAPL ,& + RUNALARM = ALARM ,& + ORBIT = ORBIT ,& + TILELATS = LATS ,& + TILELONS = LONS ,& + INTERNAL_ESMF_STATE = INTERNAL ,& + RC=STATUS ) + VERIFY_(STATUS) + + ! ----------------------------------------------------- + ! IMPORT Pointers + ! ----------------------------------------------------- + + call MAPL_GetPointer(IMPORT,PS ,'PS' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,TA ,'TA' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,QA ,'QA' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,UU ,'UU' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DZ ,'DZ' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,PCU ,'PCU' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,PLS ,'PLS' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SNO ,'SNO' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,ICE ,'ICE' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,FRZR ,'FRZR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DRPAR ,'DRPAR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DFPAR ,'DFPAR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DRNIR ,'DRNIR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DFNIR ,'DFNIR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DRUVR ,'DRUVR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DFUVR ,'DFUVR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,LWDNSRF,'LWDNSRF',RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(IMPORT,ALW ,'ALW' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,BLW ,'BLW' ,RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(IMPORT,EVAP ,'EVAP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DEVAP ,'DEVAP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SH ,'SH' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DSH ,'DSH' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,THATM ,'THATM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,QHATM ,'QHATM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,CTATM ,'CTATM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,CQATM ,'CQATM' ,RC=STATUS); VERIFY_(STATUS) + IF (catchcn_internal%ATM_CO2 == 4) call MAPL_GetPointer(IMPORT,CO2SC ,'CO2SC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,LAI ,'LAI' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,GRN ,'GRN' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,ROOTL ,'ROOTL' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,Z2CH ,'Z2CH' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,ASCATZ0,'ASCATZ0',RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,NDVI ,'NDVI' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DUDP ,'DUDP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DUSV ,'DUSV' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DUWT ,'DUWT' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,DUSD ,'DUSD' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,BCDP ,'BCDP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,BCSV ,'BCSV' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,BCWT ,'BCWT' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,BCSD ,'BCSD' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,OCDP ,'OCDP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,OCSV ,'OCSV' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,OCWT ,'OCWT' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,OCSD ,'OCSD' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SUDP ,'SUDP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SUSV ,'SUSV' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SUWT ,'SUWT' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SUSD ,'SUSD' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SSDP ,'SSDP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SSSV ,'SSSV' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SSWT ,'SSWT' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,SSSD ,'SSSD' ,RC=STATUS); VERIFY_(STATUS) + + ! ----------------------------------------------------- + ! INTERNAL Pointers + ! ----------------------------------------------------- + + call MAPL_GetPointer(INTERNAL,BF1 ,'BF1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BF2 ,'BF2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BF3 ,'BF3' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,VGWMAX ,'VGWMAX' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CDCR1 ,'CDCR1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CDCR2 ,'CDCR2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,PSIS ,'PSIS' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BEE ,'BEE' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,POROS ,'POROS' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,WPWET ,'WPWET' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,COND ,'COND' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,GNU ,'GNU' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARS1 ,'ARS1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARS2 ,'ARS2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARS3 ,'ARS3' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARA1 ,'ARA1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARA2 ,'ARA2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARA3 ,'ARA3' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARA4 ,'ARA4' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARW1 ,'ARW1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARW2 ,'ARW2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARW3 ,'ARW3' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ARW4 ,'ARW4' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TSA1 ,'TSA1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TSA2 ,'TSA2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TSB1 ,'TSB1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TSB2 ,'TSB2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ATAU ,'ATAU' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BTAU ,'BTAU' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ITY ,'ITY' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,FVG ,'FVG' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TC ,'TC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,QC ,'QC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TG ,'TG' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CAPAC ,'CAPAC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CATDEF ,'CATDEF' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RZEXC ,'RZEXC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,SRFEXC ,'SRFEXC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,GHTCNT1 ,'GHTCNT1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,GHTCNT2 ,'GHTCNT2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,GHTCNT3 ,'GHTCNT3' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,GHTCNT4 ,'GHTCNT4' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,GHTCNT5 ,'GHTCNT5' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,GHTCNT6 ,'GHTCNT6' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TSURF ,'TSURF' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,WESNN1 ,'WESNN1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,WESNN2 ,'WESNN2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,WESNN3 ,'WESNN3' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,HTSNNN1 ,'HTSNNN1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,HTSNNN2 ,'HTSNNN2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,HTSNNN3 ,'HTSNNN3' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,SNDZN1 ,'SNDZN1' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,SNDZN2 ,'SNDZN2' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,SNDZN3 ,'SNDZN3' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CH ,'CH' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CM ,'CM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CQ ,'CQ' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,FR ,'FR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,DCQ ,'DCQ' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,DCH ,'DCH' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TILE_ID ,'TILE_ID' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,NDEP ,'NDEP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ABM ,'ABM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,PEATF ,'PEATF' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,GDP ,'GDP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,HDM ,'HDM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,FIELDCAP ,'FIELDCAP' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CLI_T2M ,'CLI_T2M' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BGALBVR ,'BGALBVR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BGALBVF ,'BGALBVF' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BGALBNR ,'BGALBNR' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BGALBNF ,'BGALBNF' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CNCOL ,'CNCOL' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CNPFT ,'CNPFT' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TGWM ,'TGWM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RZMM ,'RZMM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,SFMM ,'SFMM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,BFLOWM ,'BFLOWM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TOTWATM ,'TOTWATM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TAIRM ,'TAIRM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RHM ,'RHM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,WINDM ,'WINDM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RAINFM ,'RAINFM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,SNOWFM ,'SNOWFM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RUNSRFM ,'RUNSRFM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,AR1M ,'AR1M' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TPM ,'TPM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CNSUM ,'CNSUM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,PSNSUNM ,'PSNSUNM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,PSNSHAM ,'PSNSHAM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,LMRSUNM ,'LMRSUNM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,LMRSHAM ,'LMRSHAM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,LAISUNM ,'LAISUNM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,LAISHAM ,'LAISHAM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,SNDZM ,'SNDZM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,SNDZM5D ,'SNDZM5D' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ASNOWM ,'ASNOWM' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,T2M10D ,'T2M10D' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TG10D ,'TG10D' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,T2MMIN5D ,'T2MMIN5D' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RH30D ,'RH30D' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TPREC10D ,'TPREC10D' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,TPREC60D ,'TPREC60D' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ET365D ,'ET365D' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RUNSURF ,'RUNSURF' ,RC=STATUS); VERIFY_(STATUS) + + if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then + call MAPL_GetPointer(INTERNAL,RDU001 ,'RDU001' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RDU002 ,'RDU002' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RDU003 ,'RDU003' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RDU004 ,'RDU004' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RDU005 ,'RDU005' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RBC001 ,'RBC001' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,RBC002 ,'RBC002' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ROC001 ,'ROC001' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,ROC002 ,'ROC002' , RC=STATUS); VERIFY_(STATUS) + endif + + IF (catchcn_internal%RUN_IRRIG /= 0) THEN + call MAPL_GetPointer(INTERNAL,IRRIGFRAC ,'IRRIGFRAC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,PADDYFRAC ,'PADDYFRAC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,LAIMAX ,'LAIMAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,LAIMIN ,'LAIMIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CLMPT ,'CLMPT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CLMST ,'CLMST' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CLMPF ,'CLMPF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,CLMSF ,'CLMSF' , RC=STATUS); VERIFY_(STATUS) + ENDIF + + ! ----------------------------------------------------- + ! EXPORT POINTERS + ! ----------------------------------------------------- + + call MAPL_GetPointer(EXPORT,EVAPOUT , 'EVAPOUT',ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SUBLIM , 'SUBLIM' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SHOUT , 'SHOUT' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RUNOFF , 'RUNOFF' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,EVPINT , 'EVPINT' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,EVPSOI , 'EVPSOI' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,EVPVEG , 'EVPVEG' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,EVPICE , 'EVPICE' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WAT10CM , 'WAT10CM',ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WATSOI , 'WATSOI' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICESOI , 'ICESOI' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,EVPSNO , 'EVPSNO' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,BFLOW , 'BASEFLOW',ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SMELT , 'SMELT' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE1 , 'FICE1' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE2 , 'FICE2' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FICE3 , 'FICE3' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,HLWUP , 'HLWUP' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SWNDSRF , 'SWNDSRF',ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,LWNDSRF , 'LWNDSRF',ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,HLATN , 'HLATN' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,QINFIL , 'QINFIL' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,AR1 , 'AR1' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,AR2 , 'AR2' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RZEQ , 'RZEQ' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,GHFLX , 'GHFLX' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TPSURF , 'TPSURF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TPSN1 , 'TPSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TPUST , 'TPUNST' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TPSAT , 'TPSAT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TPWLT , 'TPWLT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ASNOW , 'ASNOW' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SHSNOW , 'SHSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,AVETSNOW , 'AVETSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FRSAT , 'FRSAT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FRUST , 'FRUST' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,FRWLT , 'FRWLT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TP1 , 'TP1' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TP2 , 'TP2' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TP3 , 'TP3' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TP4 , 'TP4' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TP5 , 'TP5' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TP6 , 'TP6' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,EMIS , 'EMIS' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ALBVR , 'ALBVR' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ALBVF , 'ALBVF' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ALBNR , 'ALBNR' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ALBNF , 'ALBNF' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DELTS , 'DELTS' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DELQS , 'DELQS' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TST , 'TST' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,QST , 'QST' ,ALLOC=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,LST , 'LST' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WET1 , 'WET1' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WET2 , 'WET2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WET3 , 'WET3' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WCSF , 'WCSF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WCRZ , 'WCRZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WCPR , 'WCPR' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ACCUM , 'ACCUM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SNOMAS , 'SNOWMASS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SNOWDP , 'SNOWDP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,EVLAND , 'EVLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PRLAND , 'PRLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SNOLAND , 'SNOLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DRPARLAND , 'DRPARLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DFPARLAND , 'DFPARLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,LHSNOW , 'LHSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SWNETSNOW1 , 'SWNETSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,LWUPSNOW , 'LWUPSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,LWDNSNOW , 'LWDNSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TCSORIG , 'TCSORIG' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TPSN1IN , 'TPSN1IN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TPSN1OUT , 'TPSN1OUT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,LHLAND , 'LHLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SHLAND , 'SHLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SWLAND , 'SWLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SWDOWNLAND , 'SWDOWNLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,LWLAND , 'LWLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,GHLAND , 'GHLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,GHSNOW , 'GHSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,GHTSKIN , 'GHTSKIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SMLAND , 'SMLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TWLAND , 'TWLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TELAND , 'TELAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,TSLAND , 'TSLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DWLAND , 'DWLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DHLAND , 'DHLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SPLAND , 'SPLAND' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SPWATR , 'SPWATR' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SPSNOW , 'SPSNOW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNLAI , 'CNLAI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNTLAI , 'CNTLAI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNSAI , 'CNSAI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNTOTC , 'CNTOTC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNVEGC , 'CNVEGC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNFROOTC , 'CNFROOTC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNNPP , 'CNNPP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNGPP , 'CNGPP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNSR , 'CNSR' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNAR , 'CNAR' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNHR , 'CNHR' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNNEE , 'CNNEE' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNXSMR , 'CNXSMR' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNADD , 'CNADD' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNLOSS , 'CNLOSS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNBURN , 'CNBURN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PARABS , 'PARABS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PARINC , 'PARINC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SCSAT , 'SCSAT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SCUNS , 'SCUNS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,BTRANT , 'BTRANT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,SIF , 'SIF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNCO2 , 'CNCO2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNFIRE_CNT , 'CNFIRE_CNT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNSOM_CLOSS , 'CNSOM_CLOSS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNNDEPLOY , 'CNNDEPLOY' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNDENIT , 'CNDENIT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNSMINN_LEACHED , 'CNSMINN_LEACHED' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNSMINN , 'CNSMINN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNFIRE_NLOSS , 'CNFIRE_NLOSS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNLEAFN , 'CNLEAFN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNLEAFC , 'CNLEAFC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNGROSS_NMIN , 'CNGROSS_NMIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNNET_NMIN , 'CNNET_NMIN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNNFIX_TO_SMINN , 'CNNFIX_TO_SMINN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNACTUAL_IMMOB , 'CNACTUAL_IMMOB' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNFPG , 'CNFPG' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNFPI , 'CNFPI' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNSMINN_TO_PLANT , 'CNSMINN_TO_PLANT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNSMINN_TO_NPOOL , 'CNSMINN_TO_NPOOL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNNDEP_TO_SMINN , 'CNNDEP_TO_SMINN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNTOTVEGN , 'CNTOTVEGN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNTOTLITN , 'CNTOTLITN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNTOTSOMN , 'CNTOTSOMN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNRETRANSN , 'CNRETRANSN' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNRETRANSN_TO_NPOOL, 'CNRETRANSN_TO_NPOOL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNFUELC , 'CNFUELC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNTOTLITC , 'CNTOTLITC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNCWDC , 'CNCWDC' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNROOT , 'CNROOT' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,CNFSEL , 'CNFSEL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTDU001 ,'RMELTDU001' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTDU002 ,'RMELTDU002' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTDU003 ,'RMELTDU003' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTDU004 ,'RMELTDU004' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTDU005 ,'RMELTDU005' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTBC001 ,'RMELTBC001' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTBC002 ,'RMELTBC002' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTOC001 ,'RMELTOC001' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RMELTOC002 ,'RMELTOC002' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_WATERLEVEL,'PEATCLSM_WATERLEVEL' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,PEATCLSM_FSWCHANGE ,'PEATCLSM_FSWCHANGE' , RC=STATUS); VERIFY_(STATUS) + + IF (catchcn_internal%RUN_IRRIG /= 0) call MAPL_GetPointer(EXPORT,IRRIGRATE ,'IRRIGRATE' , RC=STATUS); VERIFY_(STATUS) + + NTILES = size(PS) + + allocate( ityp(ntiles,nveg,nzone) ) + allocate( fveg(ntiles,nveg,nzone) ) + allocate( wtzone (ntiles,nzone) ) + allocate( elai(ntiles,nveg,nzone) ) + allocate( esai(ntiles,nveg,nzone) ) + allocate( tlai(ntiles,nveg,nzone) ) + +! initialize CN model and transfer restart variables on startup +! ------------------------------------------------------------- + if(first) then + + ! set number of time steps within a XX-day/hour period for 2m temperature XX-day/hour "running mean" + ! -------------------------------------------------------------------------------------------------- + n1d = 86400/dt + n5d = 5*86400/dt + n10d = 10*86400/dt + n30d = 30*86400/dt + n60d = 60*86400/dt + n365d = 365*86400/dt + ! fzeng: this is done in such way to exclude istep in the restart file + if(init_accum) then + istep = 0 ! set model time step index to 0 when begin to accumulate the cumulative variables, fzeng, 21 Apr 2017 + else + istep = maxval((/n10d,n30d,n60d/)) ! otherwise, set model time step index to the maximum of these nXX + end if + + ! jkolassa: implement this separately for 365-day running mean of ET + if(init_accum_365) then + istep_365 = 0 ! set model time step index to 0 when begin to accumulate the cumulative variables, fzeng, 21 Apr 2017 + else + istep_365 = maxval((/n10d,n30d,n60d,n365d/)) ! otherwise, set model time step index to the maximum of these nXX + end if + + + ! variables used for summing CN inputs over multiple land model calls; not saved on restart + ! fzeng: run must end on a CN call step + ! ----------------------------------------------------------------------------------------- +! allocate( lmrsunm(ntiles,nveg,nzone) ) +! allocate( lmrsham(ntiles,nveg,nzone) ) +! allocate( runsrf(ntiles) ) +! +! lmrsunm = 0. +! lmrsham = 0. +! runsrf = 0. + + first = .false. + + endif + +! set CLM CN PFT & fraction, set carbon zone weights +! -------------------------------------------------- + do nz = 1,nzone + ityp(:,:,nz) = nint(ity(:,:)) + fveg(:,:,nz) = fvg(:,:) + wtzone(:,nz) = CN_zone_weight(nz) + end do + + ! obtain LAI from previous time step (from CN model) + ! -------------------------------------------------- + call get_CN_LAI(ntiles,ityp,fveg,elai,esai=esai,tlai = tlai) + +! OPTIONAL IMPOSE MONTHLY MEAN DIURNAL CYCLE FROM NOAA CARBON TRACKER +! ------------------------------------------------------------------- + + IF ((catchcn_internal%ATM_CO2 == 1).OR.(catchcn_internal%ATM_CO2 == 2)) THEN + READ_CT_CO2: IF(first_ct) THEN + + ! Carbon Tracker grid tiles mapping + + allocate (CT_INDEX (1:CT_grid_N_lon, 1:CT_grid_N_lat)) + do j = 1, CT_grid_N_lat + do i = 1, CT_grid_N_lon + CT_INDEX (i,j) = (j - 1) * CT_grid_N_lon + i + end do + end do + + allocate (ct2cat (1: NTILES)) + allocate (ct_tid (1: NTILES)) + + ct_tid = -9999 + ct2cat = 0 + + do N = 1, NTILES + I = NINT ((CEILING (lons(n)*90./MAPL_PI)*2 + 180.) / CT_grid_dlon) + J = NINT ((CEILING (lats(n)*90./MAPL_PI)*2 + 90.) / CT_grid_dlat) + CT2CAT (N) = ct_index (i,j) + end do + + N = count(ct2cat > 0) + + allocate (unq_mask(1:N )) + allocate (loc_int (1:N )) + + loc_int = pack(ct2cat ,mask = (ct2cat > 0)) + call MAPL_Sort (loc_int) + + unq_mask = .true. + + do i = 2,N + unq_mask(i) = .not.(loc_int(i) == loc_int(i-1)) + end do + + NUNQ = count(unq_mask) + + allocate (ThisIndex (1:NUNQ)) + ThisIndex = pack(loc_int, mask = unq_mask ) + + do i = 1, NUNQ + where (ct2cat == ThisIndex(i)) ct_tid = i + end do + + ! Reading Carbon Tracker CO2_MonthlyMean_DiurnalCycle + + call ESMF_ClockGet( CLOCK, startTime=MODELSTART, RC=STATUS ); VERIFY_(STATUS) + call ESMF_TimeGet ( MODELSTART, YY = FIRST_YY, rc=status ) ; VERIFY_(STATUS) + CALL ESMF_VMGet(vm, MPICOMMUNICATOR=comm, rc=status); VERIFY_(status) + call MPI_Info_create(info, STATUS); VERIFY_(status) + call MPI_Info_set(info, "romio_cb_read", "automatic", STATUS); VERIFY_(status) + + call MAPL_GetResource (MAPL, CO2_CycleFile, label = 'CO2_MonthlyMean_DiurnalCycle_FILE:', default = 'CO2_MonthlyMean_DiurnalCycle.nc4', RC=STATUS ) + VERIFY_(STATUS) + + STATUS = NF_OPEN (trim(CO2_CycleFile), NF_NOWRITE, CTfile); VERIFY_(status) + + allocate (CT_CO2V (1: NUNQ, 1:12, 1:8)) + allocate (CTCO2_TMP (1:CT_grid_N_lon, 1:CT_grid_N_lat, 1:12, 1:8)) + + STATUS = NF_GET_VARA_REAL (CTfile, VarID(CTfile,'CO2'), (/1,1,1,1/), & + (/CT_grid_N_lon, CT_grid_N_lat, 12, 8/), CTCO2_TMP);VERIFY_(STATUS) + + do N = 1, NUNQ + I = MOD (ThisIndex(N), CT_grid_N_lon) + IF(I == 0) I = CT_grid_N_lon + J = (ThisIndex(N) -I) / CT_grid_N_lon + 1 + + CT_CO2V (N,:,:) = CTCO2_TMP (I,J,:,:) + + end do + + status = NF_CLOSE (CTFile); VERIFY_(status) + first_ct = .false. + + deallocate (CTCO2_TMP,ct2cat, unq_mask, loc_int, ct_index, ThisIndex) + + ENDIF READ_CT_CO2 + ENDIF + + + ! -------------------------------------------------------------------------- + ! ALLOCATE LOCAL POINTERS + ! -------------------------------------------------------------------------- + + allocate(GHTCNT (N_GT, NTILES)) + allocate(WESNN (N_SNOW,NTILES)) + allocate(HTSNNN (N_SNOW,NTILES)) + allocate(SNDZN (N_SNOW,NTILES)) + allocate(FICESOUT(N_SNOW,NTILES)) + + allocate(TILEZERO (NTILES)) + allocate(DZSF (NTILES)) + allocate(SWNETFREE(NTILES)) + allocate(SWNETSNOW(NTILES)) + allocate(VEG1 (NTILES)) + allocate(VEG2 (NTILES)) + allocate(RCSAT (NTILES)) + allocate(DRCSDT (NTILES)) + allocate(DRCSDQ (NTILES)) + allocate(RCUNS (NTILES)) + allocate(DRCUDT (NTILES)) + allocate(DRCUDQ (NTILES)) + allocate(ZTH (NTILES)) + allocate(SLR (NTILES)) + allocate(RSL1 (NTILES)) + allocate(RSL2 (NTILES)) + allocate(SQSCAT (NTILES)) + allocate(RDC (NTILES)) + allocate(RDC_TMP_1(NTILES)) + allocate(RDC_TMP_2(NTILES)) + allocate(UUU (NTILES)) + allocate(RHO (NTILES)) + allocate(ZVG (NTILES)) + allocate(LAI0 (NTILES)) + allocate(GRN0 (NTILES)) + allocate(Z0 (NTILES)) + allocate(D0 (NTILES)) + allocate(SFMC (NTILES)) + allocate(RZMC (NTILES)) + allocate(PRMC (NTILES)) + allocate(ENTOT (NTILES)) + allocate(ghflxsno (NTILES)) + allocate(ghflxtskin(NTILES)) + allocate(WTOT (NTILES)) + allocate(WCHANGE (NTILES)) + allocate(ECHANGE (NTILES)) + allocate(HSNACC (NTILES)) + allocate(EVACC (NTILES)) + allocate(SHACC (NTILES)) + allocate(VSUVR (NTILES)) + allocate(VSUVF (NTILES)) + allocate(SNOVR (NTILES)) + allocate(SNOVF (NTILES)) + allocate(SNONR (NTILES)) + allocate(SNONF (NTILES)) + allocate(CAT_ID (NTILES)) + allocate(ALWX (NTILES)) + allocate(BLWX (NTILES)) + allocate(SHSNOW1 (NTILES)) + allocate(AVETSNOW1 (NTILES)) + allocate(WAT10CM1 (NTILES)) + allocate(WATSOI1 (NTILES)) + allocate(ICESOI1 (NTILES)) + allocate(LHSNOW1 (NTILES)) + allocate(LWUPSNOW1 (NTILES)) + allocate(LWDNSNOW1 (NTILES)) + allocate(NETSWSNOW (NTILES)) + allocate(TCSORIG1 (NTILES)) + allocate(TPSN1IN1 (NTILES)) + allocate(TPSN1OUT1 (NTILES)) + allocate(LHACC (NTILES)) + allocate(SUMEV (NTILES)) + allocate(fveg1 (NTILES)) + allocate(fveg2 (NTILES)) + allocate(FICE1TMP (NTILES)) + allocate(SLDTOT (NTILES)) ! total solid precip + allocate(FSW_CHANGE(NTILES)) + + allocate(SHSBT (NTILES,NUM_SUBTILES)) + allocate(DSHSBT (NTILES,NUM_SUBTILES)) + allocate(EVSBT (NTILES,NUM_SUBTILES)) + allocate(DEVSBT (NTILES,NUM_SUBTILES)) + allocate(DEDTC (NTILES,NUM_SUBTILES)) + allocate(DHSDQA (NTILES,NUM_SUBTILES)) + allocate(CFT (NTILES,NUM_SUBTILES)) + allocate(CFQ (NTILES,NUM_SUBTILES)) + allocate(TCO (NTILES,NUM_SUBTILES)) + allocate(QCO (NTILES,NUM_SUBTILES)) + allocate(DQS (NTILES,NUM_SUBTILES)) + allocate(QSAT (NTILES,NUM_SUBTILES)) + allocate(RA (NTILES,NUM_SUBTILES)) + allocate(RCONSTIT (NTILES,N_SNOW,N_constit)) + allocate(TOTDEPOS (NTILES,N_constit)) + allocate(RMELT (NTILES,N_constit)) + allocate(ALWN (NTILES,NUM_SUBTILES)) + allocate(BLWN (NTILES,NUM_SUBTILES)) + allocate(TC1_0 (NTILES)) + allocate(TC2_0 (NTILES)) + allocate(TC4_0 (NTILES)) + allocate(QA1_0 (NTILES)) + allocate(QA2_0 (NTILES)) + allocate(QA4_0 (NTILES)) + allocate(PLSIN (NTILES)) + + allocate(TA_MIN (NTILES)) + allocate(ta_count (NTILES)) + + call ESMF_VMGetCurrent ( VM, RC=STATUS ) + + debugzth = .false. + + ! -------------------------------------------------------------------------- + ! Get the current time. + ! -------------------------------------------------------------------------- + + call ESMF_ClockGet( CLOCK, currTime=CURRENT_TIME, startTime=MODELSTART, TIMESTEP=DELT, RC=STATUS ) + VERIFY_(STATUS) + if (MAPL_AM_I_Root(VM).and.debugzth) then + print *,' start time of clock ' + CALL ESMF_TimePrint ( MODELSTART, OPTIONS="string", RC=STATUS ) + endif + + ! -------------------------------------------------------------------------- + ! Offline land spin-up. + ! -------------------------------------------------------------------------- + + if (CATCHCN_INTERNAL%CATCH_SPINUP /= 0) then + + ! remove snow every Aug 1, 0z (Northern Hemisphere) or Feb 1, 0z (Southern Hemisphere) + ! + ! assumes that CURRENT_TIME actually hits 0z on first of month (which seems safe enough) + + call ESMF_TimeGet(CURRENT_TIME, mm=CurrMonth, dd=CurrDay, h=CurrHour, m=CurrMin, s=CurrSec, rc=STATUS) + VERIFY_(STATUS) + + if (CurrDay==1 .and. CurrHour==0 .and. CurrMin==0 .and. CurrSec==0) then + + if (CurrMonth==8) then + + where ( LATS >= 0. ) ! [radians] + + WESNN1 = 0. + WESNN2 = 0. + WESNN3 = 0. + HTSNNN1 = 0. + HTSNNN2 = 0. + HTSNNN3 = 0. + SNDZN1 = 0. + SNDZN2 = 0. + SNDZN3 = 0. + + end where + + else if (CurrMonth==2) then + + where ( LATS < 0. ) ! [radians] + + WESNN1 = 0. + WESNN2 = 0. + WESNN3 = 0. + HTSNNN1 = 0. + HTSNNN2 = 0. + HTSNNN3 = 0. + SNDZN1 = 0. + SNDZN2 = 0. + SNDZN3 = 0. + + end where + + end if + + end if ! 0z on first of month + + end if ! if (CATCHCN_INTERNAL%CATCH_SPINUP /= 0) + + ! -------------------------------------------------------------------------- + ! Catchment Id and vegetation types used to index into tables + ! -------------------------------------------------------------------------- + + CAT_ID = nint(tile_id) + + where(ITY(:,1) > 0.) + VEG1 = map_cat(nint(ITY(:,1))) ! map primary CN PFT to catchment type + endwhere + where(ITY(:,2) > 0.) + VEG2 = map_cat(nint(ITY(:,2))) ! map secondary CN PFT to catchment type + endwhere + + fveg1(:) = fvg(:,1) + fveg2(:) = fvg(:,2) + + allocate ( lai1(ntiles) ) + allocate ( lai2(ntiles) ) + allocate ( wght(ntiles) ) + + lai1 = 0. + wght = 0. + do nz = 1,nzone + nv = 1 + lai1(:) = lai1(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) + wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) + end do + lai1 = lai1 / max(wght,1.e-8) ! LAI for primary vegetation type + + lai2 = 0. + wght = 0. + do nz = 1,nzone + nv = 2 + lai2(:) = lai2(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) + wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) + end do + lai2 = lai2 / max(wght,1.e-8) ! LAI for secondary vegetation type + +! LAI seen by the land model +! -------------------------- + lai = fveg1*lai1 + fveg2*lai2 ! gkw: prognostic LAI on catch_internal_rst (overwrite VEGDYN import) + + ! -------------------------------------------------------------------------- + ! surface layer depth for soil moisture + ! -------------------------------------------------------------------------- + + DZSF( :) = catchcn_internal%SURFLAY + + ! -------------------------------------------------------------------------- + ! build arrays from internal state + ! -------------------------------------------------------------------------- + + GHTCNT(1,:) = GHTCNT1 + GHTCNT(2,:) = GHTCNT2 + GHTCNT(3,:) = GHTCNT3 + GHTCNT(4,:) = GHTCNT4 + GHTCNT(5,:) = GHTCNT5 + GHTCNT(6,:) = GHTCNT6 + + WESNN (1,:) = WESNN1 + WESNN (2,:) = WESNN2 + WESNN (3,:) = WESNN3 + + HTSNNN(1,:) = HTSNNN1 + HTSNNN(2,:) = HTSNNN2 + HTSNNN(3,:) = HTSNNN3 + + SNDZN (1,:) = SNDZN1 + SNDZN (2,:) = SNDZN2 + SNDZN (3,:) = SNDZN3 + + ! -------------------------------------------------------------------------- + ! retrieve the zenith angle + ! -------------------------------------------------------------------------- + +!! The next sequence is to make sure that the albedo here and in solar are in sync +!! +! Need to know when Solar was called last, so first get the solar alarm + call ESMF_ClockGetAlarm ( CLOCK, alarmname="SOLAR_Alarm", ALARM=SOLALARM, RC=STATUS ) +! VERIFY_(STATUS) + if(status==0) then +! Get the interval of the solar alarm - first get it in seconds + call ESMF_ConfigGetAttribute ( CF, DT_SOLAR, Label="SOLAR_DT:", DEFAULT=DT, RC=STATUS ) + VERIFY_(STATUS) +! Now make an ESMF interval from the increment in seconds + CALL ESMF_TimeIntervalSet ( TINT, S=NINT(DT_SOLAR), RC=STATUS ) + VERIFY_(STATUS) +! Now print out the solar alarm interval + if (MAPL_AM_I_Root(VM).and.debugzth) CALL ESMF_TimeIntervalPrint ( TINT, OPTIONS="string", RC=STATUS ) +! Now find out if it is ringing now: if so, set "BEFORE" to last time it rang before now + solalarmison = ESMF_AlarmIsRinging(SOLALARM,RC=STATUS) + VERIFY_(STATUS) + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' logical for solar alarm ',solalarmison +! if so, set "BEFORE" to last time it rang before now + if(solalarmison) then + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is ringing ' + NOW = CURRENT_TIME + BEFORE = NOW - TINT +! Now print out the last time solar alarm rang + if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) +! If alarm is not ringing now, find out when it rang last + else + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is not ringing ' + call ESMF_AlarmGet ( SOLALARM, prevRingTime=BEFORE, RC=STATUS ) + VERIFY_(STATUS) +! PrevRingTime can lie: if alarm never went off yet it gives next alarm time, not prev. + if(BEFORE > CURRENT_TIME) then + BEFORE = BEFORE-TINT + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm not ringing, prev time lied ' + if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) + else + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm not ringing, prev time okay ' + if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) + endif +! Now print out the last time solar alarm rang + endif + else + BEFORE = CURRENT_TIME + TINT = DELT + end if +! Get the zenith angle at the center of the time between the last solar call and the next one + call MAPL_SunGetInsolation(LONS, LATS, & + ORBIT, ZTH, SLR, & + INTV = TINT, & + currTime=BEFORE+DELT, & + RC=STATUS ) + VERIFY_(STATUS) + + ZTH = max(0.0,ZTH) + ZVG = fveg1*(Z2CH - SCALE4Z0*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI1)) + & + fveg2*(Z2CH - SCALE4Z0*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI2)) + + + ! For now roughnesses and displacement heights + ! are the same for all subtiles. + !--------------------------------------------------- + + Z0 = Z0_BY_ZVEG*ZVG + IF (catchcn_internal%USE_ASCATZ0 == 1) WHERE (NDVI <= 0.2) Z0 = ASCATZ0 + D0 = D0_BY_ZVEG*ZVG + + UUU = max(UU,MAPL_USMIN) * (log((ZVG-D0+Z0)/Z0) & + / log((max(DZ-D0,10.)+Z0)/Z0)) + + !--------------- GOSWIM IMPORTS FROM GOCART --------------- + ! Initialization + if (N_CONSTIT > 0) then + RCONSTIT(:,:,:) = 0.0 + TOTDEPOS(:,:) = 0.0 + RMELT(:,:) = 0.0 + endif + !------------------------------------------------------------------ + + ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: + + select case (catchcn_internal%AEROSOL_DEPOSITION) + case (0) + DUDP(:,:)=0. + DUSV(:,:)=0. + DUWT(:,:)=0. + DUSD(:,:)=0. + BCDP(:,:)=0. + BCSV(:,:)=0. + BCWT(:,:)=0. + BCSD(:,:)=0. + OCDP(:,:)=0. + OCSV(:,:)=0. + OCWT(:,:)=0. + OCSD(:,:)=0. + + case (2) + DUDP(:,:)=0. + DUSV(:,:)=0. + DUWT(:,:)=0. + DUSD(:,:)=0. + + case (3) + BCDP(:,:)=0. + BCSV(:,:)=0. + BCWT(:,:)=0. + BCSD(:,:)=0. + + case (4) + OCDP(:,:)=0. + OCSV(:,:)=0. + OCWT(:,:)=0. + OCSD(:,:)=0. + + end select + +! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 +! Note: Explanations of each variable +! TOTDEPOS(:,1): Combined dust deposition from size bin 1 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,2): Combined dust deposition from size bin 2 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,3): Combined dust deposition from size bin 3 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,4): Combined dust deposition from size bin 4 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,5): Combined dust deposition from size bin 5 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,6): Combined hydrophobic BC deposition from size bin 1 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,7): Combined hydrophilic BC deposition from size bin 2 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,8): Combined hydrophobic OC deposition from size bin 1 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,9): Combined hydrophilic OC deposition from size bin 2 (dry, conv-scav, ls-scav, sed) +!============================= Possible future applications ==================================== +! TOTDEPOS(:,10): Combined sulfate deposition from size bin 3 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,11): Combined sea salt deposition from size bin 1 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,12): Combined sea salt deposition from size bin 2 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,13): Combined sea salt deposition from size bin 3 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,14): Combined sea salt deposition from size bin 4 (dry, conv-scav, ls-scav, sed) +! TOTDEPOS(:,15): Combined sea salt deposition from size bin 5 (dry, conv-scav, ls-scav, sed) + if (N_CONSTIT > 0) then + TOTDEPOS(:,1) = DUDP(:,1) + DUSV(:,1) + DUWT(:,1) + DUSD(:,1) + TOTDEPOS(:,2) = DUDP(:,2) + DUSV(:,2) + DUWT(:,2) + DUSD(:,2) + TOTDEPOS(:,3) = DUDP(:,3) + DUSV(:,3) + DUWT(:,3) + DUSD(:,3) + TOTDEPOS(:,4) = DUDP(:,4) + DUSV(:,4) + DUWT(:,4) + DUSD(:,4) + TOTDEPOS(:,5) = DUDP(:,5) + DUSV(:,5) + DUWT(:,5) + DUSD(:,5) + TOTDEPOS(:,6) = BCDP(:,1) + BCSV(:,1) + BCWT(:,1) + BCSD(:,1) + TOTDEPOS(:,7) = BCDP(:,2) + BCSV(:,2) + BCWT(:,2) + BCSD(:,2) + TOTDEPOS(:,8) = OCDP(:,1) + OCSV(:,1) + OCWT(:,1) + OCSD(:,1) + TOTDEPOS(:,9) = OCDP(:,2) + OCSV(:,2) + OCWT(:,2) + OCSD(:,2) + endif +!============================= Possible future applications ==================================== +! TOTDEPOS(:,10) = SUDP(:,1) + SUSV(:,1) + SUWT(:,1) + SUSD(:,1) +! TOTDEPOS(:,11) = SSDP(:,1) + SSSV(:,1) + SSWT(:,1) + SSSD(:,1) +! TOTDEPOS(:,12) = SSDP(:,2) + SSSV(:,2) + SSWT(:,2) + SSSD(:,2) +! TOTDEPOS(:,13) = SSDP(:,3) + SSSV(:,3) + SSWT(:,3) + SSSD(:,3) +! TOTDEPOS(:,14) = SSDP(:,4) + SSSV(:,4) + SSWT(:,4) + SSSD(:,4) +! TOTDEPOS(:,15) = SSDP(:,5) + SSSV(:,5) + SSWT(:,5) + SSSD(:,5) + +! --------------- GOSWIM PROGRNOSTICS --------------------------- + + if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then + + ! Conversion of the masses of the snow impurities + ! Note: Explanations of each variable + ! Number of snow layer is 15: N = 1-15 + ! RCONSTIT(NTILES,N,1): Dust mass from bin 1 in layer N + ! RCONSTIT(NTILES,N,2): Dust mass from bin 2 in layer N + ! RCONSTIT(NTILES,N,3): Dust mass from bin 3 in layer N + ! RCONSTIT(NTILES,N,4): Dust mass from bin 4 in layer N + ! RCONSTIT(NTILES,N,5): Dust mass from bin 5 in layer N + ! RCONSTIT(NTILES,N,6): Hydrophobic BC mass from bin 1 in layer N + ! RCONSTIT(NTILES,N,7): Hydrophilic BC mass from bin 2 in layer N + ! RCONSTIT(NTILES,N,8): Hydrophobic OC mass from bin 1 in layer N + ! RCONSTIT(NTILES,N,9): Hydrophilic OC mass from bin 2 in layer N + !============================= Possible future applications ==================================== + ! RCONSTIT(NTILES,N,10): Sulfate mass from size bin 3 in layer N + ! RCONSTIT(NTILES,N,11): Sea salt mass from size bin 1 in layer N + ! RCONSTIT(NTILES,N,12): Sea salt mass from size bin 2 in layer N + ! RCONSTIT(NTILES,N,13): Sea salt mass from size bin 3 in layer N + ! RCONSTIT(NTILES,N,14): Sea salt mass from size bin 4 in layer N + ! RCONSTIT(NTILES,N,15): Sea salt mass from size bin 5 in layer N + if (N_CONSTIT > 0) then + RCONSTIT(:,:,1) = RDU001(:,:) + RCONSTIT(:,:,2) = RDU002(:,:) + RCONSTIT(:,:,3) = RDU003(:,:) + RCONSTIT(:,:,4) = RDU004(:,:) + RCONSTIT(:,:,5) = RDU005(:,:) + RCONSTIT(:,:,6) = RBC001(:,:) + RCONSTIT(:,:,7) = RBC002(:,:) + RCONSTIT(:,:,8) = ROC001(:,:) + RCONSTIT(:,:,9) = ROC002(:,:) + endif +!============================= Possible future applications ==================================== +! RCONSTIT(:,:,10) = RSU003(:,:) +! RCONSTIT(:,:,11) = RSS001(:,:) +! RCONSTIT(:,:,12) = RSS002(:,:) +! RCONSTIT(:,:,13) = RSS003(:,:) +! RCONSTIT(:,:,14) = RSS004(:,:) +! RCONSTIT(:,:,15) = RSS005(:,:) + endif + + ! -------------------------------------------------------------------------- + ! Parameters that depend on vegetation type only gkw: these are not used in unified + ! -------------------------------------------------------------------------- + + RSL1 = VGRDRS(VEG1)/(ROOTL*VGROTD(VEG1)) + + RSL2 = ROOTL*VGROCA(VEG1) + RSL2 = (RSL2 - 3.0 - 2.*alog(RSL2/(1.-RSL2)))/(8.*MAPL_PI*ROOTL*VGROTD(VEG1)) + + ! -------------------------------------------------------------------------- + ! Greenness and type dependent parameters + ! -------------------------------------------------------------------------- + + SQSCAT = fveg1*((VGTR11(VEG1)+VGRF11(VEG1)) * GRN + (VGTR12(VEG1)+VGRF12(VEG1)) * (1.-GRN)) + & + fveg2*((VGTR11(VEG2)+VGRF11(VEG2)) * GRN + (VGTR12(VEG2)+VGRF12(VEG2)) * (1.-GRN)) + SQSCAT = sqrt(1.0 - SQSCAT) + + ! -------------------------------------------------------------------------- + ! LAI and type dependent parameters; RDC formulation now uses veg fractions gkw: 2013-11-25, see note from Randy + ! -------------------------------------------------------------------------- + + ! old RDC formulation implemented in orginial GEOScatchCN_GridCom + ! RDC = max(VGRDA(VEG1),VGRDA(VEG2))*min(1.,lai/2.) + + ! new RDC formulation used to reproduce Fanwei Zeng's LDASsa Catchment-CN.4.0 and Eunjee Lee's Catchment-CN.4.5 simulations + rdc_tmp_1 = max( VGRDA(VEG1)*min( 1., LAI1/VGRDB(VEG1) ), 0.001) + rdc_tmp_2 = max( VGRDA(VEG2)*min( 1., LAI2/VGRDB(VEG2) ), 0.001) + RDC = max(rdc_tmp_1,rdc_tmp_2)*min(1.,lai/2.) + RDC = max(RDC,0.001) + + RHO = PS/(MAPL_RGAS*(TA*(1+MAPL_VIREPS*QA))) + + DEDTC=0.0 + DHSDQA=0.0 + + if(OFFLINE_MODE /=0) then + do N=1,NUM_SUBTILES + CFT (:,N) = 1.0 + CFQ (:,N) = 1.0 + SHSBT (:,N) = MAPL_CP*CH(:,N)*(TC(:,N)-TA) + EVSBT (:,N) = CQ(:,N)*(QC(:,N)-QA) + DSHSBT(:,N) = MAPL_CP*CH(:,N) + DEVSBT(:,N) = CQ(:,N) + BLWN(:,N) = EMIS*MAPL_STFBOL*TC(:,N)*TC(:,N)*TC(:,N) + ALWN(:,N) = -3.0*BLWN(:,N)*TC(:,N) + BLWN(:,N) = 4.0*BLWN(:,N) + end do + if(catchcn_internal%CHOOSEMOSFC==0 .and. incl_Louis_extra_derivs ==1) then + do N=1,NUM_SUBTILES + DEVSBT(:,N)=CQ(:,N)+max(0.0,-DCQ(:,N)*MAPL_VIREPS*TC(:,N)*(QC(:,N)-QA)) + DEDTC(:,N) =max(0.0,-DCQ(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(QC(:,N)-QA)) + DSHSBT(:,N)=MAPL_CP*(CH(:,N)+max(0.0,-DCH(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(TC(:,N)-TA))) + DHSDQA(:,N)=max(0.0,-MAPL_CP*DCH(:,N)*MAPL_VIREPS*TC(:,N)*(TC(:,N)-TA)) + enddo + endif + else + do N=1,NUM_SUBTILES + CFT (:,N) = (CH(:,N)/CTATM) + CFQ (:,N) = (CQ(:,N)/CQATM) + SHSBT (:,N) = (SH + DSH *(TC(:,N)-THATM))*CFT(:,N) + EVSBT (:,N) = (EVAP+ DEVAP*(QC(:,N)-QHATM))*CFQ(:,N) + DSHSBT(:,N) = DSH *CFT(:,N) + DEVSBT(:,N) = DEVAP*CFQ(:,N) + ALWN(:,N)=ALW + BLWN(:,N)=BLW + end do + end if + + ! Compute DQS; make sure QC is between QA and QSAT; compute RA. + ! + ! Some 1,000 lines below, duplicate code was present and removed in Jan 2022. + ! - reichle, 14 Jan 2022. + + do N=1,NUM_SUBTILES + DQS(:,N) = GEOS_DQSAT ( TC(:,N), PS, QSAT=QSAT(:,N), PASCALS=.true., RAMP=0.0 ) + QC (:,N) = min(max(QA(:),QSAT(:,N)),QC(:,N)) + QC (:,N) = max(min(QA(:),QSAT(:,N)),QC(:,N)) + RA (:,N) = RHO/CH(:,N) + end do + + + QC(:,FSNW) = QSAT(:,FSNW) + + ! -------------------------------------------------------------------------- + ! get total solid precip + ! -------------------------------------------------------------------------- + + SLDTOT = SNO+ICE+FRZR + + ! -------------------------------------------------------------------------- + ! protect the forcing from unsavory values, as per practice in offline + ! driver + ! -------------------------------------------------------------------------- + + ASSERT_(count(PLS<0.)==0) + ASSERT_(count(PCU<0.)==0) + ASSERT_(count(SLDTOT<0.)==0) + + LAI0 = max(0.0001 , LAI) + GRN0 = max(0.0001 , GRN) + ZTH = max(0.0001 , ZTH) + + TCO = TC + QCO = QC + + ! -------------------------------------------------------------------------- + ! actual CATCHMENT call + ! -------------------------------------------------------------------------- + + TILEZERO = 0.0 + + call MAPL_TimerOn ( MAPL, "-CATCHCNCLM51" ) + + +! ---------------------------------------------------------------------------------------- + +! gkw: start on main CN block + + allocate( btran(ntiles,nveg,nzone) ) + allocate( btran_fire(ntiles,nzone) ) + allocate( wgt(ntiles) ) + allocate( wpp(ntiles) ) + allocate( fwet(ntiles) ) + allocate( wet_in(ntiles) ) + allocate( bt(ntiles,fsat:fwlt)) + allocate( sm(ntiles,fsat:fwlt)) + allocate( SWSRF1(ntiles) ) + allocate( SWSRF2(ntiles) ) + allocate( SWSRF4(ntiles) ) + allocate( tcx(ntiles,nzone) ) + allocate( qax(ntiles,nzone) ) + allocate( rcxdt(ntiles) ) + allocate( rcxdq(ntiles) ) + allocate( car1(ntiles) ) + allocate( car2(ntiles) ) + allocate( car4(ntiles) ) + allocate( parzone(ntiles,nveg,nzone) ) + allocate( para(ntiles) ) + allocate ( totwat(ntiles) ) + if(.not. allocated(npp )) allocate( npp(ntiles) ) + if(.not. allocated(gpp )) allocate( gpp(ntiles) ) + if(.not. allocated(sr )) allocate( sr(ntiles) ) + if(.not. allocated(aresp)) allocate( aresp(ntiles) ) + if(.not. allocated(hresp)) allocate( hresp(ntiles) ) + if(.not. allocated(nee )) allocate( nee(ntiles) ) + if(.not. allocated(padd)) allocate( padd(ntiles) ) + if(.not. allocated(frootc)) allocate(frootc(ntiles) ) + if(.not. allocated(vegc)) allocate( vegc(ntiles) ) + if(.not. allocated(xsmr)) allocate( xsmr(ntiles) ) + if(.not. allocated(burn)) allocate( burn(ntiles) ) + if(.not. allocated(closs))allocate( closs(ntiles) ) + + allocate( nfire(ntiles) ) + allocate( som_closs(ntiles) ) + allocate( dayl(ntiles) ) + allocate(dayl_fac(ntiles) ) + allocate(CO2V (ntiles) ) + allocate( fsnow(ntiles) ) + allocate( ityp_tmp(ntiles) ) + allocate( Qair_relative(ntiles) ) + allocate( ndeploy(ntiles) ) + allocate( denit(ntiles) ) + allocate( sminn_leached(ntiles) ) + allocate( sminn(ntiles) ) + allocate( fire_nloss(ntiles) ) + allocate( leafn(ntiles) ) + allocate( leafc(ntiles) ) + allocate( gross_nmin(ntiles) ) + allocate( net_nmin(ntiles) ) + allocate( nfix_to_sminn(ntiles) ) + allocate( actual_immob(ntiles) ) + allocate( fpg(ntiles) ) + allocate( fpi(ntiles) ) + allocate( sminn_to_plant(ntiles) ) + allocate( sminn_to_npool(ntiles) ) + allocate( ndep_to_sminn(ntiles) ) + allocate( totvegn(ntiles) ) + allocate( totlitn(ntiles) ) + allocate( totsomn(ntiles) ) + allocate( retransn(ntiles) ) + allocate( retransn_to_npool(ntiles) ) + allocate( fuelc(ntiles) ) + allocate( totlitc(ntiles) ) + allocate( cwdc(ntiles) ) + allocate( rootc(ntiles) ) + allocate( lnfm(ntiles) ) + + allocate( tgw(ntiles,nzone) ) + allocate( rzm(ntiles,nzone) ) + allocate( rc00(ntiles,nzone) ) + allocate( rcdt(ntiles,nzone) ) + allocate( rcdq(ntiles,nzone) ) + allocate( totcolc(ntiles,nzone) ) + allocate( sfm(ntiles,nzone) ) + + allocate( albdir(ntiles,nveg,nzone,2) ) + allocate( albdif(ntiles,nveg,nzone,2) ) + + allocate( psnsun(ntiles,nveg,nzone) ) + allocate( psnsha(ntiles,nveg,nzone) ) + allocate( laisun(ntiles,nveg,nzone) ) + allocate( laisha(ntiles,nveg,nzone) ) + allocate( lmrsun(ntiles,nveg,nzone) ) + allocate( lmrsha(ntiles,nveg,nzone) ) + allocate( ht(N_gt) ) + allocate( tp(N_gt) ) + allocate( soilice(N_gt) ) + +! get current date & time gkw: this is used to transfer CN restart vars & set declination +! ----------------------- + call ESMF_TimeGet ( CURRENT_TIME, YY = AGCM_YY, & + MM = AGCM_MM, & + DD = AGCM_DD, & + H = AGCM_HH, & + M = AGCM_MI, & + S = AGCM_S , & + dayOfYear = dofyr , & + rc=status ) + VERIFY_(STATUS) + + AGCM_S_ofday = AGCM_S + 60 * AGCM_MI + 3600 * AGCM_HH + +! get ending time; determine if this is last call before ending time +! ------------------------------------------------------------------ + call ESMF_ClockGet ( clock, StopTime=StopTime ,rc=STATUS ) + VERIFY_(STATUS) + + NextTime = CURRENT_TIME + DELT + + ! 0-land tiles processors hang in MAPL_ReadForcing + ! Thus moved reading lnfm here + ! ------------------------------------------------ + + if(mod(AGCM_S_ofday,nint(catchcn_internal%DTCN)) == 0) then + ! Get lightening frequency clim file name from configuration + call MAPL_GetResource ( MAPL, LNFMFILE, label = 'LNFM_FILE:', default = 'lnfm.dat', RC=STATUS ) + VERIFY_(STATUS) + call MAPL_ReadForcing(MAPL,'LNFM',LNFMFILE,CURRENT_TIME,lnfm,ON_TILES=.true.,RC=STATUS) + VERIFY_(STATUS) + endif + + if(ntiles > 0) then ! gkw: skip threads with no land tiles + +! gkw: assign new vegetation types and fractions +! ---------------------------------------------- + cat_id = nint(tile_id) ! gkw: temporary for debugging + +! compute daylength (and daylength factor) +! ---------------------------------------- + + ! current daylight duration + call MAPL_SunGetDaylightDuration(ORBIT,lats,dayl,currTime=CURRENT_TIME,RC=STATUS) + VERIFY_(STATUS) + ! maximum daylight duration (at solstice) + call MAPL_SunGetDaylightDurationMax(ORBIT,lats,dayl_fac,currTime=CURRENT_TIME,RC=STATUS) + VERIFY_(STATUS) + ! dayl_fac is ratio current:maximum dayl squared (min 0.01 [gkw: from CLM4]) + dayl_fac = min(1.,max(0.01,(dayl/dayl_fac)**2)) + +! gkw: obtain catchment area fractions and soil moisture +! ------------------------------------------------------ + call catch_calc_soil_moist( ntiles, dzsf, vgwmax, cdcr1, cdcr2, psis, bee, poros, wpwet, & + ars1, ars2, ars3, ara1, ara2, ara3, ara4, arw1, arw2, arw3, arw4, bf1, bf2, & + srfexc, rzexc, catdef, car1, car2, car4, sfmc, rzmc, prmc, & + SWSRF1OUT=SWSRF1, SWSRF2OUT=SWSRF2, SWSRF4OUT=SWSRF4 ) + + + +! obtain saturated canopy resistance following Farquhar, CLM4 implementation + +! compute RC & PSN in each of the CN zones +! ---------------------------------------- + +! "btran" in the catchment zones; map into CN zones +! ------------------------------------------------- + sm(:,fsat) = 1.0 + +! gkw: bt2 is unstressed region only (subtract saturated and wilting areas) + do n = 1,ntiles + if(car2(n) > 0.) then + sm(n,ftrn)=(rzmc(n)/poros(n) - car1(n) - car4(n)*wpwet(n))/car2(n) + else + sm(n,ftrn)= rzmc(n)/poros(n) + endif + sm(n,ftrn) = max(sm(n,ftrn),wpwet(n)) + sm(n,ftrn) = min(sm(n,ftrn),1.) + + if(car4(n) > 0.) then + sm(n,fwlt)=(rzmc(n)/poros(n) - car1(n) - car2(n)*sm(n,ftrn))/car4(n) + else + sm(n,fwlt)= wpwet(n) + endif + sm(n,fwlt) = max(sm(n,fwlt),1.e-3) + sm(n,fwlt) = min(sm(n,fwlt),wpwet(n)-1.e-7) + end do + + bt(:,fsat) = 1.0 + bt(:,ftrn) = sm(:,ftrn)**(-bee) + wpp = wpwet ** (-bee) + bt(:,ftrn) = (bt(:,ftrn)-wpp)/(1.-wpp) + bt(:,fwlt) = 0. + + do n = 1,ntiles + + ax1 = car1(n) + ax2 = car2(n) + ax4 = 1. - ax1 - ax2 + + cn1 = wtzone(n,1) + cn2 = wtzone(n,2) + cn3 = wtzone(n,3) + +! CN zone 1 + if(ax1 .gt. cn1) then + f1(1) = cn1 ; f2(1) = 0. ; f4(1) = 0. + else + if((ax1+ax2) .gt. cn1) then + f1(1) = ax1 ; f2(1) = cn1-ax1 ; f4(1) = 0. + else + f1(1) = ax1 ; f2(1) = ax2 ; f4(1) = cn1-ax1-ax2 + endif + endif + +! CN zone 2 + if(ax1 .gt. cn1) then + cn12 = cn1 + cn2 + if(car1(n) .gt. cn12) then + f1(2) = cn2 ; f2(2) = 0. ; f4(2) = 0. + else + if((ax1+ax2) .lt. cn12) then + f1(2) = ax1-cn1 ; f2(2) = ax2 ; f4(2) = cn12-ax1-ax2 + else + f1(2) = ax1-cn1 ; f2(2) = cn12-ax1 ; f4(2) = 0. + endif + endif + else + cn23 = cn2 + cn3 + if(ax4 .gt. cn23) then + f1(2) = 0. ; f2(2) = 0. ; f4(2) = cn2 + else + if(ax4 .lt. cn3) then + f1(2) = 0. ; f2(2) = cn2 ; f4(2) = 0. + else + f1(2) = 0. ; f2(2) = cn23-ax4 ; f4(2) = ax4-cn3 + endif + endif + endif + +! CN zone 3 + if(ax4 .gt. cn3) then + f1(3) = 0. ; f2(3) = 0. ; f4(3) = cn3 + else + if((ax4+ax2) .gt. cn3) then + f1(3) = 0. ; f2(3) = cn3-ax4 ; f4(3) = ax4 + else + f1(3) = cn3-ax4-ax2 ; f2(3) = ax2 ; f4(3) = ax4 + endif + endif + + do nz = 1,nzone + btran_fire(n,nz) = (f1(nz)*bt(n,fsat) + f2(nz)*bt(n,ftrn) + f4(nz)*bt(n,fwlt) )/wtzone(n,nz) + tgw(n,nz) = (f1(nz)*tg(n,fsat) + f2(nz)*tg(n,ftrn) + f4(nz)*tg(n,fwlt))/wtzone(n,nz) + tcx(n,nz) = (f1(nz)*tc(n,fsat) + f2(nz)*tc(n,ftrn) + f4(nz)*tc(n,fwlt))/wtzone(n,nz) + qax(n,nz) = (f1(nz)*qc(n,fsat) + f2(nz)*qc(n,ftrn) + f4(nz)*qc(n,fwlt))/wtzone(n,nz) + rzm(n,nz) = (f1(nz)*sm(n,fsat) + f2(nz)*sm(n,ftrn) + f4(nz)*sm(n,fwlt))/wtzone(n,nz) + sfm(n,nz) = (f1(nz)*SWSRF1(n) + f2(nz)*SWSRF2(n) + f4(nz)*SWSRF4(n) )/wtzone(n,nz) + end do + + end do !n + +! soil temperature and hydrologic state +! ------------------------------------- + DO N=1,ntiles + +! soil temperatures +! ----------------- + + ! zbar function - reichle, 29 Jan 2022 (minus sign applied in call to GNDTMP) + ZBAR = catch_calc_zbar( bf1(n), bf2(n), catdef(n) ) + HT(:)=GHTCNT(:,N) + CALL GNDTMP(poros(n),-1.*zbar,ht,frice,tp,soilice) ! note minus sign for zbar + + ! At the CatchCNGridComp level, tp1, tp2, .., tp6 are export variables in units of Kelvin, + ! - rreichle & borescan, 6 Nov 2020 + + tp1(n) = tp(1) + Tzero + tp2(n) = tp(2) + Tzero + tp3(n) = tp(3) + Tzero + tp4(n) = tp(4) + Tzero + tp5(n) = tp(5) + Tzero + tp6(n) = tp(6) + Tzero + +! total soil liquid water +! ----------------------- + totwat(n) = cdcr2(n) - catdef(n) + rzexc(n) + srfexc(n) + totwat(n) = totwat(n)*(1. - frice) + +! baseflow +! -------- + bflow(n) = (1.-frice)*1000.* & + cond(n)*exp(-(bf3(n)-ashift)-gnu(n)*zbar)/gnu(n) + IF(catdef(n) >= cdcr1(n)) bflow(n) = 0. + bflow(n) = min(cond(n),bflow(n)) + end do + +! compute relative humidity (%) used in CNFireMod +! ----------------------------------------------- + do n = 1,ntiles + Qair_sat = MAPL_EQsat(TA(n), PS(n) ) + Qair_relative(n) = QA(n) / Qair_sat * 100. + end do + + Qair_relative(:) = min(max(0., Qair_relative(:)), 100.) + +! compute accumulated fields, fzeng +! following the methods in accFldsMod.F90 and accumulMod.F90 in CLM4.5 +! -------------------------------------------------------------------- + + istep = istep + 1 + istep_365 = istep_365 + 1 + TA_MIN(:) = 1000. + + ! running mean - reset accumulation period until greater than nstep + ! fzeng & gkw: may not be exactly 2m, but it is consistent with t_ref2m in CN model + ! T2M10D (T10 in CLM4.5): 10-day running mean of 2-m temperature (K) + ! TPREC10D (PREC10 in CLM4.5): 10-day running mean of total precipitation (mm H2O/s) + ! TPREC60D (PREC60 in CLM4.5): 60-day running mean of total precipitation (mm H2O/s) + ! --------------------------------------------------------------------------------- + if(init_accum) then + + ! (1) 5-day running mean of snow depth + accper = min(istep,n5d) + SNDZM5D = ((accper-1)*SNDZM5D + SNDZM) / accper + + ! (1) 10-day running mean of 2-m temperature (K) and total precipitation (mm H2O/s) + accper = min(istep,n10d) + T2M10D = ((accper-1)*T2M10D + TA) / accper + TPREC10D = ((accper-1)*TPREC10D + PCU + PLS + SNO) / accper + TG10D = ((accper-1)*TG10D + TG(:,1)) / accper + + ! (2) 30-day running mean of relative humidity [%] + accper = min(istep,n30d) + RH30D = ((accper-1)*RH30D + Qair_relative) / accper + + + ! (2) 60-day running mean of total precipitation (mm H2O/s) + accper = min(istep,n60d) + TPREC60D = ((accper-1)*TPREC60D + PCU + PLS + SNO) / accper + + + ! jkolassa: for T2MMIN5D compute minimum T2M once per day, then use that value to compute new 5-day running mean of minimum T2M + + do n = 1,ntiles + ta_count(n) = ta_count(n) + 1 + TA_MIN(n) = min(TA_MIN(n),TA(n)) + + if (ta_count(n) == n1d) then + T2MMIN5D(n) = ((accper-1)*T2MMIN5D(n) + TA_MIN(n)) / accper + TA_MIN(n) = 1000. + ta_count(n) = 0 + end if + end do + + else + + SNDZM5D = ((n5d-1)*SNDZM5D + SNDZM) / n5d + T2M10D = ((n10d-1)*T2M10D + TA) / n10d + TG10D = ((n10d-1)*TG10D + TG(:,1)) / n10d + TPREC10D = ((n10d-1)*TPREC10D + PCU + PLS + SNO) / n10d + RH30D = ((n30d-1)*RH30D + Qair_relative) / n30d + TPREC60D = ((n60d-1)*TPREC60D + PCU + PLS + SNO) / n60d + + + ! jkolassa: for T2MMIN5D compute minimum T2M once per day, then use that value to compute new 5-day running mean of minimum T2M + + do n = 1,ntiles + ta_count(n) = ta_count(n) + 1 + TA_MIN(n) = min(TA_MIN(n),TA(n)) + + if (ta_count(n) == n1d) then + T2MMIN5D(n) = ((accper-1)*T2MMIN5D(n) + TA_MIN(n)) / accper + TA_MIN(n) = 1000. + ta_count(n) = 0 + end if + end do + + endif + + +! get CO2 +! ------- + + if(catchcn_internal%ATM_CO2 == 3) catchcn_internal%CO2 = GETCO2(AGCM_YY,dofyr) + + CO2V (:) = catchcn_internal%CO2 + +! use CO2SC from GOCART/CO2 +! ------------------------- + + IF (catchcn_internal%ATM_CO2 == 4) THEN + + where ((CO2SC >= 0.) .and. (CO2SC <= 1000.)) + CO2V = CO2SC * 1e-6 + end where + + endif + + IF(catchcn_internal%ATM_CO2 == 1) co2g = 1. ! DO NOT SCALE USE CT CLIMATOLOGY + + CALC_CTCO2_SF: IF(catchcn_internal%ATM_CO2 == 2) THEN + + ! Compute scale factor to scale CarbonTracker CO2 monthly mean diurnal cycle (3-hourly) + CO2_YEAR = AGCM_YY + IF(catchcn_internal%CO2_YEAR_IN > 0) CO2_YEAR = catchcn_internal%CO2_YEAR_IN + + ! update EEA global average CO2 and co2 scalar at the beginning of each year, fz, 26 Sep 2016 + ! ------------------------------------------------------------------------------------------- + + IF (AGCM_YY /= CO2_YEAR) CO2_YEAR = CO2_YEAR + AGCM_YY - FIRST_YY + + if (CO2_YEAR < byr_co2g) then + co2g = co2g_byr + elseif ((CO2_YEAR >= byr_co2g).AND.(CO2_YEAR <= myr_co2g)) then + co2g = co2g_byr + dco2g_1 * (CO2_YEAR - byr_co2g) + else + co2g = co2g_myr + dco2g_2 * (CO2_YEAR - myr_co2g) + endif + + co2g = co2g / CTco2g ! = co2g/CTco2g, is used to scale CarbonTracker CO2 monthly mean diurnal cycle (3-hourly) + + ENDIF CALC_CTCO2_SF + + USE_CT_CO2: IF((catchcn_internal%ATM_CO2 == 1).OR.(catchcn_internal%ATM_CO2 == 2)) THEN + + IF(AGCM_DD < 16) THEN + + ! interpolate between AGCM_MM - 1 and AGCM_MM + + M1 = AGCM_MM -1 + Y1 = AGCM_YY + if(M1 == 0) then ; M1 = 12 ; Y1 = AGCM_YY -1 ; endif + + call ESMF_TimeSet(BEFORE, YY = Y1, MM = M1, DD = 16, & + H = 0, M = 0, S = 0, rc = STATUS) ; VERIFY_(STATUS) + call ESMF_TimeSet(AFTER , YY = AGCM_YY, MM = AGCM_MM, DD = 15, & + H = 23, M = 59, S = 59, rc = STATUS); VERIFY_(STATUS) + + call MAPL_Interp_Fac (CURRENT_TIME,BEFORE,AFTER,FAC,RC=STATUS ) ; VERIFY_(STATUS) + ASSERT_(FAC >= 0.0) + ASSERT_(FAC <= 1.0) + + DO N = 1,NTILES + CO2V (N) = (FAC * CT_CO2V (CT_TID (N),M1, AGCM_HH/3+1) + (1.0-FAC) * CT_CO2V (CT_TID (N),AGCM_MM, AGCM_HH/3+1)) * & + CO2G * 1.e-6 ! scale by EEA global average CO2 * convert from ppm + END DO + ELSE + + ! interpolate between AGCM_MM and AGCM_MM + 1 + + M1 = AGCM_MM +1 + Y1 = AGCM_YY + if(M1 == 13) then ; M1 = 1 ; Y1 = AGCM_YY +1 ; endif + + call ESMF_TimeSet(BEFORE , YY = AGCM_YY, MM = AGCM_MM, DD = 16, & + H = 0, M = 0, S = 0, rc = STATUS) ; VERIFY_(STATUS) + call ESMF_TimeSet(AFTER, YY = Y1, MM = M1, DD = 15, & + H = 23, M = 59, S = 59, rc = STATUS) ; VERIFY_(STATUS) + + call MAPL_Interp_Fac (CURRENT_TIME,BEFORE,AFTER,FAC,RC=STATUS ) ; VERIFY_(STATUS) + ASSERT_(FAC >= 0.0) + ASSERT_(FAC <= 1.0) + DO N = 1,NTILES + CO2V (N) = (FAC * CT_CO2V (CT_TID (N),AGCM_MM, AGCM_HH/3+1) + (1.0-FAC) * CT_CO2V (CT_TID (N),M1 , AGCM_HH/3+1)) * & + CO2G * 1.e-6 ! scale by EEA global average CO2 * convert from ppm + END DO + ENDIF + + ENDIF USE_CT_CO2 + + if(associated(BTRANT)) btrant = 0. + +! fraction of foliage that is wet gkw 20140327 +! ------------------------------- + do n = 1,ntiles + if(lai(n) > 1.e-4) then + fwet(n) = min(1.,max(0.,capac(n)/(0.2*lai(n)))) + else + fwet(n) = 0. + endif + end do + +! compute snow-free albedo for each PFT in each zone gkw: assume the snow albedo is not very important +! -------------------------------------------------- + do nz = 1,nzone + do nv = 1,nveg + ityp_tmp(:) = map_cat(ityp(:,nv,nz)) + +! fzeng: note that this is not exactly the same as calling sibalb_vis in the unified model because the +! "if(fveg(i)>1.e-4 .and. zth(i)>0.01)" branch in subroutine sibalb_vis is absent in the current subroutine sibalb. +! ----------------------------------------------------------------------------------------------------------------- + + call SIBALB(ntiles, ityp_tmp, elai(:,nv,nz), GRN, ZTH, & + BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo + ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles + + call StieglitzSnow_snow_albedo(ntiles, N_snow, catchcn_internal%N_CONST_LAND4SNWALB, ityp_tmp, & + elai(:,nv,nz), ZTH, & + RHOFS, & + SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & + WESNN, HTSNNN, SNDZN, & + ALBVR, ALBNR, ALBVF, ALBNF, & ! instantaneous snow-free albedos on tiles + SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles + RCONSTIT, UUU, TPSN1OUT1, DRPAR, DFPAR) + +! fsnow: pft-level; asnow: grid-level +! ----------------------------------- + where(tlai(:,nv,nz) > 0.) + fsnow(:) = 1. - elai(:,nv,nz)/tlai(:,nv,nz) + fsnow(:) = min(max(fsnow(:),0.),1.) + elsewhere + fsnow(:) = 0. + endwhere + + ! visible + albdir(:,nv,nz,1) = albvr(:)*(1.-fsnow(:)) + snovr(:)*fsnow(:) + albdif(:,nv,nz,1) = albvf(:)*(1.-fsnow(:)) + snovf(:)*fsnow(:) + + ! NIR + albdir(:,nv,nz,2) = albnr(:)*(1.-fsnow(:)) + snonr(:)*fsnow(:) + albdif(:,nv,nz,2) = albnf(:)*(1.-fsnow(:)) + snonf(:)*fsnow(:) + + end do ! nv + end do ! nz + + wet_in = max(min(PRMC / POROS,1.0),0.0) + + call catchcn_calc_rc(ntiles,fveg,TCx,QAx,PS,co2v,dayl_fac, & + T2M10D,TA,cond,psis,rzm,bee,capac,fwet,ZTH,ityp,& + DRPAR,DFPAR,albdir,albdif,dtc,dea,water_inst,bgc_vegetation_inst,rc00,rcdq,rcdt,& + laisun,laisha,psnsun,psnsha,lmrsun,lmrsha,parzone,& + btran) + + para(:) = 0. ! zero out absorbed PAR summing array + do nz = 1,nzone + do nv = 1,nveg + do n = 1,ntiles + if (fveg(n,nv,nz)>1.e-4) then ! account for fact that parzone is undefined if fveg = 0 + para(n) = para(n) + parzone(n,nv,nz)*wtzone(n,nz)*fveg(n,nv,nz) + if(associated(BTRANT)) then + btrant(n) = btrant(n) + btran(n,nv,nz)*fveg(n,nv,nz)*wtzone(n,nz) + end if + end if + end do + end do + end do + + if(associated(CNCO2)) CNCO2 = CO2V * 1e6 + deallocate (co2v) + + if(associated(PARABS)) parabs = para + if(associated(PARINC)) parinc = drpar + dfpar + + ! -------------------------------------------------------------------------- + ! Update raditation exports + ! -------------------------------------------------------------------------- + + allocate ( ALBVR_tmp(ntiles) ) + allocate ( ALBNR_tmp(ntiles) ) + allocate ( ALBVF_tmp(ntiles) ) + allocate ( ALBNF_tmp(ntiles) ) + allocate ( SNOVR_tmp(ntiles) ) + allocate ( SNONR_tmp(ntiles) ) + allocate ( SNOVF_tmp(ntiles) ) + allocate ( SNONF_tmp(ntiles) ) + + call SIBALB(NTILES, VEG1,LAI1,GRN, ZTH, & + BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo + ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles + + + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP) + TPSN1OUT1 = TPSN1OUT1 + Tzero + + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & + RHOFS, & + SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & + WESNN, HTSNNN, SNDZN, & + ALBVR, ALBNR, ALBVF, ALBNF, & ! instantaneous snow-free albedos on tiles + SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles + RCONSTIT, UUU, TPSN1OUT1, DRPAR, DFPAR) + + call SIBALB(NTILES, VEG2,LAI2,GRN, ZTH, & + BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo + ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles + + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & + RHOFS, & + SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & + WESNN, HTSNNN, SNDZN, & + ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, & ! instantaneous snow-free albedos on tiles + SNOVR_tmp, SNONR_tmp, SNOVF_tmp, SNONF_tmp, & ! instantaneous snow albedos on tiles + RCONSTIT, UUU, TPSN1OUT1, DRPAR, DFPAR ) + + ALBVR(:) = ALBVR(:)*fveg1(:) + ALBVR_tmp(:)*fveg2(:) + ALBNR(:) = ALBNR(:)*fveg1(:) + ALBNR_tmp(:)*fveg2(:) + ALBVF(:) = ALBVF(:)*fveg1(:) + ALBVF_tmp(:)*fveg2(:) + ALBNF(:) = ALBNF(:)*fveg1(:) + ALBNF_tmp(:)*fveg2(:) + + SNOVR(:) = SNOVR(:)*fveg1(:) + SNOVR_tmp(:)*fveg2(:) + SNONR(:) = SNONR(:)*fveg1(:) + SNONR_tmp(:)*fveg2(:) + SNOVF(:) = SNOVF(:)*fveg1(:) + SNOVF_tmp(:)*fveg2(:) + SNONF(:) = SNONF(:)*fveg1(:) + SNONF_tmp(:)*fveg2(:) + + if (catchcn_internal%SNOW_ALBEDO_INFO == 1) then + + ! use MODIS-derived snow albedo from bcs (via Catch restart) + ! + ! as a restart parameter from the bcs, snow albedo must not have no-data-values + ! (checks for unphysical values should be in the make_bcs package) + + call MAPL_GetPointer(INTERNAL,SNOWALB,'SNOWALB',RC=STATUS); VERIFY_(STATUS) + + SNOVR = SNOWALB + SNONR = SNOWALB + SNOVF = SNOWALB + SNONF = SNOWALB + + endif + + ! -------------------------------------------------------------------------- + ! albedo/swnet partitioning + ! -------------------------------------------------------------------------- + + VSUVR = DRPAR + DRUVR + VSUVF = DFPAR + DFUVR + + if(associated(SWDOWNLAND)) SWDOWNLAND = DRPAR + DFPAR + DRUVR + DFUVR + DRNIR + DFNIR + + SWNETFREE = (1.-ALBVR)*VSUVR + (1.-ALBVF)*VSUVF + (1.-ALBNR)*DRNIR + (1.-ALBNF)*DFNIR + SWNETSNOW = (1.-SNOVR)*VSUVR + (1.-SNOVF)*VSUVF + (1.-SNONR)*DRNIR + (1.-SNONF)*DFNIR + +! set the number of days per year when crossing year boundary or on restart gkw: use GEOS5/MAPL value +! ------------------------------------------------------------------------- + if(AGCM_YY .ne. year_prev) then + dpy = get_days_per_year(AGCM_YY) ! set the number of days for current year + year_prev = AGCM_YY + endif + + ! CN time step over 4 hours may fail; limit to 4 hours; verify that DTCN is a multiple of DT + ! ------------------------------------------------------------------------------------------ + catchcn_internal%DTCN = min(catchcn_internal%DTCN,14400.) + if(mod(catchcn_internal%DTCN,dt) /= 0) stop 'dtcn' + + ! sum over interval for CN + ! ------------------------ + + tgwm = tgwm + tgw + tpm = tpm + tp1 + sfmm = sfmm + sfm + rzmm = rzmm + rzm + bflowm = bflowm + bflow + totwatm = totwatm + totwat + + tairm = tairm + TA + rhm = rhm + Qair_relative + windm = windm + UU + rainfm = rainfm + (PCU + PLS) + snowfm = snowfm + SNO + runsrfm = runsrfm + RUNSURF + ar1m = ar1m + car1 + psnsunm = psnsunm + psnsun + psnsham = psnsham + psnsha + lmrsunm = lmrsunm + lmrsun + lmrsham = lmrsham + lmrsha + laisunm = laisunm + laisun + laisham = laisham + laisha + do n = 1,N_snow + sndzm(:) = sndzm(:) + sndzn(n,:) + end do + asnowm = asnowm + asnow + cnsum = cnsum + 1. + + ! call CN model every DTCN seconds + ! -------------------------------- + + if(mod(AGCM_S_ofday,nint(catchcn_internal%DTCN)) == 0) then + + cn_count = cn_count + 1 + + ! check whether CN is on its first 1.5 hours; since CN_Driver is called once right at the beginning, we set this variable to true when CN_Driver is called for the second time + if (cn_count .le. 2) then + first_cn = is_first_step(.true.) + else + first_cn = is_first_step(.false.) + end if + + ! fzeng: pass current date_time to the CN routines. + call upd_curr_date_time( AGCM_YY, AGCM_MM, AGCM_DD, dofyr, & + AGCM_HH, AGCM_MI, AGCM_S ) + + ! compute mean state over interval + ! -------------------------------- + do nz = 1,nzone + tgwm(:,nz) = tgwm(:,nz) / cnsum(:) + rzmm(:,nz) = rzmm(:,nz) / cnsum(:) + sfmm(:,nz) = sfmm(:,nz) / cnsum(:) + do nv = 1,nveg + psnsunm(:,nv,nz) = psnsunm(:,nv,nz) / cnsum(:) + psnsham(:,nv,nz) = psnsham(:,nv,nz) / cnsum(:) + lmrsunm(:,nv,nz) = lmrsunm(:,nv,nz) / cnsum(:) + lmrsham(:,nv,nz) = lmrsham(:,nv,nz) / cnsum(:) + laisunm(:,nv,nz) = laisunm(:,nv,nz) / cnsum(:) + laisham(:,nv,nz) = laisham(:,nv,nz) / cnsum(:) + end do + end do + tpm = tpm / cnsum + bflowm = bflowm / cnsum + totwatm = totwatm / cnsum + tairm = tairm / cnsum + rhm = rhm / cnsum + windm = windm / cnsum + rainfm = rainfm / cnsum + snowfm = snowfm / cnsum + runsrfm = runsrfm / cnsum + ar1m = ar1m / cnsum + sndzm = sndzm / cnsum + asnowm = asnowm / cnsum + + call CN_Driver(istep_cn,ntiles,ityp,fveg,ndep,tpm,tairm,psis,bee,dayl,btran_fire,ar1m,& + rzmm,sfmm,rhm,windm,rainfm,snowfm,TPREC10D,TPREC60D,ET365D,gdp,& + abm,peatf,hdm,lnfm,poros,RH30D,totwatm,bflowm,runsrfm,sndzm,& + asnowm,TG10D,T2MMIN5D,SNDZM5D,water_inst, first_cn, & + psnsunm, psnsham, lmrsunm, lmrsham, laisunm, laisham, wpwet, & + elai,esai,tlai,totcolc,npp,gpp,sr,aresp,hresp,nee,burn,closs,nfire,& + som_closs,frootc,vegc,xsmr,ndeploy,denit,sminn_leached,sminn,& + fire_nloss,leafn,leafc,gross_nmin,net_nmin,& + nfix_to_sminn,actual_immob,fpg,fpi,sminn_to_plant,& + sminn_to_npool,ndep_to_sminn,totvegn,totlitn,totsomn,& + retransn,retransn_to_npool,fuelc,totlitc,cwdc,rootc) + + istep_cn = istep_cn + 1 + + ! jkolassa: padd is a correction term that we may no longer need; + ! I am setting it to zero here in order to avoid having to change + ! the restart file for now + + padd(:) = 0. + + ! save scaled CN diagnostics + ! -------------------------- + if(associated(CNLAI)) then + cnlai(:) = 0. + do nz = 1,nzone + do nv = 1,nveg + cnlai(:) = cnlai(:) + elai(:,nv,nz)*fveg(:,nv,nz)*wtzone(:,nz) + end do + end do + cnlai(:) = cnlai(:) * cnsum + endif + + if(associated(CNTLAI)) then + cntlai(:) = 0. + do nz = 1,nzone + do nv = 1,nveg + cntlai(:) = cntlai(:) + tlai(:,nv,nz)*fveg(:,nv,nz)*wtzone(:,nz) + end do + end do + cntlai(:) = cntlai(:) * cnsum + endif + + if(associated(CNSAI)) then + cnsai(:) = 0. + do nz = 1,nzone + do nv = 1,nveg + cnsai(:) = cnsai(:) + esai(:,nv,nz)*fveg(:,nv,nz)*wtzone(:,nz) + end do + end do + cnsai(:) = cnsai(:) * cnsum + endif + + if(associated(CNTOTC)) then + cntotc(:) = 0. + do nz = 1,nzone + cntotc(:) = cntotc(:) + 1.e-3*totcolc(:,nz)*wtzone(:,nz) + end do + cntotc(:) = cntotc(:) * cnsum + endif + + if(associated(CNFIRE_CNT )) cnfire_cnt = nfire * cnsum ! fire count (s-1) + if(associated(CNSOM_CLOSS )) cnsom_closs = 1.e-3*som_closs * cnsum ! peat fire C loss (kg/m2/s) + if(associated(CNNDEPLOY )) cnndeploy = 1.e-3*ndeploy * cnsum + if(associated(CNDENIT )) cndenit = 1.e-3*denit * cnsum + if(associated(CNSMINN_LEACHED )) cnsminn_leached = 1.e-3*sminn_leached * cnsum + if(associated(CNSMINN )) cnsminn = 1.e-3*sminn * cnsum + if(associated(CNFIRE_NLOSS )) cnfire_nloss = 1.e-3*fire_nloss * cnsum + if(associated(CNLEAFN )) cnleafn = 1.e-3*leafn * cnsum + if(associated(CNLEAFC )) cnleafc = 1.e-3*leafc * cnsum + if(associated(CNGROSS_NMIN )) cngross_nmin = 1.e-3*gross_nmin * cnsum + if(associated(CNNET_NMIN )) cnnet_nmin = 1.e-3*net_nmin * cnsum + if(associated(CNNFIX_TO_SMINN )) cnnfix_to_sminn = 1.e-3*nfix_to_sminn * cnsum + if(associated(CNACTUAL_IMMOB )) cnactual_immob = 1.e-3*actual_immob * cnsum + if(associated(CNFPG )) cnfpg = fpg * cnsum + if(associated(CNFPI )) cnfpi = fpi * cnsum + if(associated(CNSMINN_TO_PLANT )) cnsminn_to_plant = 1.e-3*sminn_to_plant * cnsum + if(associated(CNSMINN_TO_NPOOL )) cnsminn_to_npool = 1.e-3*sminn_to_npool * cnsum + if(associated(CNNDEP_TO_SMINN )) cnndep_to_sminn = 1.e-3*ndep_to_sminn * cnsum + if(associated(CNTOTVEGN )) cntotvegn = 1.e-3*totvegn * cnsum + if(associated(CNTOTLITN )) cntotlitn = 1.e-3*totlitn * cnsum + if(associated(CNTOTSOMN )) cntotsomn = 1.e-3*totsomn * cnsum + if(associated(CNRETRANSN )) cnretransn = 1.e-3*retransn * cnsum + if(associated(CNRETRANSN_TO_NPOOL)) cnretransn_to_npool = 1.e-3*retransn_to_npool * cnsum + if(associated(CNFUELC )) cnfuelc = 1.e-3*fuelc * cnsum + if(associated(CNTOTLITC )) cntotlitc = 1.e-3*totlitc * cnsum + if(associated(CNCWDC )) cncwdc = 1.e-3*cwdc * cnsum + if(associated(CNROOT )) cnroot = 1.e-3*rootc * cnsum + if(associated(CNFSEL )) cnfsel = 0. + ! reset summing arrays + ! -------------------- + tgwm = 0. + tpm = 0. + sfmm = 0. + rzmm = 0. + bflowm = 0. + totwatm = 0. + tairm = 0. + rhm = 0. + windm = 0. + rainfm = 0. + snowfm = 0. + runsrfm = 0. + ar1m = 0. + psnsunm = 0. + psnsham = 0. + lmrsunm = 0. + lmrsham = 0. + laisunm = 0. + laisham = 0. + sndzm = 0. + asnowm = 0. + cnsum = 0. + + else ! CN diags set to zero + + if(associated(CNLAI )) cnlai = 0. + if(associated(CNTLAI)) cntlai = 0. + if(associated(CNSAI )) cnsai = 0. + if(associated(CNTOTC)) cntotc = 0. + if(associated(CNFIRE_CNT )) cnfire_cnt = 0. + if(associated(CNSOM_CLOSS )) cnsom_closs = 0. + if(associated(CNNDEPLOY )) cnndeploy = 0. + if(associated(CNDENIT )) cndenit = 0. + if(associated(CNSMINN_LEACHED )) cnsminn_leached = 0. + if(associated(CNSMINN )) cnsminn = 0. + if(associated(CNFIRE_NLOSS )) cnfire_nloss = 0. + if(associated(CNLEAFN )) cnleafn = 0. + if(associated(CNLEAFC )) cnleafc = 0. + if(associated(CNGROSS_NMIN )) cngross_nmin = 0. + if(associated(CNNET_NMIN )) cnnet_nmin = 0. + if(associated(CNNFIX_TO_SMINN )) cnnfix_to_sminn = 0. + if(associated(CNACTUAL_IMMOB )) cnactual_immob = 0. + if(associated(CNFPG )) cnfpg = 0. + if(associated(CNFPI )) cnfpi = 0. + if(associated(CNSMINN_TO_PLANT )) cnsminn_to_plant = 0. + if(associated(CNSMINN_TO_NPOOL )) cnsminn_to_npool = 0. + if(associated(CNNDEP_TO_SMINN )) cnndep_to_sminn = 0. + if(associated(CNTOTVEGN )) cntotvegn = 0. + if(associated(CNTOTLITN )) cntotlitn = 0. + if(associated(CNTOTSOMN )) cntotsomn = 0. + if(associated(CNRETRANSN )) cnretransn = 0. + if(associated(CNRETRANSN_TO_NPOOL)) cnretransn_to_npool = 0. + if(associated(CNFUELC )) cnfuelc = 0. + if(associated(CNTOTLITC )) cntotlitc = 0. + if(associated(CNCWDC )) cncwdc = 0. + if(associated(CNROOT )) cnroot = 0. + + endif + + ! CN_Driver outputs at DTCN are saved and used to populate below exports + ! uniformly outside DTCN. + ! ----------------------------------------------------------------------- + + if(associated(CNVEGC)) cnvegc = 1.e-3*vegc ! * cnsum + if(associated(CNFROOTC)) cnfrootc = 1.e-3*frootc ! * cnsum + if(associated(CNNPP )) cnnpp = 1.e-3*npp ! * cnsum + if(associated(CNGPP )) cngpp = 1.e-3*gpp ! * cnsum + if(associated(CNSR )) cnsr = 1.e-3*sr ! * cnsum + if(associated(CNAR )) cnar = 1.e-3*aresp ! * cnsum + if(associated(CNHR )) cnhr = 1.e-3*hresp ! * cnsum + if(associated(CNNEE )) cnnee = 1.e-3*nee ! * cnsum + if(associated(CNXSMR)) cnxsmr = 1.e-3*xsmr ! * cnsum + if(associated(CNADD )) cnadd = 1.e-3*padd ! * cnsum + if(associated(CNLOSS)) cnloss = 1.e-3*closs ! * cnsum ! total fire C loss (kg/m2/s) + if(associated(CNBURN)) cnburn = burn ! * cnsum ! area fractional fire burn rate (s-1) + + ! copy CN_restart vars to catch_internal_rst gkw: only do if stopping + ! ------------------------------------------ + record = .false. + call ESMF_ClockGetAlarm ( CLOCK, alarmname="RecordAlarm001", ALARM=RecordAlarm, RC=STATUS ) + if (status == 0) then + call ESMF_AlarmGet( RecordAlarm, RingTime = NextRecordTime, _RC) + if (NextTime == NextRecordTime) record = .true. + endif + + if(NextTime == StopTime .or. record) then + + call CN_exit(ntiles,ityp,fveg,cncol,cnpft) + i = 1 + do iv = 1,VAR_PFT + do nv = 1,NUM_VEG + do nz = 1, NUM_ZON + do n = 1,ntiles + ! to ensure unused array elements don't have crazy numbers in restart files. + if(fveg (n,nv,nz) == 0.) cnpft (n,i) = 0. + end do + i = i + 1 + end do + end do + end do + endif + +! update LAI for primary & secondary vegetation types +! --------------------------------------------------- + lai1 = 0. + wght = 0. + do nz = 1,nzone + nv = 1 + lai1(:) = lai1(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) + wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) + end do + lai1 = lai1 / max(wght,1.e-8) ! LAI for primary vegetation type + + lai2 = 0. + wght = 0. + do nz = 1,nzone + nv = 2 + lai2(:) = lai2(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) + wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) + end do + lai2 = lai2 / max(wght,1.e-8) ! LAI for secondary vegetation type + + lai = fveg1*lai1 + fveg2*lai2 ! gkw: prognostic LAI on catch_internal_rst (overwrite VEGDYN import) + LAI0 = max(0.0001 , LAI) + +! have stomatal resistance in the CN zones; map as conductance into catchment zones +! --------------------------------------------------------------------------------- + do n = 1,ntiles + + ax1 = car1(n) + ax2 = car2(n) + ax4 = 1. - ax1 - ax2 + + cn1 = wtzone(n,1) + cn2 = wtzone(n,2) + cn3 = wtzone(n,3) + +! catchment: saturated area + + if(ax1 .lt. cn1) then + f1(1) = ax1 ; f2(1) = 0. ; f3(1) = 0. + else + if(ax1 .lt. (cn1+cn2)) then + f1(1) = cn1 ; f2(1) = ax1-cn1 ; f3(1) = 0. + else + f1(1) = cn1 ; f2(1) = cn2 ; f3(1) = ax1-cn1-cn2 + endif + endif + + if(ax1 .gt. 0.) then + rcsat(n) = ax1/(f1(1)/rc00(n,1)+f2(1)/rc00(n,2)+f3(1)/rc00(n,3)) + rcxdt(n) = ax1/(f1(1)/rcdt(n,1)+f2(1)/rcdt(n,2)+f3(1)/rcdt(n,3)) + rcxdq(n) = ax1/(f1(1)/rcdq(n,1)+f2(1)/rcdq(n,2)+f3(1)/rcdq(n,3)) + else + rcsat(n) = 1.e3 + rcxdt(n) = 1.e3 + rcxdq(n) = 1.e3 + endif + +! compute deriviatives + drcsdt(n) = (rcxdt(n) - rcsat(n)) / dtc + drcsdq(n) = (rcxdq(n) - rcsat(n)) / (0.622*dea/PS(n)) + +! catchment: unstressed area + + if(ax1 .lt. cn1) then + ar = ax1 + ax2 + if(ar .lt. cn1) then + f1(2) = ax2 ; f2(2) = 0. ; f3(2) = 0. + else + if(ar .lt. (cn1+cn2)) then + f1(2) = cn1-ax1 ; f2(2) = ar-cn1 ; f3(2) = 0. + else + f1(2) = cn1-ax1 ; f2(2) = cn2 ; f3(2) = ar-cn1-cn2 + endif + endif + else + ar = ax2 + ax4 + if(ar .lt. cn3) then + f1(2) = 0. ; f2(2) = 0. ; f3(2) = ax2 + else + if(ax4 .gt. cn3) then + f1(2) = 0. ; f2(2) = ax2 ; f3(2) = 0. + else + f1(2) = 0. ; f2(2) = ar-cn3 ; f3(2) = cn3-ax4 + endif + endif + endif + + if(ax2 .gt. 0.) then + rcuns(n) = ax2/(f1(2)/rc00(n,1)+f2(2)/rc00(n,2)+f3(2)/rc00(n,3)) + rcxdt(n) = ax2/(f1(2)/rcdt(n,1)+f2(2)/rcdt(n,2)+f3(2)/rcdt(n,3)) + rcxdq(n) = ax2/(f1(2)/rcdq(n,1)+f2(2)/rcdq(n,2)+f3(2)/rcdq(n,3)) + else + rcuns(n) = 1.e3 + rcxdt(n) = 1.e3 + rcxdq(n) = 1.e3 + endif + +! compute deriviatives + drcudt(n) = (rcxdt(n) - rcuns(n)) / dtc + drcudq(n) = (rcxdq(n) - rcuns(n)) / (0.622*dea/PS(n)) + + end do + + if(associated(SCSAT )) scsat = 1. / rcsat + if(associated(SCUNS )) scuns = 1. / rcuns + + endif ! end of check for zero tiles + +! gkw: end of main CN block + + PLSIN = PLS + + ! -------------------------------------------------------------------------- + ! Call Irrigation Model + ! -------------------------------------------------------------------------- + + IF ((catchcn_internal%RUN_IRRIG /= 0).AND.(ntiles >0)) THEN + + CALL CATCH_CALC_SOIL_MOIST ( & + NTILES,dzsf,vgwmax,cdcr1,cdcr2,psis,bee,poros,wpwet, & + ars1,ars2,ars3,ara1,ara2,ara3,ara4,arw1,arw2,arw3,arw4,bf1,bf2, & + srfexc,rzexc,catdef, CAR1, CAR2, CAR4, sfmc, rzmc, prmc) + + call irrigation_rate (catchcn_internal%IRRIG_METHOD, & + NTILES, AGCM_HH, AGCM_MI, AGCM_S, lons, IRRIGFRAC, PADDYFRAC, & + CLMPT,CLMST, CLMPF, CLMSF, LAIMAX, LAIMIN, LAI0, & + POROS, WPWET, VGWMAX, RZMC, IRRIGRATE) + + PLSIN = PLS + IRRIGRATE + + ENDIF + +#ifdef DBG_CNLSM_INPUTS + call MAPL_Get(MAPL, LocStream=LOCSTREAM, RC=STATUS) + VERIFY_(STATUS) + call MAPL_LocStreamGet(LOCSTREAM, NT_GLOBAL=NT_GLOBAL, TILEGRID=TILEGRID, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TileMaskGet(tilegrid, mask, rc=status) + VERIFY_(STATUS) + + if (UNIT_i == 0) then + unit_i = GETFILE( "catchcnclm51_inputs.data", form="unformatted", RC=STATUS ) + VERIFY_(STATUS) + endif + unit = unit_i + +! Inputs + + call MAPL_VarWrite(unit, tilegrid, PCU, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, PLS, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SNO, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ICE, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, FRZR, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, UUU, mask=mask, rc=status); VERIFY_(STATUS) + + call MAPL_VarWrite(unit, tilegrid, EVSBT (:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DEVSBT(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DEDTC (:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SHSBT (:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DHSDQA(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DSHSBT(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, EVSBT (:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DEVSBT(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DEDTC (:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SHSBT (:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DHSDQA(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DSHSBT(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, EVSBT (:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DEVSBT(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DEDTC (:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SHSBT (:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DHSDQA(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DSHSBT(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, EVSBT (:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DEVSBT(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DEDTC (:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SHSBT (:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DHSDQA(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DSHSBT(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + + call MAPL_VarWrite(unit, tilegrid, TA, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, QA, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RA(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RA(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RA(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RA(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ZTH, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SWNETFREE, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SWNETSNOW, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, LWDNSRF, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, PS*.01, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, LAI0, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, GRN0, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SQSCAT, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RSL1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RSL2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RDC, mask=mask, rc=status); VERIFY_(STATUS) + + call MAPL_VarWrite(unit, tilegrid, QSAT(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DQS(:,FSAT) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ALWN(:,1) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BLWN(:,1) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, QSAT(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DQS(:,FTRN) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ALWN(:,2) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BLWN(:,2) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, QSAT(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DQS(:,FWLT) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ALWN(:,3) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BLWN(:,3) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, QSAT(:,FSNW), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DQS(:,FSNW) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ALWN(:,4) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BLWN(:,4) , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RCSAT , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DRCSDT , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DRCSDQ , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RCUNS , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DRCUDT , mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DRCUDQ , mask=mask, rc=status); VERIFY_(STATUS) + +! params + if (firsttime) then + firsttime = .false. + unit = GETFILE( "catchcnclm51_params.data", form="unformatted", RC=STATUS ) + VERIFY_(STATUS) + + call WRITE_PARALLEL(NT_GLOBAL, UNIT) + call WRITE_PARALLEL(DT, UNIT) + call WRITE_PARALLEL(catchcn_internal%USE_FWET_FOR_RUNOFF, UNIT) + call MAPL_VarWrite(unit, tilegrid, LONS, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, LATS, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, VEG1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, VEG2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, FVEG1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, FVEG2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, DZSF, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BF1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BF2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BF3, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, VGWMAX,mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, CDCR1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, CDCR2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, PSIS, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BEE, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, POROS, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, WPWET, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, COND, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, GNU, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARS1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARS2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARS3, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARA1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARA2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARA3, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARA4, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARW1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARW2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARW3, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ARW4, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TSA1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TSA2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TSB1, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TSB2, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, ATAU, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, BTAU, mask=mask, rc=status); VERIFY_(STATUS) + + call FREE_FILE(unit, RC=STATUS) + VERIFY_(STATUS) + +! Updates + unit = GETFILE( "catchcnclm51_updates.data", form="unformatted", RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_VarWrite(unit, tilegrid, TG(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TG(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TG(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TC(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TC(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, TC(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, QC(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, QC(:,FTRN), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, QC(:,FWLT), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, CAPAC, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, CATDEF, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, RZEXC, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SRFEXC, mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, GHTCNT(1,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, GHTCNT(2,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, GHTCNT(3,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, GHTCNT(4,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, GHTCNT(5,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, GHTCNT(6,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, WESNN(1,:), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, WESNN(2,:), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, WESNN(3,:), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, HTSNNN(1,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, HTSNNN(2,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, HTSNNN(3,:),mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SNDZN(1,:), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SNDZN(2,:), mask=mask, rc=status); VERIFY_(STATUS) + call MAPL_VarWrite(unit, tilegrid, SNDZN(3,:), mask=mask, rc=status); VERIFY_(STATUS) + + call FREE_FILE(unit, RC=STATUS) + VERIFY_(STATUS) + + end if + DEALLOC_(mask) +#endif + +! call unified land model +! ----------------------- + if (ntiles > 0) then + + call CATCHCN ( NTILES, LONS, LATS, DT,catchcn_internal%USE_FWET_FOR_RUNOFF, & + catchcn_internal%FWETC, catchcn_internal%FWETL, cat_id, VEG1,VEG2,FVEG1,FVEG2,DZSF ,& + PCU , PLSIN , SNO, ICE, FRZR ,& + UUU ,& + + EVSBT(:,FSAT), DEVSBT(:,FSAT), DEDTC(:,FSAT) ,& + SHSBT(:,FSAT), DHSDQA(:,FSAT), DSHSBT(:,FSAT),& + EVSBT(:,FTRN), DEVSBT(:,FTRN), DEDTC(:,FTRN) ,& + SHSBT(:,FTRN), DHSDQA(:,FTRN), DSHSBT(:,FTRN),& + EVSBT(:,FWLT), DEVSBT(:,FWLT), DEDTC(:,FWLT) ,& + SHSBT(:,FWLT), DHSDQA(:,FWLT), DSHSBT(:,FWLT),& + EVSBT(:,FSNW), DEVSBT(:,FSNW), DEDTC(:,FSNW) ,& + SHSBT(:,FSNW), DHSDQA(:,FSNW), DSHSBT(:,FSNW),& + + TA , QA ,& + + RA(:,FSAT), RA(:,FTRN), RA(:,FWLT), RA(:,FSNW) ,& + + ZTH, SWNETFREE, SWNETSNOW, LWDNSRF ,& ! LWDNSRF = *absorbed* longwave only (excl reflected) + + PS*.01 ,& + + LAI0, GRN0, SQSCAT, RSL1, RSL2, RDC ,& + + QSAT(:,FSAT) , DQS(:,FSAT) , ALWN(:,1), BLWN(:,1) ,& + QSAT(:,FTRN) , DQS(:,FTRN) , ALWN(:,2), BLWN(:,2) ,& + QSAT(:,FWLT) , DQS(:,FWLT) , ALWN(:,3), BLWN(:,3) ,& + QSAT(:,FSNW) , DQS(:,FSNW) , ALWN(:,4), BLWN(:,4) ,& + + RCSAT,DRCSDT,DRCSDQ, RCUNS,DRCUDT,DRCUDQ, & + BF1, BF2, BF3, VGWMAX, CDCR1, CDCR2, PSIS ,& + BEE, POROS, WPWET, COND, GNU ,& + ARS1, ARS2, ARS3, ARA1, ARA2, ARA3, ARA4 ,& + ARW1, ARW2, ARW3, ARW4, TSA1, TSA2, TSB1, TSB2 ,& + ATAU, BTAU, .false. ,& + + TG(:,FSAT), TG(:,FTRN), TG(:,FWLT) ,& + TC(:,FSAT), TC(:,FTRN), TC(:,FWLT) ,& + QC(:,FSAT), QC(:,FTRN), QC(:,FWLT) ,& + + CAPAC, CATDEF, RZEXC, SRFEXC, GHTCNT ,& + WESNN, HTSNNN, SNDZN ,& + + EVAPOUT, SHOUT, RUNOFF, EVPINT, EVPSOI, EVPVEG ,& + EVPICE ,& + BFLOW ,& + RUNSURF ,& + SMELT ,& + HLWUP ,& ! *emitted* longwave only (excl reflected) + SWNDSRF ,& + HLATN ,& + QINFIL ,& + AR1 ,& + AR2 ,& + RZEQ ,& + GHFLX ,& + GHFLXSNO ,& + GHFLXTSKIN ,& + TC(:,FSNW) ,& + ASNOW ,& + TP1, TP2, TP3, TP4, TP5, TP6, SFMC, RZMC, PRMC ,& + ENTOT,WTOT, WCHANGE, ECHANGE, HSNACC, EVACC, SHACC ,& + TSURF ,& + SHSNOW1, AVETSNOW1, WAT10CM1, WATSOI1, ICESOI1 ,& + LHSNOW1, LWUPSNOW1, LWDNSNOW1, NETSWSNOW ,& + TCSORIG1, TPSN1IN1, TPSN1OUT1, FSW_CHANGE, FICESOUT ,& + TC1_0=TC1_0, TC2_0=TC2_0, TC4_0=TC4_0 ,& + QA1_0=QA1_0, QA2_0=QA2_0, QA4_0=QA4_0 ,& + RCONSTIT=RCONSTIT, RMELT=RMELT, TOTDEPOS=TOTDEPOS, LHACC=LHACC) + + ! Change units of TP1, TP2, .., TP6 export variables from Celsius to Kelvin. + ! This used to be done at the level the Surface GridComp. + ! With this change, gridded TSOIL[n] exports from Surface and tile-space TP[n] exports + ! from Catch are now consistently in units of Kelvin. + ! - rreichle, borescan, 6 Nov 2020 + + TP1 = TP1 + MAPL_TICE + TP2 = TP2 + MAPL_TICE + TP3 = TP3 + MAPL_TICE + TP4 = TP4 + MAPL_TICE + TP5 = TP5 + MAPL_TICE + TP6 = TP6 + MAPL_TICE + + end if + + ! compute 365-day running mean of total ET (excluding sublimation from snow) + if(init_accum_365) then + ! 365-day running mean of total ET (W m-2) + accper = min(istep_365,n365d) + ET365D = ((accper-1)*ET365D + EVPSOI + EVPINT + EVPVEG) / accper + else + ET365D = ((n365d-1)*ET365D + EVPSOI + EVPINT + EVPVEG) / n365d + endif + + if (OFFLINE_MODE /=0) then + TC(:,FSAT) = TC1_0 + TC(:,FTRN) = TC2_0 + TC(:,FWLT) = TC4_0 + QC(:,FSAT) = QA1_0 + QC(:,FTRN) = QA2_0 + QC(:,FWLT) = QA4_0 + EVACC = 0.0 + SHACC = 0.0 + endif + + QC(:,FSNW) = GEOS_QSAT ( TC(:,FSNW), PS, PASCALS=.true., RAMP=0.0 ) + + ! -------------------------------------------------------------------------- + ! update subtile fractions + ! -------------------------------------------------------------------------- + + EMIS = fveg1*(EMSVEG(VEG1) + (EMSBARESOIL - EMSVEG(VEG1))*exp(-LAI1)) + & + fveg2*(EMSVEG(VEG2) + (EMSBARESOIL - EMSVEG(VEG2))*exp(-LAI2)) + + EMIS = EMIS *(1.-ASNOW) + EMSSNO *ASNOW + + call MAPL_SunGetInsolation(LONS, LATS, & + ORBIT, ZTH, SLR, & + INTV = TINT, & + currTime=CURRENT_TIME+DELT, & + RC=STATUS ) + VERIFY_(STATUS) + + ZTH = max(0.0,ZTH) + + ! -------------------------------------------------------------------------- + ! Update raditation exports + ! -------------------------------------------------------------------------- + + call MAPL_TimerOn(MAPL,"-ALBEDO") + if(ntiles > 0) then + call SIBALB(NTILES, VEG1,LAI1,GRN, ZTH, & + BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo + ALBVR, ALBNR, ALBVF, ALBNF, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles + + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP) + TPSN1OUT1 = TPSN1OUT1 + Tzero + + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & + RHOFS, & + SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & + WESNN, HTSNNN, SNDZN, & + ALBVR, ALBNR, ALBVF, ALBNF, & ! instantaneous snow-free albedos on tiles + SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles + RCONSTIT, UUU, TPSN1OUT1,DRPAR, DFPAR) + + call SIBALB(NTILES, VEG2,LAI2,GRN, ZTH, & + BGALBVR, BGALBVF, BGALBNR, BGALBNF, & ! gkw: MODIS soil background albedo + ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, MODIS_SCALE=.TRUE. ) ! instantaneous snow-free albedos on tiles + + + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & + RHOFS, & + SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & + WESNN, HTSNNN, SNDZN, & + ALBVR_tmp, ALBNR_tmp, ALBVF_tmp, ALBNF_tmp, & ! instantaneous snow-free albedos on tiles + SNOVR_tmp, SNONR_tmp, SNOVF_tmp, SNONF_tmp, & ! instantaneous snow albedos on tiles + RCONSTIT, UUU, TPSN1OUT1,DRPAR, DFPAR ) + + ALBVR(:) = ALBVR(:)*fveg1(:) + ALBVR_tmp(:)*fveg2(:) + ALBNR(:) = ALBNR(:)*fveg1(:) + ALBNR_tmp(:)*fveg2(:) + ALBVF(:) = ALBVF(:)*fveg1(:) + ALBVF_tmp(:)*fveg2(:) + ALBNF(:) = ALBNF(:)*fveg1(:) + ALBNF_tmp(:)*fveg2(:) + + SNOVR(:) = SNOVR(:)*fveg1(:) + SNOVR_tmp(:)*fveg2(:) + SNONR(:) = SNONR(:)*fveg1(:) + SNONR_tmp(:)*fveg2(:) + SNOVF(:) = SNOVF(:)*fveg1(:) + SNOVF_tmp(:)*fveg2(:) + SNONF(:) = SNONF(:)*fveg1(:) + SNONF_tmp(:)*fveg2(:) + + if (catchcn_internal%SNOW_ALBEDO_INFO == 1) then + + ! use MODIS-derived snow albedo from bcs (via Catch restart) + ! + ! as a restart parameter from the bcs, snow albedo must not have no-data-values + ! (checks for unphysical values should be in the make_bcs package) + + SNOVR = SNOWALB + SNONR = SNOWALB + SNOVF = SNOWALB + SNONF = SNOWALB + + endif + + ALBVR = ALBVR *(1.-ASNOW) + SNOVR *ASNOW + ALBVF = ALBVF *(1.-ASNOW) + SNOVF *ASNOW + ALBNR = ALBNR *(1.-ASNOW) + SNONR *ASNOW + ALBNF = ALBNF *(1.-ASNOW) + SNONF *ASNOW + endif + call MAPL_TimerOff(MAPL,"-ALBEDO") + + LWNDSRF = LWDNSRF - HLWUP + + ! -------------------------------------------------------------------------- + ! update outputs + ! -------------------------------------------------------------------------- + + DELTS = 0.0 + DELQS = 0.0 + + do N=1,NUM_SUBTILES + DELTS = DELTS + CFT(:,N)*(TC(:,N)-TCO(:,N))*FR(:,N) + DELQS = DELQS + CFQ(:,N)*(QC(:,N)-QCO(:,N))*FR(:,N) + end do + + FR(:,FSAT) = AR1 * (1-ASNOW) + FR(:,FTRN) = AR2 * (1-ASNOW) + FR(:,FWLT) = (1.0-(AR1+AR2))* (1-ASNOW) + FR(:,FSNW) = ASNOW + + FR = min( max( fr,0.0 ), 1.0 ) + + TST = 0.0 + QST = 0.0 + do N=1,NUM_SUBTILES + TST = TST + TC(:,N) *FR(:,N) + QST = QST + QC(:,N) *FR(:,N) + end do + + if ( OFFLINE_MODE ==0 ) then +!amm add correction term to latent heat diagnostics (HLATN is always allocated) +! this will impact the export LHLAND + HLATN = HLATN - LHACC +! also add some portion of the correction term to evap from soil, int, veg and snow + SUMEV = EVPICE+EVPSOI+EVPVEG+EVPINT + where(SUMEV>0.) + EVPICE = EVPICE - EVACC*EVPICE/SUMEV + EVPSOI = EVPSOI - EVACC*EVPSOI/SUMEV + EVPINT = EVPINT - EVACC*EVPINT/SUMEV + EVPVEG = EVPVEG - EVACC*EVPVEG/SUMEV + endwhere + endif + + if(associated( LST )) LST = TST + if(associated( TPSURF))TPSURF = TSURF + if(associated( WET1 )) WET1 = max(min(SFMC / POROS,1.0),0.0) + if(associated( WET2 )) WET2 = max(min(RZMC / POROS,1.0),0.0) + if(associated( WET3 )) WET3 = max(min(PRMC / POROS,1.0),0.0) + if(associated( WCSF )) WCSF = SFMC + if(associated( WCRZ )) WCRZ = RZMC + if(associated( WCPR )) WCPR = PRMC + + if(associated( ACCUM)) ACCUM = SLDTOT - EVPICE*(1./MAPL_ALHS) - SMELT + + if(associated(EVPSNO)) EVPSNO = EVPICE + if(associated(SUBLIM)) SUBLIM = EVPICE*(1./MAPL_ALHS)*FR(:,FSNW) + if(associated(EVLAND)) EVLAND = EVAPOUT-EVACC + if(associated(PRLAND)) PRLAND = PCU+PLS+SLDTOT + if(associated(SNOLAND)) SNOLAND = SLDTOT + if(associated(DRPARLAND)) DRPARLAND = DRPAR + if(associated(DFPARLAND)) DFPARLAND = DFPAR + if(associated(LHLAND)) LHLAND = HLATN + if(associated(SHLAND)) SHLAND = SHOUT-SHACC + if(associated(SWLAND)) SWLAND = SWNDSRF + if(associated(LWLAND)) LWLAND = LWNDSRF + if(associated(GHLAND)) GHLAND = GHFLX + if(associated(GHSNOW)) GHSNOW = GHFLXSNO + if(associated(SHSNOW)) SHSNOW = SHSNOW1 + if(associated(AVETSNOW)) AVETSNOW = AVETSNOW1 + if(associated(WAT10CM)) WAT10CM = WAT10CM1 + if(associated(WATSOI)) WATSOI = WATSOI1 + if(associated(ICESOI)) ICESOI = ICESOI1 + if(associated(LHSNOW)) LHSNOW = LHSNOW1 + if(associated(LWUPSNOW)) LWUPSNOW = LWUPSNOW1 + if(associated(LWDNSNOW)) LWDNSNOW = LWDNSNOW1 + if(associated(SWNETSNOW1)) SWNETSNOW1 = NETSWSNOW + if(associated(TCSORIG)) TCSORIG = TCSORIG1 + if(associated(TPSN1IN)) TPSN1IN = TPSN1IN1 + if(associated(TPSN1OUT)) TPSN1OUT = TPSN1OUT1 + if(associated(GHTSKIN))GHTSKIN = GHFLXTSKIN + if(associated(SMLAND)) SMLAND = SMELT + if(associated(TWLAND)) TWLAND = WTOT + if(associated(TELAND)) TELAND = ENTOT + if(associated(TSLAND)) TSLAND = WESNN (1,:) + WESNN (2,:) + WESNN (3,:) + if(associated(DWLAND)) DWLAND = WCHANGE + if(associated(DHLAND)) DHLAND = ECHANGE + if(associated(SPLAND)) SPLAND = SHACC + if(associated(SPWATR)) SPWATR = EVACC + if(associated(SPSNOW)) SPSNOW = HSNACC + + if(associated(FRSAT )) FRSAT = max( min( FR(:,FSAT),1.0 ), 0.0 ) + if(associated(FRUST )) FRUST = max( min( FR(:,FTRN),1.0 ), 0.0 ) + if(associated(FRWLT )) FRWLT = max( min( FR(:,FWLT),1.0 ), 0.0 ) + + if(associated(SNOMAS)) SNOMAS = WESNN (1,:) + WESNN (2,:) + WESNN (3,:) + if(associated(SNOWDP)) SNOWDP = SNDZN (1,:) + SNDZN (2,:) + SNDZN (3,:) + + if(associated(FICE1 )) FICE1 = max( min( FICESOUT(1,:),1.0 ), 0.0 ) + if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) + if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) + + if (N_CONSTIT > 0) then + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) + if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) + if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) + if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) + if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) + if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) + if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) + if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) + if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + endif + if(associated(PEATCLSM_FSWCHANGE )) then + where (POROS >= PEATCLSM_POROS_THRESHOLD) + PEATCLSM_FSWCHANGE = FSW_CHANGE + elsewhere + PEATCLSM_FSWCHANGE = MAPL_UNDEF + end where + end if + + if(associated(PEATCLSM_WATERLEVEL)) then + PEATCLSM_WATERLEVEL = catch_calc_peatclsm_waterlevel( BF1, BF2, CDCR2, POROS, WPWET, CATDEF ) + endif + + if(associated(TPSN1OUT)) then + where(WESNN(1,:)>0.) + TPSN1OUT = TPSN1OUT1 + elsewhere + TPSN1OUT = MAPL_UNDEF + end where + end if + + if(associated(TPSN1)) then + where(WESNN(1,:)>0.) + TPSN1 = TC(:,FSNW) + elsewhere + TPSN1 = MAPL_UNDEF + end where + end if + + if(associated(TPSAT)) then + where(FR(:,FSAT)>0.) + TPSAT = TC(:,FSAT) + elsewhere + TPSAT = MAPL_UNDEF + end where + end if + + if(associated(TPWLT)) then + where(FR(:,FWLT)>0.) + TPWLT = TC(:,FWLT) + elsewhere + TPWLT = MAPL_UNDEF + end where + end if + + if(associated(TPUST)) then + where(FR(:,FTRN)>0.) + TPUST = TC(:,FTRN) + elsewhere + TPUST = MAPL_UNDEF + end where + end if + + + ! -------------------------------------------------------------------------- + ! update internal state arrays + ! -------------------------------------------------------------------------- + + GHTCNT1 = GHTCNT(1,:) + GHTCNT2 = GHTCNT(2,:) + GHTCNT3 = GHTCNT(3,:) + GHTCNT4 = GHTCNT(4,:) + GHTCNT5 = GHTCNT(5,:) + GHTCNT6 = GHTCNT(6,:) + + WESNN1 = WESNN (1,:) + WESNN2 = WESNN (2,:) + WESNN3 = WESNN (3,:) + + HTSNNN1 = HTSNNN(1,:) + HTSNNN2 = HTSNNN(2,:) + HTSNNN3 = HTSNNN(3,:) + + SNDZN1 = SNDZN (1,:) + SNDZN2 = SNDZN (2,:) + SNDZN3 = SNDZN (3,:) + + if (catchcn_internal%N_CONST_LAND4SNWALB /= 0 .and. N_CONSTIT > 0 ) then + RDU001(:,:) = RCONSTIT(:,:,1) + RDU002(:,:) = RCONSTIT(:,:,2) + RDU003(:,:) = RCONSTIT(:,:,3) + RDU004(:,:) = RCONSTIT(:,:,4) + RDU005(:,:) = RCONSTIT(:,:,5) + RBC001(:,:) = RCONSTIT(:,:,6) + RBC002(:,:) = RCONSTIT(:,:,7) + ROC001(:,:) = RCONSTIT(:,:,8) + ROC002(:,:) = RCONSTIT(:,:,9) + end if + + ! -------------------------------------------------------------------------- + + deallocate ( wght ) + deallocate ( lai1 ) + deallocate ( lai2 ) + if (allocated (ALBVR_tmp)) deallocate ( ALBVR_tmp ) + if (allocated (ALBNR_tmp)) deallocate ( ALBNR_tmp ) + if (allocated (ALBVF_tmp)) deallocate ( ALBVF_tmp ) + if (allocated (ALBNF_tmp)) deallocate ( ALBNF_tmp ) + if (allocated (SNOVR_tmp)) deallocate ( SNOVR_tmp ) + if (allocated (SNONR_tmp)) deallocate ( SNONR_tmp ) + if (allocated (SNOVF_tmp)) deallocate ( SNOVF_tmp ) + if (allocated (SNONF_tmp)) deallocate ( SNONF_tmp ) + + deallocate(GHTCNT ) + deallocate(WESNN ) + deallocate(HTSNNN ) + deallocate(SNDZN ) + deallocate(FICESOUT ) + deallocate(TILEZERO ) + deallocate(DZSF ) + deallocate(SWNETFREE) + deallocate(SWNETSNOW) + deallocate(VEG1 ) + deallocate(VEG2 ) + deallocate(RCSAT ) + deallocate(DRCSDT ) + deallocate(DRCSDQ ) + deallocate(RCUNS ) + deallocate(DRCUDT ) + deallocate(DRCUDQ ) + deallocate(ZTH ) + deallocate(SLR ) + deallocate(RSL1 ) + deallocate(RSL2 ) + deallocate(SQSCAT ) + deallocate(RDC ) + deallocate(RDC_TMP_1) + deallocate(RDC_TMP_2) + deallocate(UUU ) + deallocate(RHO ) + deallocate(ZVG ) + deallocate(LAI0 ) + deallocate(GRN0 ) + deallocate(Z0 ) + deallocate(D0 ) + deallocate(SFMC ) + deallocate(RZMC ) + deallocate(PRMC ) + deallocate(ENTOT ) + deallocate(WTOT ) + deallocate(GHFLXSNO ) + deallocate(SHSNOW1 ) + deallocate(AVETSNOW1) + deallocate(WAT10CM1 ) + deallocate(WATSOI1 ) + deallocate(ICESOI1 ) + deallocate(LHSNOW1 ) + deallocate(LWUPSNOW1) + deallocate(LWDNSNOW1) + deallocate(NETSWSNOW) + deallocate(TCSORIG1 ) + deallocate(LHACC ) + deallocate(SUMEV ) + deallocate(TPSN1IN1 ) + deallocate(TPSN1OUT1) + deallocate(GHFLXTSKIN) + deallocate(WCHANGE ) + deallocate(ECHANGE ) + deallocate(HSNACC ) + deallocate(EVACC ) + deallocate(SHACC ) + deallocate(VSUVR ) + deallocate(VSUVF ) + deallocate(SNOVR ) + deallocate(SNOVF ) + deallocate(SNONR ) + deallocate(SNONF ) + deallocate(SHSBT ) + deallocate(DSHSBT ) + deallocate(EVSBT ) + deallocate(DEVSBT ) + deallocate(DEDTC ) + deallocate(DHSDQA ) + deallocate(CFT ) + deallocate(CFQ ) + deallocate(TCO ) + deallocate(QCO ) + deallocate(DQS ) + deallocate(QSAT ) + deallocate(RA ) + deallocate(CAT_ID ) + deallocate(ALWX ) + deallocate(BLWX ) + deallocate(ALWN ) + deallocate(BLWN ) + deallocate(TC1_0 ) + deallocate(TC2_0 ) + deallocate(TC4_0 ) + deallocate(QA1_0 ) + deallocate(QA2_0 ) + deallocate(QA4_0 ) + deallocate(fveg1 ) + deallocate(fveg2 ) + deallocate(RCONSTIT ) + deallocate(TOTDEPOS ) + deallocate(RMELT ) + deallocate(FICE1TMP ) + deallocate(SLDTOT ) + deallocate(FSW_CHANGE) + deallocate( btran ) + deallocate( wgt ) + deallocate( wpp ) + deallocate( fwet ) + deallocate( wet_in ) + deallocate( sm ) + deallocate( SWSRF1 ) + deallocate( SWSRF2 ) + deallocate( SWSRF4 ) + deallocate( tcx ) + deallocate( qax ) + deallocate( rcxdt ) + deallocate( rcxdq ) + deallocate( car1 ) + deallocate( car2 ) + deallocate( car4 ) + deallocate( parzone ) + deallocate( para ) + deallocate( totwat ) + deallocate( nfire ) + deallocate(som_closs) + deallocate( dayl ) + deallocate(dayl_fac ) + deallocate( fsnow ) + deallocate( ityp_tmp ) + deallocate( Qair_relative ) + deallocate( ndeploy ) + deallocate( denit ) + deallocate( sminn_leached ) + deallocate( sminn ) + deallocate( fire_nloss ) + deallocate( leafn ) + deallocate( leafc ) + deallocate( gross_nmin ) + deallocate( net_nmin ) + deallocate( nfix_to_sminn ) + deallocate( actual_immob ) + deallocate( fpg ) + deallocate( fpi ) + deallocate( sminn_to_plant ) + deallocate( sminn_to_npool ) + deallocate( ndep_to_sminn ) + deallocate( totvegn ) + deallocate( totlitn ) + deallocate( totsomn ) + deallocate( retransn ) + deallocate( retransn_to_npool ) + deallocate( fuelc ) + deallocate( totlitc ) + deallocate( cwdc ) + deallocate( rootc ) + deallocate( lnfm ) + + deallocate( tgw ) + deallocate( rzm ) + deallocate( rc00 ) + deallocate( rcdt ) + deallocate( rcdq ) + deallocate( totcolc ) + deallocate( wtzone ) + deallocate( sfm ) + deallocate( bt ) + deallocate( btran_fire ) + deallocate( albdir ) + deallocate( albdif ) + deallocate( elai ) + deallocate( esai ) + deallocate( fveg ) + deallocate( tlai ) + deallocate( psnsun ) + deallocate( psnsha ) + deallocate( laisun ) + deallocate( laisha ) + deallocate( ityp ) + deallocate( lmrsun ) + deallocate( lmrsha ) + deallocate( ht ) + deallocate( tp ) + deallocate( soilice ) + deallocate (PLSIN) + deallocate(TA_MIN) + deallocate(ta_count) + call MAPL_TimerOff ( MAPL, "-CATCHCNCLM51" ) + RETURN_(ESMF_SUCCESS) + + end subroutine Driver + +! Commented out functions betai(), betacf(), and gammln(). +! These functions are not used and were reproduced identically in +! GEOS_CatchCNCLM40GridComp.F90 and in GEOS_CatchCNCLM45GridComp.F90. +! Another copy was in GEOScatchCN_GridComp/utils/math_routines.F90 but +! there function betai() was missing the restriction 0.0125 0.9875) x = 0.9875 +! +! if(x.lt.0..or.x.gt.1.)print *, 'bad argument x in betai',x +! if(x.lt.0..or.x.gt.1.)stop +! if(x.eq.0..or.x.eq.1.)then +! bt=0. +! else +! bt=exp(gammln(a+b)-gammln(a)-gammln(b) & +! +a*log(x)+b*log(1.-x)) +! endif +! +! if(x.lt.(a+1.)/(a+b+2.))then +! betai=bt*betacf(a,b,x)/a +! return +! else +! betai=1.-bt*betacf(b,a,1.-x)/b +! return +! endif +! +! END FUNCTION betai +! +! ! ------------------------------------------------------- +! +! FUNCTION betacf(a,b,x) +! +! INTEGER MAXIT +! REAL betacf,a,b,x,EPS,FPMIN +! PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) +! INTEGER m,m2 +! REAL aa,c,d,del,h,qab,qam,qap +! +! qab=a+b +! qap=a+1. +! qam=a-1. +! c=1. +! d=1.-qab*x/qap +! +! if(abs(d).lt.FPMIN)d=FPMIN +! d=1./d +! h=d +! do m=1,MAXIT +! m2=2*m +! aa=m*(b-m)*x/((qam+m2)*(a+m2)) +! d=1.+aa*d +! if(abs(d).lt.FPMIN)d=FPMIN +! c=1.+aa/c +! if(abs(c).lt.FPMIN)c=FPMIN +! d=1./d +! h=h*d*c +! aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) +! d=1.+aa*d +! if(abs(d).lt.FPMIN)d=FPMIN +! c=1.+aa/c +! if(abs(c).lt.FPMIN)c=FPMIN +! d=1./d +! del=d*c +! h=h*del +! if(abs(del-1.).lt.EPS)exit +! enddo +! betacf=h +! return +! +! END FUNCTION betacf +! +! ! -------------------------------------------------------------- +! +! FUNCTION gammln(xx) +! +! REAL gammln,xx +! INTEGER j +! DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) +! +! SAVE cof,stp +! DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, & +! 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, & +! -.5395239384953d-5,2.5066282746310005d0/ +! x=xx +! y=x +! tmp=x+5.5d0 +! tmp=(x+0.5d0)*log(tmp)-tmp +! ser=1.000000000190015d0 +! do j=1,6 +! y=y+1.d0 +! ser=ser+cof(j)/y +! enddo +! gammln=tmp+log(stp*ser/x) +! return +! +! END FUNCTION gammln + + ! -------------------------------------------------------------- + + integer function VarID (NCFID, VNAME) + + integer, intent (in) :: NCFID + character(*), intent (in) :: VNAME + integer :: status + + STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID); VERIFY_(STATUS) + + end function VarID + +end subroutine RUN2 + +!BOP +! !IROUTINE: RUN0 -- Extra run method for the OFFLINE case, called by RUN1 +! !INTERFACE: + +subroutine RUN0(gc, import, export, clock, rc) + + ! !ARGUMENTS: + type(ESMF_GridComp), intent(inout) :: gc ! Gridded component + type(ESMF_State), intent(inout) :: import ! Import state + type(ESMF_State), intent(inout) :: export ! Export state + type(ESMF_Clock), intent(inout) :: clock ! The clock + integer, optional, intent( out) :: rc ! Error code + + ! !DESCRIPTION: In the OFFLINE case, some diagnostic vars (INTERNAL states + ! asnow and emis) are updated here. + !EOP + + ! ErrLog variables + integer :: status + character(len=ESMF_MAXSTR) :: Iam + character(len=ESMF_MAXSTR) :: comp_name + + ! Local variables + + !! ESMF/MAPL variables + type(MAPL_MetaComp), pointer :: MAPL + type(ESMF_State) :: INTERNAL + + !! IMPORT pointers + real, pointer :: ps (:)=>null() + + !! INTERNAL pointers + !! -asnow-emis-ww-fr- + real, pointer :: ity(:,:)=>null() + real, pointer :: fvg(:,:)=>null() + real, pointer :: asnow(:)=>null() + real, pointer :: emis(:)=>null() + real, pointer :: ww(:,:)=>null() + real, pointer :: fr(:,:)=>null() + real, pointer :: DCQ(:,:)=>null() + real, pointer :: DCH(:,:)=>null() + !! -prognostic-variables- + real, pointer :: tc(:,:)=>null() + real, pointer :: qc(:,:)=>null() + real, pointer :: htsnnn1(:)=>null() + real, pointer :: wesnn1(:)=>null() + real, pointer :: wesnn2(:)=>null() + real, pointer :: wesnn3(:)=>null() + real, pointer :: srfexc(:)=>null() + real, pointer :: rzexc(:)=>null() + real, pointer :: catdef(:)=>null() + !! -parameters- + real, pointer :: vgwmax(:)=>null() + real, pointer :: cdcr1(:)=>null() + real, pointer :: cdcr2(:)=>null() + real, pointer :: psis(:)=>null() + real, pointer :: bee(:)=>null() + real, pointer :: poros(:)=>null() + real, pointer :: wpwet(:)=>null() + real, pointer :: ars1(:)=>null() + real, pointer :: ars2(:)=>null() + real, pointer :: ars3(:)=>null() + real, pointer :: ara1(:)=>null() + real, pointer :: ara2(:)=>null() + real, pointer :: ara3(:)=>null() + real, pointer :: ara4(:)=>null() + real, pointer :: arw1(:)=>null() + real, pointer :: arw2(:)=>null() + real, pointer :: arw3(:)=>null() + real, pointer :: arw4(:)=>null() + real, pointer :: bf1(:)=>null() + real, pointer :: bf2(:)=>null() + + !! Miscellaneous + integer :: ntiles, nv, nz + real, allocatable :: dummy(:) + real, allocatable :: dzsf(:), ar1(:), ar2(:), wesnn(:,:) + real, allocatable :: catdefcp(:), srfexccp(:), rzexccp(:) + real, allocatable :: VEG1(:), VEG2(:) + integer, allocatable :: ityp(:,:,:) + real, allocatable :: fveg(:,:,:), elai(:,:,:), esai(:,:,:), wtzone(:,:), lai1(:), lai2(:), wght(:) + real, allocatable,dimension(:) :: fveg1, fveg2 + + type(T_CATCHCN_STATE), pointer :: catchcn_internal + type(CATCHCN_WRAP) :: wrap + + ! Begin... + + ! Get component name and setup traceback handle + call ESMF_GridCompGet(gc, name=comp_name, rc=status) + VERIFY_(status) + Iam = trim(comp_name)//"::RUN0" + + ! Get MAPL object + call MAPL_GetObjectFromGC(gc, MAPL, rc=status) + VERIFY_(status) + + ! Get component's internal ESMF state + call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, rc=status) + VERIFY_(status) + + call ESMF_UserCompGetInternalState(gc, 'CatchcnInternal', wrap, status) + VERIFY_(status) + catchcn_internal => wrap%ptr + ! Pointers to IMPORTs + call MAPL_GetPointer(import, ps, 'PS', rc=status) + VERIFY_(status) + + ! Pointers to EXPORTs + call MAPL_GetPointer(export, asnow, 'ASNOW', rc=status) + VERIFY_(status) + call MAPL_GetPointer(export, emis, 'EMIS', rc=status) + VERIFY_(status) + + ! Pointers to INTERNALs + call MAPL_GetPointer(INTERNAL, ITY, 'ITY', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, FVG, 'FVG', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, fr, 'FR', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, ww, 'WW', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, DCQ, 'DCQ', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, DCH, 'DCH', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, tc, 'TC', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, qc, 'QC', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, htsnnn1, 'HTSNNN1', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, wesnn1, 'WESNN1', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, wesnn2, 'WESNN2', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, wesnn3, 'WESNN3', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, vgwmax, 'VGWMAX', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, cdcr1, 'CDCR1', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, cdcr2, 'CDCR2', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, psis, 'PSIS', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, bee, 'BEE', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, poros, 'POROS', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, wpwet, 'WPWET', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, ars1, 'ARS1', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, ars2, 'ARS2', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, ars3, 'ARS3', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, ara1, 'ARA1', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, ara2, 'ARA2', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, ara3, 'ARA3', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, ara4, 'ARA4', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, arw1, 'ARW1', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, arw2, 'ARW2', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, arw3, 'ARW3', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, arw4, 'ARW4', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, bf1, 'BF1', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, bf2, 'BF2', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, srfexc, 'SRFEXC', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, rzexc, 'RZEXC', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, catdef, 'CATDEF', rc=status) + VERIFY_(status) + + ! Number of tiles and a dummy real array + ntiles = size(HTSNNN1) + + allocate(dummy(ntiles), stat=status) + VERIFY_(status) + ! Reset WW + WW = 0. + + ! get CNLAI to compute emmissivity + allocate(fveg1 (NTILES)) + allocate(fveg2 (NTILES)) + allocate(veg1(ntiles), stat=status) + VERIFY_(status) + allocate(veg2(ntiles), stat=status) + VERIFY_(status) + allocate( ityp(ntiles,num_veg,num_zon) ) + allocate( fveg(ntiles,num_veg,num_zon) ) + allocate( wtzone(ntiles,num_zon) ) + allocate( elai(ntiles,num_veg,num_zon) ) + allocate( esai(ntiles,num_veg,num_zon) ) + + allocate ( lai1(ntiles) ) + allocate ( lai2(ntiles) ) + allocate ( wght(ntiles) ) + +! set CLM CN PFT & fraction, set carbon zone weights +! -------------------------------------------------- + do nz = 1,num_zon + ityp(:,:,nz) = nint(ity(:,:)) + fveg(:,:,nz) = fvg(:,:) + wtzone(:,nz) = CN_zone_weight(nz) + end do + + call get_CN_LAI(ntiles,ityp,fveg,elai,esai=esai) + + lai1 = 0. + wght = 0. + do nz = 1,num_zon + nv = 1 + lai1(:) = lai1(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) + wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) + end do + lai1 = lai1 / max(wght,1.e-8) ! LAI for primary vegetation type + + lai2 = 0. + wght = 0. + do nz = 1,num_zon + nv = 2 + lai2(:) = lai2(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) + wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) + end do + lai2 = lai2 / max(wght,1.e-8) ! LAI for secondary vegetation type + + deallocate ( ityp ) + deallocate ( fveg ) + deallocate ( elai ) + deallocate ( esai ) + deallocate ( wtzone ) + +! Vegetation types used to index into tables +!-------------------------------------------- + + where(ITY(:,1) > 0.) + VEG1 = map_cat(nint(ITY(:,1))) ! gkw: primary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 + endwhere + where(ITY(:,2) > 0.) + VEG2 = map_cat(nint(ITY(:,2))) ! gkw: secondary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 + endwhere + _ASSERT((count(VEG1>NTYPS.or.VEG1<1)==0),'needs informative message') + _ASSERT((count(VEG2>NTYPS.or.VEG2<1)==0),'needs informative message') + fveg1(:) = fvg(:,1) + fveg2(:) = fvg(:,2) + + ! Compute ASNOW and EMIS + allocate(wesnn(3,ntiles), stat=status) + VERIFY_(status) + wesnn(1,:) = wesnn1 + wesnn(2,:) = wesnn2 + wesnn(3,:) = wesnn3 + call StieglitzSnow_calc_asnow(N_snow, ntiles, wesnn, asnow) + + EMIS = fveg1*(EMSVEG(NINT(VEG1)) + (EMSBARESOIL - EMSVEG(NINT(VEG1)))*exp(-LAI1)) + & + fveg2*(EMSVEG(NINT(VEG2)) + (EMSBARESOIL - EMSVEG(NINT(VEG2)))*exp(-LAI2)) + + emis = emis*(1.-asnow) + EMSSNO*asnow + + ! Compute FR + ! Step 1: set dzsf + ! Step 2: compute ar1, ar2 via call to catch_calc_soil_moist() + ! Step 3: compute fr + + ! -step-1- + allocate(dzsf(ntiles), stat=status) + VERIFY_(status) + dzsf = catchcn_internal%SURFLAY + + ! -step-2- + allocate(ar1(ntiles), stat=status) + VERIFY_(status) + allocate(ar2(ntiles), stat=status) + VERIFY_(status) + ! -we-don't-want-to-modify-srfexc-rzexc-and-catdef- + ! -so-we-create-local-copies- + allocate(catdefcp(ntiles), stat=status) + VERIFY_(status) + allocate(srfexccp(ntiles), stat=status) + VERIFY_(status) + allocate(rzexccp(ntiles), stat=status) + VERIFY_(status) + catdefcp = catdef + srfexccp = srfexc + rzexccp = rzexc + call catch_calc_soil_moist( & + ! intent(in) + ntiles, dzsf, vgwmax, cdcr1, cdcr2, & + psis, bee, poros, wpwet, & + ars1, ars2, ars3, & + ara1, ara2, ara3, ara4, & + arw1, arw2, arw3, arw4, bf1, bf2, & + ! intent(inout) + ! from process_cat + srfexccp, rzexccp, catdefcp, & + ! use this one can match process_cat + ! srfexc, rzexc, catdef, & + ! intent(out) + ar1, ar2, dummy & + ) + + fr(:,FSAT) = ar1 * (1-asnow) + fr(:,FTRN) = ar2 * (1-asnow) + fr(:,FWLT) = (1.0-(ar1+ar2))* (1-asnow) + fr(:,FSNW) = asnow + fr = min(max(fr,0.0),1.0) + + ! Overwrite the top layer snow temperature tc(4) with its diagnosed value + call StieglitzSnow_calc_tpsnow(ntiles, htsnnn1, wesnn1, tc(:,4), dummy) + tc(:,FSNW) = tc(:,FSNW) + MAPL_TICE ! Convert to K + + ! Overwrite qc(4) + !qc(:,FSNW) = GEOS_QSAT(tc(:,FSNW), PS, PASCALS=.true., RAMP=0.0) + qc(:,FSNW) = MAPL_EQsat(tc(:,FSNW),PS,OverIce=.true.) + + ! Clean up + if (allocated(catdefcp)) deallocate(catdefcp) + if (allocated(srfexccp)) deallocate(srfexccp) + if (allocated(rzexccp)) deallocate(rzexccp) + if (allocated(dummy)) deallocate(dummy) + if (allocated(dzsf)) deallocate(dzsf) + if (allocated(ar1)) deallocate(ar1) + if (allocated(ar2)) deallocate(ar2) + if (allocated(wesnn)) deallocate(wesnn) + if (allocated(fveg1)) deallocate (fveg1) + if (allocated(fveg2)) deallocate (fveg2) + if (allocated(veg1)) deallocate (veg1) + if (allocated(veg2)) deallocate (veg2) + if (allocated(lai1)) deallocate (lai1) + if (allocated(lai2)) deallocate (lai2) + if (allocated(wght)) deallocate (wght) + + ! All done + RETURN_(ESMF_SUCCESS) + +end subroutine RUN0 + +end module GEOS_CatchCNCLM51GridCompMod + +subroutine SetServices(gc, rc) + use ESMF + use GEOS_CatchCNCLM51GridCompMod, only : mySetservices=>SetServices + type(ESMF_GridComp) :: gc + integer, intent(out) :: rc + call mySetServices(gc, rc=rc) +end subroutine diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchcn_iau.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchcn_iau.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/clm_varpar_shared.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/clm_varpar_shared.F90 old mode 100644 new mode 100755 index c5d39f267..c543cfab5 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/clm_varpar_shared.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/clm_varpar_shared.F90 @@ -16,14 +16,19 @@ module clm_varpar_shared ! ! Define number of levels - integer, parameter :: numpft_CN = 19 ! actual # of pfts (without bare), same as in Catchment-CN.clm4 + integer, parameter :: numpft_CN = 19 ! actual # of pfts (without bare) for Catchment-CN4.0 and Catchment-CN4.5 + integer, parameter :: numpft_CN51 = 15 ! actual # of pfts (without bare) for Catchment-CN5.1 integer, parameter, PUBLIC :: NUM_ZON_CN=3 ! number of CN hydrology zones per tile - integer, parameter, PUBLIC :: NUM_VEG_CN=4 ! number of CN PFTs per zone + integer, parameter, PUBLIC :: NUM_VEG_CN=4 ! number of CN PFTs per zone for Catchment-CN4.0 and Catchment-CN4.5 + integer, parameter, PUBLIC :: NUM_VEG_CN51 = 2 ! number of CN PFTs per zone for Catchment-CN5.1 integer, parameter, PUBLIC :: VAR_COL_40=40 ! number of CN column restart variables integer, parameter, PUBLIC :: VAR_PFT_40=74 ! number of CN PFT variables per column integer, parameter, PUBLIC :: VAR_COL_45=35 ! number of CN column restart variables integer, parameter, PUBLIC :: VAR_PFT_45=75 ! number of CN PFT variables per column + integer, parameter, PUBLIC :: VAR_COL_51=37 ! number of CN column restart variables + integer, parameter, PUBLIC :: VAR_PFT_51=83 ! number of CN PFT restart variables + !------------------------------------------------------------------------------ end module clm_varpar_shared diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/dbg_cnlsm_offline.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/dbg_cnlsm_offline.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catch_incr.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catch_incr.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/catchment.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/dbg_clsm_offline.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/dbg_clsm_offline.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/m_dbg_routines.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/m_dbg_routines.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSigni_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSigni_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSigni_GridComp/GEOS_IgniGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSigni_GridComp/GEOS_IgniGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSigni_GridComp/GEOS_IgniGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSigni_GridComp/GEOS_IgniGridComp.rc old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSigni_GridComp/tests/Makefile b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSigni_GridComp/tests/Makefile old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build_rivernetwork.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build_rivernetwork.py old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSvegdyn_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSvegdyn_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSvegdyn_GridComp/GEOS_VegdynGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSvegdyn_GridComp/GEOS_VegdynGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_constants.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_constants.f90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/lsm_routines.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/sibalb_coeff.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/sibalb_coeff.f90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/update_model_paras.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/update_model_paras.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferPacking.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferPacking.h old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferPacking_RUN1.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferPacking_RUN1.h old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferUnpacking.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferUnpacking.h old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferUnpacking_RUN1.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/BufferUnpacking_RUN1.h old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_CICE4ColumnPhysGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_CICE4ColumnPhysGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_ObioImportsGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_ObioImportsGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SaltWaterGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SaltWaterGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GetPtr.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GetPtr.h old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GetPtr_RUN1.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GetPtr_RUN1.h old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/OASIMalbedoMod.f b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/OASIMalbedoMod.f old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 index 2a7fdaf59..4bfe5deca 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 @@ -109,23 +109,23 @@ subroutine SurfParams_init(LAND_PARAMS,LSM_CHOICE, rc) _ASSERT(.FALSE.,'LAND_PARAMS not valid or incompatible with LSM_CHOICE') end select -! else if (LSM_CHOICE==3) then -! select case (LAND_PARAMS) -! -! case ("CN_CLM45") ! parameters to reproduce Eunjee Lee's Catchment-CN4.5 fire carbon emission simulations -! LAND_FIX = .TRUE. -! CSOIL_2 = 70000. ! Post H5_0 -! WEMIN = 13. -! AICEV = 0.107 -! AICEN = 19.893 -! FLWALPHA = 0.005 -! ASTRFR = 0.333 ! reverted -! STEXP = 1. ! reverted -! RSWILT = 2000. -! -! case DEFAULT -! _ASSERT(.FALSE.,'LAND_PARAMS not valid or incompatible with LSM_CHOICE') -! end select + else if (LSM_CHOICE==4) then + select case (LAND_PARAMS) + + case ("CN_CLM51") + LAND_FIX = .TRUE. + CSOIL_2 = 70000. ! Post H5_0 + WEMIN = 13. + AICEV = 0.107 + AICEN = 19.893 + FLWALPHA = 0.005 + ASTRFR = 0.333 ! reverted + STEXP = 1. ! reverted + RSWILT = 2000. + + case DEFAULT + _ASSERT(.FALSE.,'LAND_PARAMS not valid or incompatible with LSM_CHOICE') + end select else _ASSERT(.FALSE.,'land model choice not valid') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/LDAS_DateTimeMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/LDAS_DateTimeMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/read_riveroutlet.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/read_riveroutlet.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/util.c b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/util.c old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/zip.c b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/zip.c old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/README b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/README old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/chk_clsm_params.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/chk_clsm_params.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/compare_bcs.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/compare_bcs.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/modis_scale_factor.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/modis_scale_factor.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/mosaic_classes_on_tiles.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/mosaic_classes_on_tiles.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/plot_curves.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/plot_curves.csh old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/plot_curves.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/plot_curves.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/plot_geos5_grid.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/plot_geos5_grid.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/soil_types_on_tiles.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/misc/soil_types_on_tiles.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/README b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/README old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/soil/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/soil/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/soil/loss_during_day.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/soil/loss_during_day.f90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/soil/loss_surf_5cm_gensoil.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/soil/loss_surf_5cm_gensoil.f90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/soil/m_loss_during_routines.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/soil/m_loss_during_routines.f90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/.gitignore b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/.gitignore old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 old mode 100644 new mode 100755 index 43a16b7b9..e98bae6c4 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 @@ -7,21 +7,28 @@ module CatchmentCNRstMod use ESMF use MAPL use CatchmentRstMod, only : CatchmentRst - use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg => NUM_VEG_CN, & + use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg_40 => NUM_VEG_CN, nveg_51 => NUM_VEG_CN51, & VAR_COL_40, VAR_PFT_40, VAR_COL_45, VAR_PFT_45, & - npft => numpft_CN + VAR_COL_51, VAR_PFT_51, & + npft => numpft_CN, npft_51 => numpft_CN51 use nanMod , only : nan implicit none real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) + integer :: iclass_40(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) + integer :: iclass_45(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) + integer :: iclass_51(npft_51) = (/1,1,2,3,3,4,5,5,6,7,9,10,11,11,11/) + integer, dimension(:), allocatable :: iclass type, extends(CatchmentRst) :: CatchmentCNRst logical :: isCLM45 + logical :: isCLM51 logical :: isCLM40 + integer :: VAR_COL integer :: VAR_PFT + integer :: NVEG real, allocatable :: cnity(:,:) real, allocatable :: fvg(:,:) real, allocatable :: tg(:,:) @@ -62,6 +69,14 @@ module CatchmentCNRstMod real, allocatable :: sfmcm(:) real, allocatable :: psnsunm(:,:,:) real, allocatable :: psnsham(:,:,:) + real, allocatable :: lmrsunm(:,:,:) + real, allocatable :: lmrsham(:,:,:) + real, allocatable :: laisunm(:,:,:) + real, allocatable :: laisham(:,:,:) + real, allocatable :: rh30d(:) + real, allocatable :: tg10d(:) + real, allocatable :: t2mmin5d(:) + real, allocatable :: sndzm5d(:) contains procedure :: write_nc4 @@ -99,7 +114,9 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) catch%isCLM45 = .false. + catch%isCLM51 = .false. catch%isCLM40 = .false. + call formatter%open(filename, pFIO_READ, __RC__) meta = formatter%read(__RC__) ntiles = meta%get_dimension('tile', __RC__) @@ -110,11 +127,19 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) catch%isCLM40 = .true. catch%VAR_COL = VAR_COL_40 catch%VAR_PFT = VAR_PFT_40 + catch%NVEG = nveg_40 endif if (index(cnclm, '45') /=0) then catch%isCLM45 = .true. catch%VAR_COL = VAR_COL_45 catch%VAR_PFT = VAR_PFT_45 + catch%nveg = nveg_40 + endif + if (index(cnclm, '51') /=0) then + catch%VAR_COL = VAR_COL_51 + catch%VAR_PFT = VAR_PFT_51 + catch%isCLM51 = .true. + catch%nveg = nveg_51 endif if (myid == 0) then @@ -156,6 +181,31 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) call MAPL_VarRead(formatter,"TPREC60D", catch%TPREC60D , __RC__) call MAPL_VarRead(formatter,"SFMM", catch%sfmm , __RC__) endif + + if( catch%isCLM51) then + call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) + call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) + call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) + call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) + call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) + call MAPL_VarRead(formatter,"RHM", catch%RHM , __RC__) + call MAPL_VarRead(formatter,"WINDM", catch%WINDM , __RC__) + call MAPL_VarRead(formatter,"RAINFM", catch%RAINFM , __RC__) + call MAPL_VarRead(formatter,"SNOWFM", catch%SNOWFM , __RC__) + call MAPL_VarRead(formatter,"RUNSRFM", catch%RUNSRFM, __RC__) + call MAPL_VarRead(formatter,"AR1M", catch%AR1M , __RC__) + call MAPL_VarRead(formatter,"SNDZM5D", catch%SNDZM5D , __RC__) + call MAPL_VarRead(formatter,"T2M10D", catch%T2M10D , __RC__) + call MAPL_VarRead(formatter,"T2MMIN5D",catch%T2MMIN5D, __RC__) + call MAPL_VarRead(formatter,"TG10D", catch%TG10D , __RC__) + call MAPL_VarRead(formatter,"RH30D", catch%RH30D , __RC__) + call MAPL_VarRead(formatter,"TPREC10D",catch%TPREC10D, __RC__) + call MAPL_VarRead(formatter,"TPREC60D",catch%TPREC60D, __RC__) + endif + do j=1,dim1 + call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) + enddo + call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL, __RC__) ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 @@ -177,6 +227,10 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) call MAPL_VarRead(formatter, "ASNOWM", catch%asnowm ,_RC) call MAPL_VarRead(formatter, "PSNSUNM", catch%psnsunm,_RC) call MAPL_VarRead(formatter, "PSNSHAM", catch%psnsham,_RC) + call MAPL_VarRead(formatter, "LMRSUNM", catch%lmrsunm,_RC) + call MAPL_VarRead(formatter, "LMRSHAM", catch%lmrsham,_RC) + call MAPL_VarRead(formatter, "LAISUNM", catch%psnsunm,_RC) + call MAPL_VarRead(formatter, "LAISHAM", catch%psnsham,_RC) call MAPL_VarRead(formatter, "RZMM", catch%rzmm ,_RC) call MAPL_VarRead(formatter, "TGWM", catch%tgwm ,_RC) endif @@ -196,7 +250,9 @@ function CatchmentCNRst_empty(meta, cnclm, time, rc) result (catch) character(len=256) :: Iam = "CatchmentCNRst_empty" catch%isCLM45 = .false. + catch%isCLM51 = .false. catch%isCLM40 = .false. + catch%ntiles = meta%get_dimension('tile', __RC__) catch%time = time catch%meta = meta @@ -210,6 +266,11 @@ function CatchmentCNRst_empty(meta, cnclm, time, rc) result (catch) catch%VAR_COL = VAR_COL_45 catch%VAR_PFT = VAR_PFT_45 endif + if (index(cnclm, '51') /=0) then + catch%VAR_COL = VAR_COL_51 + catch%VAR_PFT = VAR_PFT_51 + catch%isCLM51 = .true. + endif call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) if (myid ==0) call catch%allocate_cn(__RC__) @@ -278,6 +339,36 @@ subroutine write_nc4(this, filename, rc) call MAPL_VarWrite(formatter,"T2M10D", this%t2m10d ) call MAPL_VarWrite(formatter,"TPREC10D",this%tprec10d ) call MAPL_VarWrite(formatter,"TPREC60D",this%tprec60d ) + call MAPL_VarWrite(formatter,"LMRSUNM", this%LMRSUNM ) + call MAPL_VarWrite(formatter,"LMRSHAM", this%LMRSHAM ) + + elseif (this%isCLM51) then + + call MAPL_VarWrite(formatter,"SFMM", this%sfmm) + + call MAPL_VarWrite(formatter,"ABM", this%ABM, rc =rc ) + call MAPL_VarWrite(formatter,"FIELDCAP",this%FIELDCAP) + call MAPL_VarWrite(formatter,"HDM", this%HDM ) + call MAPL_VarWrite(formatter,"GDP", this%GDP ) + call MAPL_VarWrite(formatter,"PEATF", this%PEATF ) + call MAPL_VarWrite(formatter,"RHM", this%RHM) + call MAPL_VarWrite(formatter,"WINDM", this%WINDM) + call MAPL_VarWrite(formatter,"RAINFM", this%RAINFM) + call MAPL_VarWrite(formatter,"SNOWFM", this%SNOWFM) + call MAPL_VarWrite(formatter,"RUNSRFM", this%RUNSRFM) + call MAPL_VarWrite(formatter,"AR1M", this%AR1M) + call MAPL_VarWrite(formatter,"SNDZM5D", this%SNDZM5D) + call MAPL_VarWrite(formatter,"T2M10D", this%T2M10D) + call MAPL_VarWrite(formatter,"T2MMIN5D",this%T2MMIN5D) + call MAPL_VarWrite(formatter,"TG10D", this%TG10D) + call MAPL_VarWrite(formatter,"RH30D", this%RH30D) + call MAPL_VarWrite(formatter,"TPREC10D",this%TPREC10D) + call MAPL_VarWrite(formatter,"TPREC60D",this%TPREC60D) + call MAPL_VarWrite(formatter,"LMRSUNM", this%LMRSUNM ) + call MAPL_VarWrite(formatter,"LMRSHAM", this%LMRSHAM ) + call MAPL_VarWrite(formatter,"LAISUNM", this%LAISUNM ) + call MAPL_VarWrite(formatter,"LAISHAM", this%LAISHAM ) + endif if (this%isCLM40) call MAPL_VarWrite(formatter,"SFMCM", this%sfmcm) @@ -294,8 +385,10 @@ subroutine allocate_cn(this,rc) class(CatchmentCNRst), intent(inout) :: this integer, optional, intent(out):: rc integer :: status - integer :: ncol,npft, ntiles - + integer :: ncol,npft, ntiles, nveg + + + nveg = this%NVEG ntiles = this%ntiles ncol = nzone* this%VAR_COL npft = nzone*nveg*this%VAR_PFT @@ -330,10 +423,13 @@ subroutine allocate_cn(this,rc) allocate(this%asnowm (ntiles)) allocate(this%psnsunm(ntiles,nveg,nzone)) allocate(this%psnsham(ntiles,nveg,nzone)) + allocate(this%lmrsunm(ntiles,nveg,nzone)) + allocate(this%lmrsham(ntiles,nveg,nzone)) + allocate(this%laisunm(ntiles,nveg,nzone)) + allocate(this%laisham(ntiles,nveg,nzone)) allocate(this%rzmm (ntiles,nzone)) allocate(this%tgwm (ntiles,nzone)) - if (this%isCLM40) then allocate(this%sfmcm (ntiles)) endif @@ -349,6 +445,22 @@ subroutine allocate_cn(this,rc) allocate(this%t2m10d (ntiles)) allocate(this%sfmm (ntiles,nzone)) endif + if (this%isCLM51) then + allocate(this%ar1m (ntiles)) + allocate(this%rainfm (ntiles)) + allocate(this%rhm (ntiles)) + allocate(this%runsrfm (ntiles)) + allocate(this%snowfm (ntiles)) + allocate(this%windm (ntiles)) + allocate(this%tprec10d(ntiles)) + allocate(this%tprec60d(ntiles)) + allocate(this%t2m10d (ntiles)) + allocate(this%sfmm (ntiles,nzone)) + allocate(this%rh30d (ntiles)) + allocate(this%tg10d (ntiles)) + allocate(this%t2mmin5d(ntiles)) + allocate(this%sndzm5d (ntiles)) + endif _RETURN(_SUCCESS) end subroutine allocate_cn @@ -364,14 +476,17 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) real, allocatable :: T2(:), hdm(:), fc(:), gdp(:), peatf(:) integer, allocatable :: ity(:), abm (:) integer :: STATUS, ntiles, unit27, unit28, unit29, unit30 - integer :: idum, i,j,n, ib, nv + integer :: idum, i,j,n, ib, nv, nveg real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) + integer, dimension(npft) :: map_pft logical :: NEWLAND logical :: file_exists type(NetCDF4_Fileformatter) :: CatchCNFmt character*256 :: Iam = "add_bcs" + nveg = this%nveg + open (10,file =trim(OutBcsDir)//"/clsm/catchment.def",status='old',form='formatted') read (10,*) ntiles close (10, status = 'keep') @@ -425,7 +540,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) endif - if (this%isCLM45 ) then + if ((this%isCLM45) .or. (this%isCLM51)) then open(newunit=unit30, file=trim(OutBcsDir)//'/clsm/CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') do n=1,ntiles @@ -512,8 +627,49 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) endif enddo - this%cnity = reshape([CLMC_pt1,CLMC_pt2,CLMC_st1,CLMC_st2],[ntiles,4]) - this%fvg = reshape([CLMC_pf1,CLMC_pf2,CLMC_sf1,CLMC_sf2],[ntiles,4]) + ! if using Catchment-CN5.1, reduce down to 2 PFTs + ! step 1: map split PFTs to their parent type + ! step 2: add up area fractions + + if (this%isCLM51) then + + map_pft = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 10, 11, 12, 13, 13, 14, 14, 15, 15 /) + + do n = 1,ntiles + + ! map split PFTs to parent PFTs + CLMC_pt1(n) = map_pft(CLMC_pt1(n)) + CLMC_pt2(n) = map_pft(CLMC_pt2(n)) + CLMC_st1(n) = map_pft(CLMC_st1(n)) + CLMC_st2(n) = map_pft(CLMC_st2(n)) + + ! combine area fractions of same PFTs, + ! otherwise retain area fraction of single present PFT + + if (CLMC_pt1(n).eq.CLMC_pt2(n)) then + CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) + CLMC_pf2(n) = 0. + else if (CLMC_pt1(n).ne.CLMC_pt2(n)) then + CLMC_pf1(n) = maxval((/ CLMC_pf1(n), CLMC_pf2(n) /)) + endif + + if (CLMC_st1(n).eq.CLMC_st2(n)) then + CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) + CLMC_sf2(n) = 0. + else if (CLMC_st1(n).ne.CLMC_st2(n)) then + CLMC_sf1(n) = maxval((/ CLMC_sf1(n), CLMC_sf2(n) /)) + endif + end do + + endif + + if ((this%isCLM40).or.(this%isCLM45)) then + this%cnity = reshape([CLMC_pt1,CLMC_pt2,CLMC_st1,CLMC_st2],[ntiles,4]) + this%fvg = reshape([CLMC_pf1,CLMC_pf2,CLMC_sf1,CLMC_sf2],[ntiles,4]) + elseif (this%isCLM51) then + this%cnity = reshape([CLMC_pt1,CLMC_st1],[ntiles,2]) + this%fvg = reshape([CLMC_pf1,CLMC_sf1],[ntiles,2]) + endif this%ndep = ndep this%t2 = t2 @@ -522,7 +678,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) this%BGALBNR = BNIRDR this%BGALBNF = BNIRDF - if (this%isCLM45) then + if ((this%isCLM45) .or. (this%isCLM51))then this%abm = real(abm) this%fieldcap = fc this%hdm = hdm @@ -555,12 +711,13 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 integer :: AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR=0,AGCM_DATE, & AGCM_MI, AGCM_S, dofyr + real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, tg_tmp, dummy_tmp real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:), var_out(:), var_psn(:,:,:), & - var_out_zone(:,:) - integer :: status, in_ntiles, out_ntiles, numprocs + var_out_zone(:,:), var_lmr(:,:,:), var_lai(:,:,:) + integer :: status, in_ntiles, out_ntiles, numprocs, npft_int logical :: root_proc - integer :: mpierr, n, i, k, tag, req, st, ed, myid, L, iv, nv,nz, var_col, var_pft + integer :: mpierr, n, i, k, tag, req, st, ed, myid, L, iv, nv,nz, var_col, var_pft, nveg real, allocatable, dimension(:) :: lat_tmp type(MAPL_SunOrbit) :: ORBIT type(ESMF_Time) :: CURRENT_TIME @@ -570,7 +727,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) character(*), parameter :: Iam = "CatchmentCN::Re_tile" - + nveg = this%NVEG in_ntiles = this%ntiles var_pft = this%var_pft var_col = this%var_col @@ -668,26 +825,44 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) ityp_offl = this%cnity fveg_offl = this%fvg + if ((this%isCLM40) .or. (this%isCLM45)) then + npft_int = npft + else if (this%isCLM51) then + npft_int = npft_51 + endif + do n = 1, in_ntiles do nv = 1,nveg - if(ityp_offl(n,nv)<0 .or. ityp_offl(n,nv)>npft) stop 'ityp' + if(ityp_offl(n,nv)<0 .or. ityp_offl(n,nv)>npft_int) stop 'ityp' if(fveg_offl(n,nv)<0..or. fveg_offl(n,nv)>1.00001) stop 'fveg' end do if (nint(this%tile_id(n)) /= n) stop ("cannot assign ity_offl to cnity and fvg_offl to fvg") - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then - if(ityp_offl(N,1) /= 0) then - ityp_offl(N,3) = ityp_offl(N,1) - else - ityp_offl(N,3) = ityp_offl(N,2) + if ((this%isCLM40) .or. (this%isCLM45)) then + + if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then + if(ityp_offl(N,1) /= 0) then + ityp_offl(N,3) = ityp_offl(N,1) + else + ityp_offl(N,3) = ityp_offl(N,2) + endif endif - endif - if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) ityp_offl(N,1) = ityp_offl(N,2) - if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) ityp_offl(N,2) = ityp_offl(N,1) - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) /= 0)) ityp_offl(N,3) = ityp_offl(N,4) - if((ityp_offl(N,4) == 0).and.(ityp_offl(N,3) /= 0)) ityp_offl(N,4) = ityp_offl(N,3) + if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) ityp_offl(N,1) = ityp_offl(N,2) + if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) ityp_offl(N,2) = ityp_offl(N,1) + if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) /= 0)) ityp_offl(N,3) = ityp_offl(N,4) + if((ityp_offl(N,4) == 0).and.(ityp_offl(N,3) /= 0)) ityp_offl(N,4) = ityp_offl(N,3) + + elseif (this%isCLM51) then + + if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) then + ityp_offl(N,1) = ityp_offl(N,2) + else if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) then + ityp_offl(N,2) = ityp_offl(N,1) + endif + + endif end do endif @@ -703,36 +878,57 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) st = low_ind(i+1) l = nt_local(i+1) tag = i*numprocs - call MPI_send(this%cnity(st,1),l, MPI_REAL, i, tag, MPI_COMM_WORLD, mpierr) - call MPI_send(this%cnity(st,2),l, MPI_REAL, i, tag+1, MPI_COMM_WORLD, mpierr) - call MPI_send(this%cnity(st,3),l, MPI_REAL, i, tag+2, MPI_COMM_WORLD, mpierr) - call MPI_send(this%cnity(st,4),l, MPI_REAL, i, tag+3, MPI_COMM_WORLD, mpierr) - call MPI_send(this%fvg(st,1),l, MPI_REAL, i, tag+4, MPI_COMM_WORLD, mpierr) - call MPI_send(this%fvg(st,2),l, MPI_REAL, i, tag+5, MPI_COMM_WORLD, mpierr) - call MPI_send(this%fvg(st,3),l, MPI_REAL, i, tag+6, MPI_COMM_WORLD, mpierr) - call MPI_send(this%fvg(st,4),l, MPI_REAL, i, tag+7, MPI_COMM_WORLD, mpierr) + if ((this%isCLM40) .or. (this%isCLM45)) then + call MPI_send(this%cnity(st,1),l, MPI_REAL, i, tag, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,2),l, MPI_REAL, i, tag+1, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,3),l, MPI_REAL, i, tag+2, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,4),l, MPI_REAL, i, tag+3, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,1),l, MPI_REAL, i, tag+4, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,2),l, MPI_REAL, i, tag+5, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,3),l, MPI_REAL, i, tag+6, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,4),l, MPI_REAL, i, tag+7, MPI_COMM_WORLD, mpierr) + else if (this%isCLM51) then + call MPI_send(this%cnity(st,1),l, MPI_REAL, i, tag, MPI_COMM_WORLD, mpierr) + call MPI_send(this%cnity(st,2),l, MPI_REAL, i, tag+1, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,1),l, MPI_REAL, i, tag+2, MPI_COMM_WORLD, mpierr) + call MPI_send(this%fvg(st,2),l, MPI_REAL, i, tag+3, MPI_COMM_WORLD, mpierr) + endif enddo st = low_ind(1) l = nt_local(1) ed = st + l -1 - CLMC_pt1 = this%cnity(st:ed,1) - CLMC_pt2 = this%cnity(st:ed,2) - CLMC_st1 = this%cnity(st:ed,3) - CLMC_st2 = this%cnity(st:ed,4) - CLMC_pf1 = this%fvg(st:ed,1) - CLMC_pf2 = this%fvg(st:ed,2) - CLMC_sf1 = this%fvg(st:ed,3) - CLMC_sf2 = this%fvg(st:ed,4) + if ((this%isCLM40) .or. (this%isCLM45)) then + CLMC_pt1 = this%cnity(st:ed,1) + CLMC_pt2 = this%cnity(st:ed,2) + CLMC_st1 = this%cnity(st:ed,3) + CLMC_st2 = this%cnity(st:ed,4) + CLMC_pf1 = this%fvg(st:ed,1) + CLMC_pf2 = this%fvg(st:ed,2) + CLMC_sf1 = this%fvg(st:ed,3) + CLMC_sf2 = this%fvg(st:ed,4) + elseif (this%isCLM51) then + CLMC_pt1 = this%cnity(st:ed,1) + CLMC_st1 = this%cnity(st:ed,2) + CLMC_pf1 = this%fvg(st:ed,1) + CLMC_sf1 = this%fvg(st:ed,2) + endif else tag = myid*numprocs - call MPI_RECV(CLMC_pt1,nt_local(myid+1) , MPI_REAL, 0, tag, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_pt2,nt_local(myid+1) , MPI_REAL, 0, tag+1, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_st1,nt_local(myid+1) , MPI_REAL, 0, tag+2, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_st2,nt_local(myid+1) , MPI_REAL, 0, tag+3, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_pf1,nt_local(myid+1) , MPI_REAL, 0, tag+4, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_pf2,nt_local(myid+1) , MPI_REAL, 0, tag+5, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_sf1,nt_local(myid+1) , MPI_REAL, 0, tag+6, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(CLMC_sf2,nt_local(myid+1) , MPI_REAL, 0, tag+7, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + if ((this%isCLM40) .or. (this%isCLM45)) then + call MPI_RECV(CLMC_pt1,nt_local(myid+1) , MPI_REAL, 0, tag, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pt2,nt_local(myid+1) , MPI_REAL, 0, tag+1, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_st1,nt_local(myid+1) , MPI_REAL, 0, tag+2, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_st2,nt_local(myid+1) , MPI_REAL, 0, tag+3, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pf1,nt_local(myid+1) , MPI_REAL, 0, tag+4, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pf2,nt_local(myid+1) , MPI_REAL, 0, tag+5, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_sf1,nt_local(myid+1) , MPI_REAL, 0, tag+6, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_sf2,nt_local(myid+1) , MPI_REAL, 0, tag+7, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + elseif (this%isCLM51) then + call MPI_RECV(CLMC_pt1,nt_local(myid+1) , MPI_REAL, 0, tag, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_st1,nt_local(myid+1) , MPI_REAL, 0, tag+1, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_pf1,nt_local(myid+1) , MPI_REAL, 0, tag+2, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + call MPI_RECV(CLMC_sf1,nt_local(myid+1) , MPI_REAL, 0, tag+3, MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) + end if endif call MPI_Barrier(MPI_COMM_WORLD, STATUS) @@ -741,7 +937,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) call GetIds(this%lonc,this%latc,this%lonn,this%latt,id_loc_cn, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) + fveg_offl, ityp_offl,this%isCLM51) call MPI_Barrier(MPI_COMM_WORLD, STATUS) @@ -790,6 +986,7 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) this%tg = tg_tmp deallocate(tg_tmp) + var_out = this%bflowm (this%id_glb(:)) this%bflowm = var_out var_out = this%totwatm(this%id_glb(:)) @@ -818,6 +1015,35 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) enddo this%psnsham = var_psn + do nz = 1, nzone + do nv = 1, nveg + var_lmr(:,nv,nz) = this%lmrsunm(this%id_glb(:), nv,nz) + enddo + enddo + this%lmrsunm= var_lmr + + do nz = 1, nzone + do nv = 1, nveg + var_lmr(:,nv,nz) = this%lmrsham(this%id_glb(:), nv,nz) + enddo + enddo + this%lmrsham = var_lmr + + do nz = 1, nzone + do nv = 1, nveg + var_lai(:,nv,nz) = this%laisunm(this%id_glb(:), nv,nz) + enddo + enddo + this%laisunm= var_lai + + do nz = 1, nzone + do nv = 1, nveg + var_lai(:,nv,nz) = this%laisham(this%id_glb(:), nv,nz) + enddo + enddo + this%laisham = var_lai + + do nz = 1, nzone var_out_zone(:,nz) = this%rzmm(this%id_glb(:), nz) enddo @@ -880,8 +1106,21 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) print *, 'calculating regridded carbn' + if (this%isCLM40) then + allocate(iclass(1:npft)) + iclass = iclass_40 + elseif (this%isCLM45) then + allocate(iclass(1:npft)) + iclass = iclass_45 + elseif (this%isCLM51) then + allocate(iclass(1:npft_51)) + iclass = iclass_51 + end if + + + call regrid_carbon (out_NTILES, in_ntiles,id_glb_cn, & - DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) + DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl, iclass) deallocate (var_off_col,var_off_pft) endif call MPI_Barrier(MPI_COMM_WORLD, STATUS) @@ -890,13 +1129,14 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) contains SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) + DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl,iclass_in) ! write out regridded carbon variables implicit none integer, intent (in) :: NTILES, in_ntiles,id_glb (ntiles,nveg) real, intent (in) :: DAYX (NTILES), var_off_col(in_ntiles,NZONE,var_col), var_off_pft(in_ntiles,NZONE, NVEG, var_pft) real, intent (in), dimension(in_ntiles,nveg) :: fveg_offl, ityp_offl + integer, intent(in), dimension(:) :: iclass_in real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) @@ -915,14 +1155,27 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & allocate (CLMC_st2(NTILES)) allocate (VAR_DUM (NTILES)) - CLMC_pt1 = this%cnity(:,1) - CLMC_pt2 = this%cnity(:,2) - CLMC_st1 = this%cnity(:,3) - CLMC_st2 = this%cnity(:,4) - CLMC_pf1 = this%fvg(:,1) - CLMC_pf2 = this%fvg(:,2) - CLMC_sf1 = this%fvg(:,3) - CLMC_sf2 = this%fvg(:,4) + if ((this%isCLM40).or.(this%isCLM45)) then + CLMC_pt1 = this%cnity(:,1) + CLMC_pt2 = this%cnity(:,2) + CLMC_st1 = this%cnity(:,3) + CLMC_st2 = this%cnity(:,4) + CLMC_pf1 = this%fvg(:,1) + CLMC_pf2 = this%fvg(:,2) + CLMC_sf1 = this%fvg(:,3) + CLMC_sf2 = this%fvg(:,4) + + elseif (this%isCLM51) then + + CLMC_pt1 = this%cnity(:,1) + CLMC_st1 = this%cnity(:,3) + CLMC_st2 = this%cnity(:,4) + CLMC_pf1 = this%fvg(:,1) + CLMC_pf2 = this%fvg(:,2) + CLMC_sf1 = this%fvg(:,3) + CLMC_sf2 = this%fvg(:,4) + + end if allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) @@ -936,20 +1189,38 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & NVLOOP2 : do nv = 1, nveg - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif + if ((this%isCLM40).or.(this%isCLM45)) then + + if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary + nx = nv + 2 + else + nx = nv - 2 + endif + + if (nv == 1) ityp_new = CLMC_pt1(n) + if (nv == 1) fveg_new = CLMC_pf1(n) + if (nv == 2) ityp_new = CLMC_pt2(n) + if (nv == 2) fveg_new = CLMC_pf2(n) + if (nv == 3) ityp_new = CLMC_st1(n) + if (nv == 3) fveg_new = CLMC_sf1(n) + if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) fveg_new = CLMC_sf2(n) + + elseif (this%isCLM51) then + + if(nv <= 1) then ! index for secondary PFT index if primary or primary if secondary + nx = nv + 1 + else + nx = nv - 1 + endif + + if (nv == 1) ityp_new = CLMC_pt1(n) + if (nv == 1) fveg_new = CLMC_pf1(n) + if (nv == 2) ityp_new = CLMC_st1(n) + if (nv == 2) fveg_new = CLMC_sf1(n) + + end if - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) if (fveg_new > fmin) then offl_cell = Id_glb(n,nv) @@ -958,7 +1229,7 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & iv = nv ! same type fraction (primary of secondary) else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then + else if(iclass_in(ityp_new)==iclass_in(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then iv = nv ! primary, other type (same class) else if(fveg_offl (offl_cell,nx)> fmin) then iv = nx ! secondary, other type (same class) @@ -1017,15 +1288,21 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) + if ((this%isCLM40).or.(this%isCLM45)) then + if (nv == 1) ityp_new = CLMC_pt1(n) + if (nv == 1) fveg_new = CLMC_pf1(n) + if (nv == 2) ityp_new = CLMC_pt2(n) + if (nv == 2) fveg_new = CLMC_pf2(n) + if (nv == 3) ityp_new = CLMC_st1(n) + if (nv == 3) fveg_new = CLMC_sf1(n) + if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) fveg_new = CLMC_sf2(n) + elseif (this%isCLM51) then + if (nv == 1) ityp_new = CLMC_pt1(n) + if (nv == 1) fveg_new = CLMC_pf1(n) + if (nv == 2) ityp_new = CLMC_st1(n) + if (nv == 2) fveg_new = CLMC_sf1(n) + end if if(fveg_new > fmin) then var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) @@ -1099,6 +1376,16 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) if(this%isCLM45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) + if(this%isCLM51) then + var_pft_out(n, nz,nv,76) = max(var_pft_out(n, nz,nv,76),0.) + var_pft_out(n, nz,nv,77) = max(var_pft_out(n, nz,nv,77),0.) + var_pft_out(n, nz,nv,78) = max(var_pft_out(n, nz,nv,78),0.) + var_pft_out(n, nz,nv,79) = max(var_pft_out(n, nz,nv,79),0.) + var_pft_out(n, nz,nv,80) = max(var_pft_out(n, nz,nv,80),0.) + var_pft_out(n, nz,nv,81) = max(var_pft_out(n, nz,nv,81),0.) + var_pft_out(n, nz,nv,82) = max(var_pft_out(n, nz,nv,82),0.) + var_pft_out(n, nz,nv,83) = max(var_pft_out(n, nz,nv,83),0.) + end if endif end do NVLOOP3 ! end veg loop endif ! end carbon check @@ -1310,6 +1597,16 @@ SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & end do end do end do + elseif(this%isclm51) then + do iv = 1,VAR_PFT + do nv = 1,nveg + do nz = 1,nzone + this%cnpft(:,i) = var_pft_out(:, nz,nv,iv) + !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) + i = i + 1 + end do + end do + end do else do iv = 1,VAR_PFT do nv = 1,nveg diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentRst.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/README b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/README old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltImpConverter.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/SaltIntSplitter.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 index cd2bce354..a7f300a0a 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 @@ -33,14 +33,18 @@ program Scale_CatchCN integer, parameter :: nveg = 4 integer, parameter :: nzone = 3 integer :: VAR_COL, VAR_PFT - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column + integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables in CatchCNCLM40 + integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column in CatchCNCLM40 integer, parameter :: npft = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - + integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables in CatchCNCLM45 + integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column in CatchCNCLM45 + integer, parameter :: npft_51 = 15 + integer, parameter :: VAR_COL_CLM51 = 35 ! number of CN column restart variables in CatchCNCLM51 + integer, parameter :: VAR_PFT_CLM51 = 81 ! number of CN PFT variables per column in CatchCNCLM51 + logical :: clm45 = .false. - integer :: un_dim3 + logical :: clm51 = .false. + integer :: un_dim3, un_dim4 type catch_rst real, pointer :: bf1(:) @@ -116,6 +120,19 @@ program Scale_CatchCN real, pointer :: HDM (:) real, pointer :: GDP (:) real, pointer :: PEATF (:) + real, pointer :: RHM (:) + real, pointer :: RH30D (:) + real, pointer :: WINDM (:) + real, pointer :: RAINFM (:) + real, pointer :: SNOWFM (:) + real, pointer :: RUNSURFM(:) + real, pointer :: AR1M (:) + real, pointer :: TG10D (:) + real, pointer :: T2M10D (:) + real, pointer :: T2MMIN5D(:) + real, pointer :: TPREC10D(:) + real, pointer :: TPREC60D(:) + real, pointer :: SNDZM5D (:) endtype catch_rst type(catch_rst) catch(3) @@ -185,11 +202,17 @@ program Scale_CatchCN ntiles = cfg(1)%get_dimension('tile', __RC__) un_dim3 = cfg(1)%get_dimension('unknown_dim3', __RC__) - if(un_dim3 == 105) then + un_dim4 = cfg(1)%get_dimension('unknown_dim4', __RC__) + if((un_dim3 == 105).and.(un_dim4 == 900)) then clm45 = .true. VAR_COL = VAR_COL_CLM45 VAR_PFT = VAR_PFT_CLM45 print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 + elseif((un_dim3 == 105).and.(un_dim4 == 972)) then + clm51 = .true. + VAR_COL = VAR_COL_CLM51 + VAR_PFT = VAR_PFT_CLM51 + print *, 'Processing CLM51 restarts : ', VAR_COL, VAR_PFT, clm51 else print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 endif @@ -608,6 +631,25 @@ subroutine readcatchcn_nc4 (catch,formatter,cfg, rc) call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) + elseif(clm51) then + call MAPL_VarRead(formatter,"ABM", catch%ABM , __RC__) + call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) + call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) + call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) + call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) + call MAPL_VarRead(formatter,"RHM", catch%RHM , __RC__) + call MAPL_VarRead(formatter,"WINDM", catch%WINDM , __RC__) + call MAPL_VarRead(formatter,"RAINFM", catch%RAINFM , __RC__) + call MAPL_VarRead(formatter,"SNOWFM", catch%SNOWFM , __RC__) + call MAPL_VarRead(formatter,"RUNSRFM", catch%RUNSURFM, __RC__) + call MAPL_VarRead(formatter,"AR1M", catch%AR1M , __RC__) + call MAPL_VarRead(formatter,"SNDZM5D", catch%SNDZM5D , __RC__) + call MAPL_VarRead(formatter,"T2M10D", catch%T2M10D , __RC__) + call MAPL_VarRead(formatter,"T2MMIN5D",catch%T2MMIN5D, __RC__) + call MAPL_VarRead(formatter,"TG10D", catch%TG10D , __RC__) + call MAPL_VarRead(formatter,"RH30D", catch%RH30D , __RC__) + call MAPL_VarRead(formatter,"TPREC10D",catch%TPREC10D, __RC__) + call MAPL_VarRead(formatter,"TPREC60D",catch%TPREC60D, __RC__) endif do j=1,dim1 call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) @@ -851,6 +893,29 @@ subroutine writecatchcn_nc4 (catch,formatter,cfg) call MAPL_VarWrite(formatter,"T2M10D", var) call MAPL_VarWrite(formatter,"TPREC10D",var) call MAPL_VarWrite(formatter,"TPREC60D",var) + elseif (clm51) then + do j=1,dim1 + call MAPL_VarWrite(formatter,"SFMM", var,offset1=j) + enddo + + call MAPL_VarWrite(formatter,"ABM", catch%ABM, rc =rc ) + call MAPL_VarWrite(formatter,"FIELDCAP",catch%FIELDCAP) + call MAPL_VarWrite(formatter,"HDM", catch%HDM ) + call MAPL_VarWrite(formatter,"GDP", catch%GDP ) + call MAPL_VarWrite(formatter,"PEATF", catch%PEATF ) + call MAPL_VarWrite(formatter,"RHM", var) + call MAPL_VarWrite(formatter,"WINDM", var) + call MAPL_VarWrite(formatter,"RAINFM", var) + call MAPL_VarWrite(formatter,"SNOWFM", var) + call MAPL_VarWrite(formatter,"RUNSRFM", var) + call MAPL_VarWrite(formatter,"AR1M", var) + call MAPL_VarWrite(formatter,"SNDZM5D", var) + call MAPL_VarWrite(formatter,"T2M10D", var) + call MAPL_VarWrite(formatter,"T2MMIN5D",var) + call MAPL_VarWrite(formatter,"TG10D", var) + call MAPL_VarWrite(formatter,"RH30D", var) + call MAPL_VarWrite(formatter,"TPREC10D",var) + call MAPL_VarWrite(formatter,"TPREC60D",var) else call MAPL_VarWrite(formatter,"SFMCM", var) endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 old mode 100644 new mode 100755 index 814ed551d..06ffef6d8 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/getids.F90 @@ -286,18 +286,21 @@ subroutine GetIds_accurate_mpi (loni,lati,lono,lato,Id, tid_in) deallocate (mask) end subroutine GetIds_accurate_mpi - + ! ***************************************************************************** subroutine GetIds_carbon (loni,lati,lono,lato,Id, tid_in, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - + fveg_offl, ityp_offl,isCLM51) + + use clm_varpar_shared , only : nveg_40 => NUM_VEG_CN, nveg_51 => NUM_VEG_CN51, & + npft => numpft_CN, npft_51 => numpft_CN51 implicit none - integer, parameter :: npft = 19 - integer, parameter :: nveg = 4 + integer :: nveg real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) + integer :: iclass_40_45(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) + integer :: iclass_51(npft_51) = (/1,1,2,3,3,4,5,5,6,7,9,10,11,11,11/) + integer, dimension(:), allocatable :: iclass integer :: NT_IN, NT_OUT, n, i, nplus,nv, nx, ityp_new integer, dimension (:), intent (in) :: tid_in integer, dimension (:,:), intent (inout) :: id @@ -305,6 +308,7 @@ subroutine GetIds_carbon (loni,lati,lono,lato,Id, tid_in, & real, dimension (:), intent (in) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 real, dimension(:,:), intent (in) :: fveg_offl, ityp_offl + logical, intent(in) :: isCLM51 logical :: tile_found logical, allocatable, dimension (:) :: mask integer, allocatable, dimension (:) :: sub_tid @@ -314,6 +318,16 @@ subroutine GetIds_carbon (loni,lati,lono,lato,Id, tid_in, & NT_IN = SIZE (loni) NT_OUT = SIZE (lono) + + if (isCLM51) then + allocate(iclass(1:npft_51)) + iclass = iclass_51 + nveg = nveg_51 + elseif (.not.isCLM51) then + allocate(iclass(1:npft)) + iclass = iclass_40_45 + nveg = nveg_40 + end if allocate (mask (1: NT_IN)) @@ -365,23 +379,44 @@ subroutine GetIds_carbon (loni,lati,lono,lato,Id, tid_in, & NV_LOOP: do nv = 1, nveg - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - SEEK : if((Id (n, nv) < 0).and.(fveg_new > fmin)) then - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary + if (isCLM51) then + if (nv == 1) ityp_new = CLMC_pt1(n) + if (nv == 1) fveg_new = CLMC_pf1(n) + if (nv == 2) ityp_new = CLMC_st1(n) + if (nv == 2) fveg_new = CLMC_sf1(n) + + else if (.not.isCLM51) then + + if (nv == 1) ityp_new = CLMC_pt1(n) + if (nv == 1) fveg_new = CLMC_pf1(n) + if (nv == 2) ityp_new = CLMC_pt2(n) + if (nv == 2) fveg_new = CLMC_pf2(n) + if (nv == 3) ityp_new = CLMC_st1(n) + if (nv == 3) fveg_new = CLMC_sf1(n) + if (nv == 4) ityp_new = CLMC_st2(n) + if (nv == 4) fveg_new = CLMC_sf2(n) + + end if + + + SEEK : if((Id (n, nv) < 0).and.(fveg_new > fmin)) then + + if (isCLM51) then + if(nv <= 1) then ! index for secondary PFT index if primary or primary if secondary + nx = nv + 1 + else + nx = nv - 1 + endif + + else if (.not.isCLM51) then + + if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary nx = nv + 2 - else - nx = nv - 2 - endif - + else + nx = nv - 2 + endif + endif + sub_ityp1 = ityp_offl (sub_tid,nv) sub_fevg1 = fveg_offl (sub_tid,nv) sub_ityp2 = ityp_offl (sub_tid,nx) @@ -427,11 +462,16 @@ subroutine GetIds_carbon (loni,lati,lono,lato,Id, tid_in, & deallocate (sub_ityp1, sub_fevg1, sub_ityp2, sub_fevg2, rev_dist) tile_found = .true. - if((tile_found).and.((CLMC_pf1(n) > fmin).and.(Id(n,1) < 0))) tile_found = .false. - if((tile_found).and.((CLMC_pf2(n) > fmin).and.(Id(n,2) < 0))) tile_found = .false. - if((tile_found).and.((CLMC_sf1(n) > fmin).and.(Id(n,3) < 0))) tile_found = .false. - if((tile_found).and.((CLMC_sf2(n) > fmin).and.(Id(n,4) < 0))) tile_found = .false. - + if (isCLM51) then + if((tile_found).and.((CLMC_pf1(n) > fmin).and.(Id(n,1) < 0))) tile_found = .false. + if((tile_found).and.((CLMC_sf1(n) > fmin).and.(Id(n,2) < 0))) tile_found = .false. + else if (.not.isCLM51) then + if((tile_found).and.((CLMC_pf1(n) > fmin).and.(Id(n,1) < 0))) tile_found = .false. + if((tile_found).and.((CLMC_pf2(n) > fmin).and.(Id(n,2) < 0))) tile_found = .false. + if((tile_found).and.((CLMC_sf1(n) > fmin).and.(Id(n,3) < 0))) tile_found = .false. + if((tile_found).and.((CLMC_sf2(n) > fmin).and.(Id(n,4) < 0))) tile_found = .false. + endif + if(tile_found) GO TO 100 ! if not increase the window size diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CICERestart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CICERestart.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 index e4ab880c8..65c380f07 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 @@ -1314,7 +1314,7 @@ SUBROUTINE regrid_carbon_vars ( & call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) + fveg_offl, ityp_offl,.false.) ! jkolassa June 2023: hardocding to work for CatchCN4.0/4.5 for now (not 5.1), since this routine will be replaced by one that works for all CatchCN versions shortly. deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2,lonc,latc,lonn,latt) ! update id_glb in root diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 old mode 100644 new mode 100755 index 5e3da8d3a..2b7a434f0 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 @@ -51,8 +51,11 @@ PROGRAM mk_GEOSldasRestarts integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column integer, parameter :: npft = 19 integer, parameter :: npft_clm45 = 19 + integer, parameter :: npft_clm51 = 15 integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column + integer, parameter :: VAR_COL_CLM51 = 35 ! number of CN column restart variables + integer, parameter :: VAR_PFT_CLM51 = 81 ! number of CN PFT variables per column real, parameter :: nan = O'17760000000' real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value @@ -115,6 +118,7 @@ PROGRAM mk_GEOSldasRestarts CHARACTER( * ), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz' CHARACTER( * ), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' logical :: clm45 = .false. + logical :: clm51 = .false. logical :: second_visit integer :: zoom, k, n, infos character*100 :: InRestart @@ -160,7 +164,7 @@ PROGRAM mk_GEOSldasRestarts print *,'(1) to create an initial catch(cn)_internal_rst file ready for an offline experiment :' print *,'--------------------------------------------------------------------------------------' print *,'(1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50)' - print *,'where MODEL : catch, catchcnclm40, catchcnclm45' + print *,'where MODEL : catch, catchcnclm40, catchcnclm45, catchcnclm51' print *,'(1.2) sbatch mkLDAS.j' print *,' ' print *,'(2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment :' @@ -206,6 +210,12 @@ PROGRAM mk_GEOSldasRestarts VAR_COL = VAR_COL_CLM45 VAR_PFT = VAR_PFT_CLM45 endif + + if (index(model,'51') /=0) then + clm51 = .true. + VAR_COL = VAR_COL_CLM51 + VAR_PFT = VAR_PFT_CLM51 + endif catch_scaler = 'Scale_CatchCN' else catch_scaler = 'Scale_Catch' @@ -378,11 +388,18 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) meta_data = ldFmt%read(__RC__) call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then + if((meta_data%get_dimension('unknown_dim3',rc=status) == 105) .and. & + (meta_data%get_dimension('unknown_dim4',rc=status) == 900)) then clm45 = .true. VAR_COL = VAR_COL_CLM45 VAR_PFT = VAR_PFT_CLM45 if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 + elseif((meta_data%get_dimension('unknown_dim3',rc=status) == 105) .and. & + (meta_data%get_dimension('unknown_dim4',rc=status) == 972)) then + clm51 = .true. + VAR_COL = VAR_COL_CLM51 + VAR_PFT = VAR_PFT_CLM51 + if (root_proc) print *, 'Processing CLM51 restarts : ', VAR_COL, VAR_PFT, clm45 else if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 endif @@ -634,7 +651,7 @@ SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MOD call GetIds(lonc,latc,lonn,latt,id_loc_cn, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) + fveg_offl, ityp_offl,.false.) !jkolassa June 2023: logical argument hardcoded at end means this code does not work for Catchment-CN5.1; acceptable since mk_GEOSldasRestarts.F90 will be replaced if(root_proc) allocate (id_glb_cn (ntiles,nveg)) @@ -767,6 +784,11 @@ SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDI VAR_PFT = VAR_PFT_CLM45 if ( .not. clm45) stop ' ERROR: Given clm45 restart, but the model is not clm45' if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 + elseif(meta_data%get_dimension('unknown_dim4',rc=status) == 972) then + VAR_COL = VAR_COL_CLM51 + VAR_PFT = VAR_PFT_CLM51 + if ( .not. clm51) stop ' ERROR: Given clm51 restart, but the model is not clm51' + if (root_proc) print *, 'Processing CLM51 restarts : ', VAR_COL, VAR_PFT, clm45 else if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 endif @@ -1312,6 +1334,8 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) + real, allocatable :: CLMC51_pf1(:), CLMC51_pf2(:), CLMC51_sf1(:), CLMC51_sf2(:) + real, allocatable :: CLMC51_pt1(:), CLMC51_pt2(:), CLMC51_st1(:), CLMC51_st2(:) real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) @@ -1348,8 +1372,11 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) + allocate (CLMC51_pf1(ntiles), CLMC51_pf2(ntiles), CLMC51_sf1(ntiles)) + allocate (CLMC51_sf2(ntiles), CLMC51_pt1(ntiles), CLMC51_pt2(ntiles)) allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) + allocate (CLMC51_st1(ntiles), CLMC51_st2(ntiles)) allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) allocate (peatf(ntiles), abm(ntiles), var1(ntiles), RITY(ntiles)) @@ -1426,6 +1453,14 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) end do CLOSE (30, STATUS = 'KEEP') endif + if(clm51) then + open(unit=30, file=trim(DataDir)//'CLM5.1_abm_peatf_gdp_hdm_fc' ,form='formatted') + do n=1,ntiles + read (32, *) i, j, abm(n), peatf(n), & + gdp(n), hdm(n), fc(n) + end do + CLOSE (32, STATUS = 'KEEP') + endif endif @@ -1444,6 +1479,10 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') endif + if(clm51) then + open(unit=31, file=trim(DataDir)//'CLM5.1_veg_typs_fracs',form='formatted') + open(unit=32, file=trim(DataDir)//'CLM5.1_abm_peatf_gdp_hdm_fc' ,form='formatted') + endif endif do n=1,ntiles @@ -1481,6 +1520,14 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) read (30, *) i, j, abm(n), peatf(n), & gdp(n), hdm(n), fc(n) endif + + if(clm51) then + read (31, *) i,j, CLMC51_pt1(n), CLMC51_pt2(n), CLMC51_st1(n), CLMC51_st2(n), & + CLMC51_pf1(n), CLMC51_pf2(n), CLMC51_sf1(n), CLMC51_sf2(n) + + read (32, *) i, j, abm(n), peatf(n), & + gdp(n), hdm(n), fc(n) + endif endif end do @@ -1498,6 +1545,10 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLOSE (29, STATUS = 'KEEP') CLOSE (30, STATUS = 'KEEP') endif + if(clm51) then + CLOSE (31, STATUS = 'KEEP') + CLOSE (32, STATUS = 'KEEP') + endif endif endif @@ -1586,6 +1637,36 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLMC45_sf1(n) = fvg(3) CLMC45_sf2(n) = fvg(4) endif + + if(CLM51) then + ! CLM 51 + + CLMC51_pf1(n) = CLMC51_pf1(n) / 100. + CLMC51_pf2(n) = CLMC45_pf2(n) / 100. + CLMC51_sf1(n) = CLMC51_sf1(n) / 100. + CLMC51_sf2(n) = CLMC51_sf2(n) / 100. + + fvg(1) = CLMC51_pf1(n) + fvg(2) = CLMC51_pf2(n) + fvg(3) = CLMC51_sf1(n) + fvg(4) = CLMC51_sf2(n) + + BARE = 1. + + DO NV = 1, NVEG + BARE = BARE - FVG(NV)! subtract vegetated fractions + END DO + + if (BARE /= 0.) THEN + IB = MAXLOC(FVG(:),1) + FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. + ENDIF + + CLMC51_pf1(n) = fvg(1) + CLMC51_pf2(n) = fvg(2) + CLMC51_sf1(n) = fvg(3) + CLMC51_sf2(n) = fvg(4) + endif endif enddo @@ -1670,6 +1751,45 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) CLMC45_sf2(n) = 0. endif endif + + if (clm51) then + ! CLM51 + if(CLMC51_pf1(n) <= 1.e-4) then + CLMC51_pf2(n) = CLMC51_pf2(n) + CLMC51_pf1(n) + CLMC51_pf1(n) = 0. + endif + + if(CLMC51_pf2(n) <= 1.e-4) then + CLMC51_pf1(n) = CLMC51_pf1(n) + CLMC51_pf2(n) + CLMC51_pf2(n) = 0. + endif + + if(CLMC51_sf1(n) <= 1.e-4) then + if(CLMC51_sf2(n) > 1.e-4) then + CLMC51_sf2(n) = CLMC51_sf2(n) + CLMC51_sf1(n) + else if(CLMC51_pf2(n) > 1.e-4) then + CLMC51_pf2(n) = CLMC51_pf2(n) + CLMC51_sf1(n) + else if(CLMC51_pf1(n) > 1.e-4) then + CLMC51_pf1(n) = CLMC51_pf1(n) + CLMC51_sf1(n) + else + stop 'fveg3' + endif + CLMC51_sf1(n) = 0. + endif + + if(CLMC51_sf2(n) <= 1.e-4) then + if(CLMC51_sf1(n) > 1.e-4) then + CLMC51_sf1(n) = CLMC51_sf1(n) + CLMC51_sf2(n) + else if(CLMC51_pf2(n) > 1.e-4) then + CLMC51_pf2(n) = CLMC51_pf2(n) + CLMC51_sf2(n) + else if(CLMC51_pf1(n) > 1.e-4) then + CLMC51_pf1(n) = CLMC51_pf1(n) + CLMC51_sf2(n) + else + stop 'fveg4' + endif + CLMC51_sf2(n) = 0. + endif + endif end do endif @@ -1740,7 +1860,7 @@ SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNR'), (/1/), (/NTILES/),BNIRDR) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNF'), (/1/), (/NTILES/),BNIRDF) - if(CLM45) then + if((CLM45) .or. (CLM51)) then STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ABM' ), (/1/), (/NTILES/),real(ABM)) STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FIELDCAP'), (/1/), (/NTILES/),FC) @@ -1966,7 +2086,7 @@ SUBROUTINE regrid_carbon_vars (NTILES, model) call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) + fveg_offl, ityp_offl,.false.) !jkolassa June 2023: logical input argument hardcoded at end means that this code does not work for Catchment-CN5.1, which is considered acceptable, since mk_GEOSldasRestarts.F90 is about to be replaced with code that doe swork for Catchment-CN5.1 ! update id_glb in root @@ -2255,6 +2375,14 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) if(clm45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) + if(clm51) then + var_pft_out(n, nz,nv,76) = max(var_pft_out(n, nz,nv,76),0.) + var_pft_out(n, nz,nv,77) = max(var_pft_out(n, nz,nv,77),0.) + var_pft_out(n, nz,nv,78) = max(var_pft_out(n, nz,nv,78),0.) + var_pft_out(n, nz,nv,79) = max(var_pft_out(n, nz,nv,79),0.) + var_pft_out(n, nz,nv,80) = max(var_pft_out(n, nz,nv,80),0.) + var_pft_out(n, nz,nv,81) = max(var_pft_out(n, nz,nv,81),0.) + end if endif end do NVLOOP3 ! end veg loop endif ! end carbon check @@ -2458,6 +2586,15 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & end do end do end do + elseif(clm51) then + do iv = 1,VAR_PFT + do nv = 1,nveg + do nz = 1,nzone + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) + i = i + 1 + end do + end do + end do else do iv = 1,VAR_PFT do nv = 1,nveg @@ -2495,6 +2632,20 @@ SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC10D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC60D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'T2M10D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + elseif(clm51) then + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'AR1M' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RAINFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RHM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RUNSRFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNOWFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WINDM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC10D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC60D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'T2M10D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RH30D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TG10D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'T2MMIN5D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) + STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM5D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) else STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_LakeLandiceSaltRestarts.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_RouteRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_RouteRestarts.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catchANDcnRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_catchANDcnRestarts.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/edmf.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/idl/vis.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/idl/vis.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/idl/zosea.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/idl/zosea.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/scm_surface.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/scm_surface.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/shoc.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/.gitignore b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/.gitignore old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/ARIESg3_GridCompMod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/ARIESg3_GridCompMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/FVdycore_arch.mk b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/FVdycore_arch.mk old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/dynamics_vars.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/dynamics_vars.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/fft99.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/fft99.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dycore.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dycore.F old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_lattice_module.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_lattice_module.F old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_state_module.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_state_module.F old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_gcmutil.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_gcmutil.F old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_grids.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_grids.F old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mpi_util.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mpi_util.F old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc.F old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc_interface b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc_interface old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_wrapper.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_wrapper.F old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/gmap.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/gmap.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/par_xsum.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/par_xsum.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/pft_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/pft_module.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/remap.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/remap.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/shr_kind_mod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/shr_kind_mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/BlendingMod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/BlendingMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_GridCompMod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_GridCompMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_arch.mk b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_arch.mk old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_wrapper.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_wrapper.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVperf_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVperf_module.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/G3_AVRX.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/G3_AVRX.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/benergy.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/benergy.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/cd_core.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/cd_core.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/diag_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/diag_module.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/dynamics_vars.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/dynamics_vars.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/epvd.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/epvd.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fft99.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fft99.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fill_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fill_module.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/geopk.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/geopk.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/glosum.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/glosum.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/gmap.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/gmap.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/mapz_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/mapz_module.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_vecsum.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_vecsum.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_xsum.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_xsum.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pft_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pft_module.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pkez.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pkez.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pmaxmin.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pmaxmin.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/remap.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/remap.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/shr_kind_mod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/shr_kind_mod.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/sw_core.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/sw_core.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/te_map.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/te_map.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/tp_core.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/tp_core.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/trac2d.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/trac2d.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/NeuralNet.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/NeuralNet.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/bomex_reader.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/bomex_reader.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/cfmip_ic.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/cfmip_ic.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/cptread.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/cptread.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/gate_reader.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/gate_reader.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/cleanunder.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/cleanunder.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/int2d.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/int2d.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/make_bcs_ics.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/make_bcs_ics.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/make_land_files.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/make_land_files.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/makeup_sstfiles.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/makeup_sstfiles.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/mktile.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/mktile.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_catch_internal.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_catch_internal.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_fv_internal.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_fv_internal.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_land_bcs.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_land_bcs.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_lnd_albedos.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_lnd_albedos.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_sst.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_sst.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_topo.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_topo.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_vegdyn_internal.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/read_vegdyn_internal.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/readlaigrn.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/readlaigrn.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/readtilefile.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/readtilefile.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/rewrite_fv_internal.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/rewrite_fv_internal.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/rewrite_moist_internal.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/rewrite_moist_internal.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/rewrite_sstfiles.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/rewrite_sstfiles.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/rewrite_topofiles.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/rewrite_topofiles.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/write_datmodyn_internal.pro b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/idl/write_datmodyn_internal.pro old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/ppm.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/ppm.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/reader.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/reader.F90 old mode 100644 new mode 100755 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/stratus_ic.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/stratus_ic.F90 old mode 100644 new mode 100755 diff --git a/GEOSdataatm_GridComp/CMakeLists.txt b/GEOSdataatm_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSdataatm_GridComp/GEOS_DataAtmGridComp.F90 b/GEOSdataatm_GridComp/GEOS_DataAtmGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSmkiau_GridComp/CMakeLists.txt b/GEOSmkiau_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSmkiau_GridComp/DFI_GridComp.F90 b/GEOSmkiau_GridComp/DFI_GridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSmkiau_GridComp/DynVec_GridComp.F90 b/GEOSmkiau_GridComp/DynVec_GridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 b/GEOSmkiau_GridComp/GEOS_mkiauGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSmkiau_GridComp/IAU_GridCompMod.F90 b/GEOSmkiau_GridComp/IAU_GridCompMod.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/.gitignore b/GEOSogcm_GridComp/.gitignore old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/CMakeLists.txt b/GEOSogcm_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/CMakeLists.txt b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/GEOS_OceanbiogeochemGridComp.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/GEOS_OceanbiogeochemGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/carbon.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/carbon.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/co2calc_SWS.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/co2calc_SWS.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/daysetbio.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/daysetbio.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/definebio.h b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/definebio.h old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/definetab.h b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/definetab.h old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/drtsafe.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/drtsafe.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/kloop.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/kloop.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/ppco2.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/ppco2.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/ptend.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/ptend.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/setbio.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/setbio.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/sink.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/sink.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/ta_iter_SWS.F90 b/GEOSogcm_GridComp/GEOS_OceanBioGeoChemGridComp/ta_iter_SWS.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OgcmGridComp.F90 b/GEOSogcm_GridComp/GEOS_OgcmGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/CMakeLists.txt b/GEOSogcm_GridComp/GEOS_OradBioGridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/GEOS_OradBioGridComp.F90 b/GEOSogcm_GridComp/GEOS_OradBioGridComp/GEOS_OradBioGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/aasack.F90 b/GEOSogcm_GridComp/GEOS_OradBioGridComp/aasack.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/comlte.h b/GEOSogcm_GridComp/GEOS_OradBioGridComp/comlte.h old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/daysetrad.F90 b/GEOSogcm_GridComp/GEOS_OradBioGridComp/daysetrad.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/definebio.h b/GEOSogcm_GridComp/GEOS_OradBioGridComp/definebio.h old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/edeu.F90 b/GEOSogcm_GridComp/GEOS_OradBioGridComp/edeu.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/glight.F90 b/GEOSogcm_GridComp/GEOS_OradBioGridComp/glight.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/lidata.F90 b/GEOSogcm_GridComp/GEOS_OradBioGridComp/lidata.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradBioGridComp/setlte.F90 b/GEOSogcm_GridComp/GEOS_OradBioGridComp/setlte.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradGridComp/CMakeLists.txt b/GEOSogcm_GridComp/GEOS_OradGridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOS_OradGridComp/GEOS_OradGridComp.F90 b/GEOSogcm_GridComp/GEOS_OradGridComp/GEOS_OradGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/.gitignore b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/.gitignore old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CMakeLists.txt b/GEOSogcm_GridComp/GEOSseaice_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOSCICEDyna_GridComp/CMakeLists.txt b/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOSCICEDyna_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOS_SeaIceGridComp.F90 b/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOS_SeaIceGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOSdataseaice_GridComp/CMakeLists.txt b/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOSdataseaice_GridComp/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOSdataseaice_GridComp/GEOS_DataSeaIceGridComp.F90 b/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOSdataseaice_GridComp/GEOS_DataSeaIceGridComp.F90 old mode 100644 new mode 100755 diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOSdataseaice_GridComp/GEOS_DataSeaIceGridComp_ExtData.F90 b/GEOSogcm_GridComp/GEOSseaice_GridComp/GEOSdataseaice_GridComp/GEOS_DataSeaIceGridComp_ExtData.F90 old mode 100644 new mode 100755 diff --git a/LICENSE b/LICENSE old mode 100644 new mode 100755 diff --git a/LICENSE-NOSA b/LICENSE-NOSA old mode 100644 new mode 100755 diff --git a/README.md b/README.md old mode 100644 new mode 100755