diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOS_SurfaceGridComp.F90 index 0718f700a..d4c84c4b2 100644 --- 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 @@ -2963,7 +2963,7 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - IF(LSM_CHOICE > 1) THEN + IF(LSM_CHOICE >= 2) THEN call MAPL_AddExportSpec(GC ,& LONG_NAME = 'CN_exposed_leaf-area_index',& @@ -3019,7 +3019,7 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - if (LSM_CHOICE == 3) then + if (LSM_CHOICE >= 4) then call MAPL_AddExportSpec(GC ,& LONG_NAME = 'CN_fine_root_carbon' ,& UNITS = 'kg m-2' ,& @@ -3057,6 +3057,24 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_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_total_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' ,& @@ -5663,6 +5681,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() @@ -5970,6 +5990,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() @@ -6853,15 +6875,17 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT , CDCR2 , 'CDCR2' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT , POROS , 'POROS' , RC=STATUS); VERIFY_(STATUS) - IF(LSM_CHOICE > 1) THEN + IF(LSM_CHOICE >= 2) THEN 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 , CNROOT , 'CNROOT' , RC=STATUS); VERIFY_(STATUS) - if (LSM_CHOICE == 3) then + if (LSM_CHOICE >= 4) 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) @@ -7489,15 +7513,17 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MKTILE(CDCR2 ,CDCR2TILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(POROS ,POROSTILE ,NT,RC=STATUS); VERIFY_(STATUS) - IF (LSM_CHOICE > 1) THEN + IF (LSM_CHOICE >= 2) THEN call MKTILE(CNLAI ,CNLAITILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(CNTLAI ,CNTLAITILE ,NT,RC=STATUS); VERIFY_(STATUS) call MKTILE(CNSAI ,CNSAITILE ,NT,RC=STATUS); VERIFY_(STATUS) 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 >= 4) 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) @@ -8444,6 +8470,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) @@ -9081,6 +9115,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 ) @@ -9445,7 +9481,7 @@ subroutine DOTYPE(type,RC) VERIFY_(STATUS) - IF (LSM_CHOICE > 1) THEN + IF (LSM_CHOICE >= 2) THEN call MAPL_GetPointer(GEX(type), dum, 'CNLAI' , ALLOC=associated(CNLAITILE ), notFoundOK=.true., RC=STATUS) VERIFY_(STATUS) call MAPL_GetPointer(GEX(type), dum, 'CNTLAI' , ALLOC=associated(CNTLAITILE ), notFoundOK=.true., RC=STATUS) @@ -9458,8 +9494,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 >= 4) 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) @@ -10131,6 +10172,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/GEOSland_GridComp/GEOS_LandGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 index 69d73008e..6229a42ac 100644 --- 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,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,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 >= 4) 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,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 index 5eb959f4d..90baa4a31 100644 --- 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 @@ -1,7 +1,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 index 05b20561d..e0eca4e90 100644 --- 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 @@ -1,4 +1,4 @@ -! It is a proxy of clm 4.0 and clm 4.5 +! It is a proxy of CNCLM40 and CNCLM51 #include "MAPL_Generic.h" @@ -48,12 +48,12 @@ subroutine SetServices ( GC, RC ) ! Local Variables - type(MAPL_MetaComp), pointer :: MAPL=>null() - character(len=ESMF_MAXSTR) :: CATCHCN_VERSION - type(ESMF_GridComp), pointer :: gcs(:) - type(T_CATCHCN_STATE), pointer :: CATCHCN_INTERNAL_STATE - class(T_CATCH_STATE), pointer :: statePtr - type(CATCHCN_WRAP) :: wrap + type(MAPL_MetaComp), pointer :: MAPL=>null() + character(len=ESMF_MAXSTR) :: CATCHCN_VERSION + type(ESMF_GridComp), pointer :: gcs(:) + type(T_CATCHCN_STATE), pointer :: CATCHCN_INTERNAL_STATE + class(T_CATCH_STATE), pointer :: statePtr + type(CATCHCN_WRAP) :: wrap character(len=ESMF_MAXSTR) :: SURFRC type(ESMF_Config) :: SCF, CF @@ -86,38 +86,48 @@ subroutine SetServices ( GC, RC ) call MAPL_GetResource ( MAPL, CATCHCN_INTERNAL_STATE%CATCH_SPINUP, Label="CATCHMENT_SPINUP:", DEFAULT=0, RC=STATUS) VERIFY_(STATUS) - ! resource variables from GEOS_SurfaceGridComp.rc + ! put resource variables from rc file into SCF config object (GCM: SURFRC=GEOS_SurfaceGridComp.rc, LDAS: SURFRC=LDAS.rc) call MAPL_GetResource ( MAPL, SURFRC, label = 'SURFRC:', default = 'GEOS_SurfaceGridComp.rc', RC=STATUS) ; VERIFY_(STATUS) SCF = ESMF_ConfigCreate(rc=status) ; VERIFY_(STATUS) call ESMF_ConfigLoadFile(SCF,SURFRC,rc=status) ; VERIFY_(STATUS) + ! assemble internal state from SCF config object call surface_params_to_wrap_state(statePtr, SCF, _RC) call ESMF_ConfigDestroy(SCF, _RC) - + + call MAPL_GetResource ( MAPL, LSM_CHOICE, Label="LSM_CHOICE:", DEFAULT=2, RC=STATUS) + VERIFY_(STATUS) + + ! Add select rc variables to [the CF config object within] MAPL so that the Children GridComps (CNCLM40 and CNCLM51) can get + ! them in SetServices() from MAPL. In the Children's SetServices(), "catchcn_internal" is not yet available. call MAPL_Get (MAPL, CF=CF, _RC) - call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%ATM_CO2, Label='ATM_CO2:', _RC) - call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%N_CONST_LAND4SNWALB, Label='N_CONST_LAND4SNWALB:', _RC) - call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%RUN_IRRIG, Label='RUN_IRRIG:', _RC) - call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%PRESCRIBE_DVG, Label='PRESCRIBE_DVG:', _RC) - call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%SNOW_ALBEDO_INFO, Label='SNOW_ALBEDO_INFO:', _RC) + call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%ATM_CO2, Label='ATM_CO2:', _RC) + call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%N_CONST_LAND4SNWALB, Label='N_CONST_LAND4SNWALB:', _RC) + call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%SNOW_ALBEDO_INFO, Label='SNOW_ALBEDO_INFO:', _RC) + if (LSM_CHOICE==2) then + call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%RUN_IRRIG, Label='RUN_IRRIG:', _RC) + call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%PRESCRIBE_DVG, Label='PRESCRIBE_DVG:', _RC) + elseif (LSM_CHOICE==4) then + call ESMF_ConfigSetAttribute(CF, value=CATCHCN_INTERNAL_STATE%MOSFC_EXTRA_DERIVS_OFFL_LAND, Label='MOSFC_EXTRA_DERIVS_OFFL_LAND:', _RC) + end if call MAPL_Set (MAPL, CF=CF, _RC) - call MAPL_GetResource ( MAPL, LSM_CHOICE, Label="LSM_CHOICE:", DEFAULT=2, RC=STATUS) - VERIFY_(STATUS) + ! prep CatchCN ensemble and Children tmp = '' if (NUM_LDAS_ENSEMBLE >1) then - !catchcn_exxxx - tmp(1:ens_id_width)=COMP_NAME(8:8+ens_id_width-1) + !catchcn_exxxx + tmp(1:ens_id_width)=COMP_NAME(8:8+ens_id_width-1) endif - if ( LSM_CHOICE == 2 ) then + + 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 for CatchCN should equal 2 (CLM40) or 4 (CLM51)") endif wrap%ptr =>CATCHCN_INTERNAL_STATE @@ -127,13 +137,13 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, RC=STATUS ) VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN1, RC=STATUS ) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN1, RC=STATUS ) VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN2, RC=STATUS ) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN2, RC=STATUS ) VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_FINALIZE, Finalize, RC=status) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_FINALIZE, Finalize, RC=status) VERIFY_(status) ! Set the state variable specs. ( should be the combinations of clm4.0 and clm4.5 @@ -936,9 +946,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 >= 4) 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/CNAllocationMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNAllocationMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNAnnualUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNAnnualUpdateMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNBalanceCheckMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNBalanceCheckMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNCStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNCStateUpdate1Mod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNCStateUpdate2Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNCStateUpdate2Mod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNCStateUpdate3Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNCStateUpdate3Mod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNDecompMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNDecompMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNEcosystemDynMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNEcosystemDynMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNFireMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNFireMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNGRespMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNGRespMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNGapMortalityMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNGapMortalityMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNHarvestMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNHarvestMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNMRespMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNMRespMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNNDynamicsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNNDynamicsMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNNStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNNStateUpdate1Mod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNNStateUpdate2Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNNStateUpdate2Mod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNNStateUpdate3Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNNStateUpdate3Mod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNPhenologyMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNPhenologyMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNPrecisionControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNPrecisionControlMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNSetValueMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNSetValueMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNSummaryMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNSummaryMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNVegStructUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNVegStructUpdateMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNWoodProductsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNWoodProductsMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CN_DriverMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CN_DriverMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNiniTimeVar.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/CNiniTimeVar.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clm_time_manager.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clm_time_manager.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clm_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clm_varcon.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clm_varpar.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clm_varpar.F90 old mode 100755 new mode 100644 index 3bab4f385..920428fa6 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clm_varpar.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clm_varpar.F90 @@ -10,10 +10,13 @@ module clm_varpar ! ! !USES: - use clm_varpar_shared, only : VAR_COL =>VAR_COL_40, VAR_PFT => VAR_PFT_40, & - numpft => numpft_CN, NUM_ZON => NUM_ZON_CN, & - NUM_VEG => NUM_VEG_CN - + use clm_varpar_shared, only : & + VAR_COL => VAR_COL_40, & + VAR_PFT => VAR_PFT_40, & + numpft => NUM_PFT_CN_40, & + NUM_ZON => NUM_ZON_CN, & + NUM_VEG => NUM_VEG_CN_40 + ! ! !PUBLIC TYPES: implicit none @@ -32,7 +35,8 @@ module clm_varpar ! clm_varpar_init seems to do something similar; less prone to error to move ! these three lines there? (slevis) - integer, parameter :: max_pft_per_col = numpft+1 + + integer, parameter :: max_pft_per_col = numpft + 1 ! !PUBLIC MEMBER FUNCTIONS: public clm_varpar_init ! set parameters diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clmtype.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clmtype.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clmtypeInitMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/clmtypeInitMod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/compute_rc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/compute_rc.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/pftvarcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/pftvarcon.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/shr_const_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/shr_const_mod.F90 old mode 100755 new mode 100644 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/subgridAveMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/CLM40/subgridAveMod.F90 old mode 100755 new mode 100644 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 index cbebc22a3..439c06ac5 100644 --- 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 @@ -1273,7 +1273,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddInternalSpec(GC ,& LONG_NAME = 'mean_catchment_temp_incl_snw',& UNITS = 'K' ,& - SHORT_NAME = 'TSURF' ,& + SHORT_NAME = 'TSURF' ,& ! legacy (and obsolete) internal spec w/ bad name; see ExportSpec TPSURF DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RESTART = RESTART ,& @@ -7310,14 +7310,14 @@ subroutine Driver ( RC ) TC(:,FSNW) ,& ASNOW ,& TP1, TP2, TP3, TP4, TP5, TP6, SFMC, RZMC, PRMC ,& - ENTOT,WTOT, WCHANGE, ECHANGE, HSNACC, EVACC, SHACC ,& + ENTOT,WTOT, WCHANGE, ECHANGE, HSNACC, EVACC, LHACC, 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) + RCONSTIT=RCONSTIT, RMELT=RMELT, TOTDEPOS=TOTDEPOS) ! Change units of TP1, TP2, .., TP6 export variables from Celsius to Kelvin. ! This used to be done at the level the Surface GridComp. 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 deleted file mode 100644 index dd9f9496f..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CMakeLists.txt +++ /dev/null @@ -1,55 +0,0 @@ -esma_set_this () -string (REPLACE GEOScatchCN_GridComp_ "" is_openmp ${this}) - -set (srcs - update_model_para4cn.F90 - clmtype.F90 - clm_time_manager.F90 - shr_const_mod.F90 - clm_varpar.F90 - clm_varcon.F90 - clm_varctl.F90 - subgridAveMod.F90 - CNAllocationMod.F90 - CNAnnualUpdateMod.F90 - CNCStateUpdate1Mod.F90 - CNCStateUpdate2Mod.F90 - CNCStateUpdate3Mod.F90 - CNNStateUpdate1Mod.F90 - CNNStateUpdate2Mod.F90 - CNNStateUpdate3Mod.F90 - CNDecompCascadeMod_BGC.F90 - CNDecompMod.F90 - CNFireMod.F90 - CNGapMortalityMod.F90 - pftvarcon.F90 - CNMRespMod.F90 - CNGRespMod.F90 - CNNDynamicsMod.F90 - CNPhenologyMod.F90 - CNPrecisionControlMod.F90 - CNSetValueMod.F90 - CNVegStructUpdateMod.F90 - CNVerticalProfileMod.F90 - CNSoilLittVertTranspMod.F90 - CNWoodProductsMod.F90 - CNSummaryMod.F90 - CNEcosystemDynMod.F90 - clmtypeInitMod.F90 - CNiniTimeVar.F90 - CNBalanceCheckMod.F90 - CN_DriverMod.F90 - compute_rc.F90 - TridiagonalMod.F90 - getco2.F90 - ) - -esma_add_library (${this} - SRCS ${srcs} - DEPENDENCIES MAPL GEOS_LandShared GEOS_CatchCNShared ESMF::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/GEOScatchCNCLM45_GridComp/CLM45/CNAllocationMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNAllocationMod.F90 deleted file mode 100644 index f6bb1442c..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNAllocationMod.F90 +++ /dev/null @@ -1,1486 +0,0 @@ -module CNAllocationMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNAllocationMod -! -! !DESCRIPTION: -! Module holding routines used in allocation model for coupled carbon -! nitrogen code. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varcon, only: dzsoi_decomp - use clm_varctl, only: use_c13, use_c14 - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: CNAllocationInit ! Initialization - public :: CNAllocation ! run method - public :: CNAllocation_Carbon_only ! Return Carbon_only status - -! !PUBLIC DATA MEMBERS: - character(len=*), parameter, public :: suplnAll=& ! Supplemental Nitrogen for all PFT's - 'ALL' - character(len=*), parameter, public :: suplnNon=& ! No supplemental Nitrogen - 'NONE' - character(len=15), public :: suplnitro = suplnNon ! Supplemental Nitrogen mode - logical, public :: Carbon_only = .false. ! Carbon only mode - ! (Nitrogen is prescribed NOT prognostic) - -! !PRIVATE DATA MEMBERS: - real(r8):: dt !decomp timestep (seconds) - real(r8):: bdnr !bulk denitrification rate (1/s) - real(r8):: dayscrecover !number of days to recover negative cpool - real(r8), pointer :: arepr(:) !reproduction allocation coefficient - real(r8), pointer :: aroot(:) !root allocation coefficient - real(r8), pointer:: col_plant_ndemand(:) !column-level plant N demand -! logical :: crop_supln = .false. ! Prognostic crop receives supplemental Nitrogen -! -! !REVISION HISTORY: -! 8/5/03: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNAllocation_Carbon_only -! -! !INTERFACE: -logical function CNAllocation_Carbon_only() -! -! !DESCRIPTION: Return Carbon_only flag. -! -!EOP -!----------------------------------------------------------------------- - CNAllocation_Carbon_only = Carbon_only -end function CNAllocation_Carbon_only - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNAllocationInit -! -! !INTERFACE: -subroutine CNAllocationInit ( lbc, ubc, lbp, ubp ) -! -! !DESCRIPTION: -! -! !USES: - use clm_varcon , only: secspday - use clm_time_manager, only: get_step_size - use clm_varctl , only: crop_prog,iulog - use nanMod , only: nan -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column-index bounds - integer, intent(in) :: lbp, ubp ! pft-index bounds -! -! !CALLED FROM: -! -! !REVISION HISTORY: -! 4/6/11: Created by Erik Kluzek -! -! !LOCAL VARIABLES: - character(len=32) :: subname = 'CNAllocationInit' -!EOP -!----------------------------------------------------------------------- - if ( crop_prog )then - allocate(arepr(lbp:ubp)) - allocate(aroot(lbp:ubp)) - arepr(:) = nan - aroot(:) = nan - end if - allocate(col_plant_ndemand(lbc:ubc)) - col_plant_ndemand(:) = nan - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! set some space-and-time constant parameters - bdnr = 0.5_r8 * (dt/secspday) - dayscrecover = 30.0_r8 - - ! 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 - stop 'CNAllocationInit ERROR: supplemental Nitrogen flag is not correct' - end select - -end subroutine CNAllocationInit - -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNAllocation -! -! !INTERFACE: -subroutine CNAllocation (lbp, ubp, lbc, ubc, & - num_soilc, filter_soilc, num_soilp, filter_soilp ) -! -! !DESCRIPTION: -! -! !USES: - use clmtype - use subgridAveMod, only: p2c - use clm_varpar , only: nlevsoi, nlevdecomp -#ifdef NITRIF_DENITRIF - use clm_varcon, only: nitrif_n2o_loss_frac -#endif - - use pftvarcon , only: npcropmin, nsoybean - use clm_varcon, only: secspday, istcrop - use clm_time_manager , only : get_step_size - use nanMod , only: nan -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbp, ubp ! pft-index bounds - integer, intent(in) :: lbc, ubc ! column-index bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(ubp-lbp+1) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNdecompAlloc in module CNdecompMod.F90 -! -! !REVISION HISTORY: -! 8/5/03: Created by Peter Thornton -! 10/23/03, Peter Thornton: migrated to vector data structures -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays -! - ! pft level - integer , pointer :: ivt(:) ! pft vegetation type - integer , pointer :: pcolumn(:) ! pft's column index - integer , pointer :: pfti(:) ! initial pft index in landunit - real(r8), pointer :: lgsf(:) ! long growing season factor [0-1] - real(r8), pointer :: xsmrpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N - real(r8), pointer :: psnsun(:) ! sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: psnsha(:) ! shaded leaf-level photosynthesis (umol CO2 /m**2/ s) - - real(r8), pointer :: c13_psnsun(:) ! C13 sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: c13_psnsha(:) ! C13 shaded leaf-level photosynthesis (umol CO2 /m**2/ s) - - real(r8), pointer :: c14_psnsun(:) ! C14 sunlit leaf-level photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: c14_psnsha(:) ! C14 shaded leaf-level photosynthesis (umol CO2 /m**2/ s) - - real(r8), pointer :: laisun(:) ! sunlit projected leaf area index - real(r8), pointer :: laisha(:) ! shaded projected leaf area index - real(r8), pointer :: leafc(:) - real(r8), pointer :: frootc(:) - real(r8), pointer :: livestemc(:) - real(r8), pointer :: leaf_mr(:) - real(r8), pointer :: froot_mr(:) - real(r8), pointer :: livestem_mr(:) - real(r8), pointer :: livecroot_mr(:) - real(r8), pointer :: grain_mr(:) - real(r8), pointer :: leaf_curmr(:) - real(r8), pointer :: froot_curmr(:) - real(r8), pointer :: livestem_curmr(:) - real(r8), pointer :: livecroot_curmr(:) - real(r8), pointer :: grain_curmr(:) - real(r8), pointer :: leaf_xsmr(:) - real(r8), pointer :: froot_xsmr(:) - real(r8), pointer :: livestem_xsmr(:) - real(r8), pointer :: livecroot_xsmr(:) - real(r8), pointer :: grain_xsmr(:) - ! column level - real(r8), pointer :: sminn_vr(:,:) ! (gN/m3) soil mineral N - ! ecophysiological constants - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: froot_leaf(:) ! allocation parameter: new fine root C per new leaf C (gC/gC) - real(r8), pointer :: croot_stem(:) ! allocation parameter: new coarse root C per new stem C (gC/gC) - real(r8), pointer :: stem_leaf(:) ! allocation parameter: new stem c per new leaf C (gC/gC) - real(r8), pointer :: flivewd(:) ! allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units) - real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN) - real(r8), pointer :: frootcn(:) ! fine root C:N (gC/gN) - real(r8), pointer :: livewdcn(:) ! live wood (phloem and ray parenchyma) C:N (gC/gN) - real(r8), pointer :: deadwdcn(:) ! dead wood (xylem and heartwood) C:N (gC/gN) - real(r8), pointer :: fcur2(:) ! allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage - integer, pointer :: plandunit(:) ! index into landunit level quantities - integer, pointer :: clandunit(:) ! index into landunit level quantities - integer , pointer :: itypelun(:) ! landunit type - logical , pointer :: croplive(:) ! flag, true if planted, not harvested - integer , pointer :: peaklai(:) ! 1: max allowed lai; 0: not at max - real(r8), pointer :: gddmaturity(:)! gdd needed to harvest - real(r8), pointer :: huileaf(:) ! heat unit index needed from planting to leaf emergence - real(r8), pointer :: huigrain(:) ! same to reach vegetative maturity - real(r8), pointer :: hui(:) ! =gdd since planting (gddplant) - real(r8), pointer :: leafout(:) ! =gdd from top soil layer temperature - real(r8), pointer :: aleafi(:) ! saved allocation coefficient from phase 2 - real(r8), pointer :: astemi(:) ! saved allocation coefficient from phase 2 - real(r8), pointer :: aleaf(:) ! leaf allocation coefficient - real(r8), pointer :: astem(:) ! stem allocation coefficient - real(r8), pointer :: graincn(:) ! grain C:N (gC/gN) - real(r8), pointer :: fleafcn(:) ! leaf c:n during organ fill - real(r8), pointer :: fstemcn(:) ! stem c:n during organ fill - real(r8), pointer :: ffrootcn(:) ! froot c:n during organ fill - real(r8), pointer :: declfact(:) ! Decline factor for gddmaturity used in CNAllocation - real(r8), pointer :: bfact(:) ! Exponential factor used in CNAllocation for fraction allocated to leaf - real(r8), pointer :: aleaff(:) ! Leaf Allocation coefficient parameter used in CNAllocation - real(r8), pointer :: arootf(:) ! Root Allocation coefficient parameter used in CNAllocation - real(r8), pointer :: astemf(:) ! Stem Allocation coefficient parameter used in CNAllocation - real(r8), pointer :: arooti(:) ! Root Allocation coefficient parameter used in CNAllocation - real(r8), pointer :: fleafi(:) ! Leaf Allocation coefficient parameter fraction used in CNAllocation - real(r8), pointer :: allconsl(:) ! Leaf Allocation coefficient parameter power used in CNAllocation - real(r8), pointer :: allconss(:) ! Stem Allocation coefficient parameter power used in CNAllocation - real(r8), pointer :: grperc(:) ! Growth respiration factor (unitless) - real(r8), pointer :: grpnow(:) ! Growth respiration factor (unitless) -! -! local pointers to implicit in/out arrays -! - ! pft level - real(r8), pointer :: grain_flag(:) ! 1: grain fill stage; 0: not - real(r8), pointer :: gpp(:) ! GPP flux before downregulation (gC/m2/s) - real(r8), pointer :: availc(:) ! C flux available for allocation (gC/m2/s) - real(r8), pointer :: xsmrpool_recover(:) ! C flux assigned to recovery of negative cpool (gC/m2/s) - real(r8), pointer :: c_allometry(:) ! C allocation index (DIM) - real(r8), pointer :: n_allometry(:) ! N allocation index (DIM) - real(r8), pointer :: plant_ndemand(:) ! N flux required to support initial GPP (gN/m2/s) - real(r8), pointer :: tempsum_potential_gpp(:) ! temporary annual sum of potential GPP - real(r8), pointer :: tempmax_retransn(:) ! temporary annual max of retranslocated N pool (gN/m2) - real(r8), pointer :: annsum_potential_gpp(:) ! annual sum of potential GPP - real(r8), pointer :: avail_retransn(:) ! N flux available from retranslocation pool (gN/m2/s) - real(r8), pointer :: annmax_retransn(:) ! annual max of retranslocated N pool - real(r8), pointer :: plant_nalloc(:) ! total allocated N flux (gN/m2/s) - real(r8), pointer :: plant_calloc(:) ! total allocated C flux (gC/m2/s) - real(r8), pointer :: excess_cflux(:) ! C flux not allocated due to downregulation (gC/m2/s) - real(r8), pointer :: downreg(:) ! fractional reduction in GPP due to N limitation (DIM) - real(r8), pointer :: annsum_npp(:) ! annual sum of NPP, for wood allocation - real(r8), pointer :: cpool_to_xsmrpool(:) - real(r8), pointer :: psnsun_to_cpool(:) - real(r8), pointer :: psnshade_to_cpool(:) - - real(r8), pointer :: c13_psnsun_to_cpool(:) - real(r8), pointer :: c13_psnshade_to_cpool(:) - - real(r8), pointer :: c14_psnsun_to_cpool(:) - real(r8), pointer :: c14_psnshade_to_cpool(:) - - real(r8), pointer :: cpool_to_leafc(:) - real(r8), pointer :: cpool_to_leafc_storage(:) - real(r8), pointer :: cpool_to_frootc(:) - real(r8), pointer :: cpool_to_frootc_storage(:) - real(r8), pointer :: cpool_to_livestemc(:) - real(r8), pointer :: cpool_to_livestemc_storage(:) - real(r8), pointer :: cpool_to_deadstemc(:) - real(r8), pointer :: cpool_to_deadstemc_storage(:) - real(r8), pointer :: cpool_to_livecrootc(:) - real(r8), pointer :: cpool_to_livecrootc_storage(:) - real(r8), pointer :: cpool_to_deadcrootc(:) - real(r8), pointer :: cpool_to_deadcrootc_storage(:) - real(r8), pointer :: cpool_to_gresp_storage(:) ! allocation to growth respiration storage (gC/m2/s) - real(r8), pointer :: retransn_to_npool(:) ! deployment of retranslocated N (gN/m2/s) - real(r8), pointer :: sminn_to_npool(:) ! deployment of soil mineral N uptake (gN/m2/s) - real(r8), pointer :: cpool_to_grainc(:) ! allocation to grain C (gC/m2/s) - real(r8), pointer :: cpool_to_grainc_storage(:) ! allocation to grain C storage (gC/m2/s) - real(r8), pointer :: npool_to_grainn(:) ! allocation to grain N (gN/m2/s) - real(r8), pointer :: npool_to_grainn_storage(:) ! allocation to grain N storage (gN/m2/s) - real(r8), pointer :: npool_to_leafn(:) ! allocation to leaf N (gN/m2/s) - real(r8), pointer :: npool_to_leafn_storage(:) ! allocation to leaf N storage (gN/m2/s) - real(r8), pointer :: npool_to_frootn(:) ! allocation to fine root N (gN/m2/s) - real(r8), pointer :: npool_to_frootn_storage(:) ! allocation to fine root N storage (gN/m2/s) - real(r8), pointer :: npool_to_livestemn(:) - real(r8), pointer :: npool_to_livestemn_storage(:) - real(r8), pointer :: npool_to_deadstemn(:) - real(r8), pointer :: npool_to_deadstemn_storage(:) - real(r8), pointer :: npool_to_livecrootn(:) - real(r8), pointer :: npool_to_livecrootn_storage(:) - real(r8), pointer :: npool_to_deadcrootn(:) - real(r8), pointer :: npool_to_deadcrootn_storage(:) - ! column level - real(r8), pointer :: fpi(:) ! fraction of potential immobilization (no units) - real(r8), pointer :: fpg(:) ! fraction of potential gpp (no units) - real(r8), pointer :: potential_immob(:) - real(r8), pointer :: actual_immob(:) - real(r8), pointer :: sminn_to_plant(:) - real(r8), pointer :: fpi_vr(:,:) ! fraction of potential immobilization (no units) -#ifndef NITRIF_DENITRIF - real(r8), pointer :: sminn_to_denit_excess_vr(:,:) -#else - real(r8), parameter :: compet_plant_no3 = 1.0 ! (unitless) relative compettiveness of plants for NO3 - real(r8), parameter :: compet_plant_nh4 = 1.0 ! (unitless) relative compettiveness of plants for NH4 - real(r8), parameter :: compet_decomp_no3 = 1.0 ! (unitless) relative competitiveness of immobilizers for NO3 - real(r8), parameter :: compet_decomp_nh4 = 1.0 ! (unitless) relative competitiveness of immobilizers for NH4 - real(r8), parameter :: compet_denit = 1.0 ! (unitless) relative competitiveness of denitrifiers for NO3 - real(r8), parameter :: compet_nit = 1.0 ! (unitless) relative competitiveness of nitrifiers for NH4 - real(r8) :: fpi_no3_vr(lbc:ubc,1:nlevdecomp) ! fraction of potential immobilization supplied by no3(no units) - real(r8) :: fpi_nh4_vr(lbc:ubc,1:nlevdecomp) ! fraction of potential immobilization supplied by nh4 (no units) - real(r8) :: sum_nh4_demand(lbc:ubc,1:nlevdecomp), sum_nh4_demand_scaled(lbc:ubc,1:nlevdecomp) - real(r8) :: sum_no3_demand(lbc:ubc,1:nlevdecomp), sum_no3_demand_scaled(lbc:ubc,1:nlevdecomp) - real(r8), pointer :: smin_no3_vr(:,:) ! (gN/m3) soil mineral NO3 - real(r8), pointer :: smin_nh4_vr(:,:) ! (gN/m3) soil mineral NH4 - real(r8), pointer :: f_nit_vr(:,:) ! (gN/m3/s) soil nitrification flux - real(r8), pointer :: f_denit_vr(:,:) ! (gN/m3/s) soil denitrification flux - real(r8), pointer :: pot_f_nit_vr(:,:) ! (gN/m3/s) potential soil nitrification flux - real(r8), pointer :: pot_f_denit_vr(:,:) ! (gN/m3/s) potential soil denitrification flux - real(r8), pointer :: actual_immob_no3_vr(:,:) - real(r8), pointer :: actual_immob_nh4_vr(:,:) - real(r8), pointer :: smin_no3_to_plant_vr(:,:) - real(r8), pointer :: smin_nh4_to_plant_vr(:,:) - real(r8), pointer :: n2_n2o_ratio_denit_vr(:,:) ! ratio of N2 to N2O production by denitrification [gN/gN] - real(r8), pointer :: f_n2o_denit_vr(:,:) ! flux of N2O from denitrification [gN/m3/s] - real(r8), pointer :: f_n2o_nit_vr(:,:) ! flux of N2O from nitrification [gN/m3/s] -#endif - real(r8), pointer :: sminn_to_plant_vr(:,:) - real(r8), pointer :: supplement_to_sminn_vr(:,:) - real(r8), pointer :: nfixation_prof(:,:) - real(r8), pointer :: potential_immob_vr(:,:) - real(r8), pointer :: actual_immob_vr(:,:) -! -! local pointers to implicit out arrays -! - real(r8), pointer :: leafn_to_retransn(:) - real(r8), pointer :: frootn_to_retransn(:) - real(r8), pointer :: livestemn_to_retransn(:) -! -! !OTHER LOCAL VARIABLES: - integer :: c,p,l,pi !indices - integer :: fp !lake filter pft index - integer :: fc !lake filter column 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):: 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):: curmr, curmr_ratio !xsmrpool temporary variables - real(r8):: sum_ndemand_vr(lbc:ubc, 1:nlevdecomp) !total column N demand (gN/m3/s) at a given level - integer :: j ! level index - real(r8):: nuptake_prof(lbc:ubc, 1:nlevdecomp) - real(r8):: sminn_tot(lbc:ubc) - 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 - -#ifndef NITRIF_DENITRIF - integer :: nlimit(lbc:ubc,0:nlevdecomp) !flag for N limitation - real(r8):: residual_sminn_vr(lbc:ubc, 1:nlevdecomp) - real(r8):: residual_sminn(lbc:ubc) -#else - integer :: nlimit_no3(lbc:ubc,0:nlevdecomp) !flag for NO3 limitation - integer :: nlimit_nh4(lbc:ubc,0:nlevdecomp) !flag for NH4 limitation - real(r8):: residual_smin_nh4_vr(lbc:ubc, 1:nlevdecomp) - real(r8):: residual_smin_no3_vr(lbc:ubc, 1:nlevdecomp) - real(r8):: residual_smin_nh4(lbc:ubc) - real(r8):: residual_smin_no3(lbc:ubc) -#endif - real(r8):: residual_plant_ndemand(lbc:ubc) - - -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - ivt =>pft%itype - pcolumn =>pft%column - plandunit =>pft%landunit - clandunit =>col%landunit - pfti =>col%pfti - itypelun => lun%itype - lgsf => pepv%lgsf - xsmrpool => pcs%xsmrpool - retransn => pns%retransn - psnsun => pcf%psnsun - psnsha => pcf%psnsha -! if ( use_c13 ) then -! c13_psnsun => pc13f%psnsun -! c13_psnsha => pc13f%psnsha -! c13_psnsun_to_cpool => pc13f%psnsun_to_cpool -! c13_psnshade_to_cpool => pc13f%psnshade_to_cpool -! endif -! if ( use_c14 ) then -! c14_psnsun => pc14f%psnsun -! c14_psnsha => pc14f%psnsha -! c14_psnsun_to_cpool => pc14f%psnsun_to_cpool -! c14_psnshade_to_cpool => pc14f%psnshade_to_cpool -! endif - laisun => pps%laisun - laisha => pps%laisha - leafc => pcs%leafc - frootc => pcs%frootc - livestemc => pcs%livestemc - leaf_mr => pcf%leaf_mr - froot_mr => pcf%froot_mr - livestem_mr => pcf%livestem_mr - livecroot_mr => pcf%livecroot_mr - grain_mr => pcf%grain_mr - leaf_curmr => pcf%leaf_curmr - froot_curmr => pcf%froot_curmr - livestem_curmr => pcf%livestem_curmr - livecroot_curmr => pcf%livecroot_curmr - grain_curmr => pcf%grain_curmr - leaf_xsmr => pcf%leaf_xsmr - froot_xsmr => pcf%froot_xsmr - livestem_xsmr => pcf%livestem_xsmr - livecroot_xsmr => pcf%livecroot_xsmr - grain_xsmr => pcf%grain_xsmr - sminn_vr => cns%sminn_vr - woody => pftcon%woody - froot_leaf => pftcon%froot_leaf - croot_stem => pftcon%croot_stem - stem_leaf => pftcon%stem_leaf - flivewd => pftcon%flivewd - leafcn => pftcon%leafcn - frootcn => pftcon%frootcn - livewdcn => pftcon%livewdcn - deadwdcn => pftcon%deadwdcn - fcur2 => pftcon%fcur - gddmaturity => pps%gddmaturity - huileaf => pps%huileaf - huigrain => pps%huigrain - hui => pps%gddplant - leafout => pps%gddtsoi - croplive => pps%croplive - peaklai => pps%peaklai - graincn => pftcon%graincn - fleafcn => pftcon%fleafcn - ffrootcn => pftcon%ffrootcn - fstemcn => pftcon%fstemcn - declfact => pftcon%declfact - bfact => pftcon%bfact - aleaff => pftcon%aleaff - arootf => pftcon%arootf - astemf => pftcon%astemf - arooti => pftcon%arooti - fleafi => pftcon%fleafi - allconsl => pftcon%allconsl - allconss => pftcon%allconss - grperc => pftcon%grperc - grpnow => pftcon%grpnow - ! Assign local pointers to derived type arrays (out) - grain_flag => pepv%grain_flag - gpp => pepv%gpp - availc => pepv%availc - xsmrpool_recover => pepv%xsmrpool_recover - c_allometry => pepv%c_allometry - n_allometry => pepv%n_allometry - plant_ndemand => pepv%plant_ndemand - tempsum_potential_gpp => pepv%tempsum_potential_gpp - tempmax_retransn => pepv%tempmax_retransn - annsum_potential_gpp => pepv%annsum_potential_gpp - avail_retransn => pepv%avail_retransn - annmax_retransn => pepv%annmax_retransn - plant_nalloc => pepv%plant_nalloc - plant_calloc => pepv%plant_calloc - excess_cflux => pepv%excess_cflux - downreg => pepv%downreg - annsum_npp => pepv%annsum_npp - cpool_to_xsmrpool => pcf%cpool_to_xsmrpool - psnsun_to_cpool => pcf%psnsun_to_cpool - psnshade_to_cpool => pcf%psnshade_to_cpool - cpool_to_leafc => pcf%cpool_to_leafc - cpool_to_leafc_storage => pcf%cpool_to_leafc_storage - cpool_to_frootc => pcf%cpool_to_frootc - cpool_to_frootc_storage => pcf%cpool_to_frootc_storage - cpool_to_livestemc => pcf%cpool_to_livestemc - cpool_to_livestemc_storage => pcf%cpool_to_livestemc_storage - cpool_to_deadstemc => pcf%cpool_to_deadstemc - cpool_to_deadstemc_storage => pcf%cpool_to_deadstemc_storage - cpool_to_livecrootc => pcf%cpool_to_livecrootc - cpool_to_livecrootc_storage => pcf%cpool_to_livecrootc_storage - cpool_to_deadcrootc => pcf%cpool_to_deadcrootc - cpool_to_deadcrootc_storage => pcf%cpool_to_deadcrootc_storage - cpool_to_gresp_storage => pcf%cpool_to_gresp_storage - cpool_to_grainc => pcf%cpool_to_grainc - cpool_to_grainc_storage => pcf%cpool_to_grainc_storage - npool_to_grainn => pnf%npool_to_grainn - npool_to_grainn_storage => pnf%npool_to_grainn_storage - retransn_to_npool => pnf%retransn_to_npool - sminn_to_npool => pnf%sminn_to_npool - npool_to_leafn => pnf%npool_to_leafn - npool_to_leafn_storage => pnf%npool_to_leafn_storage - npool_to_frootn => pnf%npool_to_frootn - npool_to_frootn_storage => pnf%npool_to_frootn_storage - npool_to_livestemn => pnf%npool_to_livestemn - npool_to_livestemn_storage => pnf%npool_to_livestemn_storage - npool_to_deadstemn => pnf%npool_to_deadstemn - npool_to_deadstemn_storage => pnf%npool_to_deadstemn_storage - npool_to_livecrootn => pnf%npool_to_livecrootn - npool_to_livecrootn_storage => pnf%npool_to_livecrootn_storage - npool_to_deadcrootn => pnf%npool_to_deadcrootn - npool_to_deadcrootn_storage => pnf%npool_to_deadcrootn_storage - leafn_to_retransn => pnf%leafn_to_retransn - frootn_to_retransn => pnf%frootn_to_retransn - livestemn_to_retransn => pnf%livestemn_to_retransn - fpg => cps%fpg - potential_immob => cnf%potential_immob - actual_immob => cnf%actual_immob - sminn_to_plant => cnf%sminn_to_plant - fpi => cps%fpi - fpi_vr => cps%fpi_vr -#ifndef NITRIF_DENITRIF - sminn_to_denit_excess_vr => cnf%sminn_to_denit_excess_vr -#else - smin_nh4_vr => cns%smin_nh4_vr - smin_no3_vr => cns%smin_no3_vr - pot_f_nit_vr => cnf%pot_f_nit_vr - pot_f_denit_vr => cnf%pot_f_denit_vr - f_nit_vr => cnf%f_nit_vr - f_denit_vr => cnf%f_denit_vr - actual_immob_no3_vr => cnf%actual_immob_no3_vr - actual_immob_nh4_vr => cnf%actual_immob_nh4_vr - smin_no3_to_plant_vr => cnf%smin_no3_to_plant_vr - smin_nh4_to_plant_vr => cnf%smin_nh4_to_plant_vr - n2_n2o_ratio_denit_vr => cnf%n2_n2o_ratio_denit_vr - f_n2o_denit_vr => cnf%f_n2o_denit_vr - f_n2o_nit_vr => cnf%f_n2o_nit_vr -#endif - supplement_to_sminn_vr => cnf%supplement_to_sminn_vr - sminn_to_plant_vr => cnf%sminn_to_plant_vr - nfixation_prof => cps%nfixation_prof - potential_immob_vr => cnf%potential_immob_vr - actual_immob_vr => cnf%actual_immob_vr - aleafi => pps%aleafi - astemi => pps%astemi - aleaf => pps%aleaf - astem => pps%astem - - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! loop over pfts to assess the total plant N demand - do fp=1,num_soilp - p = filter_soilp(fp) - - ! get the time step total gross photosynthesis - ! this is coming from the canopy fluxes code, and is the - ! gpp that is used to control stomatal conductance. - ! For the nitrogen downregulation code, this is assumed - ! to be the potential gpp, and the actual gpp will be - ! reduced due to N limitation. - - ! Convert psn from umol/m2/s -> gC/m2/s - - ! The input psn (psnsun and psnsha) are expressed per unit LAI - ! in the sunlit and shaded canopy, respectively. These need to be - ! scaled by laisun and laisha to get the total gpp for allocation - - psnsun_to_cpool(p) = psnsun(p) * laisun(p) * 12.011e-6_r8 - psnshade_to_cpool(p) = psnsha(p) * laisha(p) * 12.011e-6_r8 - -! if ( use_c13 ) then -! c13_psnsun_to_cpool(p) = c13_psnsun(p) * laisun(p) * 12.011e-6_r8 -! c13_psnshade_to_cpool(p) = c13_psnsha(p) * laisha(p) * 12.011e-6_r8 -! endif - -! if ( use_c14 ) then -! c14_psnsun_to_cpool(p) = c14_psnsun(p) * laisun(p) * 12.011e-6_r8 -! c14_psnshade_to_cpool(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-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 (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 (ivt(p) /= nsoybean .or. astem(p) == astemf(ivt(p))) then - if (grain_flag(p) == 0._r8) 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 - grain_flag(p) = 1._r8 - 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 (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 - 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 (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 - plant_ndemand(p) = plant_ndemand(p) - retransn_to_npool(p) - - end do ! end pft loop - - ! now use the p2c routine to get the column-averaged plant_ndemand - call p2c(num_soilc,filter_soilc,plant_ndemand,col_plant_ndemand) - -#ifndef NITRIF_DENITRIF - ! column loops to resolve plant/heterotroph competition for mineral N - - ! 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) .gt. 0.) then - nuptake_prof(c,j) = sminn_vr(c,j) / sminn_tot(c) - else - nuptake_prof(c,j) = nfixation_prof(c,j) - endif - - sum_ndemand_vr(c,j) = col_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 = clandunit(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) = col_plant_ndemand(c) * nuptake_prof(c,j) - else if ( Carbon_only) then !.or. & -! (crop_supln .and. (itypelun(l) == istcrop) .and. & -! (ivt(pfti(c)) >= npcropmin)) )then - ! 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) = col_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 - - ! 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) - 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) = col_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) .gt. 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) .gt. 0._r8 .and. residual_sminn(c) .gt. 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) - sum_ndemand_vr(c,j) = potential_immob_vr(c,j) + sminn_to_plant_vr(c,j) - 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 ((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 - 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 (col_plant_ndemand(c) > 0.0_r8) then - fpg(c) = sminn_to_plant(c) / col_plant_ndemand(c) - else - fpg(c) = 1.0_r8 - end if - - ! 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 - - ! 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) .gt. 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 = clandunit(c) - - ! first compete for nh4 - sum_nh4_demand(c,j) = col_plant_ndemand(c) * nuptake_prof(c,j) + potential_immob_vr(c,j) + pot_f_nit_vr(c,j) - sum_nh4_demand_scaled(c,j) = col_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) - smin_nh4_to_plant_vr(c,j) = col_plant_ndemand(c) * nuptake_prof(c,j) - - f_nit_vr(c,j) = pot_f_nit_vr(c,j) - - 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 - 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)) - smin_nh4_to_plant_vr(c,j) = min((smin_nh4_vr(c,j)/dt)*(col_plant_ndemand(c)*nuptake_prof(c,j) & - *compet_plant_nh4 / sum_nh4_demand_scaled(c,j)), col_plant_ndemand(c) & - *nuptake_prof(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)) - 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 - - ! next compete for no3 - sum_no3_demand(c,j) = (col_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) = (col_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 - - 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) = 1 - 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)) - smin_no3_to_plant_vr(c,j) = (col_plant_ndemand(c)*nuptake_prof(c,j)-smin_nh4_to_plant_vr(c,j)) - - f_denit_vr(c,j) = pot_f_denit_vr(c,j) - - 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 - 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)*((col_plant_ndemand(c)*nuptake_prof(c,j)-& - smin_nh4_to_plant_vr(c,j))*compet_plant_no3 / sum_no3_demand_scaled(c,j)), & - col_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) = 0.0_r8 - smin_no3_to_plant_vr(c,j) = 0.0_r8 - f_denit_vr(c,j) = 0.0_r8 - end if - - 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 ( Carbon_only) then !.or. & -! (crop_supln .and. (itypelun(l) == istcrop) .and. & -! (ivt(pfti(c)) >= npcropmin)) ) then - - if ( fpi_no3_vr(c,j) + fpi_nh4_vr(c,j) .lt. 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) .lt. col_plant_ndemand(c)*nuptake_prof(c,j) ) then - supplement_to_sminn_vr(c,j) = supplement_to_sminn_vr(c,j) + & - (col_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) = col_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 - - 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 - - ! 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) = col_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) .gt. 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_vr(c,j) + smin_nh4_to_plant_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) .gt. 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) = col_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) .gt. 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_vr(c,j) + smin_no3_to_plant_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) .gt. 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 - - ! 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 - if (col_plant_ndemand(c) > 0.0_r8) then - fpg(c) = sminn_to_plant(c) / col_plant_ndemand(c) - else - fpg(c) = 1._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._r8 - end if - end do ! end of column loops -#endif - - - - ! start new pft loop to distribute the available N between the - ! competing pfts on the basis of relative demand, and allocate C and N to - ! new growth and storage - - do fp=1,num_soilp - p = filter_soilp(fp) - c = pcolumn(p) - - ! set some local allocation variables - f1 = froot_leaf(ivt(p)) - f2 = croot_stem(ivt(p)) - - ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, - ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) - ! There was an error in this formula in previous version, where the coefficient - ! was 0.004 instead of 0.0025. - ! This variable allocation is only for trees. Shrubs have a constant - ! allocation as specified in the pft-physiology file. The value is also used - ! as a trigger here: -1.0 means to use the dynamic allocation (trees). - if (stem_leaf(ivt(p)) == -1._r8) then - f3 = (2.7/(1.0+exp(-0.004*(annsum_npp(p) - 300.0)))) - 0.4 - else - f3 = stem_leaf(ivt(p)) - end if - - f4 = flivewd(ivt(p)) - g1 = grperc(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)) 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. - !fcur = fcur + (1._r8 - fcur)*lgsf(p) - sminn_to_npool(p) = plant_ndemand(p) * fpg(c) - plant_nalloc(p) = sminn_to_npool(p) + retransn_to_npool(p) - - - ! calculate the associated carbon allocation, and the excess - ! carbon flux that must be accounted for through downregulation - plant_calloc(p) = plant_nalloc(p) * (c_allometry(p)/n_allometry(p)) - excess_cflux(p) = availc(p) - plant_calloc(p) - - - ! reduce gpp fluxes due to N limitation - if (gpp(p) > 0.0_r8) then - downreg(p) = excess_cflux(p)/gpp(p) - psnsun_to_cpool(p) = psnsun_to_cpool(p)*(1._r8 - downreg(p)) - psnshade_to_cpool(p) = psnshade_to_cpool(p)*(1._r8 - downreg(p)) -! if ( use_c13 ) then -! c13_psnsun_to_cpool(p) = c13_psnsun_to_cpool(p)*(1._r8 - downreg(p)) -! c13_psnshade_to_cpool(p) = c13_psnshade_to_cpool(p)*(1._r8 - downreg(p)) -! endif - -! if ( use_c14 ) then -! c14_psnsun_to_cpool(p) = c14_psnsun_to_cpool(p)*(1._r8 - downreg(p)) -! c14_psnshade_to_cpool(p) = c14_psnshade_to_cpool(p)*(1._r8 - downreg(p)) -! endif - end if - - ! calculate the amount of new leaf C dictated by these allocation - ! decisions, and calculate the daily fluxes of C and N to current - ! growth and storage pools - - ! fcur is the proportion of this day's growth that is displayed now, - ! the remainder going into storage for display next year through the - ! transfer pools - - nlc = plant_calloc(p) / c_allometry(p) - 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 - - ! 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) - - end do ! end pft loop - -end subroutine CNAllocation - -!#endif - -end module CNAllocationMod 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 deleted file mode 100644 index 248555ed0..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNAnnualUpdateMod.F90 +++ /dev/null @@ -1,168 +0,0 @@ -module CNAnnualUpdateMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNAnnualUpdateMod -! -! !DESCRIPTION: -! Module for updating annual summation variables -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: CNAnnualUpdate -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNAnnualUpdate -! -! !INTERFACE: -subroutine CNAnnualUpdate(lbc, ubc, lbp, ubp, num_soilc, filter_soilc, & - num_soilp, filter_soilp) -! -! !DESCRIPTION: -! On the radiation time step, update annual summation variables -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size, get_days_per_year - use clm_varcon , only: secspday - use subgridAveMod , only: p2c -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: lbp, ubp ! pft bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(ubp-lbp+1) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine clm_driver1 -! -! !REVISION HISTORY: -! 10/1/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: pcolumn(:) ! index into column level - ! quantities -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: annsum_counter(:) ! seconds since last annual accumulator turnover - real(r8), pointer :: tempsum_potential_gpp(:) ! temporary annual sum of potential GPP - real(r8), pointer :: annsum_potential_gpp(:) ! annual sum of potential GPP - real(r8), pointer :: tempmax_retransn(:) ! temporary annual max of retranslocated N pool (gN/m2) - real(r8), pointer :: annmax_retransn(:) ! annual max of retranslocated N pool (gN/m2) - real(r8), pointer :: tempavg_t2m(:) ! temporary average 2m air temperature (K) - real(r8), pointer :: annavg_t2m(:) ! annual average 2m air temperature (K) - real(r8), pointer :: tempsum_npp(:) ! temporary sum NPP (gC/m2/yr) - real(r8), pointer :: annsum_npp(:) ! annual sum NPP (gC/m2/yr) - real(r8), pointer :: cannsum_npp(:) ! column annual sum NPP (gC/m2/yr) - real(r8), pointer :: cannavg_t2m(:) !annual average of 2m air temperature, averaged from pft-level (K) -#if (defined CNDV) - real(r8), pointer :: tempsum_litfall(:) ! temporary sum litfall (gC/m2/yr) - real(r8), pointer :: annsum_litfall(:) ! annual sum litfall (gC/m2/yr) -#endif -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: c,p ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers to derived type arrays - annsum_counter => cps%annsum_counter - tempsum_potential_gpp => pepv%tempsum_potential_gpp - annsum_potential_gpp => pepv%annsum_potential_gpp - tempmax_retransn => pepv%tempmax_retransn - annmax_retransn => pepv%annmax_retransn - tempavg_t2m => pepv%tempavg_t2m - annavg_t2m => pepv%annavg_t2m - tempsum_npp => pepv%tempsum_npp - annsum_npp => pepv%annsum_npp - cannsum_npp => cps%cannsum_npp - cannavg_t2m => cps%cannavg_t2m -#if (defined CNDV) - tempsum_litfall => pepv%tempsum_litfall - annsum_litfall => pepv%annsum_litfall -#endif - pcolumn =>pft%column - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - annsum_counter(c) = annsum_counter(c) + dt - end do - - if (num_soilc .gt. 0) then - - if (annsum_counter(filter_soilc(1)) >= get_days_per_year() * secspday) then - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - ! update annual plant ndemand accumulator - annsum_potential_gpp(p) = tempsum_potential_gpp(p) - tempsum_potential_gpp(p) = 0._r8 - - ! update annual total N retranslocation accumulator - annmax_retransn(p) = tempmax_retransn(p) - tempmax_retransn(p) = 0._r8 - - ! update annual average 2m air temperature accumulator - annavg_t2m(p) = tempavg_t2m(p) - tempavg_t2m(p) = 0._r8 - - ! update annual NPP accumulator, convert to annual total - annsum_npp(p) = tempsum_npp(p) * dt - tempsum_npp(p) = 0._r8 - -#if (defined CNDV) - ! update annual litfall accumulator, convert to annual total - annsum_litfall(p) = tempsum_litfall(p) * dt - tempsum_litfall(p) = 0._r8 -#endif - end do - - ! use p2c routine to get selected column-average pft-level fluxes and states - call p2c(num_soilc, filter_soilc, annsum_npp, cannsum_npp) - call p2c(num_soilc, filter_soilc, annavg_t2m, cannavg_t2m) - end if - - end if - - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - if (annsum_counter(c) >= get_days_per_year() * secspday) annsum_counter(c) = 0._r8 - end do - -end subroutine CNAnnualUpdate -!----------------------------------------------------------------------- -!#endif - -end module CNAnnualUpdateMod 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 deleted file mode 100644 index db5506f40..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNBalanceCheckMod.F90 +++ /dev/null @@ -1,436 +0,0 @@ - -module CNBalanceCheckMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNBalanceCheckMod -! -! !DESCRIPTION: -! Module for carbon mass balance checking. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varctl , only: iulog - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: BeginCBalance - public :: BeginNBalance - public :: CBalanceCheck - public :: NBalanceCheck -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: BeginCBalance -! -! !INTERFACE: -subroutine BeginCBalance(lbc, ubc, num_soilc, filter_soilc) -! -! !DESCRIPTION: -! On the radiation time step, calculate the beginning carbon balance for mass -! conservation checks. -! -! !USES: - use clmtype -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_soilc ! number of soil columns filter - integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns -! -! !CALLED FROM: -! subroutine clm_driver1 -! -! !REVISION HISTORY: -! 2/4/05: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays - real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool -! -! local pointers to implicit out arrays - real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2) - -! -! !OTHER LOCAL VARIABLES: - integer :: c ! indices - integer :: fc ! lake filter indices -! -!EOP -!----------------------------------------------------------------------- - ! assign local pointers at the column level - col_begcb => ccbal%begcb - totcolc => ccs%totcolc - - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! calculate beginning column-level carbon balance, - ! for mass conservation check - - col_begcb(c) = totcolc(c) - - end do ! end of columns loop - - -end subroutine BeginCBalance -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: BeginNBalance -! -! !INTERFACE: -subroutine BeginNBalance(lbc, ubc, num_soilc, filter_soilc) -! -! !DESCRIPTION: -! On the radiation time step, calculate the beginning nitrogen balance for mass -! conservation checks. -! -! !USES: - use clmtype -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_soilc ! number of soil columns filter - integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns -! -! !CALLED FROM: -! subroutine clm_driver1 -! -! !REVISION HISTORY: -! 2/4/05: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays - real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg -! -! local pointers to implicit out arrays - real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) -! - -! !OTHER LOCAL VARIABLES: - integer :: c ! indices - integer :: fc ! lake filter indices -! -!EOP -!----------------------------------------------------------------------- - ! assign local pointers at the column level - col_begnb => cnbal%begnb - totcoln => cns%totcoln - - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! calculate beginning column-level nitrogen balance, - ! for mass conservation check - - col_begnb(c) = totcoln(c) - - end do ! end of columns loop - -end subroutine BeginNBalance -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CBalanceCheck -! -! !INTERFACE: -subroutine CBalanceCheck(lbc, ubc, num_soilc, filter_soilc) -! -! !DESCRIPTION: -! On the radiation time step, perform carbon mass conservation check for column and pft -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns -! -! !CALLED FROM: -! subroutine clm_driver1 -! -! !REVISION HISTORY: -! 12/9/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! -! local pointers to implicit in arrays - real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool - real(r8), pointer :: gpp(:) ! (gC/m2/s) gross primary production - real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic - real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss - real(r8), pointer :: col_hrv_xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s) - real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from product pools and conversion - real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss - real(r8), pointer :: som_c_leached(:) ! total SOM C loss from vertical transport (gC/m^2/s) -! -! local pointers to implicit out arrays - real(r8), pointer :: col_cinputs(:) ! (gC/m2/s) total column-level carbon inputs (for balance check) - real(r8), pointer :: col_coutputs(:) ! (gC/m2/s) total column-level carbon outputs (for balance check) - real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2) - real(r8), pointer :: col_endcb(:) ! carbon mass, end of time step (gC/m**2) - real(r8), pointer :: col_errcb(:) ! carbon balance error for the timestep (gC/m**2) -! -! !OTHER LOCAL VARIABLES: - integer :: c,err_index ! indices - integer :: fc ! lake filter indices - logical :: err_found ! error flag - real(r8):: dt ! radiation time step (seconds) - integer :: icnt ! counter -!EOP -!----------------------------------------------------------------------- - - ! assign local pointers to column-level arrays - totcolc => ccs%totcolc - gpp => pcf_a%gpp - er => ccf%er - col_fire_closs => ccf%col_fire_closs - col_hrv_xsmrpool_to_atm => pcf_a%hrv_xsmrpool_to_atm - dwt_closs => ccf%dwt_closs - product_closs => ccf%product_closs - - col_cinputs => ccf%col_cinputs - col_coutputs => ccf%col_coutputs - col_begcb => ccbal%begcb - col_endcb => ccbal%endcb - col_errcb => ccbal%errcb - som_c_leached => ccf%som_c_leached - - - ! set time steps - dt = real( get_step_size(), r8 ) - - icnt = 0 - err_found = .false. - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! calculate the total column-level carbon storage, for mass conservation check - - col_endcb(c) = totcolc(c) - - ! calculate total column-level inputs - - col_cinputs(c) = gpp(c) - - ! calculate total column-level outputs - ! er = ar + hr, col_fire_closs includes pft-level fire losses - - col_coutputs(c) = er(c) + col_fire_closs(c) + dwt_closs(c) + product_closs(c) + col_hrv_xsmrpool_to_atm(c) - - ! subtract leaching flux - col_coutputs(c) = col_coutputs(c) - som_c_leached(c) - - ! calculate the total column-level carbon balance error for this time step - col_errcb(c) = (col_cinputs(c) - col_coutputs(c))*dt - & - (col_endcb(c) - col_begcb(c)) - - ! check for significant errors (1e-8 for real*8, 1e0 for real*4) - if (col_endcb(c) > 0. .and. abs(col_errcb(c)) > 0.1) then - err_found = .true. - err_index = c - icnt = icnt + 1 - if(icnt > 1 .and. abs(col_errcb(c)) > abs(col_errcb(err_index))) err_index = c - endif - - 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) - stop 'CBalance' - end if - - -end subroutine CBalanceCheck -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: NBalanceCheck -! -! !INTERFACE: -subroutine NBalanceCheck(lbc, ubc, num_soilc, filter_soilc) -! -! !DESCRIPTION: -! On the radiation time step, perform nitrogen mass conservation check -! for column and pft -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varctl , only: crop_prog -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns -! -! !CALLED FROM: -! subroutine clm_driver1 -! -! !REVISION HISTORY: -! 12/9/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! -! local pointers to implicit in arrays - real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg - real(r8), pointer :: ndep_to_sminn(:) ! atmospheric N deposition to soil mineral N (gN/m2/s) - real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) - real(r8), pointer :: fert_to_sminn(:) - real(r8), pointer :: soyfixn_to_sminn(:) - real(r8), pointer :: supplement_to_sminn(:) ! supplemental N supply (gN/m2/s) - real(r8), pointer :: denit(:) ! total rate of denitrification (gN/m2/s) -#ifndef NITRIF_DENITRIF - real(r8), pointer :: sminn_leached(:) ! soil mineral N pool loss to leaching (gN/m2/s) -#else - real(r8), pointer :: smin_no3_leached(:) ! soil mineral NO3 pool loss to leaching (gN/m2/s) - real(r8), pointer :: smin_no3_runoff(:) ! soil mineral NO3 pool loss to runoff (gN/m2/s) - real(r8), pointer :: f_n2o_nit(:) ! flux of N2o from nitrification [gN/m^2/s] -#endif - real(r8), pointer :: col_fire_nloss(:) ! total column-level fire N loss (gN/m2/s) - real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion - real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss - real(r8), pointer :: som_n_leached(:) ! total SOM N loss from vertical transport -! -! local pointers to implicit in/out arrays -! -! local pointers to implicit out arrays - real(r8), pointer :: col_ninputs(:) ! column-level N inputs (gN/m2/s) - real(r8), pointer :: col_noutputs(:) ! column-level N outputs (gN/m2/s) - real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) - real(r8), pointer :: col_endnb(:) ! nitrogen mass, end of time step (gN/m**2) - real(r8), pointer :: col_errnb(:) ! nitrogen balance error for the timestep (gN/m**2) - -! !OTHER LOCAL VARIABLES: - integer :: c,err_index,j ! indices - integer :: fc ! lake filter indices - logical :: err_found ! error flag - real(r8):: dt ! radiation time step (seconds) - integer :: icnt ! counter -!EOP -!----------------------------------------------------------------------- - ! assign local pointers to column-level arrays - - totcoln => cns%totcoln - ndep_to_sminn => cnf%ndep_to_sminn - nfix_to_sminn => cnf%nfix_to_sminn - fert_to_sminn => cnf%fert_to_sminn - soyfixn_to_sminn => cnf%soyfixn_to_sminn - supplement_to_sminn => cnf%supplement_to_sminn - denit => cnf%denit -#ifndef NITRIF_DENITRIF - sminn_leached => cnf%sminn_leached -#else - smin_no3_leached => cnf%smin_no3_leached - smin_no3_runoff => cnf%smin_no3_runoff - f_n2o_nit => cnf%f_n2o_nit -#endif - col_fire_nloss => cnf%col_fire_nloss - dwt_nloss => cnf%dwt_nloss - product_nloss => cnf%product_nloss - som_n_leached => cnf%som_n_leached - - col_ninputs => cnf%col_ninputs - col_noutputs => cnf%col_noutputs - col_begnb => cnbal%begnb - col_endnb => cnbal%endnb - col_errnb => cnbal%errnb - - ! set time steps - dt = real( get_step_size(), r8 ) - - icnt = 0 - err_found = .false. - ! column loop - do fc = 1,num_soilc - c=filter_soilc(fc) - - ! calculate the total column-level nitrogen storage, for mass conservation check - - col_endnb(c) = totcoln(c) - - ! calculate total column-level inputs - - col_ninputs(c) = ndep_to_sminn(c) + nfix_to_sminn(c) + supplement_to_sminn(c) - if (crop_prog) col_ninputs(c) = col_ninputs(c) + & - fert_to_sminn(c) + soyfixn_to_sminn(c) - - ! calculate total column-level outputs - - col_noutputs(c) = denit(c) + col_fire_nloss(c) + dwt_nloss(c) + product_nloss(c) - -#ifndef NITRIF_DENITRIF - 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) -#endif - - col_noutputs(c) = col_noutputs(c) - som_n_leached(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 (col_endnb(c) > 0. .and. abs(col_errnb(c)) > 0.1) then - err_found = .true. - err_index = c - icnt = icnt + 1 - if(icnt > 1 .and. abs(col_errnb(c)) > abs(col_errnb(err_index))) err_index = c - endif - - 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 - stop 'NBalance' - end if - - end subroutine NBalanceCheck - !----------------------------------------------------------------------- -!#endif - -end module CNBalanceCheckMod 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 deleted file mode 100644 index 262f1e817..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate1Mod.F90 +++ /dev/null @@ -1,662 +0,0 @@ -module CNCStateUpdate1Mod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CStateUpdate1Mod -! -! !DESCRIPTION: -! Module for carbon state variable update, non-mortality fluxes. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varpar , only: ndecomp_cascade_transitions, nlevdecomp - - implicit none - save - private -! -! !PUBLIC MEMBER FUNCTIONS: - public:: CStateUpdate1 - public:: CStateUpdate0 -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CStateUpdate0 -! -! !INTERFACE: -subroutine CStateUpdate0(num_soilp, filter_soilp, isotope) -! -! !DESCRIPTION: -! On the radiation time step, update cpool carbon state -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - character(len=*), intent(in) :: isotope ! 'bulk', 'c13' or 'c14' -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 7/1/05: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays - real(r8), pointer :: psnshade_to_cpool(:) - real(r8), pointer :: psnsun_to_cpool(:) -! -! local pointers to implicit in/out arrays - real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool -! !OTHER LOCAL VARIABLES: - type(pft_cflux_type), pointer :: pcisof - type(pft_cstate_type), pointer :: pcisos - integer :: p ! indices - integer :: fp ! lake filter indices - real(r8):: dt ! radiation time step (seconds) -! -!EOP -!----------------------------------------------------------------------- - - ! select which isotope - select case (isotope) - case ('bulk') - pcisof => pcf - pcisos => pcs - case ('c14') - pcisof => pc14f - pcisos => pc14s - case ('c13') - pcisof => pc13f - pcisos => pc13s - case default - stop 'CNCIsoStateUpdate1Mod: iso must be bulk, c13 or c14' - end select - - ! assign local pointers at the pft level - cpool => pcisos%cpool - psnshade_to_cpool => pcisof%psnshade_to_cpool - psnsun_to_cpool => pcisof%psnsun_to_cpool - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - ! gross photosynthesis fluxes - cpool(p) = cpool(p) + psnsun_to_cpool(p)*dt - cpool(p) = cpool(p) + psnshade_to_cpool(p)*dt - end do - -end subroutine CStateUpdate0 -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CStateUpdate1 -! -! !INTERFACE: -subroutine CStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, isotope) -! -! !DESCRIPTION: -! On the radiation time step, update all the prognostic carbon state -! variables (except for gap-phase mortality and fire fluxes) -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varpar , only: i_met_lit, i_cel_lit, i_lig_lit, i_cwd - use pftvarcon , only: npcropmin - use clm_varctl, only: crop_prog -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - character(len=*), intent(in) :: isotope ! 'bulk', 'c13' or 'c14' -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 8/1/03: Created by Peter Thornton -! 12/5/03, Peter Thornton: Added livewood turnover fluxes -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays -! - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - integer , pointer :: ivt(:) ! pft vegetation type - integer , pointer :: harvdate(:) ! harvest date - real(r8), pointer :: xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s) - real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:) - real(r8), pointer :: deadstemc_xfer_to_deadstemc(:) - real(r8), pointer :: frootc_xfer_to_frootc(:) - real(r8), pointer :: leafc_xfer_to_leafc(:) - real(r8), pointer :: livecrootc_xfer_to_livecrootc(:) - real(r8), pointer :: livestemc_xfer_to_livestemc(:) - real(r8), pointer :: cpool_to_xsmrpool(:) - real(r8), pointer :: cpool_to_deadcrootc(:) - real(r8), pointer :: cpool_to_deadcrootc_storage(:) - real(r8), pointer :: cpool_to_deadstemc(:) - real(r8), pointer :: cpool_to_deadstemc_storage(:) - real(r8), pointer :: cpool_to_frootc(:) - real(r8), pointer :: cpool_to_frootc_storage(:) - real(r8), pointer :: cpool_to_gresp_storage(:) - real(r8), pointer :: cpool_to_leafc(:) - real(r8), pointer :: cpool_to_leafc_storage(:) - real(r8), pointer :: cpool_to_livecrootc(:) - real(r8), pointer :: cpool_to_livecrootc_storage(:) - real(r8), pointer :: cpool_to_livestemc(:) - real(r8), pointer :: cpool_to_livestemc_storage(:) - real(r8), pointer :: deadcrootc_storage_to_xfer(:) - real(r8), pointer :: deadstemc_storage_to_xfer(:) - real(r8), pointer :: frootc_storage_to_xfer(:) - real(r8), pointer :: frootc_to_litter(:) - real(r8), pointer :: gresp_storage_to_xfer(:) - real(r8), pointer :: leafc_storage_to_xfer(:) - real(r8), pointer :: leafc_to_litter(:) - real(r8), pointer :: livecrootc_storage_to_xfer(:) - real(r8), pointer :: livecrootc_to_deadcrootc(:) - real(r8), pointer :: livestemc_storage_to_xfer(:) - real(r8), pointer :: livestemc_to_deadstemc(:) - real(r8), pointer :: livestem_curmr(:) - real(r8), pointer :: froot_curmr(:) - real(r8), pointer :: leaf_curmr(:) - real(r8), pointer :: livecroot_curmr(:) - real(r8), pointer :: grain_curmr(:) - real(r8), pointer :: livestem_xsmr(:) - real(r8), pointer :: froot_xsmr(:) - real(r8), pointer :: leaf_xsmr(:) - real(r8), pointer :: livecroot_xsmr(:) - real(r8), pointer :: grain_xsmr(:) - real(r8), pointer :: cpool_deadcroot_gr(:) - real(r8), pointer :: cpool_deadcroot_storage_gr(:) - real(r8), pointer :: cpool_deadstem_gr(:) - real(r8), pointer :: cpool_deadstem_storage_gr(:) - real(r8), pointer :: cpool_froot_gr(:) - real(r8), pointer :: cpool_froot_storage_gr(:) - real(r8), pointer :: cpool_leaf_gr(:) - real(r8), pointer :: cpool_leaf_storage_gr(:) - real(r8), pointer :: cpool_livecroot_gr(:) - real(r8), pointer :: cpool_livecroot_storage_gr(:) - real(r8), pointer :: cpool_livestem_gr(:) ! live stem growth respiration (gC/m2/s) - real(r8), pointer :: cpool_livestem_storage_gr(:) ! live stem growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_deadcroot_gr(:) ! dead coarse root growth respiration from storage (gC/m2/s) - real(r8), pointer :: transfer_deadstem_gr(:) ! dead stem growth respiration from storage (gC/m2/s) - real(r8), pointer :: transfer_froot_gr(:) ! fine root growth respiration from storage (gC/m2/s) - real(r8), pointer :: transfer_leaf_gr(:) ! leaf growth respiration from storage (gC/m2/s) - real(r8), pointer :: transfer_livecroot_gr(:) ! live coarse root growth respiration from storage (gC/m2/s) - real(r8), pointer :: transfer_livestem_gr(:) ! live stem growth respiration from storage (gC/m2/s) - real(r8), pointer :: cpool_to_grainc(:) ! allocation to grain C (gC/m2/s) - real(r8), pointer :: cpool_to_grainc_storage(:) ! allocation to grain C storage (gC/m2/s) - real(r8), pointer :: grainc_storage_to_xfer(:) ! grain C shift storage to transfer (gC/m2/s) - real(r8), pointer :: livestemc_to_litter(:) ! live stem C litterfall (gC/m2/s) - real(r8), pointer :: grainc_to_food(:) ! grain C to food (gC/m2/s) - real(r8), pointer :: grainc_xfer_to_grainc(:) ! grain C growth from storage (gC/m2/s) - real(r8), pointer :: cpool_grain_gr(:) ! grain growth respiration (gC/m2/s) - real(r8), pointer :: cpool_grain_storage_gr(:) ! grain growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_grain_gr(:) ! grain growth respiration from storage (gC/m2/s) -! -! local pointers to implicit in/out arrays - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_cpools_sourcesink(:,:,:) ! (gC/m3/timestep) change in decomposing c pools. Used to update concentrations concurrently with vertical transport equation - real(r8), pointer :: decomp_cascade_hr_vr(:,:,:) ! vertically-resolved het. resp. from decomposing C pools (gC/m3/s) - real(r8), pointer :: decomp_cascade_ctransfer_vr(:,:,:) ! vertically-resolved C transferred along deomposition cascade (gC/m3/s) - 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 - real(r8), pointer :: grainc(:) ! (gC/m2) grain C - real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage - real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer - real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: xsmrpool(:) ! (gC/m2) execss maint resp C pool - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: phenology_c_to_litr_met_c(:,:) ! C fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gC/m3/s) - real(r8), pointer :: phenology_c_to_litr_cel_c(:,:) ! C fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gC/m3/s) - real(r8), pointer :: phenology_c_to_litr_lig_c(:,:) ! C fluxes associated with phenology (litterfall and crop) to litter lignin pool (gC/m3/s) - -! local pointers for dynamic landcover fluxes and states - real(r8), pointer :: dwt_seedc_to_leaf(:) - real(r8), pointer :: dwt_seedc_to_deadstem(:) - real(r8), pointer :: dwt_frootc_to_litr_met_c(:,:) - real(r8), pointer :: dwt_frootc_to_litr_cel_c(:,:) - real(r8), pointer :: dwt_frootc_to_litr_lig_c(:,:) - real(r8), pointer :: dwt_livecrootc_to_cwdc(:,:) ! (gC/m2/s) live coarse root to CWD due to landcover change - real(r8), pointer :: dwt_deadcrootc_to_cwdc(:,:) ! (gC/m2/s) dead coarse root to CWD due to landcover change - real(r8), pointer :: seedc(:) - -! -! !OTHER LOCAL VARIABLES: - type(pft_cflux_type), pointer :: pcisof - type(pft_cstate_type), pointer :: pcisos - type(column_cflux_type), pointer :: ccisof - type(column_cstate_type), pointer :: ccisos - integer :: c,p,j,k,l ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) -! -!EOP -!----------------------------------------------------------------------- - ! select which isotope - select case (isotope) - case ('bulk') - pcisof => pcf - pcisos => pcs - ccisof => ccf - ccisos => ccs - case ('c14') - pcisof => pc14f - pcisos => pc14s - ccisof => cc14f - ccisos => cc14s - case ('c13') - pcisof => pc13f - pcisos => pc13s - ccisof => cc13f - ccisos => cc13s - case default - stop 'CNCIsoStateUpdate1Mod: iso must be bulk, c13 or c14' - end select - - ! assign local pointers - woody => pftcon%woody - - ! assign local pointers at the column level - decomp_cpools_vr => ccisos%decomp_cpools_vr - decomp_cpools_sourcesink => ccisof%decomp_cpools_sourcesink - decomp_cascade_hr_vr => ccisof%decomp_cascade_hr_vr - decomp_cascade_ctransfer_vr => ccisof%decomp_cascade_ctransfer_vr - cascade_donor_pool => decomp_cascade_con%cascade_donor_pool - cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool - phenology_c_to_litr_met_c => ccisof%phenology_c_to_litr_met_c - phenology_c_to_litr_cel_c => ccisof%phenology_c_to_litr_cel_c - phenology_c_to_litr_lig_c => ccisof%phenology_c_to_litr_lig_c - - ! new pointers for dynamic landcover - dwt_seedc_to_leaf => ccisof%dwt_seedc_to_leaf - dwt_seedc_to_deadstem => ccisof%dwt_seedc_to_deadstem - dwt_frootc_to_litr_met_c => ccisof%dwt_frootc_to_litr_met_c - dwt_frootc_to_litr_cel_c => ccisof%dwt_frootc_to_litr_cel_c - dwt_frootc_to_litr_lig_c => ccisof%dwt_frootc_to_litr_lig_c - dwt_livecrootc_to_cwdc => ccisof%dwt_livecrootc_to_cwdc - dwt_deadcrootc_to_cwdc => ccisof%dwt_deadcrootc_to_cwdc - seedc => ccisos%seedc - - ! assign local pointers at the pft level - ivt =>pft%itype - cpool_deadcroot_gr => pcisof%cpool_deadcroot_gr - cpool_deadcroot_storage_gr => pcisof%cpool_deadcroot_storage_gr - cpool_deadstem_gr => pcisof%cpool_deadstem_gr - cpool_deadstem_storage_gr => pcisof%cpool_deadstem_storage_gr - cpool_froot_gr => pcisof%cpool_froot_gr - cpool_froot_storage_gr => pcisof%cpool_froot_storage_gr - cpool_leaf_gr => pcisof%cpool_leaf_gr - cpool_leaf_storage_gr => pcisof%cpool_leaf_storage_gr - cpool_livecroot_gr => pcisof%cpool_livecroot_gr - cpool_livecroot_storage_gr => pcisof%cpool_livecroot_storage_gr - cpool_livestem_gr => pcisof%cpool_livestem_gr - cpool_livestem_storage_gr => pcisof%cpool_livestem_storage_gr - cpool_to_xsmrpool => pcisof%cpool_to_xsmrpool - cpool_to_deadcrootc => pcisof%cpool_to_deadcrootc - cpool_to_deadcrootc_storage => pcisof%cpool_to_deadcrootc_storage - cpool_to_deadstemc => pcisof%cpool_to_deadstemc - cpool_to_deadstemc_storage => pcisof%cpool_to_deadstemc_storage - cpool_to_frootc => pcisof%cpool_to_frootc - cpool_to_frootc_storage => pcisof%cpool_to_frootc_storage - cpool_to_gresp_storage => pcisof%cpool_to_gresp_storage - cpool_to_leafc => pcisof%cpool_to_leafc - cpool_to_leafc_storage => pcisof%cpool_to_leafc_storage - cpool_to_livecrootc => pcisof%cpool_to_livecrootc - cpool_to_livecrootc_storage => pcisof%cpool_to_livecrootc_storage - cpool_to_livestemc => pcisof%cpool_to_livestemc - cpool_to_livestemc_storage => pcisof%cpool_to_livestemc_storage - deadcrootc_storage_to_xfer => pcisof%deadcrootc_storage_to_xfer - deadcrootc_xfer_to_deadcrootc => pcisof%deadcrootc_xfer_to_deadcrootc - deadstemc_storage_to_xfer => pcisof%deadstemc_storage_to_xfer - deadstemc_xfer_to_deadstemc => pcisof%deadstemc_xfer_to_deadstemc - froot_curmr => pcisof%froot_curmr - froot_xsmr => pcisof%froot_xsmr - frootc_storage_to_xfer => pcisof%frootc_storage_to_xfer - frootc_to_litter => pcisof%frootc_to_litter - frootc_xfer_to_frootc => pcisof%frootc_xfer_to_frootc - gresp_storage_to_xfer => pcisof%gresp_storage_to_xfer - leaf_curmr => pcisof%leaf_curmr - leaf_xsmr => pcisof%leaf_xsmr - leafc_storage_to_xfer => pcisof%leafc_storage_to_xfer - leafc_to_litter => pcisof%leafc_to_litter - leafc_xfer_to_leafc => pcisof%leafc_xfer_to_leafc - livecroot_curmr => pcisof%livecroot_curmr - livecroot_xsmr => pcisof%livecroot_xsmr - livecrootc_storage_to_xfer => pcisof%livecrootc_storage_to_xfer - livecrootc_to_deadcrootc => pcisof%livecrootc_to_deadcrootc - livecrootc_xfer_to_livecrootc => pcisof%livecrootc_xfer_to_livecrootc - livestem_curmr => pcisof%livestem_curmr - livestem_xsmr => pcisof%livestem_xsmr - livestemc_storage_to_xfer => pcisof%livestemc_storage_to_xfer - livestemc_to_deadstemc => pcisof%livestemc_to_deadstemc - livestemc_xfer_to_livestemc => pcisof%livestemc_xfer_to_livestemc - transfer_deadcroot_gr => pcisof%transfer_deadcroot_gr - transfer_deadstem_gr => pcisof%transfer_deadstem_gr - transfer_froot_gr => pcisof%transfer_froot_gr - transfer_leaf_gr => pcisof%transfer_leaf_gr - transfer_livecroot_gr => pcisof%transfer_livecroot_gr - transfer_livestem_gr => pcisof%transfer_livestem_gr - harvdate => pps%harvdate - xsmrpool_to_atm => pcisof%xsmrpool_to_atm - cpool_grain_gr => pcisof%cpool_grain_gr - cpool_grain_storage_gr => pcisof%cpool_grain_storage_gr - cpool_to_grainc => pcisof%cpool_to_grainc - cpool_to_grainc_storage => pcisof%cpool_to_grainc_storage - livestemc_to_litter => pcisof%livestemc_to_litter - grain_curmr => pcf%grain_curmr - grain_xsmr => pcf%grain_xsmr - grainc_storage_to_xfer => pcisof%grainc_storage_to_xfer - grainc_to_food => pcisof%grainc_to_food - grainc_xfer_to_grainc => pcisof%grainc_xfer_to_grainc - transfer_grain_gr => pcisof%transfer_grain_gr - grainc => pcisos%grainc - grainc_storage => pcisos%grainc_storage - grainc_xfer => pcisos%grainc_xfer - cpool => pcisos%cpool - xsmrpool => pcisos%xsmrpool - deadcrootc => pcisos%deadcrootc - deadcrootc_storage => pcisos%deadcrootc_storage - deadcrootc_xfer => pcisos%deadcrootc_xfer - deadstemc => pcisos%deadstemc - deadstemc_storage => pcisos%deadstemc_storage - deadstemc_xfer => pcisos%deadstemc_xfer - frootc => pcisos%frootc - frootc_storage => pcisos%frootc_storage - frootc_xfer => pcisos%frootc_xfer - gresp_storage => pcisos%gresp_storage - gresp_xfer => pcisos%gresp_xfer - leafc => pcisos%leafc - leafc_storage => pcisos%leafc_storage - leafc_xfer => pcisos%leafc_xfer - livecrootc => pcisos%livecrootc - livecrootc_storage => pcisos%livecrootc_storage - livecrootc_xfer => pcisos%livecrootc_xfer - livestemc => pcisos%livestemc - livestemc_storage => pcisos%livestemc_storage - livestemc_xfer => pcisos%livestemc_xfer - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! column level fluxes - - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - ! seeding fluxes, from dynamic landcover - seedc(c) = seedc(c) - dwt_seedc_to_leaf(c) * dt - seedc(c) = seedc(c) - dwt_seedc_to_deadstem(c) * dt - end do - - ! plant to litter fluxes - do j = 1,nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - ! phenology and dynamic land cover fluxes - decomp_cpools_sourcesink(c,j,i_met_lit) = ( phenology_c_to_litr_met_c(c,j) + dwt_frootc_to_litr_met_c(c,j) ) *dt - decomp_cpools_sourcesink(c,j,i_cel_lit) = ( phenology_c_to_litr_cel_c(c,j) + dwt_frootc_to_litr_cel_c(c,j) ) *dt - decomp_cpools_sourcesink(c,j,i_lig_lit) = ( phenology_c_to_litr_lig_c(c,j) + dwt_frootc_to_litr_lig_c(c,j) ) *dt - decomp_cpools_sourcesink(c,j,i_cwd) = ( dwt_livecrootc_to_cwdc(c,j) + dwt_deadcrootc_to_cwdc(c,j) ) *dt - end do - end do - - ! litter and SOM HR fluxes - do k = 1, ndecomp_cascade_transitions - do j = 1,nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_cpools_sourcesink(c,j,cascade_donor_pool(k)) = & - decomp_cpools_sourcesink(c,j,cascade_donor_pool(k)) & - - ( decomp_cascade_hr_vr(c,j,k) + decomp_cascade_ctransfer_vr(c,j,k)) *dt - end do - end do - end do - do k = 1, ndecomp_cascade_transitions - if ( cascade_receiver_pool(k) .ne. 0 ) then ! skip terminal transitions - do j = 1,nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_cpools_sourcesink(c,j,cascade_receiver_pool(k)) = & - decomp_cpools_sourcesink(c,j,cascade_receiver_pool(k)) & - + decomp_cascade_ctransfer_vr(c,j,k)*dt - end do - end do - end if - end do - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! phenology: transfer growth fluxes - leafc(p) = leafc(p) + leafc_xfer_to_leafc(p)*dt - leafc_xfer(p) = leafc_xfer(p) - leafc_xfer_to_leafc(p)*dt - frootc(p) = frootc(p) + frootc_xfer_to_frootc(p)*dt - frootc_xfer(p) = frootc_xfer(p) - frootc_xfer_to_frootc(p)*dt - if (woody(ivt(p)) == 1._r8) then - livestemc(p) = livestemc(p) + livestemc_xfer_to_livestemc(p)*dt - livestemc_xfer(p) = livestemc_xfer(p) - livestemc_xfer_to_livestemc(p)*dt - deadstemc(p) = deadstemc(p) + deadstemc_xfer_to_deadstemc(p)*dt - deadstemc_xfer(p) = deadstemc_xfer(p) - deadstemc_xfer_to_deadstemc(p)*dt - livecrootc(p) = livecrootc(p) + livecrootc_xfer_to_livecrootc(p)*dt - livecrootc_xfer(p) = livecrootc_xfer(p) - livecrootc_xfer_to_livecrootc(p)*dt - deadcrootc(p) = deadcrootc(p) + deadcrootc_xfer_to_deadcrootc(p)*dt - deadcrootc_xfer(p) = deadcrootc_xfer(p) - deadcrootc_xfer_to_deadcrootc(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - ! lines here for consistency; the transfer terms are zero - livestemc(p) = livestemc(p) + livestemc_xfer_to_livestemc(p)*dt - livestemc_xfer(p) = livestemc_xfer(p) - livestemc_xfer_to_livestemc(p)*dt - grainc(p) = grainc(p) + grainc_xfer_to_grainc(p)*dt - grainc_xfer(p) = grainc_xfer(p) - grainc_xfer_to_grainc(p)*dt - end if - - ! phenology: litterfall fluxes - leafc(p) = leafc(p) - leafc_to_litter(p)*dt - frootc(p) = frootc(p) - frootc_to_litter(p)*dt - - ! livewood turnover fluxes - if (woody(ivt(p)) == 1._r8) then - livestemc(p) = livestemc(p) - livestemc_to_deadstemc(p)*dt - deadstemc(p) = deadstemc(p) + livestemc_to_deadstemc(p)*dt - livecrootc(p) = livecrootc(p) - livecrootc_to_deadcrootc(p)*dt - deadcrootc(p) = deadcrootc(p) + livecrootc_to_deadcrootc(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - livestemc(p) = livestemc(p) - livestemc_to_litter(p)*dt - grainc(p) = grainc(p) - grainc_to_food(p)*dt - end if - - ! maintenance respiration fluxes from cpool - cpool(p) = cpool(p) - cpool_to_xsmrpool(p)*dt - cpool(p) = cpool(p) - leaf_curmr(p)*dt - cpool(p) = cpool(p) - froot_curmr(p)*dt - if (woody(ivt(p)) == 1._r8) then - cpool(p) = cpool(p) - livestem_curmr(p)*dt - cpool(p) = cpool(p) - livecroot_curmr(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - cpool(p) = cpool(p) - livestem_curmr(p)*dt - cpool(p) = cpool(p) - grain_curmr(p)*dt - end if - - ! maintenance respiration fluxes from xsmrpool - xsmrpool(p) = xsmrpool(p) + cpool_to_xsmrpool(p)*dt - xsmrpool(p) = xsmrpool(p) - leaf_xsmr(p)*dt - xsmrpool(p) = xsmrpool(p) - froot_xsmr(p)*dt - if (woody(ivt(p)) == 1._r8) then - xsmrpool(p) = xsmrpool(p) - livestem_xsmr(p)*dt - xsmrpool(p) = xsmrpool(p) - livecroot_xsmr(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - xsmrpool(p) = xsmrpool(p) - livestem_xsmr(p)*dt - xsmrpool(p) = xsmrpool(p) - grain_xsmr(p)*dt - if (harvdate(p) < 999) then ! beginning at harvest, send to atm - xsmrpool_to_atm(p) = xsmrpool_to_atm(p) + xsmrpool(p)/dt - xsmrpool(p) = xsmrpool(p) - xsmrpool_to_atm(p)*dt - end if - end if - - ! allocation fluxes - cpool(p) = cpool(p) - cpool_to_leafc(p)*dt - leafc(p) = leafc(p) + cpool_to_leafc(p)*dt - cpool(p) = cpool(p) - cpool_to_leafc_storage(p)*dt - leafc_storage(p) = leafc_storage(p) + cpool_to_leafc_storage(p)*dt - cpool(p) = cpool(p) - cpool_to_frootc(p)*dt - frootc(p) = frootc(p) + cpool_to_frootc(p)*dt - cpool(p) = cpool(p) - cpool_to_frootc_storage(p)*dt - frootc_storage(p) = frootc_storage(p) + cpool_to_frootc_storage(p)*dt - if (woody(ivt(p)) == 1._r8) then - cpool(p) = cpool(p) - cpool_to_livestemc(p)*dt - livestemc(p) = livestemc(p) + cpool_to_livestemc(p)*dt - cpool(p) = cpool(p) - cpool_to_livestemc_storage(p)*dt - livestemc_storage(p) = livestemc_storage(p) + cpool_to_livestemc_storage(p)*dt - cpool(p) = cpool(p) - cpool_to_deadstemc(p)*dt - deadstemc(p) = deadstemc(p) + cpool_to_deadstemc(p)*dt - cpool(p) = cpool(p) - cpool_to_deadstemc_storage(p)*dt - deadstemc_storage(p) = deadstemc_storage(p) + cpool_to_deadstemc_storage(p)*dt - cpool(p) = cpool(p) - cpool_to_livecrootc(p)*dt - livecrootc(p) = livecrootc(p) + cpool_to_livecrootc(p)*dt - cpool(p) = cpool(p) - cpool_to_livecrootc_storage(p)*dt - livecrootc_storage(p) = livecrootc_storage(p) + cpool_to_livecrootc_storage(p)*dt - cpool(p) = cpool(p) - cpool_to_deadcrootc(p)*dt - deadcrootc(p) = deadcrootc(p) + cpool_to_deadcrootc(p)*dt - cpool(p) = cpool(p) - cpool_to_deadcrootc_storage(p)*dt - deadcrootc_storage(p) = deadcrootc_storage(p) + cpool_to_deadcrootc_storage(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - cpool(p) = cpool(p) - cpool_to_livestemc(p)*dt - livestemc(p) = livestemc(p) + cpool_to_livestemc(p)*dt - cpool(p) = cpool(p) - cpool_to_livestemc_storage(p)*dt - livestemc_storage(p) = livestemc_storage(p) + cpool_to_livestemc_storage(p)*dt - cpool(p) = cpool(p) - cpool_to_grainc(p)*dt - grainc(p) = grainc(p) + cpool_to_grainc(p)*dt - cpool(p) = cpool(p) - cpool_to_grainc_storage(p)*dt - grainc_storage(p) = grainc_storage(p) + cpool_to_grainc_storage(p)*dt - end if - - ! growth respiration fluxes for current growth - cpool(p) = cpool(p) - cpool_leaf_gr(p)*dt - cpool(p) = cpool(p) - cpool_froot_gr(p)*dt - if (woody(ivt(p)) == 1._r8) then - cpool(p) = cpool(p) - cpool_livestem_gr(p)*dt - cpool(p) = cpool(p) - cpool_deadstem_gr(p)*dt - cpool(p) = cpool(p) - cpool_livecroot_gr(p)*dt - cpool(p) = cpool(p) - cpool_deadcroot_gr(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - cpool(p) = cpool(p) - cpool_livestem_gr(p)*dt - cpool(p) = cpool(p) - cpool_grain_gr(p)*dt - end if - - ! growth respiration for transfer growth - gresp_xfer(p) = gresp_xfer(p) - transfer_leaf_gr(p)*dt - gresp_xfer(p) = gresp_xfer(p) - transfer_froot_gr(p)*dt - if (woody(ivt(p)) == 1._r8) then - gresp_xfer(p) = gresp_xfer(p) - transfer_livestem_gr(p)*dt - gresp_xfer(p) = gresp_xfer(p) - transfer_deadstem_gr(p)*dt - gresp_xfer(p) = gresp_xfer(p) - transfer_livecroot_gr(p)*dt - gresp_xfer(p) = gresp_xfer(p) - transfer_deadcroot_gr(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - gresp_xfer(p) = gresp_xfer(p) - transfer_livestem_gr(p)*dt - gresp_xfer(p) = gresp_xfer(p) - transfer_grain_gr(p)*dt - end if - - ! growth respiration at time of storage - cpool(p) = cpool(p) - cpool_leaf_storage_gr(p)*dt - cpool(p) = cpool(p) - cpool_froot_storage_gr(p)*dt - if (woody(ivt(p)) == 1._r8) then - cpool(p) = cpool(p) - cpool_livestem_storage_gr(p)*dt - cpool(p) = cpool(p) - cpool_deadstem_storage_gr(p)*dt - cpool(p) = cpool(p) - cpool_livecroot_storage_gr(p)*dt - cpool(p) = cpool(p) - cpool_deadcroot_storage_gr(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - cpool(p) = cpool(p) - cpool_livestem_storage_gr(p)*dt - cpool(p) = cpool(p) - cpool_grain_storage_gr(p)*dt - end if - - ! growth respiration stored for release during transfer growth - cpool(p) = cpool(p) - cpool_to_gresp_storage(p)*dt - gresp_storage(p) = gresp_storage(p) + cpool_to_gresp_storage(p)*dt - - ! move storage pools into transfer pools - leafc_storage(p) = leafc_storage(p) - leafc_storage_to_xfer(p)*dt - leafc_xfer(p) = leafc_xfer(p) + leafc_storage_to_xfer(p)*dt - frootc_storage(p) = frootc_storage(p) - frootc_storage_to_xfer(p)*dt - frootc_xfer(p) = frootc_xfer(p) + frootc_storage_to_xfer(p)*dt - if (woody(ivt(p)) == 1._r8) then - livestemc_storage(p) = livestemc_storage(p) - livestemc_storage_to_xfer(p)*dt - livestemc_xfer(p) = livestemc_xfer(p) + livestemc_storage_to_xfer(p)*dt - deadstemc_storage(p) = deadstemc_storage(p) - deadstemc_storage_to_xfer(p)*dt - deadstemc_xfer(p) = deadstemc_xfer(p) + deadstemc_storage_to_xfer(p)*dt - livecrootc_storage(p) = livecrootc_storage(p) - livecrootc_storage_to_xfer(p)*dt - livecrootc_xfer(p) = livecrootc_xfer(p) + livecrootc_storage_to_xfer(p)*dt - deadcrootc_storage(p) = deadcrootc_storage(p) - deadcrootc_storage_to_xfer(p)*dt - deadcrootc_xfer(p) = deadcrootc_xfer(p) + deadcrootc_storage_to_xfer(p)*dt - gresp_storage(p) = gresp_storage(p) - gresp_storage_to_xfer(p)*dt - gresp_xfer(p) = gresp_xfer(p) + gresp_storage_to_xfer(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - ! lines here for consistency; the transfer terms are zero - livestemc_storage(p) = livestemc_storage(p) - livestemc_storage_to_xfer(p)*dt - livestemc_xfer(p) = livestemc_xfer(p) + livestemc_storage_to_xfer(p)*dt - grainc_storage(p) = grainc_storage(p) - grainc_storage_to_xfer(p)*dt - grainc_xfer(p) = grainc_xfer(p) + grainc_storage_to_xfer(p)*dt - end if - - end do ! end of pft loop - -end subroutine CStateUpdate1 -!----------------------------------------------------------------------- -!#endif - -end module CNCStateUpdate1Mod 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 deleted file mode 100644 index c42d90543..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate2Mod.F90 +++ /dev/null @@ -1,485 +0,0 @@ - -module CNCStateUpdate2Mod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CStateUpdate2Mod -! -! !DESCRIPTION: -! Module for carbon state variable update, mortality fluxes. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: CStateUpdate2 - public:: CStateUpdate2h -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CStateUpdate2 -! -! !INTERFACE: -subroutine CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, isotope) -! -! !DESCRIPTION: -! On the radiation time step, update all the prognostic carbon state -! variables affected by gap-phase mortality fluxes -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varpar , only: nlevsoi, nlevdecomp - use clm_varpar , only: i_met_lit, i_cel_lit, i_lig_lit, i_cwd -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - character(len=*), intent(in) :: isotope ! 'bulk', 'c13' or 'c14' -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 3/29/04: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays - real(r8), pointer :: gap_mortality_c_to_litr_met_c(:,:) ! C fluxes associated with gap mortality to litter metabolic pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_litr_cel_c(:,:) ! C fluxes associated with gap mortality to litter cellulose pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_litr_lig_c(:,:) ! C fluxes associated with gap mortality to litter lignin pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_cwdc(:,:) ! C fluxes associated with gap mortality to CWD pool (gC/m3/s) - real(r8), pointer :: m_deadcrootc_storage_to_litter(:) - real(r8), pointer :: m_deadcrootc_to_litter(:) - real(r8), pointer :: m_deadcrootc_xfer_to_litter(:) - real(r8), pointer :: m_deadstemc_storage_to_litter(:) - real(r8), pointer :: m_deadstemc_to_litter(:) - real(r8), pointer :: m_deadstemc_xfer_to_litter(:) - real(r8), pointer :: m_frootc_storage_to_litter(:) - real(r8), pointer :: m_frootc_to_litter(:) - real(r8), pointer :: m_frootc_xfer_to_litter(:) - real(r8), pointer :: m_gresp_storage_to_litter(:) - real(r8), pointer :: m_gresp_xfer_to_litter(:) - real(r8), pointer :: m_leafc_storage_to_litter(:) - real(r8), pointer :: m_leafc_to_litter(:) - real(r8), pointer :: m_leafc_xfer_to_litter(:) - real(r8), pointer :: m_livecrootc_storage_to_litter(:) - real(r8), pointer :: m_livecrootc_to_litter(:) - real(r8), pointer :: m_livecrootc_xfer_to_litter(:) - real(r8), pointer :: m_livestemc_storage_to_litter(:) - real(r8), pointer :: m_livestemc_to_litter(:) - real(r8), pointer :: m_livestemc_xfer_to_litter(:) -! -! local pointers to implicit in/out arrays - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) !(gC/m2) dead coarse root C transfer - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) !(gC/m2) live coarse root C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer -! -! -! local pointers to implicit out arrays -! -! -! !OTHER LOCAL VARIABLES: - type(pft_cflux_type), pointer :: pcisof - type(pft_cstate_type), pointer :: pcisos - type(column_cflux_type), pointer :: ccisof - type(column_cstate_type), pointer :: ccisos - integer :: c,p,j ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) -! -!EOP -!----------------------------------------------------------------------- - ! select which isotope - select case (isotope) - case ('bulk') - pcisof => pcf - pcisos => pcs - ccisof => ccf - ccisos => ccs - case ('c14') - pcisof => pc14f - pcisos => pc14s - ccisof => cc14f - ccisos => cc14s - case ('c13') - pcisof => pc13f - pcisos => pc13s - ccisof => cc13f - ccisos => cc13s - case default - stop 'CNCIsoStateUpdate2Mod: iso must be bulk, c13 or c14' - end select - - ! assign local pointers at the column level - gap_mortality_c_to_litr_met_c => ccisof%gap_mortality_c_to_litr_met_c - gap_mortality_c_to_litr_cel_c => ccisof%gap_mortality_c_to_litr_cel_c - gap_mortality_c_to_litr_lig_c => ccisof%gap_mortality_c_to_litr_lig_c - gap_mortality_c_to_cwdc => ccisof%gap_mortality_c_to_cwdc - decomp_cpools_vr => ccisos%decomp_cpools_vr - - - ! assign local pointers at the pft level - m_deadcrootc_storage_to_litter => pcisof%m_deadcrootc_storage_to_litter - m_deadcrootc_to_litter => pcisof%m_deadcrootc_to_litter - m_deadcrootc_xfer_to_litter => pcisof%m_deadcrootc_xfer_to_litter - m_deadstemc_storage_to_litter => pcisof%m_deadstemc_storage_to_litter - m_deadstemc_to_litter => pcisof%m_deadstemc_to_litter - m_deadstemc_xfer_to_litter => pcisof%m_deadstemc_xfer_to_litter - m_frootc_storage_to_litter => pcisof%m_frootc_storage_to_litter - m_frootc_to_litter => pcisof%m_frootc_to_litter - m_frootc_xfer_to_litter => pcisof%m_frootc_xfer_to_litter - m_gresp_storage_to_litter => pcisof%m_gresp_storage_to_litter - m_gresp_xfer_to_litter => pcisof%m_gresp_xfer_to_litter - m_leafc_storage_to_litter => pcisof%m_leafc_storage_to_litter - m_leafc_to_litter => pcisof%m_leafc_to_litter - m_leafc_xfer_to_litter => pcisof%m_leafc_xfer_to_litter - m_livecrootc_storage_to_litter => pcisof%m_livecrootc_storage_to_litter - m_livecrootc_to_litter => pcisof%m_livecrootc_to_litter - m_livecrootc_xfer_to_litter => pcisof%m_livecrootc_xfer_to_litter - m_livestemc_storage_to_litter => pcisof%m_livestemc_storage_to_litter - m_livestemc_to_litter => pcisof%m_livestemc_to_litter - m_livestemc_xfer_to_litter => pcisof%m_livestemc_xfer_to_litter - deadcrootc => pcisos%deadcrootc - deadcrootc_storage => pcisos%deadcrootc_storage - deadcrootc_xfer => pcisos%deadcrootc_xfer - deadstemc => pcisos%deadstemc - deadstemc_storage => pcisos%deadstemc_storage - deadstemc_xfer => pcisos%deadstemc_xfer - frootc => pcisos%frootc - frootc_storage => pcisos%frootc_storage - frootc_xfer => pcisos%frootc_xfer - gresp_storage => pcisos%gresp_storage - gresp_xfer => pcisos%gresp_xfer - leafc => pcisos%leafc - leafc_storage => pcisos%leafc_storage - leafc_xfer => pcisos%leafc_xfer - livecrootc => pcisos%livecrootc - livecrootc_storage => pcisos%livecrootc_storage - livecrootc_xfer => pcisos%livecrootc_xfer - livestemc => pcisos%livestemc - livestemc_storage => pcisos%livestemc_storage - livestemc_xfer => pcisos%livestemc_xfer - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! 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 - decomp_cpools_vr(c,j,i_met_lit) = decomp_cpools_vr(c,j,i_met_lit) + gap_mortality_c_to_litr_met_c(c,j) * dt - decomp_cpools_vr(c,j,i_cel_lit) = decomp_cpools_vr(c,j,i_cel_lit) + gap_mortality_c_to_litr_cel_c(c,j) * dt - decomp_cpools_vr(c,j,i_lig_lit) = decomp_cpools_vr(c,j,i_lig_lit) + gap_mortality_c_to_litr_lig_c(c,j) * dt - decomp_cpools_vr(c,j,i_cwd) = decomp_cpools_vr(c,j,i_cwd) + gap_mortality_c_to_cwdc(c,j) * dt - - end do - end do - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! pft-level carbon fluxes from gap-phase mortality - ! displayed pools - leafc(p) = leafc(p) - m_leafc_to_litter(p) * dt - frootc(p) = frootc(p) - m_frootc_to_litter(p) * dt - livestemc(p) = livestemc(p) - m_livestemc_to_litter(p) * dt - deadstemc(p) = deadstemc(p) - m_deadstemc_to_litter(p) * dt - livecrootc(p) = livecrootc(p) - m_livecrootc_to_litter(p) * dt - deadcrootc(p) = deadcrootc(p) - m_deadcrootc_to_litter(p) * dt - - ! storage pools - leafc_storage(p) = leafc_storage(p) - m_leafc_storage_to_litter(p) * dt - frootc_storage(p) = frootc_storage(p) - m_frootc_storage_to_litter(p) * dt - livestemc_storage(p) = livestemc_storage(p) - m_livestemc_storage_to_litter(p) * dt - deadstemc_storage(p) = deadstemc_storage(p) - m_deadstemc_storage_to_litter(p) * dt - livecrootc_storage(p) = livecrootc_storage(p) - m_livecrootc_storage_to_litter(p) * dt - deadcrootc_storage(p) = deadcrootc_storage(p) - m_deadcrootc_storage_to_litter(p) * dt - gresp_storage(p) = gresp_storage(p) - m_gresp_storage_to_litter(p) * dt - - ! transfer pools - leafc_xfer(p) = leafc_xfer(p) - m_leafc_xfer_to_litter(p) * dt - frootc_xfer(p) = frootc_xfer(p) - m_frootc_xfer_to_litter(p) * dt - livestemc_xfer(p) = livestemc_xfer(p) - m_livestemc_xfer_to_litter(p) * dt - deadstemc_xfer(p) = deadstemc_xfer(p) - m_deadstemc_xfer_to_litter(p) * dt - livecrootc_xfer(p) = livecrootc_xfer(p) - m_livecrootc_xfer_to_litter(p) * dt - deadcrootc_xfer(p) = deadcrootc_xfer(p) - m_deadcrootc_xfer_to_litter(p) * dt - gresp_xfer(p) = gresp_xfer(p) - m_gresp_xfer_to_litter(p) * dt - end do ! end of pft loop - -end subroutine CStateUpdate2 -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CStateUpdate2h -! -! !INTERFACE: -subroutine CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, isotope) -! -! !DESCRIPTION: -! Update all the prognostic carbon state -! variables affected by harvest mortality fluxes -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varpar , only: nlevdecomp - use clm_varpar , only: i_met_lit, i_cel_lit, i_lig_lit, i_cwd -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - character(len=*), intent(in) :: isotope ! 'bulk', 'c13' or 'c14' -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 5/20/09: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays - real(r8), pointer :: harvest_c_to_litr_met_c(:,:) ! C fluxes associated with harvest to litter metabolic pool (gC/m3/s) - real(r8), pointer :: harvest_c_to_litr_cel_c(:,:) ! C fluxes associated with harvest to litter cellulose pool (gC/m3/s) - real(r8), pointer :: harvest_c_to_litr_lig_c(:,:) ! C fluxes associated with harvest to litter lignin pool (gC/m3/s) - real(r8), pointer :: harvest_c_to_cwdc(:,:) ! C fluxes associated with harvest to CWD pool (gC/m3/s) - real(r8), pointer :: hrv_deadcrootc_storage_to_litter(:) - real(r8), pointer :: hrv_deadcrootc_to_litter(:) - real(r8), pointer :: hrv_deadcrootc_xfer_to_litter(:) - real(r8), pointer :: hrv_deadstemc_storage_to_litter(:) - real(r8), pointer :: hrv_deadstemc_to_prod10c(:) - real(r8), pointer :: hrv_deadstemc_to_prod100c(:) - real(r8), pointer :: hrv_deadstemc_xfer_to_litter(:) - real(r8), pointer :: hrv_frootc_storage_to_litter(:) - real(r8), pointer :: hrv_frootc_to_litter(:) - real(r8), pointer :: hrv_frootc_xfer_to_litter(:) - real(r8), pointer :: hrv_gresp_storage_to_litter(:) - real(r8), pointer :: hrv_gresp_xfer_to_litter(:) - real(r8), pointer :: hrv_leafc_storage_to_litter(:) - real(r8), pointer :: hrv_leafc_to_litter(:) - real(r8), pointer :: hrv_leafc_xfer_to_litter(:) - real(r8), pointer :: hrv_livecrootc_storage_to_litter(:) - real(r8), pointer :: hrv_livecrootc_to_litter(:) - real(r8), pointer :: hrv_livecrootc_xfer_to_litter(:) - real(r8), pointer :: hrv_livestemc_storage_to_litter(:) - real(r8), pointer :: hrv_livestemc_to_litter(:) - real(r8), pointer :: hrv_livestemc_xfer_to_litter(:) - real(r8), pointer :: hrv_xsmrpool_to_atm(:) -! -! local pointers to implicit in/out arrays - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: xsmrpool(:) ! (gC/m2) abstract C pool to meet excess MR demand -! -! -! local pointers to implicit out arrays -! -! -! !OTHER LOCAL VARIABLES: - type(pft_cflux_type), pointer :: pcisof - type(pft_cstate_type), pointer :: pcisos - type(column_cflux_type), pointer :: ccisof - type(column_cstate_type), pointer :: ccisos - integer :: c,p,j,k,l ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) -! -!EOP -!----------------------------------------------------------------------- - ! select which isotope - select case (isotope) - case ('bulk') - pcisof => pcf - pcisos => pcs - ccisof => ccf - ccisos => ccs - case ('c14') - pcisof => pc14f - pcisos => pc14s - ccisof => cc14f - ccisos => cc14s - case ('c13') - pcisof => pc13f - pcisos => pc13s - ccisof => cc13f - ccisos => cc13s - case default - stop 'CNCIsoStateUpdate2Mod: iso must be bulk, c13 or c14' - end select - - ! assign local pointers at the column level ! assign local pointers at the column level - harvest_c_to_litr_met_c => ccisof%harvest_c_to_litr_met_c - harvest_c_to_litr_cel_c => ccisof%harvest_c_to_litr_cel_c - harvest_c_to_litr_lig_c => ccisof%harvest_c_to_litr_lig_c - harvest_c_to_cwdc => ccisof%harvest_c_to_cwdc - decomp_cpools_vr => ccisos%decomp_cpools_vr - - ! assign local pointers at the pft level - hrv_deadcrootc_storage_to_litter => pcisof%hrv_deadcrootc_storage_to_litter - hrv_deadcrootc_to_litter => pcisof%hrv_deadcrootc_to_litter - hrv_deadcrootc_xfer_to_litter => pcisof%hrv_deadcrootc_xfer_to_litter - hrv_deadstemc_storage_to_litter => pcisof%hrv_deadstemc_storage_to_litter - hrv_deadstemc_to_prod10c => pcisof%hrv_deadstemc_to_prod10c - hrv_deadstemc_to_prod100c => pcisof%hrv_deadstemc_to_prod100c - hrv_deadstemc_xfer_to_litter => pcisof%hrv_deadstemc_xfer_to_litter - hrv_frootc_storage_to_litter => pcisof%hrv_frootc_storage_to_litter - hrv_frootc_to_litter => pcisof%hrv_frootc_to_litter - hrv_frootc_xfer_to_litter => pcisof%hrv_frootc_xfer_to_litter - hrv_gresp_storage_to_litter => pcisof%hrv_gresp_storage_to_litter - hrv_gresp_xfer_to_litter => pcisof%hrv_gresp_xfer_to_litter - hrv_leafc_storage_to_litter => pcisof%hrv_leafc_storage_to_litter - hrv_leafc_to_litter => pcisof%hrv_leafc_to_litter - hrv_leafc_xfer_to_litter => pcisof%hrv_leafc_xfer_to_litter - hrv_livecrootc_storage_to_litter => pcisof%hrv_livecrootc_storage_to_litter - hrv_livecrootc_to_litter => pcisof%hrv_livecrootc_to_litter - hrv_livecrootc_xfer_to_litter => pcisof%hrv_livecrootc_xfer_to_litter - hrv_livestemc_storage_to_litter => pcisof%hrv_livestemc_storage_to_litter - hrv_livestemc_to_litter => pcisof%hrv_livestemc_to_litter - hrv_livestemc_xfer_to_litter => pcisof%hrv_livestemc_xfer_to_litter - hrv_xsmrpool_to_atm => pcisof%hrv_xsmrpool_to_atm - deadcrootc => pcisos%deadcrootc - deadcrootc_storage => pcisos%deadcrootc_storage - deadcrootc_xfer => pcisos%deadcrootc_xfer - deadstemc => pcisos%deadstemc - deadstemc_storage => pcisos%deadstemc_storage - deadstemc_xfer => pcisos%deadstemc_xfer - frootc => pcisos%frootc - frootc_storage => pcisos%frootc_storage - frootc_xfer => pcisos%frootc_xfer - gresp_storage => pcisos%gresp_storage - gresp_xfer => pcisos%gresp_xfer - leafc => pcisos%leafc - leafc_storage => pcisos%leafc_storage - leafc_xfer => pcisos%leafc_xfer - livecrootc => pcisos%livecrootc - livecrootc_storage => pcisos%livecrootc_storage - livecrootc_xfer => pcisos%livecrootc_xfer - livestemc => pcisos%livestemc - livestemc_storage => pcisos%livestemc_storage - livestemc_xfer => pcisos%livestemc_xfer - xsmrpool => pcisos%xsmrpool - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! column level carbon fluxes from harvest mortality - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! column harvest fluxes - decomp_cpools_vr(c,j,i_met_lit) = decomp_cpools_vr(c,j,i_met_lit) + harvest_c_to_litr_met_c(c,j) * dt - decomp_cpools_vr(c,j,i_cel_lit) = decomp_cpools_vr(c,j,i_cel_lit) + harvest_c_to_litr_cel_c(c,j) * dt - decomp_cpools_vr(c,j,i_lig_lit) = decomp_cpools_vr(c,j,i_lig_lit) + harvest_c_to_litr_lig_c(c,j) * dt - decomp_cpools_vr(c,j,i_cwd) = decomp_cpools_vr(c,j,i_cwd) + harvest_c_to_cwdc(c,j) * dt - - ! wood to product pools - states updated in CNWoodProducts() - end do - end do - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! pft-level carbon fluxes from harvest mortality - ! displayed pools - leafc(p) = leafc(p) - hrv_leafc_to_litter(p) * dt - frootc(p) = frootc(p) - hrv_frootc_to_litter(p) * dt - livestemc(p) = livestemc(p) - hrv_livestemc_to_litter(p) * dt - deadstemc(p) = deadstemc(p) - hrv_deadstemc_to_prod10c(p) * dt - deadstemc(p) = deadstemc(p) - hrv_deadstemc_to_prod100c(p) * dt - livecrootc(p) = livecrootc(p) - hrv_livecrootc_to_litter(p) * dt - deadcrootc(p) = deadcrootc(p) - hrv_deadcrootc_to_litter(p) * dt - - ! xsmrpool - xsmrpool(p) = xsmrpool(p) - hrv_xsmrpool_to_atm(p) * dt - - ! storage pools - leafc_storage(p) = leafc_storage(p) - hrv_leafc_storage_to_litter(p) * dt - frootc_storage(p) = frootc_storage(p) - hrv_frootc_storage_to_litter(p) * dt - livestemc_storage(p) = livestemc_storage(p) - hrv_livestemc_storage_to_litter(p) * dt - deadstemc_storage(p) = deadstemc_storage(p) - hrv_deadstemc_storage_to_litter(p) * dt - livecrootc_storage(p) = livecrootc_storage(p) - hrv_livecrootc_storage_to_litter(p) * dt - deadcrootc_storage(p) = deadcrootc_storage(p) - hrv_deadcrootc_storage_to_litter(p) * dt - gresp_storage(p) = gresp_storage(p) - hrv_gresp_storage_to_litter(p) * dt - - ! transfer pools - leafc_xfer(p) = leafc_xfer(p) - hrv_leafc_xfer_to_litter(p) * dt - frootc_xfer(p) = frootc_xfer(p) - hrv_frootc_xfer_to_litter(p) * dt - livestemc_xfer(p) = livestemc_xfer(p) - hrv_livestemc_xfer_to_litter(p) * dt - deadstemc_xfer(p) = deadstemc_xfer(p) - hrv_deadstemc_xfer_to_litter(p) * dt - livecrootc_xfer(p) = livecrootc_xfer(p) - hrv_livecrootc_xfer_to_litter(p) * dt - deadcrootc_xfer(p) = deadcrootc_xfer(p) - hrv_deadcrootc_xfer_to_litter(p) * dt - gresp_xfer(p) = gresp_xfer(p) - hrv_gresp_xfer_to_litter(p) * dt - - end do ! end of pft loop - -end subroutine CStateUpdate2h -!----------------------------------------------------------------------- -!#endif - -end module CNCStateUpdate2Mod 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 deleted file mode 100644 index 1871d372f..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNCStateUpdate3Mod.F90 +++ /dev/null @@ -1,331 +0,0 @@ - -module CNCStateUpdate3Mod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CStateUpdate3Mod -! -! !DESCRIPTION: -! Module for carbon state variable update, mortality fluxes. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: CStateUpdate3 -! -! !REVISION HISTORY: -! 7/27/2004: Created by Peter Thornton -! F. Li and S. Levis (11/06/12) -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CStateUpdate3 -! -! !INTERFACE: -subroutine CStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp, isotope) -! -! !DESCRIPTION: -! On the radiation time step, update all the prognostic carbon state -! variables affected by fire fluxes -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varpar , only: nlevdecomp, ndecomp_pools - use clm_varpar , only: i_cwd, i_met_lit, i_cel_lit, i_lig_lit - -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - character(len=*), intent(in) :: isotope ! 'bulk', 'c13' or 'c14' -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 3/29/04: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays - real(r8), pointer :: fire_mortality_c_to_cwdc(:,:) ! C fluxes associated with fire mortality to CWD pool (gC/m3/s) - real(r8), pointer :: m_decomp_cpools_to_fire_vr(:,:,:) ! vertically-resolved decomposing C fire loss (gC/m3/s) - real(r8), pointer :: m_deadcrootc_storage_to_fire(:) - real(r8), pointer :: m_deadcrootc_to_fire(:) - real(r8), pointer :: m_deadcrootc_xfer_to_fire(:) - real(r8), pointer :: m_deadstemc_storage_to_fire(:) - real(r8), pointer :: m_deadstemc_to_fire(:) - real(r8), pointer :: m_deadstemc_xfer_to_fire(:) - real(r8), pointer :: m_frootc_storage_to_fire(:) - real(r8), pointer :: m_frootc_to_fire(:) - real(r8), pointer :: m_frootc_xfer_to_fire(:) - real(r8), pointer :: m_gresp_storage_to_fire(:) - real(r8), pointer :: m_gresp_xfer_to_fire(:) - real(r8), pointer :: m_leafc_storage_to_fire(:) - real(r8), pointer :: m_leafc_to_fire(:) - real(r8), pointer :: m_leafc_xfer_to_fire(:) - real(r8), pointer :: m_livecrootc_storage_to_fire(:) - real(r8), pointer :: m_livecrootc_to_fire(:) - real(r8), pointer :: m_livecrootc_xfer_to_fire(:) - real(r8), pointer :: m_livestemc_storage_to_fire(:) - real(r8), pointer :: m_livestemc_to_fire(:) - real(r8), pointer :: m_livestemc_xfer_to_fire(:) - ! - real(r8), pointer :: m_leafc_to_litter_fire(:) - real(r8), pointer :: m_leafc_storage_to_litter_fire(:) - real(r8), pointer :: m_leafc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemc_to_litter_fire(:) - real(r8), pointer :: m_livestemc_storage_to_litter_fire(:) - real(r8), pointer :: m_livestemc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemc_to_deadstemc_fire(:) - real(r8), pointer :: m_deadstemc_to_litter_fire(:) - real(r8), pointer :: m_deadstemc_storage_to_litter_fire(:) - real(r8), pointer :: m_deadstemc_xfer_to_litter_fire(:) - real(r8), pointer :: m_frootc_to_litter_fire(:) - real(r8), pointer :: m_frootc_storage_to_litter_fire(:) - real(r8), pointer :: m_frootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_storage_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_to_deadcrootc_fire(:) - real(r8), pointer :: m_deadcrootc_to_litter_fire(:) - real(r8), pointer :: m_deadcrootc_storage_to_litter_fire(:) - real(r8), pointer :: m_deadcrootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_gresp_storage_to_litter_fire(:) - real(r8), pointer :: m_gresp_xfer_to_litter_fire(:) - ! - real(r8), pointer :: m_c_to_litr_met_fire(:,:) - real(r8), pointer :: m_c_to_litr_cel_fire(:,:) - real(r8), pointer :: m_c_to_litr_lig_fire(:,:) -! local pointers to implicit in/out arrays - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer -! -! local pointers to implicit out arrays -! -! !OTHER LOCAL VARIABLES: - type(pft_cflux_type), pointer :: pcisof - type(pft_cstate_type), pointer :: pcisos - type(column_cflux_type), pointer :: ccisof - type(column_cstate_type), pointer :: ccisos - integer :: c,p,j,l,k ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) - -!EOP -!----------------------------------------------------------------------- - ! select which isotope - select case (isotope) - case ('bulk') - pcisof => pcf - pcisos => pcs - ccisof => ccf - ccisos => ccs - case ('c14') - pcisof => pc14f - pcisos => pc14s - ccisof => cc14f - ccisos => cc14s - case ('c13') - pcisof => pc13f - pcisos => pc13s - ccisof => cc13f - ccisos => cc13s - case default - stop 'CNCIsoStateUpdate3Mod: iso must be bulk, c13 or c14' - end select - - ! assign local pointers at the column level - fire_mortality_c_to_cwdc => ccisof%fire_mortality_c_to_cwdc - m_decomp_cpools_to_fire_vr => ccisof%m_decomp_cpools_to_fire_vr - decomp_cpools_vr => ccisos%decomp_cpools_vr - m_c_to_litr_met_fire => ccisof%m_c_to_litr_met_fire - m_c_to_litr_cel_fire => ccisof%m_c_to_litr_cel_fire - m_c_to_litr_lig_fire => ccisof%m_c_to_litr_lig_fire - - ! assign local pointers at the pft level - m_leafc_to_fire => pcisof%m_leafc_to_fire - m_leafc_storage_to_fire => pcisof%m_leafc_storage_to_fire - m_leafc_xfer_to_fire => pcisof%m_leafc_xfer_to_fire - m_livestemc_to_fire => pcisof%m_livestemc_to_fire - m_livestemc_storage_to_fire => pcisof%m_livestemc_storage_to_fire - m_livestemc_xfer_to_fire => pcisof%m_livestemc_xfer_to_fire - m_deadstemc_to_fire => pcisof%m_deadstemc_to_fire - m_deadstemc_storage_to_fire => pcisof%m_deadstemc_storage_to_fire - m_deadstemc_xfer_to_fire => pcisof%m_deadstemc_xfer_to_fire - m_frootc_to_fire => pcisof%m_frootc_to_fire - m_frootc_storage_to_fire => pcisof%m_frootc_storage_to_fire - m_frootc_xfer_to_fire => pcisof%m_frootc_xfer_to_fire - m_livecrootc_to_fire => pcisof%m_livecrootc_to_fire - m_livecrootc_storage_to_fire => pcisof%m_livecrootc_storage_to_fire - m_livecrootc_xfer_to_fire => pcisof%m_livecrootc_xfer_to_fire - m_deadcrootc_to_fire => pcisof%m_deadcrootc_to_fire - m_deadcrootc_storage_to_fire => pcisof%m_deadcrootc_storage_to_fire - m_deadcrootc_xfer_to_fire => pcisof%m_deadcrootc_xfer_to_fire - m_gresp_storage_to_fire => pcisof%m_gresp_storage_to_fire - m_gresp_xfer_to_fire => pcisof%m_gresp_xfer_to_fire - - m_leafc_to_litter_fire => pcisof%m_leafc_to_litter_fire - m_leafc_storage_to_litter_fire => pcisof%m_leafc_storage_to_litter_fire - m_leafc_xfer_to_litter_fire => pcisof%m_leafc_xfer_to_litter_fire - m_livestemc_to_litter_fire => pcisof%m_livestemc_to_litter_fire - m_livestemc_storage_to_litter_fire => pcisof%m_livestemc_storage_to_litter_fire - m_livestemc_xfer_to_litter_fire => pcisof%m_livestemc_xfer_to_litter_fire - m_livestemc_to_deadstemc_fire => pcisof%m_livestemc_to_deadstemc_fire - m_deadstemc_to_litter_fire => pcisof%m_deadstemc_to_litter_fire - m_deadstemc_storage_to_litter_fire => pcisof%m_deadstemc_storage_to_litter_fire - m_deadstemc_xfer_to_litter_fire => pcisof%m_deadstemc_xfer_to_litter_fire - m_frootc_to_litter_fire => pcisof%m_frootc_to_litter_fire - m_frootc_storage_to_litter_fire => pcisof%m_frootc_storage_to_litter_fire - m_frootc_xfer_to_litter_fire => pcisof%m_frootc_xfer_to_litter_fire - m_livecrootc_to_litter_fire => pcisof%m_livecrootc_to_litter_fire - m_livecrootc_storage_to_litter_fire => pcisof%m_livecrootc_storage_to_litter_fire - m_livecrootc_xfer_to_litter_fire => pcisof%m_livecrootc_xfer_to_litter_fire - m_livecrootc_to_deadcrootc_fire => pcisof%m_livecrootc_to_deadcrootc_fire - m_deadcrootc_to_litter_fire => pcisof%m_deadcrootc_to_litter_fire - m_deadcrootc_storage_to_litter_fire => pcisof%m_deadcrootc_storage_to_litter_fire - m_deadcrootc_xfer_to_litter_fire => pcisof%m_deadcrootc_xfer_to_litter_fire - m_gresp_storage_to_litter_fire => pcisof%m_gresp_storage_to_litter_fire - m_gresp_xfer_to_litter_fire => pcisof%m_gresp_xfer_to_litter_fire - - - deadcrootc => pcisos%deadcrootc - deadcrootc_storage => pcisos%deadcrootc_storage - deadcrootc_xfer => pcisos%deadcrootc_xfer - deadstemc => pcisos%deadstemc - deadstemc_storage => pcisos%deadstemc_storage - deadstemc_xfer => pcisos%deadstemc_xfer - frootc => pcisos%frootc - frootc_storage => pcisos%frootc_storage - frootc_xfer => pcisos%frootc_xfer - gresp_storage => pcisos%gresp_storage - gresp_xfer => pcisos%gresp_xfer - leafc => pcisos%leafc - leafc_storage => pcisos%leafc_storage - leafc_xfer => pcisos%leafc_xfer - livecrootc => pcisos%livecrootc - livecrootc_storage => pcisos%livecrootc_storage - livecrootc_xfer => pcisos%livecrootc_xfer - livestemc => pcisos%livestemc - livestemc_storage => pcisos%livestemc_storage - livestemc_xfer => pcisos%livestemc_xfer - - ! set time steps - dt = real( get_step_size(), r8 ) - - - ! column level carbon fluxes from fire - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - ! pft-level wood to column-level CWD (uncombusted wood) - decomp_cpools_vr(c,j,i_cwd) = decomp_cpools_vr(c,j,i_cwd) + fire_mortality_c_to_cwdc(c,j) * dt - - ! pft-level wood to column-level litter (uncombusted wood) - decomp_cpools_vr(c,j,i_met_lit) = decomp_cpools_vr(c,j,i_met_lit) + m_c_to_litr_met_fire(c,j)* dt - decomp_cpools_vr(c,j,i_cel_lit) = decomp_cpools_vr(c,j,i_cel_lit) + m_c_to_litr_cel_fire(c,j)* dt - decomp_cpools_vr(c,j,i_lig_lit) = decomp_cpools_vr(c,j,i_lig_lit) + m_c_to_litr_lig_fire(c,j)* dt - end do - end do - - ! litter and CWD losses to fire - do l = 1, ndecomp_pools - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_cpools_vr(c,j,l) = decomp_cpools_vr(c,j,l) - m_decomp_cpools_to_fire_vr(c,j,l) * dt - end do - end do - end do - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! pft-level carbon fluxes from fire - ! displayed pools - leafc(p) = leafc(p) - m_leafc_to_fire(p) * dt - leafc(p) = leafc(p) - m_leafc_to_litter_fire(p) * dt - frootc(p) = frootc(p) - m_frootc_to_fire(p) * dt - frootc(p) = frootc(p) - m_frootc_to_litter_fire(p) * dt - livestemc(p) = livestemc(p) - m_livestemc_to_fire(p) * dt - livestemc(p) = livestemc(p) - m_livestemc_to_litter_fire(p) * dt - deadstemc(p) = deadstemc(p) - m_deadstemc_to_fire(p) * dt - deadstemc(p) = deadstemc(p) - m_deadstemc_to_litter_fire(p) * dt - livecrootc(p) = livecrootc(p) - m_livecrootc_to_fire(p) * dt - livecrootc(p) = livecrootc(p) - m_livecrootc_to_litter_fire(p)* dt - deadcrootc(p) = deadcrootc(p) - m_deadcrootc_to_fire(p) * dt - deadcrootc(p) = deadcrootc(p) - m_deadcrootc_to_litter_fire(p)* dt - - ! storage pools - leafc_storage(p) = leafc_storage(p) - m_leafc_storage_to_fire(p) * dt - leafc_storage(p) = leafc_storage(p) - m_leafc_storage_to_litter_fire(p) * dt - frootc_storage(p) = frootc_storage(p) - m_frootc_storage_to_fire(p) * dt - frootc_storage(p) = frootc_storage(p) - m_frootc_storage_to_litter_fire(p) * dt - livestemc_storage(p) = livestemc_storage(p) - m_livestemc_storage_to_fire(p) * dt - livestemc_storage(p) = livestemc_storage(p) - m_livestemc_storage_to_litter_fire(p) * dt - deadstemc_storage(p) = deadstemc_storage(p) - m_deadstemc_storage_to_fire(p) * dt - deadstemc_storage(p) = deadstemc_storage(p) - m_deadstemc_storage_to_litter_fire(p) * dt - livecrootc_storage(p) = livecrootc_storage(p) - m_livecrootc_storage_to_fire(p) * dt - livecrootc_storage(p) = livecrootc_storage(p) - m_livecrootc_storage_to_litter_fire(p)* dt - deadcrootc_storage(p) = deadcrootc_storage(p) - m_deadcrootc_storage_to_fire(p) * dt - deadcrootc_storage(p) = deadcrootc_storage(p) - m_deadcrootc_storage_to_litter_fire(p)* dt - gresp_storage(p) = gresp_storage(p) - m_gresp_storage_to_fire(p) * dt - gresp_storage(p) = gresp_storage(p) - m_gresp_storage_to_litter_fire(p) * dt - - ! transfer pools - leafc_xfer(p) = leafc_xfer(p) - m_leafc_xfer_to_fire(p) * dt - leafc_xfer(p) = leafc_xfer(p) - m_leafc_xfer_to_litter_fire(p) * dt - frootc_xfer(p) = frootc_xfer(p) - m_frootc_xfer_to_fire(p) * dt - frootc_xfer(p) = frootc_xfer(p) - m_frootc_xfer_to_litter_fire(p) * dt - livestemc_xfer(p) = livestemc_xfer(p) - m_livestemc_xfer_to_fire(p) * dt - livestemc_xfer(p) = livestemc_xfer(p) - m_livestemc_xfer_to_litter_fire(p) * dt - deadstemc_xfer(p) = deadstemc_xfer(p) - m_deadstemc_xfer_to_fire(p) * dt - deadstemc_xfer(p) = deadstemc_xfer(p) - m_deadstemc_xfer_to_litter_fire(p) * dt - livecrootc_xfer(p) = livecrootc_xfer(p) - m_livecrootc_xfer_to_fire(p) * dt - livecrootc_xfer(p) = livecrootc_xfer(p) - m_livecrootc_xfer_to_litter_fire(p)* dt - deadcrootc_xfer(p) = deadcrootc_xfer(p) - m_deadcrootc_xfer_to_fire(p) * dt - deadcrootc_xfer(p) = deadcrootc_xfer(p) - m_deadcrootc_xfer_to_litter_fire(p)* dt - gresp_xfer(p) = gresp_xfer(p) - m_gresp_xfer_to_fire(p) * dt - gresp_xfer(p) = gresp_xfer(p) - m_gresp_xfer_to_litter_fire(p) * dt - - end do ! end of pft loop - -end subroutine CStateUpdate3 -!----------------------------------------------------------------------- -!#endif - -end module CNCStateUpdate3Mod 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 deleted file mode 100644 index 523a973e8..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNDecompCascadeMod_BGC.F90 +++ /dev/null @@ -1,803 +0,0 @@ -module CNDecompCascadeMod_BGC -!#ifdef CN - -#ifndef CENTURY_DECOMP - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNDecompMod -! -! !DESCRIPTION: -! Module that sets the coeffiecients used in the decomposition cascade submodel. This uses the BGC parameters as in CLMCN 4.0 -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use shr_const_mod, only: SHR_CONST_TKFRZ - use clm_varpar , only: nlevsoi, nlevgrnd, nlevdecomp, ndecomp_cascade_transitions, ndecomp_pools, nsompools - use clm_varpar , only: i_met_lit, i_cel_lit, i_lig_lit, i_cwd - use clm_varctl , only: iulog, spinup_state - use clm_varcon, only: zsoi -#ifdef LCH4 - use clm_varctl, only: anoxia - use ch4varcon, only: mino2lim -#endif - - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: init_decompcascade, decomp_rate_constants -! -! !PUBLIC DATA MEMBERS: -#if (defined VERTSOILC) - real(r8), public :: decomp_depth_efolding = 0.5_r8 ! (meters) e-folding depth for reduction in decomposition [set to large number for depth-independance] -#endif - real(r8), public :: froz_q10 = 1.5_r8 ! separate q10 for frozen soil respiration rates. default to same as above zero rates -#ifdef LCH4 - logical, public :: anoxia_wtsat = .false. ! true ==> weight anoxia by inundated fraction -#endif - integer, public :: nlev_soildecomp_standard ! used here and in ch4Mod - - !! parameters for AD spinup - real(r8), public, parameter :: spinup_vector(nsompools) = (/ 1.0_r8, 1.0_r8, 5.0_r8, 70.0_r8 /) ! multipliers for soil decomp during accelerated spinup - -!EOP -!----------------------------------------------------------------------- - -contains - - -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: init_decompcascade -! -! !INTERFACE: -subroutine init_decompcascade(begc, endc) - -! !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 clmtype - use clm_time_manager , only : get_step_size - -! !ARGUMENTS: - implicit none -! -! !CALLED FROM: -! -! -! !REVISION HISTORY: -! - ! column level - integer :: begc, endc ! per-proc beginning and ending column indices - - !-- properties of each pathway along decomposition cascade - character(len=8), pointer :: cascade_step_name(:) ! name of transition - real(r8), pointer :: rf_decomp_cascade(:,:,:) ! respired fraction in decomposition step (frac) - 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 - real(r8), pointer :: pathfrac_decomp_cascade(:,:,:) ! what fraction of C leaving a given pool passes through a given transition (frac) - !-- 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 - 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 for AD spinup associated with each 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_atm - 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 - - - - cascade_step_name => decomp_cascade_con%cascade_step_name - rf_decomp_cascade => cps%rf_decomp_cascade - cascade_donor_pool => decomp_cascade_con%cascade_donor_pool - cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool - pathfrac_decomp_cascade => cps%pathfrac_decomp_cascade - floating_cn_ratio_decomp_pools => decomp_cascade_con%floating_cn_ratio_decomp_pools - decomp_pool_name_restart => decomp_cascade_con%decomp_pool_name_restart - decomp_pool_name_history => decomp_cascade_con%decomp_pool_name_history - decomp_pool_name_long => decomp_cascade_con%decomp_pool_name_long - decomp_pool_name_short => decomp_cascade_con%decomp_pool_name_short - is_litter => decomp_cascade_con%is_litter - is_soil => decomp_cascade_con%is_soil - is_cwd => decomp_cascade_con%is_cwd - initial_cn_ratio => decomp_cascade_con%initial_cn_ratio - initial_stock => decomp_cascade_con%initial_stock - is_metabolic => decomp_cascade_con%is_metabolic - is_cellulose => decomp_cascade_con%is_cellulose - is_lignin => decomp_cascade_con%is_lignin - spinup_factor => decomp_cascade_con%spinup_factor - - - !------- time-constant coefficients ---------- ! - ! set soil organic matter compartment C:N ratios (from Biome-BGC v4.2.0) - cn_s1 = 12.0_r8 - cn_s2 = 12.0_r8 - cn_s3 = 10.0_r8 - cn_s4 = 10.0_r8 - - ! set respiration fractions for fluxes between compartments - ! (from Biome-BGC v4.2.0) - rf_l1s1 = 0.39_r8 - rf_l2s2 = 0.55_r8 - rf_l3s3 = 0.29_r8 - rf_s1s2 = 0.28_r8 - rf_s2s3 = 0.46_r8 - rf_s3s4 = 0.55_r8 - - ! set the cellulose and lignin fractions for coarse woody debris - cwd_fcel = 0.76_r8 - cwd_flig = 0.24_r8 - - !------------------- list of pools and their attributes ------------ - - i_litr1 = i_met_lit - floating_cn_ratio_decomp_pools(i_litr1) = .true. - decomp_pool_name_restart(i_litr1) = 'litr1' - decomp_pool_name_history(i_litr1) = 'LITR1' - decomp_pool_name_long(i_litr1) = 'litter 1' - 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_pool_name_restart(i_litr2) = 'litr2' - decomp_pool_name_history(i_litr2) = 'LITR2' - decomp_pool_name_long(i_litr2) = 'litter 2' - 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_pool_name_restart(i_litr3) = 'litr3' - decomp_pool_name_history(i_litr3) = 'LITR3' - decomp_pool_name_long(i_litr3) = 'litter 3' - 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. - - floating_cn_ratio_decomp_pools(i_cwd) = .true. - decomp_pool_name_restart(i_cwd) = 'cwd' - decomp_pool_name_history(i_cwd) = 'CWD' - decomp_pool_name_long(i_cwd) = 'coarse woody debris' - 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. - - i_soil1 = 5 - floating_cn_ratio_decomp_pools(i_soil1) = .false. - decomp_pool_name_restart(i_soil1) = 'soil1' - decomp_pool_name_history(i_soil1) = 'SOIL1' - decomp_pool_name_long(i_soil1) = 'soil 1' - 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. - - i_soil2 = 6 - floating_cn_ratio_decomp_pools(i_soil2) = .false. - decomp_pool_name_restart(i_soil2) = 'soil2' - decomp_pool_name_history(i_soil2) = 'SOIL2' - decomp_pool_name_long(i_soil2) = 'soil 2' - 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. - - i_soil3 = 7 - floating_cn_ratio_decomp_pools(i_soil3) = .false. - decomp_pool_name_restart(i_soil3) = 'soil3' - decomp_pool_name_history(i_soil3) = 'SOIL3' - decomp_pool_name_long(i_soil3) = 'soil 3' - 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. - - i_soil4 = 8 - floating_cn_ratio_decomp_pools(i_soil4) = .false. - decomp_pool_name_restart(i_soil4) = 'soil4' - decomp_pool_name_history(i_soil4) = 'SOIL4' - decomp_pool_name_long(i_soil4) = 'soil 4' - 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. - - i_atm = 0 !! for terminal pools (i.e. 100% respiration) - floating_cn_ratio_decomp_pools(i_atm) = .false. - decomp_pool_name_restart(i_atm) = 'atmosphere' - decomp_pool_name_history(i_atm) = 'atmosphere' - decomp_pool_name_long(i_atm) = 'atmosphere' - 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 - spinup_factor(i_cwd) = 1._r8 - spinup_factor(i_soil1) = spinup_vector(1) - spinup_factor(i_soil2) = spinup_vector(2) - spinup_factor(i_soil3) = spinup_vector(3) - spinup_factor(i_soil4) = spinup_vector(4) - - - - !---------------- list of transitions and their time-independent coefficients ---------------! - i_l1s1 = 1 - cascade_step_name(i_l1s1) = 'L1S1' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_l1s1) = rf_l1s1 - cascade_donor_pool(i_l1s1) = i_litr1 - cascade_receiver_pool(i_l1s1) = i_soil1 - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_l1s1) = 1.0_r8 - - i_l2s2 = 2 - cascade_step_name(i_l2s2) = 'L2S2' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_l2s2) = rf_l2s2 - cascade_donor_pool(i_l2s2) = i_litr2 - cascade_receiver_pool(i_l2s2) = i_soil2 - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_l2s2) = 1.0_r8 - - i_l3s3 = 3 - cascade_step_name(i_l3s3) = 'L3S3' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_l3s3) = rf_l3s3 - cascade_donor_pool(i_l3s3) = i_litr3 - cascade_receiver_pool(i_l3s3) = i_soil3 - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_l3s3) = 1.0_r8 - - i_s1s2 = 4 - cascade_step_name(i_s1s2) = 'S1S2' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_s1s2) = rf_s1s2 - cascade_donor_pool(i_s1s2) = i_soil1 - cascade_receiver_pool(i_s1s2) = i_soil2 - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_s1s2) = 1.0_r8 - - i_s2s3 = 5 - cascade_step_name(i_s2s3) = 'S2S3' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_s2s3) = rf_s2s3 - cascade_donor_pool(i_s2s3) = i_soil2 - cascade_receiver_pool(i_s2s3) = i_soil3 - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_s2s3) = 1.0_r8 - - i_s3s4 = 6 - cascade_step_name(i_s3s4) = 'S3S4' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_s3s4) = rf_s3s4 - cascade_donor_pool(i_s3s4) = i_soil3 - cascade_receiver_pool(i_s3s4) = i_soil4 - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_s3s4) = 1.0_r8 - - i_s4atm = 7 - cascade_step_name(i_s4atm) = 'S4' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_s4atm) = 1. - cascade_donor_pool(i_s4atm) = i_soil4 - cascade_receiver_pool(i_s4atm) = i_atm - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_s4atm) = 1.0_r8 - - i_cwdl2 = 8 - cascade_step_name(i_cwdl2) = 'CWDL2' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_cwdl2) = 0._r8 - cascade_donor_pool(i_cwdl2) = i_cwd - cascade_receiver_pool(i_cwdl2) = i_litr2 - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_cwdl2) = cwd_fcel - - i_cwdl3 = 9 - cascade_step_name(i_cwdl3) = 'CWDL3' - rf_decomp_cascade(begc:endc,1:nlevdecomp,i_cwdl3) = 0._r8 - cascade_donor_pool(i_cwdl3) = i_cwd - cascade_receiver_pool(i_cwdl3) = i_litr3 - pathfrac_decomp_cascade(begc:endc,1:nlevdecomp,i_cwdl3) = cwd_flig - - -end subroutine init_decompcascade - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: decomp_rate_constants -! -! !INTERFACE: - -subroutine decomp_rate_constants(lbc, ubc, num_soilc, filter_soilc) -! -! !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 clmtype - use clm_time_manager , only : get_step_size - use clm_varcon, only: secspday - - ! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns -! -! !CALLED FROM: -! -! -! !REVISION HISTORY: -! - ! column level - real(r8), pointer :: decomp_k(:,:,:) ! rate constant for decomposition (1./sec) - real(r8), pointer :: t_scalar(:,:) ! soil temperature scalar for decomp - real(r8), pointer :: w_scalar(:,:) ! soil water scalar for decomp - real(r8), pointer :: o_scalar(:,:) ! fraction by which decomposition is limited by anoxia - - real(r8), pointer :: dz(:,:) ! soil layer thickness (m) - real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm) - real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) -#ifdef LCH4 - real(r8), pointer :: o2stress_unsat(:,:) ! Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) - real(r8), pointer :: o2stress_sat(:,:) ! Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) - real(r8), pointer :: finundated(:) ! fractional inundated area (excluding dedicated wetland columns) -#endif - integer, pointer :: alt_indx(:) ! current depth of thaw - - real(r8) :: dt ! decomp timestep (seconds) - real(r8):: dtd ! decomp timestep (days) -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - real(r8):: frw(lbc:ubc) ! rooting fraction weight - real(r8), pointer:: 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):: w_scalar(lbc:ubc,1:nlevdecomp) !soil water scalar for decomp - 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 3 - real(r8):: k_frag ! fragmentation rate constant CWD - real(r8):: ck_l1 ! corrected decomposition rate constant litter 1 - real(r8):: ck_l2 ! corrected decomposition rate constant litter 2 - real(r8):: ck_l3 ! corrected decomposition rate constant litter 3 - real(r8):: ck_s1 ! corrected decomposition rate constant SOM 1 - real(r8):: ck_s2 ! corrected decomposition rate constant SOM 2 - real(r8):: ck_s3 ! corrected decomposition rate constant SOM 3 - real(r8):: ck_s4 ! corrected decomposition rate constant SOM 3 - real(r8):: ck_frag ! corrected fragmentation rate constant CWD - real(r8):: cwd_fcel ! cellulose fraction of coarse woody debris - real(r8):: cwd_flig ! lignin fraction of coarse woody debris - real(r8):: cwdc_loss ! fragmentation rate for CWD carbon (gC/m2/s) - real(r8):: cwdn_loss ! fragmentation rate for CWD nitrogen (gN/m2/s) - - 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 - -#if (defined VERTSOILC) - real(r8) :: depth_scalar(lbc:ubc,1:nlevdecomp) -#endif - - ! Assign local pointers to derived type arrays - t_soisno => ces%t_soisno - sucsat => cps%sucsat - soilpsi => cps%soilpsi - dz => cps%dz - t_scalar => ccf%t_scalar - w_scalar => ccf%w_scalar - o_scalar => ccf%o_scalar - decomp_k => ccf%decomp_k -#ifdef LCH4 - o2stress_sat => cch4%o2stress_sat - o2stress_unsat => cch4%o2stress_unsat - finundated => cws%finundated -#endif - alt_indx => cps%alt_indx - - - ! set time steps - dt = real( get_step_size(), r8 ) - 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 = -log(1.0_r8-0.7_r8) - k_l2 = -log(1.0_r8-0.07_r8) - k_l3 = -log(1.0_r8-0.014_r8) - k_s1 = -log(1.0_r8-0.07_r8) - k_s2 = -log(1.0_r8-0.014_r8) - k_s3 = -log(1.0_r8-0.0014_r8) - k_s4 = -log(1.0_r8-0.0001_r8) - k_frag = -log(1.0_r8-0.001_r8) - - ! calculate the new discrete-time decay rate for model timestep - k_l1 = 1.0_r8-exp(-k_l1*dtd) - k_l2 = 1.0_r8-exp(-k_l2*dtd) - k_l3 = 1.0_r8-exp(-k_l3*dtd) - k_s1 = 1.0_r8-exp(-k_s1*dtd) - k_s2 = 1.0_r8-exp(-k_s2*dtd) - k_s3 = 1.0_r8-exp(-k_s3*dtd) - k_s4 = 1.0_r8-exp(-k_s4*dtd) - k_frag = 1.0_r8-exp(-k_frag*dtd) - - ! The following code implements the acceleration part of the AD spinup - ! algorithm, by multiplying all of the SOM decomposition base rates by 10.0. - -if ( spinup_state .eq. 1 ) then - k_s1 = k_s1 * spinup_vector(1) - k_s2 = k_s2 * spinup_vector(2) - k_s3 = k_s3 * spinup_vector(3) - k_s4 = k_s4 * spinup_vector(4) -endif - - i_litr1 = 1 - i_litr2 = 2 - i_litr3 = 3 - i_soil1 = 5 - i_soil2 = 6 - i_soil3 = 7 - i_soil4 = 8 - - - - ! ! CWD fragmentation -> litter pools - ! thse have now been put into the regular decomposition cascade - ! cwdc_loss = cwdc_vr(c,j) * ck_frag / dt - ! cwdc_to_litr2c_vr(c,j) = cwdc_loss * cwd_fcel - ! cwdc_to_litr3c_vr(c,j) = cwdc_loss * cwd_flig - ! cwdn_loss = cwdn_vr(c,j) * ck_frag / dt - ! cwdn_to_litr2n_vr(c,j) = cwdn_loss * cwd_fcel - ! cwdn_to_litr3n_vr(c,j) = cwdn_loss * cwd_flig - - - !--- 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(lbc:ubc) = 0._r8 - nlev_soildecomp_standard=1 ! 5 originally in CLM4.5, changed to 1 because we have only 1 hydrologically active soil layer (1m thick, see CN_Driver), fzeng, 10 Mar 2017 - allocate(fr(lbc:ubc,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) .ge. SHR_CONST_TKFRZ) then - t_scalar(c,1)=t_scalar(c,1) + (1.5**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8))*fr(c,j) - else - t_scalar(c,1)=t_scalar(c,1) + (1.5**(-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. - - minpsi = -10.0_r8; - - do j = 1,nlev_soildecomp_standard - do fc = 1,num_soilc - c = filter_soilc(fc) - if (j==1) w_scalar(c,:) = 0._r8 - maxpsi = sucsat(c,j) * (-9.8e-6_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 - -#ifdef LCH4 - if (anoxia_wtsat) then ! Adjust for saturated fraction if unfrozen. - do fc = 1,num_soilc - c = filter_soilc(fc) - if (alt_indx(c) >= nlev_soildecomp_standard .and. t_soisno(c,1) > SHR_CONST_TKFRZ) then - w_scalar(c,1) = w_scalar(c,1)*(1._r8 - finundated(c)) + finundated(c) - end if - end do - end if -#endif - -#ifdef LCH4 - ! 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 - - if (.not. anoxia_wtsat) then - o_scalar(c,1) = o_scalar(c,1) + fr(c,j) * max(o2stress_unsat(c,j), mino2lim) - else - o_scalar(c,1) = o_scalar(c,1) + fr(c,j) * & - (max(o2stress_unsat(c,j), mino2lim)*(1._r8 - finundated(c)) + & - max(o2stress_sat(c,j), mino2lim)*finundated(c) ) - end if - end do - end do - else - o_scalar(lbc:ubc,1:nlevdecomp) = 1._r8 - end if -#else - o_scalar(lbc:ubc,1:nlevdecomp) = 1._r8 -#endif - - 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) .ge. SHR_CONST_TKFRZ) then - t_scalar(c,j)= (1.5**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8)) - else - t_scalar(c,j)= (1.5**(-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. - - minpsi = -10.0_r8; - do j = 1,nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - maxpsi = sucsat(c,j) * (-9.8e-6_r8) - 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 -#ifdef LCH4 - if (anoxia_wtsat .and. t_soisno(c,j) > SHR_CONST_TKFRZ) then ! wet area will have w_scalar of 1 if unfrozen - w_scalar(c,j) = w_scalar(c,j)*(1._r8 - finundated(c)) + finundated(c) - end if -#endif - end do - end do - - end if - -#ifdef LCH4 - ! 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) - - if (.not. anoxia_wtsat) then - o_scalar(c,j) = max(o2stress_unsat(c,j), mino2lim) - else - o_scalar(c,j) = max(o2stress_unsat(c,j), mino2lim) * (1._r8 - finundated(c)) + & - max(o2stress_sat(c,j), mino2lim) * finundated(c) - end if - end do - end do - else - o_scalar(lbc:ubc,1:nlevdecomp) = 1._r8 - end if -#else - o_scalar(lbc:ubc,1:nlevdecomp) = 1._r8 -#endif - -#if (defined VERTSOILC) - ! 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 -#endif - -#if (defined VERTSOILC) - 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_cwd) = k_frag * 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 - 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_cwd) = k_frag * 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 - end do - end do -#endif - - - -end subroutine decomp_rate_constants -#endif - -!#endif - - -end module CNDecompCascadeMod_BGC - 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 deleted file mode 100644 index 95e2b9b9b..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNDecompMod.F90 +++ /dev/null @@ -1,439 +0,0 @@ -module CNDecompMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNDecompMod -! -! !DESCRIPTION: -! Module holding routines used in litter and soil decomposition model -! for coupled carbon-nitrogen code. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use shr_const_mod, only: SHR_CONST_TKFRZ - use clm_varctl , only: iulog - use clm_varcon, only: dzsoi_decomp -#ifndef CENTURY_DECOMP - use CNDecompCascadeMod_BGC, only : decomp_rate_constants -#else - use CNDecompCascadeMod_CENTURY, only : decomp_rate_constants -#endif -#ifdef NITRIF_DENITRIF - use CNNitrifDenitrifMod, only: nitrif_denitrif -#endif - use CNVerticalProfileMod, only: decomp_vertprofiles - - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: CNDecompAlloc - -! -! !REVISION HISTORY: -! 8/15/03: Created by Peter Thornton -! 10/23/03, Peter Thornton: migrated to vector data structures -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNDecompAlloc -! -! !INTERFACE: -subroutine CNDecompAlloc (lbp, ubp, lbc, ubc, num_soilc, filter_soilc, & - num_soilp, filter_soilp) -! -! !DESCRIPTION: -! -! !USES: - use clmtype - use CNAllocationMod , only: CNAllocation - use clm_time_manager, only: get_step_size - use clm_varpar , only: nlevsoi,nlevgrnd,nlevdecomp,ndecomp_cascade_transitions,ndecomp_pools -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbp, ubp ! pft-index bounds - integer, intent(in) :: lbc, ubc ! column-index bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(ubp-lbp+1) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 8/15/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - ! all c pools involved in decomposition - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - ! all n pools involved in decomposition - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - - integer, pointer :: clandunit(:) ! index into landunit level quantities - integer , pointer :: itypelun(:) ! landunit type - ! pft level - real(r8), pointer :: rootfr(:,:) ! fraction of roots in each soil layer (nlevgrnd) -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: fpi_vr(:,:) ! fraction of potential immobilization (no units) - real(r8), pointer :: decomp_cascade_hr_vr(:,:,:) ! vertically-resolved het. resp. from decomposing C pools (gC/m3/s) - real(r8), pointer :: decomp_cascade_ctransfer_vr(:,:,:) ! vertically-resolved het. resp. from decomposing C pools (gC/m3/s) - real(r8), pointer :: decomp_pools_hr(:,:) ! het. resp. from decomposing C pools (gC/m2/s) - real(r8), pointer :: decomp_cascade_ctransfer(:,:) ! vertically-resolved C transferred along deomposition cascade (gC/m3/s) - real(r8), pointer :: decomp_cascade_ntransfer_vr(:,:,:) ! vert-res transfer of N from donor to receiver pool along decomp. cascade (gN/m3/s) - real(r8), pointer :: decomp_cascade_sminn_flux_vr(:,:,:) ! vert-res mineral N flux for transition along decomposition cascade (gN/m3/s) - - real(r8), pointer :: potential_immob_vr(:,:) -#ifndef NITRIF_DENITRIF - real(r8), pointer :: sminn_to_denit_decomp_cascade_vr(:,:,:) - real(r8), pointer :: sminn_to_denit_excess_vr(:,:) -#endif - real(r8), pointer :: gross_nmin_vr(:,:) - real(r8), pointer :: net_nmin_vr(:,:) - real(r8), pointer :: gross_nmin(:) ! gross rate of N mineralization (gN/m2/s) - real(r8), pointer :: net_nmin(:) ! net rate of N mineralization (gN/m2/s) - ! For methane code -#ifdef LCH4 - real(r8), pointer :: fphr(:,:) ! fraction of potential SOM + LITTER heterotrophic respiration - real(r8), pointer :: w_scalar(:,:) ! fraction by which decomposition is limited by moisture availability -#endif - real(r8), pointer :: decomp_k(:,:,:) ! rate constant for decomposition (1./sec) - real(r8), pointer :: rf_decomp_cascade(:,:,:) ! respired fraction in decomposition step (frac) - 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 - real(r8), pointer :: pathfrac_decomp_cascade(:,:,:) ! what fraction of C leaving a given pool passes through a given transition (frac) - logical, pointer :: floating_cn_ratio_decomp_pools(:) ! TRUE => pool has fixed C:N ratio - -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: - integer :: c,j,k,l,m !indices - integer :: fc !lake filter column index - real(r8):: p_decomp_cpool_loss(lbc:ubc,1:nlevdecomp,1:ndecomp_cascade_transitions) !potential C loss from one pool to another - real(r8):: pmnf_decomp_cascade(lbc:ubc,1:nlevdecomp,1:ndecomp_cascade_transitions) !potential mineral N flux, from one pool to another - real(r8):: immob(lbc:ubc,1:nlevdecomp) !potential N immobilization - real(r8):: ratio !temporary variable - real(r8):: dnp !denitrification proportion - real(r8):: cn_decomp_pools(lbc:ubc,1:nlevdecomp,1:ndecomp_pools) - real(r8), pointer :: initial_cn_ratio(:) ! c:n ratio for initialization of pools - integer, parameter :: i_atm = 0 - integer, pointer :: altmax_indx(:) ! maximum annual depth of thaw - integer, pointer :: altmax_lastyear_indx(:) ! prior year maximum annual depth of thaw - - - ! For methane code -#ifndef NITRIF_DENITRIF - real(r8):: phr_vr(lbc:ubc,1:nlevdecomp) !potential HR (gC/m3/s) -#else - real(r8), pointer :: phr_vr(:,:) !potential HR (gC/m3/s) -#endif - real(r8):: hrsum(lbc:ubc,1:nlevdecomp) !sum of HR (gC/m2/s) - - !EOP - !----------------------------------------------------------------------- - - decomp_cpools_vr => ccs%decomp_cpools_vr - decomp_cascade_hr_vr => ccf%decomp_cascade_hr_vr - decomp_cascade_ctransfer_vr => ccf%decomp_cascade_ctransfer_vr - decomp_npools_vr => cns%decomp_npools_vr - decomp_cascade_ntransfer_vr => cnf%decomp_cascade_ntransfer_vr - decomp_cascade_sminn_flux_vr => cnf%decomp_cascade_sminn_flux_vr - fpi_vr => cps%fpi_vr - potential_immob_vr => cnf%potential_immob_vr - - decomp_k => ccf%decomp_k - rf_decomp_cascade => cps%rf_decomp_cascade - cascade_donor_pool => decomp_cascade_con%cascade_donor_pool - cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool - pathfrac_decomp_cascade => cps%pathfrac_decomp_cascade - floating_cn_ratio_decomp_pools => decomp_cascade_con%floating_cn_ratio_decomp_pools - initial_cn_ratio => decomp_cascade_con%initial_cn_ratio - altmax_indx => cps%altmax_indx - altmax_lastyear_indx => cps%altmax_lastyear_indx - -#ifndef NITRIF_DENITRIF - sminn_to_denit_decomp_cascade_vr => cnf%sminn_to_denit_decomp_cascade_vr - sminn_to_denit_excess_vr => cnf%sminn_to_denit_excess_vr -#else - phr_vr => ccf%phr_vr -#endif - gross_nmin_vr => cnf%gross_nmin_vr - net_nmin_vr => cnf%net_nmin_vr - gross_nmin => cnf%gross_nmin - net_nmin => cnf%net_nmin - ! For methane code -#ifdef LCH4 - fphr => cch4%fphr - w_scalar => ccf%w_scalar -#endif - - rootfr => pps%rootfr - clandunit =>col%landunit - itypelun => lun%itype - - - - call decomp_rate_constants(lbc, ubc, num_soilc, filter_soilc) - - - ! set initial values for potential C and N fluxes - p_decomp_cpool_loss(:,:,:) = 0._r8 - pmnf_decomp_cascade(:,:,:) = 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) .gt. 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)) .gt. 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) .ne. 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 - - ! 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 - - call decomp_vertprofiles(lbp, ubp, lbc,ubc,num_soilc,filter_soilc,num_soilp,filter_soilp) - -#ifdef NITRIF_DENITRIF - ! calculate nitrification and denitrification rates - call nitrif_denitrif(lbc, ubc, num_soilc, filter_soilc) -#endif - - - ! now that potential N immobilization is known, call allocation - ! to resolve the competition between plants and soil heterotrophs - ! for available soil mineral N resource. - - call CNAllocation(lbp, ubp, lbc,ubc,num_soilc,filter_soilc,num_soilp, & - filter_soilp) - - ! column loop to calculate actual immobilization and decomp rates, following - ! resolution of plant/heterotroph competition for mineral N - - dnp = 0.01_r8 - - ! 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) .gt. 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 - - ! upon return from CNAllocation, the fraction of potential immobilization - ! has been set (cps%fpi_vr). 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)) .gt. 0._r8) then - if ( pmnf_decomp_cascade(c,j,k) .gt. 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) -#ifndef NITRIF_DENITRIF - sminn_to_denit_decomp_cascade_vr(c,j,k) = 0._r8 - else - sminn_to_denit_decomp_cascade_vr(c,j,k) = -dnp * pmnf_decomp_cascade(c,j,k) -#endif - 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) .ne. 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) .ne. 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 -#ifndef NITRIF_DENITRIF - sminn_to_denit_decomp_cascade_vr(c,j,k) = 0._r8 -#endif - decomp_cascade_sminn_flux_vr(c,j,k) = 0._r8 - end if - - end do - end do - end do - -#ifdef LCH4 - ! 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 -#endif - - ! vertically integrate net and gross mineralization fluxes for diagnostic output - do j = 1,nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - 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) - end do - end do - - end subroutine CNDecompAlloc - - -!#endif - -end module CNDecompMod 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 deleted file mode 100644 index 41354c980..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNEcosystemDynMod.F90 +++ /dev/null @@ -1,303 +0,0 @@ -module CNEcosystemDynMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNEcosystemDynMod -! -! !DESCRIPTION: -! Ecosystem dynamics: phenology, vegetation -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varctl , only: fpftdyn, use_c13, use_c14 -! -! !PUBLIC TYPES: - implicit none - save -! -! !PUBLIC MEMBER FUNCTIONS: - public :: CNEcosystemDynInit ! Ecosystem dynamics initialization - public :: CNEcosystemDyn ! Ecosystem dynamics: phenology, vegetation -! -! -! !REVISION HISTORY: -! Created by Peter Thornton -! 19 May 2009: PET - modified to include call to harvest routine -!F. Li and S. Levis (11/06/12) -! -! !PRIVATE MEMBER FUNCTIONS: -! -! !PRIVATE TYPES: -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNEcosystemDynInit -! -! !INTERFACE: - subroutine CNEcosystemDynInit(lbg, ubg, lbc, ubc, lbp, ubp ) -! -! !DESCRIPTION: -! Initialzation of the CN Ecosystem dynamics. -! -! !USES: - use CNAllocationMod, only : CNAllocationInit - use CNPhenologyMod , only : CNPhenologyInit -! use CNFireMod , only : CNFireInit -! use CNC14DecayMod , only : C14_init_BombSpike -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbg, ubg ! gridcell bounds - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: lbp, ubp ! pft bounds -! -! !CALLED FROM: -! -! !REVISION HISTORY: -! 04/05/11, Erik Kluzek creation -! -! !LOCAL VARIABLES: -!EOP -!----------------------------------------------------------------------- - call CNAllocationInit ( lbc, ubc, lbp, ubp ) - call CNPhenologyInit ( lbp, ubp ) -! call CNFireInit ( lbg, ubg ) ! hdm and lnfm data are read in another way, fzeng - -! if ( use_c14 ) call C14_init_BombSpike() - - end subroutine CNEcosystemDynInit - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNEcosystemDyn -! -! !INTERFACE: - subroutine CNEcosystemDyn(lbc, ubc, lbp, ubp, num_soilc, filter_soilc, & - num_soilp, filter_soilp, num_pcropp, filter_pcropp, doalb, tileid_soilp) -! -! !DESCRIPTION: -! The core CN code is executed here. Calculates fluxes for maintenance -! respiration, decomposition, allocation, phenology, and growth respiration. -! These routines happen on the radiation time step so that canopy structure -! stays synchronized with albedo calculations. -! -! !USES: - use clmtype - use CNSetValueMod , only: CNZeroFluxes - use CNNDynamicsMod , only: CNNDeposition,CNNFixation, CNNLeaching, CNNFert, CNSoyfix - use CNMRespMod , only: CNMResp - use CNDecompMod , only: CNDecompAlloc - use CNPhenologyMod , only: CNPhenology - use CNGRespMod , only: CNGResp - use CNCStateUpdate1Mod , only: CStateUpdate1,CStateUpdate0 - use CNNStateUpdate1Mod , only: NStateUpdate1 - use CNGapMortalityMod , only: CNGapMortality - use CNCStateUpdate2Mod , only: CStateUpdate2, CStateUpdate2h - use CNNStateUpdate2Mod , only: NStateUpdate2, NStateUpdate2h - use CNFireMod , only: CNFireArea, CNFireFluxes - use CNCStateUpdate3Mod , only: CStateUpdate3 - use CNNStateUpdate3Mod , only: NStateUpdate3 - use CNPrecisionControlMod, only: CNPrecisionControl - use CNVegStructUpdateMod , only: CNVegStructUpdate -! use CNAnnualUpdateMod , only: CNAnnualUpdate - use CNSummaryMod , only: CSummary, NSummary -! use CNCIsoFluxMod , only: CIsoFlux1, CIsoFlux2, CIsoFlux2h, CIsoFlux3 -! use CNC14DecayMod , only: C14Decay, C14BombSpike -! use pftdynMod , only: CNHarvest - use CNWoodProductsMod , only: CNWoodProducts - use CNSoilLittVertTranspMod, only: CNSoilLittVertTransp -! use perf_mod , only: t_startf, t_stopf - use clm_varctl , only: crop_prog -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: lbp, ubp ! pft bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(ubp-lbp+1) ! filter for soil pfts - integer, intent(in) :: num_pcropp ! number of prog. crop pfts in filter - integer, intent(in) :: filter_pcropp(ubp-lbp+1)! filter for prognostic crop pfts - logical, intent(in) :: doalb ! true = surface albedo calculation time step - integer, intent(in) :: tileid_soilp(:) ! tile index for debugging -! -! !CALLED FROM: -! -! !REVISION HISTORY: -! 10/22/03, Peter Thornton: created from EcosystemDyn during migration to -! new vector code. -! 11/3/03, Peter Thornton: removed update of elai, esai, frac_veg_nosno_alb. -! These are now done in CNVegStructUpdate(), which is called -! prior to SurfaceAlbedo(). -! 11/13/03, Peter Thornton: switched from nolake to soil filtering. -! -! !LOCAL VARIABLES: -! -! local pointers to implicit in arguments -! -! local pointers to implicit out arguments -! -! !OTHER LOCAL VARIABLES: -! -!EOP -!----------------------------------------------------------------------- - - ! if (doalb) then - - ! Call the main CN routines -! call t_startf('CNZero') - call CNZeroFluxes(num_soilc, filter_soilc, num_soilp, filter_soilp) -! call t_stopf('CNZero') - -! call t_startf('CNDeposition') - call CNNDeposition(lbc, ubc) -! call t_stopf('CNDeposition') - -! call t_startf('CNFixation') - call CNNFixation(num_soilc,filter_soilc) -! call t_stopf('CNFixation') - -! call t_startf('CNMResp') - if (crop_prog) call CNNFert(num_soilc,filter_soilc) - - if (crop_prog) call CNSoyfix(num_soilc, filter_soilc, num_soilp, filter_soilp) - - call CNMResp(lbc, ubc, num_soilc, filter_soilc, num_soilp, filter_soilp) -! call t_stopf('CNMResp') - -! call t_startf('CNDecompAlloc') - call CNDecompAlloc(lbp, ubp, lbc, ubc, num_soilc, filter_soilc, & - num_soilp, filter_soilp ) -! call t_stopf('CNDecompAlloc') - - ! CNphenology needs to be called after CNdecompAlloc, because it - ! depends on current time-step fluxes to new growth on the last - ! litterfall timestep in deciduous systems - -! call t_startf('CNPhenology') - call CNPhenology(num_soilc, filter_soilc, num_soilp, filter_soilp, & - num_pcropp, filter_pcropp, doalb) -! call t_stopf('CNPhenology') - -! call t_startf('CNUpdate0') - call CNGResp(num_soilp, filter_soilp) - - call CStateUpdate0(num_soilp, filter_soilp, 'bulk') - -! if ( use_c13 ) call CStateUpdate0(num_soilp, filter_soilp, 'c13') -! call t_stopf('CNUpdate0') - -! call t_startf('CNUpdate1') -! if ( use_c13 ) call CIsoFlux1(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CStateUpdate0(num_soilp, filter_soilp, 'c14') - -! if ( use_c14 ) call CIsoFlux1(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - - call CStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, 'bulk') - -! if ( use_c13 ) call CStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - - call NStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, tileid_soilp) - -! call t_startf('CNSoilLittVertTransp') - call CNSoilLittVertTransp(lbc, ubc, num_soilc, filter_soilc) -! call t_stopf('CNSoilLittVertTransp') - -! call t_startf('CNGapMortality') - call CNGapMortality(num_soilc, filter_soilc, num_soilp, filter_soilp) -! call t_stopf('CNGapMortality') - -! call t_stopf('CNUpdate1') - -! call t_startf('CNUpdate2') -! if ( use_c13 ) call CIsoFlux2(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CIsoFlux2(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - - call CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, 'bulk') - -! if ( use_c13 ) call CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - - call NStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp) - -! if (fpftdyn /= ' ') then -! call CNHarvest(num_soilc, filter_soilc, num_soilp, filter_soilp) -! end if - -! if ( use_c13 ) call CIsoFlux2h(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CIsoFlux2h(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - - call CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, 'bulk') - -! if ( use_c13 ) call CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - - call NStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp) - - call CNWoodProducts(num_soilc, filter_soilc) - - call CNFireArea(num_soilc, filter_soilc,num_soilp, filter_soilp) - - call CNFireFluxes(num_soilc, filter_soilc, num_soilp, filter_soilp) - - call CNNLeaching(lbc, ubc, num_soilc, filter_soilc) -! call t_stopf('CNUpdate2') - -! call t_startf('CNUpdate3') -! if ( use_c13 ) call CIsoFlux3(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CIsoFlux3(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - - call CStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp, 'bulk') - -! if ( use_c13 ) call CStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - -! if ( use_c14 ) call C14Decay(num_soilc, filter_soilc, num_soilp, filter_soilp) - -! if ( use_c14 ) call C14BombSpike(num_soilp, filter_soilp) - - call NStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp) -! call t_stopf('CNUpdate3') - -! call t_startf('CNsum') - call CNPrecisionControl(num_soilc, filter_soilc, num_soilp, filter_soilp) - - if (doalb) then - call CNVegStructUpdate(num_soilp, filter_soilp) - end if - -! call CNAnnualUpdate(num_soilc, filter_soilc, num_soilp, filter_soilp) - - call CSummary(num_soilc, filter_soilc, num_soilp, filter_soilp, 'bulk') - -! if ( use_c13 ) call CSummary(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c13') - -! if ( use_c14 ) call CSummary(num_soilc, filter_soilc, num_soilp, filter_soilp, 'c14') - - call NSummary(num_soilc, filter_soilc, num_soilp, filter_soilp) -! call t_stopf('CNsum') - -! end if !end of if-doalb block - - end subroutine CNEcosystemDyn -!#endif -!----------------------------------------------------------------------- -end module CNEcosystemDynMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNFireMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNFireMod.F90 deleted file mode 100755 index 973cfbcce..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNFireMod.F90 +++ /dev/null @@ -1,1928 +0,0 @@ - -module CNFireMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNFireMod -! -! !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)" -! 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 MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use shr_const_mod , only: SHR_CONST_PI,SHR_CONST_TKFRZ -! use shr_strdata_mod, only: shr_strdata_type, shr_strdata_create, shr_strdata_print, & -! shr_strdata_advance - use subgridAveMod , only: p2c - use clm_varctl , only: iulog, use_nofire - use clm_varpar , only: nlevdecomp, ndecomp_pools - use clm_varcon , only: dzsoi_decomp - use pftvarcon , only: noveg, nbrdlf_evr_trp_tree -! use catch_types , only: cn_param_type -! use spmdMod , only: masterproc, mpicom, comp_id -! use fileutils , only: getavu, relavu -! use controlMod , only: NLFilename -! use decompMod , only: gsmap_lnd_gdc2glo -! use domainMod , only: ldomain -! use mct_mod - implicit none - save - private -! !PUBLIC TYPES: - -!! fzeng: we don't use CNFireInit or CNFireInterp - -! !PUBLIC MEMBER FUNCTIONS: -! public :: CNFireInit ! Initialization of CNFire -! public :: CNFireInterp ! Interpolate fire data - public :: CNFireArea ! Calculate fire area - public :: CNFireFluxes ! Calculate fire fluxes - -! !PRIVATE MEMBER FUNCTIONS: -! private :: hdm_init ! position datasets for dynamic human population density -! private :: hdm_interp ! interpolates between two years of human pop. density file data -! private :: lnfm_init ! position datasets for Lightning -! private :: lnfm_interp ! interpolates between two years of Lightning file data - -! !PRIVATE MEMBER DATA: - real(r8), pointer :: forc_lnfm(:) ! Lightning frequency, unit must be counts/km2/hr, fzeng, 24 Aug 2017 - real(r8), pointer :: forc_hdm(:) ! Human population density, unit must be person/km2, fzeng, 24 Aug 2017 - real(r8), parameter :: secsphr = 3600._r8 ! Seconds in an hour - real(r8), parameter :: borealat = 40._r8 ! Latitude for boreal peat fires - -!! hdm and lnfm data are read in another way, fzeng -! type(shr_strdata_type) :: sdat_hdm ! Human population density input data stream -! type(shr_strdata_type) :: sdat_lnfm ! Lightning input data stream -! -! !REVISION HISTORY: -! -!EOP -!----------------------------------------------------------------------- - -contains - -!!----------------------------------------------------------------------- -!!BOP -!! -!! !IROUTINE: CNFireInit -!! -!! !INTERFACE: -!subroutine CNFireInit( begg, endg ) -! -!! !DESCRIPTION: -!! Initialize CN Fire module -!! Not used in Catchment-CN. hdm and lnfm data are read in another way. fzeng -!! -!! !USES: -!! -!! !ARGUMENTS: -! implicit none -! integer, intent(IN) :: begg, endg ! gridcell index bounds -! -!! !REVISION HISTORY: -!! !LOCAL VARIABLES: -!!EOP -!!----------------------------------------------------------------------- -! call hdm_init( begg, endg ) -! call hdm_interp( ) -! call lnfm_init( begg, endg ) -! call lnfm_interp() - -!----------------------------------------------------------------------- -!end subroutine CNFireInit - - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNFireInterp -! -! !INTERFACE: -!subroutine CNFireInterp() -! -! !DESCRIPTION: -! Interpolate CN Fire datasets -! -! !USES: -! -! !ARGUMENTS: -! implicit none -! -! !REVISION HISTORY: -! !LOCAL VARIABLES: -!EOP -!----------------------------------------------------------------------- -! call hdm_interp() -! call lnfm_interp() - -!----------------------------------------------------------------------- -!end subroutine CNFireInterp - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNFireArea -! -! !INTERFACE: -subroutine CNFireArea (num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! Computes column-level burned area in each timestep - -! fzeng, 24 Jan 2018 -! Change nc4_grass to nc4_grass2 throughout CNFireArea because Catchment-CN has split types for c4 grass -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size, get_days_per_year, get_curr_date, get_nstep - use clm_varpar , only: max_pft_per_col, numpft - use clm_varcon , only: secspday -! use shr_infnan_mod , only: shr_infnan_isnan - use, intrinsic :: ieee_arithmetic, only: shr_infnan_isnan => ieee_is_nan - use clm_varctl , only: fpftdyn - use pftvarcon , only: nc4_grass2, nc3crop, ndllf_evr_tmp_tree, & - nbrdlf_evr_trp_tree, nbrdlf_dcd_trp_tree, & - nbrdlf_evr_shrub -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - ! pft-level - real(r8), pointer :: prec10(:) ! 10-day running mean of tot. precipitation - real(r8), pointer :: prec60(:) ! 60-day running mean of tot. precipitation - real(r8), pointer :: lfpftd(:) ! decrease of pft weight (0-1) on the col. for timestep - real(r8), pointer :: wtcol(:) ! pft weight on the column - integer , pointer :: ivt(:) ! vegetation type for this pft - real(r8), pointer :: fveg(:) ! vegetation fraction for this pft - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool - real(r8), pointer :: btran2(:) ! root zone soil wetness - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - integer , pointer :: burndate(:) ! burn date for crop - real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool - - - ! column-level - real(r8), pointer :: fsat(:) ! fractional area with water table at surface - real(r8), pointer :: lfc(:) ! conversion area frac. of BET+BDT that haven't burned before - real(r8), pointer :: cwtgcell(:) ! column's weight relative to corresponding gridcell - real(r8), pointer :: dtrotr_col(:) ! annual decreased fraction coverage of BET+BDT on gridcell - real(r8), pointer :: trotr1_col(:) ! pft weight of BET on the gridcell (0-1) - real(r8), pointer :: trotr2_col(:) ! pft weight of BDT on the gridcell (0-1) - real(r8), pointer :: prec10_col(:) ! 10-day running mean of tot. precipitation - real(r8), pointer :: prec60_col(:) ! 60-day running mean of tot. precipitation - integer , pointer :: npfts(:) ! number of pfts on the column - integer , pointer :: pfti(:) ! pft index array - integer , pointer :: cgridcell(:) ! gridcell of corresponding column - real(r8), pointer :: wf(:) ! soil water as frac. of whc for top 0.05 m - real(r8), pointer :: wf2(:) ! soil water as frac. of whc for top 0.17 m - real(r8), pointer :: tsoi17(:) ! soil T for top 0.17 m - real(r8), pointer :: gdp_lf(:) ! gdp data - real(r8), pointer :: peatf_lf(:) ! peatland fraction data - integer, pointer :: abm_lf(:) ! prescribed crop fire time - real(r8), pointer :: totlitc(:) ! (gC/m2) total lit C (column-level mean) - real(r8), pointer :: fsr_col(:) ! fire spread rate at column level (m/s) - real(r8), pointer :: fd_col(:) ! fire duration at column level (second) - real(r8), pointer :: rootc_col(:) ! root carbon - real(r8), pointer :: baf_crop(:) ! burned area fraction for cropland - real(r8), pointer :: baf_peatf(:) ! burned area fraction for peatland - real(r8), pointer :: fbac(:) ! total burned area out of conversion - real(r8), pointer :: fbac1(:) ! burned area out of conversion region due to land use fire - real(r8), pointer :: cropf_col(:) ! cropland fraction in veg column - real(r8), pointer :: btran_col(:) ! transpiration wetness factor (0 to 1) - real(r8), pointer :: wtlf(:) ! fractional coverage of non-crop PFTs - real(r8), pointer :: lfwt(:) ! fractional coverage of non-crop and non-bare-soil PFTs - real(r8), pointer :: totvegc_col(:) ! totvegc at column level - real(r8), pointer :: leafc_col(:) ! leaf carbon at column level - real(r8), pointer :: lgdp_col(:) ! gdp limitation factor for nfire - real(r8), pointer :: lgdp1_col(:) ! gdp limitation factor for baf per fire - real(r8), pointer :: lpop_col(:) ! pop limitation factor for baf per fire - real(r8), pointer :: fuelc(:) ! fuel avalability factor for Reg.C - real(r8), pointer :: fuelc_crop(:) ! fuel avalability factor for Reg.A - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vert.-resolved decomposing c pools - real(r8), pointer :: cpool_col(:) ! temporary photosynthate C pool at column level - - ! grid-level - real(r8), pointer :: latdeg(:) ! latitude (degrees) - real(r8), pointer :: forc_rain(:) ! rain rate [mm/s] - real(r8), pointer :: forc_snow(:) ! snow rate [mm/s] - real(r8), pointer :: forc_rh(:) ! atmospheric relative humidity (%) - real(r8), pointer :: forc_t(:) ! atmospheric temperature (Kelvin) - real(r8), pointer :: forc_wind(:) ! atmospheric wind speed (m/s) - - ! ecophysiological constants, fzeng - real(r8), pointer :: fsr_pft(:) ! Fire spread rate (m/s) - real(r8), pointer :: fd_pft(:) ! Fire duration (hr) - -! local pointers to implicit in/out scalars -! - ! column-level - real(r8), pointer :: nfire(:) ! fire counts (count/km2/second), valid only in Reg. C - real(r8), pointer :: farea_burned(:)! fractional area burned per second - logical, pointer :: is_cwd(:) ! TRUE => pool is a cwd pool -! -! !OTHER LOCAL VARIABLES: - ! modified according to clm4_6_00, fzeng, 7 May 2019 - real(r8), parameter :: lfuel=75._r8 !110._r8 ! lower threshold of fuel mass (gC/m2) for ignition, Li et al., BG 2014, fzeng, 7 May 2019 - real(r8), parameter :: ufuel=1050._r8 ! upper threshold of fuel mass(gC/m2) for ignition - real(r8), parameter :: g0=0.05_r8 ! g(W) when W=0 m/s - - ! a1 parameter for cropland fire in (Li et. al., 2014), but changed from - ! /timestep to /hr - real(r8), parameter :: cropfire_a1 = 0.3_r8 !0.31_r8 ! hr-1, see clm4_6_00 and Li et al., BG 2014, fzeng, 7 May 2019 - - ! c parameter for peatland fire in Li et. al. (2013) - ! boreal peat fires (was different in paper),changed from /timestep to /hr - real(r8), parameter :: boreal_peatfire_c = 4.2e-5_r8 !4.2d-5 ! hr-1, see clm4_6_00, fzeng, 7 May 2019 - ! non-boreal peat fires (was different in paper) - real(r8), parameter :: non_boreal_peatfire_c = 0.001_r8 ! hr-1, fzeng, 24 Aug 2017 - - 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 ! - real(r8), parameter ::cli_scale = 0.035_r8 !global constant for deforestation fires (/d), see clm4_6_00, fzeng, 7 May 2019 - real(r8) ::cri ! - real(r8):: fb ! availability of fuel - 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 on fire occurrence - real(r8):: spread_m ! combustability of fuel on fire spread - real(r8):: Lb_lf ! length-to-breadth ratio added by Lifang - integer :: i_cwd ! cwd pool - real(r8) :: lh ! - real(r8) :: fs ! - real(r8) :: ig ! - real(r8) :: hdmlf ! human density - - ! local variables for PFT fire modifications - logical :: pft_4_flag ! flag for presence of PFT 4 - real(r8):: fire_m_tmp - real, dimension(0:numpft) :: fire_m_fac ! array to parameterize combustibility sensitivity to soil moisture separately for each PFT -!EOP -!----------------------------------------------------------------------- -! declare fire_m_fac array used to compute PFT-dependent combustibility (jkolassa 08/2020) - -data fire_m_fac / SHR_CONST_PI, SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI,SHR_CONST_PI/ - -! only allow fires in very dry conditions in PFTs 4 and 6 (jkolassa 08/2020) -fire_m_fac(4) = 10.e15 -fire_m_fac(6) = 10.e15 - -! assign local pointers to derived type members (pft-level) - wtcol =>pft%wtcol - ivt =>pft%itype - prec60 => pps%prec60 - prec10 => pps%prec10 - deadcrootc => pcs%deadcrootc - deadcrootc_storage => pcs%deadcrootc_storage - deadcrootc_xfer => pcs%deadcrootc_xfer - frootc => pcs%frootc - frootc_storage => pcs%frootc_storage - frootc_xfer => pcs%frootc_xfer - livecrootc => pcs%livecrootc - livecrootc_storage => pcs%livecrootc_storage - livecrootc_xfer => pcs%livecrootc_xfer - totvegc => pcs%totvegc - btran2 => pps%btran2 - leafc => pcs%leafc - leafc_storage => pcs%leafc_storage - leafc_xfer => pcs%leafc_xfer - lfpftd => pps%lfpftd - burndate => pps%burndate - cpool => pcs%cpool - - - ! assign local pointers to derived type members (column-level) - cwtgcell =>col%wtgcell - npfts =>col%npfts - pfti =>col%pfti - wf => cps%wf - wf2 => cps%wf2 - tsoi17 => ces%tsoi17 - farea_burned => cps%farea_burned - baf_crop => cps%baf_crop - baf_peatf => cps%baf_peatf - fbac => cps%fbac - fbac1 => cps%fbac1 - cropf_col => cps%cropf_col - gdp_lf => cps%gdp_lf - peatf_lf => cps%peatf_lf - abm_lf => cps%abm_lf - nfire => cps%nfire - totlitc => ccs%totlitc - fsr_col => cps%fsr_col - fd_col => cps%fd_col - rootc_col => ccs%rootc_col - totvegc_col => ccs%totvegc_col - leafc_col => ccs%leafc_col - lgdp_col => cps%lgdp_col - lgdp1_col => cps%lgdp1_col - lpop_col => cps%lpop_col - fuelc => ccs%fuelc - fuelc_crop => ccs%fuelc_crop - btran_col => cps%btran_col - wtlf => cps%wtlf - lfwt => cps%lfwt - cgridcell =>col%gridcell - trotr1_col => cps%trotr1_col - trotr2_col => cps%trotr2_col - dtrotr_col => cps%dtrotr_col - prec60_col => cps%prec60_col - prec10_col => cps%prec10_col - lfc => cps%lfc - fsat => cws%fsat - is_cwd => decomp_cascade_con%is_cwd - decomp_cpools_vr => ccs%decomp_cpools_vr - cpool_col => ccs%cpool_col - -! write(*,*) 'size PFTi ', size(pfti) -! write(*,*) 'PFTi vals ', pfti(1:10) - - !assign local pointers to derived type members (grid-level) - forc_rh => grc%forc_rh - forc_wind => grc%forc_wind - forc_t => grc%forc_t - forc_rain => grc%forc_rain - forc_snow => grc%forc_snow - latdeg => grc%latdeg - forc_hdm => grc%forc_hdm - forc_lnfm => grc%forc_lnfm - - !assign local pointers to ecophysiological constants, fzeng - fsr_pft => pftcon%fsr_pft - fd_pft => pftcon%fd_pft - - !pft to column average - call p2c(num_soilc, filter_soilc, prec10, prec10_col) - call p2c(num_soilc, filter_soilc, prec60, prec60_col) - call p2c(num_soilc, filter_soilc,totvegc, totvegc_col) - call p2c(num_soilc, filter_soilc,leafc, leafc_col) - call p2c(num_soilc, filter_soilc,cpool, cpool_col) - call get_curr_date (kyr, kmo, kda, mcsec) - dayspyr = get_days_per_year() - ! Get model step size - dt = real( get_step_size(), r8 ) - ! - ! 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 ! see clm4_6_00, fzeng, 7 May 2019 - 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 pi = 1,max_pft_per_col - do fc = 1,num_soilc - c = filter_soilc(fc) - if (pi <= npfts(c)) then - p = pfti(c) + pi - 1 - ! For crop veg types - if( ivt(p) > nc4_grass2 )then - cropf_col(c) = cropf_col(c) + wtcol(p) - end if - ! For natural vegetation (non-crop) - if( ivt(p) >= ndllf_evr_tmp_tree .and. ivt(p) <= nc4_grass2 )then - lfwt(c) = lfwt(c) + wtcol(p) - end if - end if - end do - end do - ! - ! Calculate crop fuel - ! - do fc = 1,num_soilc - c = filter_soilc(fc) - fuelc_crop(c)=0._r8 - end do - do pi = 1,max_pft_per_col - do fc = 1,num_soilc - c = filter_soilc(fc) - if (pi <= npfts(c)) then - p = pfti(c) + pi - 1 - ! For crop PFT's - if( ivt(p) > nc4_grass2 .and. 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))*wtcol(p)/cropf_col(c) + & - totlitc(c)*leafc(p)/leafc_col(c)*wtcol(p)/cropf_col(c) - end if - end if - end do - 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 ! see clm4_6_00 and Li et al., BG 2014, fzeng, 7 May 2019 - trotr2_col(c)= 0._r8 ! see clm4_6_00 and Li et al., BG 2014, fzeng, 7 May 2019 - if (fpftdyn /= ' ') then !true when landuse data is used - dtrotr_col(c)=0._r8 - end if - end do - do pi = 1,max_pft_per_col - do fc = 1,num_soilc - c = filter_soilc(fc) - g = cgridcell(c) - if (pi <= npfts(c)) then - p = pfti(c) + pi - 1 - ! For non-crop -- natural vegetation and bare-soil - if( ivt(p) .lt. nc3crop .and. cropf_col(c) .lt. 1.0_r8 )then - if( .not. shr_infnan_isnan(btran2(p)) .and. btran2(p) .le. 1._r8 )then - btran_col(c) = btran_col(c)+btran2(p)*wtcol(p) - wtlf(c) = wtlf(c)+wtcol(p) - end if - if( ivt(p) == nbrdlf_evr_trp_tree .and. wtcol(p) .gt. 0._r8 )then -! trotr1_col(c)=trotr1_col(c)+wtcol(p)*cwtgcell(c) - trotr1_col(c)=trotr1_col(c)+wtcol(p) ! wtcol is already the pft weight in the gridcell/tile in Catchment-CN4.5, fzeng, 12 July 2019 - end if - if( ivt(p) == nbrdlf_dcd_trp_tree .and. wtcol(p) .gt. 0._r8 )then -! trotr2_col(c)=trotr2_col(c)+wtcol(p)*cwtgcell(c) - trotr2_col(c)=trotr2_col(c)+wtcol(p) ! wtcol is already the pft weight in the gridcell/tile in Catchment-CN4.5, fzeng, 12 July 2019 - end if - if ( fpftdyn /= ' ' ) then !true when landuse data is used - if( ivt(p) == nbrdlf_evr_trp_tree .or. ivt(p) == nbrdlf_dcd_trp_tree )then - if(lfpftd(p).gt.0._r8)then - dtrotr_col(c)=dtrotr_col(c)+lfpftd(p)*cwtgcell(c) - end if - end if - end if - if (wtcol(p) > 0.) then ! Exclude the PFTs that do not exist in the column to avoid adding nan. F Zeng, 23 June 2017 - 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))*wtcol(p) - end if - - fsr_col(c) = fsr_col(c) + fsr_pft(ivt(p))*wtcol(p)/(1.0_r8-cropf_col(c)) - - if( lfwt(c) .ne. 0.0_r8 )then - hdmlf=forc_hdm(g) - - ! all these constants are in Li et al. BG (2012a,b;2013) - - if( hdmlf .gt. 0.1_r8 )then - ! For NOT bare-soil - if( ivt(p) .ne. noveg )then - ! For shrub and grass (crop already excluded above) - if( ivt(p) .ge. 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))*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)))*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))*wtcol(p)/lfwt(c) - else ! for trees - if( gdp_lf(c) .gt. 20._r8 )then - lgdp_col(c) =lgdp_col(c)+0.2_r8*wtcol(p)/(1.0_r8 - cropf_col(c)) ! GDP 0.2 - else - lgdp_col(c) = lgdp_col(c)+wtcol(p)/(1.0_r8 - cropf_col(c)) - end if - if( gdp_lf(c) .gt. 20._r8 )then - lgdp1_col(c) = lgdp1_col(c)+0.62_r8*wtcol(p)/lfwt(c) - else - if( gdp_lf(c) .gt. 8._r8 ) then - lgdp1_col(c)=lgdp1_col(c)+0.83_r8*wtcol(p)/lfwt(c) - else - lgdp1_col(c)=lgdp1_col(c)+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)))*wtcol(p)/lfwt(c) - end if - end if - else - lgdp_col(c) = lgdp_col(c)+wtcol(p)/(1.0_r8 - cropf_col(c)) - lgdp1_col(c) = lgdp1_col(c)+wtcol(p)/lfwt(c) - lpop_col(c) = lpop_col(c)+wtcol(p)/lfwt(c) - end if - end if - - fd_col(c) = fd_col(c) + fd_pft(ivt(p))*wtcol(p)*secsphr/(1.0_r8-cropf_col(c)) - end if - end if - end do - end do - - if (fpftdyn /= ' ') then !true when landuse data is used - do fc = 1,num_soilc - c = filter_soilc(fc) - if( dtrotr_col(c) .gt. 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 pi = 1,max_pft_per_col - do fc = 1,num_soilc - c = filter_soilc(fc) - g= cgridcell(c) - hdmlf=forc_hdm(g) - if (pi <= npfts(c)) then - p = pfti(c) + pi - 1 - ! For crop - if( forc_t(g) .ge. SHR_CONST_TKFRZ .and. ivt(p) .gt. nc4_grass2 .and. & - kmo == abm_lf(c) .and. forc_rain(g)+forc_snow(g) .eq. 0._r8 .and. & - burndate(p) >= 999 .and. wtcol(p) .gt. 0._r8 )then ! catch crop burn time - ! 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*wtcol(p) ! removed *dt, see clm4_6_00, fzeng, 7 May 2019, so baf_crop is per second instead of per time step now - if( fb*fhd*fgdp*wtcol(p) .gt. 0._r8)then - burndate(p)=kda - end if - end if - end if - end do - end do - ! - ! calculate peatland fire - ! - do fc = 1, num_soilc - c = filter_soilc(fc) - g= cgridcell(c) - if(grc%latdeg(g).lt.borealat )then - baf_peatf(c) = non_boreal_peatfire_c/secsphr*max(0._r8, & ! removed *dt, see clm4_6_00, fzeng, 7 May 2019 - 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))* & ! removed *dt, see clm4_6_00, fzeng, 7 May 2019 - 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 - ! - fuelc = 0. ! added to avoid floating overflow, fzeng, 31 July 2019 - do fc = 1, num_soilc - c = filter_soilc(fc) - g = cgridcell(c) - hdmlf=forc_hdm(g) - nfire(c) = 0._r8 ! This is done in CNInitMod.F90 in clm4_6_00, fzeng, 9 May 2019 - if( cropf_col(c) .lt. 1.0 )then - pft_4_flag = .false. - do pi = 1,max_pft_per_col ! this loop can be avoided by directly targeting PFT 4 - ! kept for now to be able to extend modifications to other PFTs;jkolassa Jun 2020 - p = pfti(c) + pi - 1 - if ((ivt(p)==nbrdlf_evr_trp_tree).and.(wtcol(p).gt.0.)) then - pft_4_flag = .true. - end if - end do - ! see clm4_6_00 and Li et al., BG 2014, fzeng, 7 May 2019 -! if (trotr1_col(c)+trotr2_col(c)>0.6_r8) then - ! Allow trotr2 (i.e. broadleaf deciduous tropical trees in ESA) - ! in Africa to burn, because this type is classified as woody savanna - ! and savanna in MODIS land cover which is more consistent with - ! CLM4.5CN tree and grass fractions in Africa, fzeng, 12 July 2019; - ! additional modification by jkolassa (pft_4_flag=.false.) enables - ! fires for PFT 4 again in attempt to improve fire carbon emissions over Africa - ! changes (pft_4_flag==.false.) to (.not. pft_4_flag). W.J. - if ((trotr1_col(c)>0.6_r8) .and. ( .not. pft_4_flag )) then - farea_burned(c)=min(1.0_r8,baf_crop(c)+baf_peatf(c)) - else - fuelc(c) = totlitc(c)+totvegc_col(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 = 0. ! jkolassa 09/2020: made fire combustability computation PFT-dependent in order to be able to control combustibility sensitivity to soil moisture separately for each PFT - do pi = 1,max_pft_per_col - p = pfti(c) + pi - 1 - fire_m_tmp = exp(-fire_m_fac(ivt(p))*(m/0.69_r8)**2)*(1.0_r8 - max(0._r8, & - min(1._r8,(forc_rh(g)-30._r8)/(80._r8-30._r8))))* & - min(1._r8,exp(SHR_CONST_PI*(forc_t(g)-SHR_CONST_TKFRZ)/10._r8)) - fire_m = fire_m + (fire_m_tmp*wtcol(p)) - end do - lh = 0.0035_r8*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+forc_lnfm(g)/24/(5.16_r8+2.16_r8*cos(3._r8*grc%latdeg(g)))*0.25_r8)*(1._r8-fs)*(1._r8-cropf_col(c)) ! There is a bug here. The input of "cos" must be in radians!! fzeng, 2 Aug 2019 - ig = (lh+forc_lnfm(g)/24/(5.16_r8+2.16_r8*cos(3._r8*min(60.,abs(grc%latdeg(g)))*(SHR_CONST_PI/180._r8)))*0.25_r8)*(1._r8-fs)*(1._r8-cropf_col(c)) ! our forc_lnfm is counts/km2/day, so divided by 24 to get per hr, fzeng, 7 May 2019 - 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)-0.3_r8)/ & -! (0.7_r8-0.3_r8))))*(1.0-max(0._r8, & -! min(1._r8,(forc_rh(g)-30._r8)/(80._r8-30._r8)))) - spread_m = (1.0_r8 - max(0._r8,min(1._r8,(btran_col(c)/wtlf(c)-0.4_r8)/ & ! To reduce burned area biases, changed the btran lower threshold from 0.3 to 0.4, - (0.8_r8-0.4_r8))))*(1.0-max(0._r8, & ! and the btran upper threshold from 0.7 to 0.8, fzeng, 9 Aug 2019 - min(1._r8,(forc_rh(g)-30._r8)/(80._r8-30._r8)))) - else - spread_m = 0.0_r8 - end if - farea_burned(c) = min(1._r8,(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 ! (trotr1_col(c)+trotr2_col(c)>0.6_r8) - ! - ! if landuse change data is used, calculate deforestation fires and - ! add it in the total of burned area fraction - ! - if (fpftdyn /= ' ') then !true when landuse change data is used - 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(g)+forc_snow(g))*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 ! (fpftdyn /= ' ') - - else - farea_burned(c) = min(1._r8,baf_crop(c)+baf_peatf(c)) - end if ! ( cropf_col(c) .lt. 1.0 ) - - if (use_nofire) then - ! zero out the fire area if NOFIRE flag is on - - farea_burned(c) = 0._r8 - baf_crop(c) = 0._r8 - baf_peatf(c) = 0._r8 - fbac(c) = 0._r8 - fbac1(c) = 0._r8 - ! with NOFIRE, tree carbon is still removed in landuse change regions by the - ! landuse code - end if - - end do ! end of column loop - -end subroutine CNFireArea -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNFireFluxes -! -! !INTERFACE: -subroutine CNFireFluxes (num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! Fire effects routine for coupled carbon-nitrogen code (CN). -! Relies primarily on estimate of fractional area burned in this -! timestep, from CNFireArea(). -! -! 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)/dt*seconds_per_year)*0.8 -! where dt is the time step size (sec),avg means the temporal average in a year -! seconds_per_year is the number of seconds in a year. -! -! !USES: - use clmtype - use pftvarcon, only: nc3crop - use clm_time_manager, only: get_step_size,get_days_per_year,get_curr_date - use clm_varpar, only : max_pft_per_col - use clm_varctl , only: fpftdyn - use clm_varcon , only: secspday -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn() -! -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! -#if (defined CNDV) - real(r8), pointer :: nind(:) ! number of individuals (#/m2) -#endif - real(r8), pointer :: woody(:) ! woody lifeform (1=woody, 0=not woody) - logical , pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details) - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: wtcol(:) ! pft weight relative to column - real(r8), pointer :: latdeg(:) ! latitude (degrees) - integer , pointer :: cgridcell(:) ! gridcell of corresponding column - integer , pointer :: npfts(:) ! number of pfts for each column - integer , pointer :: pfti(:) ! beginning pft index for each column - integer , pointer :: pcolumn(:) ! pft's column index - real(r8), pointer :: farea_burned(:) ! timestep fractional area burned (proportion) - real(r8), pointer :: fire_mortality_c_to_cwdc(:,:) ! C fluxes associated with fire mortality to CWD pool (gC/m3/s) - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: fire_mortality_n_to_cwdn(:,:) ! N fluxes associated with fire mortality to CWD pool (gN/m3/s) - real(r8), pointer :: lfc(:) ! conversion area frac. of BET+BDT that haven't burned before - real(r8), pointer :: lfc2(:) ! conversion area frac. of BET+BDT that burned this timestep - real(r8), pointer :: fbac1(:) ! burned area out of conversion region due to land use fire - real(r8), pointer :: baf_crop(:) ! baf for cropland - real(r8), pointer :: baf_peatf(:) ! baf for peatlabd - real(r8), pointer :: leafcmax(:) ! (gC/m2) ann max leaf C - real(r8), pointer :: fbac(:) ! total burned area out of conversion - real(r8), pointer :: cropf_col(:) ! cropland fraction in veg column - - real(r8), pointer :: dtrotr_col(:) ! annual decreased fraction coverage of BET+BDT (0-1) on the gridcell - real(r8), pointer :: trotr1_col(:) ! pft weight of BET on the gridcell (0-1) - real(r8), pointer :: trotr2_col(:) ! pft weight of BDT on the gridcell (0-1) - - real(r8), pointer :: totsomc(:) ! (gC/m2) total soil organic matter carbon - real(r8), pointer :: somc_fire(:) ! (gC/m2/s)fire carbon emissions due to peat burning - - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N - - real(r8), pointer :: m_leafc_to_fire(:) ! (gC/m2/s) fire C emissions from leafc - real(r8), pointer :: m_leafc_storage_to_fire(:) ! (gC/m2/s) fire C emissions from leafc_storage - real(r8), pointer :: m_leafc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from leafc_xfer - real(r8), pointer :: m_livestemc_to_fire(:) ! (gC/m2/s) fire C emissions from livestemc - real(r8), pointer :: m_livestemc_storage_to_fire(:) ! (gC/m2/s) fire C emissions from livestemc_storage - real(r8), pointer :: m_livestemc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from livestemc_xfer - real(r8), pointer :: m_deadstemc_to_fire(:) ! (gC/m2/s) fire C emissions from deadstemc_xfer - real(r8), pointer :: m_deadstemc_storage_to_fire(:) ! (gC/m2/s) fire C emissions from deadstemc_storage - real(r8), pointer :: m_deadstemc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from deadstemc_xfer - real(r8), pointer :: m_frootc_to_fire(:) ! (gC/m2/s) fire C emissions from frootc - real(r8), pointer :: m_frootc_storage_to_fire(:) ! (gC/m2/s) fire C emissions from frootc_storage - real(r8), pointer :: m_frootc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from frootc_xfer - real(r8), pointer :: m_livecrootc_to_fire(:) ! (gC/m2/s) fire C emissions from livecrootc - real(r8), pointer :: m_livecrootc_storage_to_fire(:)! (gC/m2/s) fire C emissions from livecrootc_storage - real(r8), pointer :: m_livecrootc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from livecrootc_xfer - real(r8), pointer :: m_deadcrootc_to_fire(:) ! (gC/m2/s) fire C emissions from deadcrootc - real(r8), pointer :: m_deadcrootc_storage_to_fire(:)! (gC/m2/s) fire C emissions from deadcrootc_storage - real(r8), pointer :: m_deadcrootc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from deadcrootc_xfer - real(r8), pointer :: m_gresp_storage_to_fire(:) ! (gC/m2/s) fire C emissions from gresp_storage - real(r8), pointer :: m_gresp_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from gresp_xfer - real(r8), pointer :: m_decomp_cpools_to_fire_vr(:,:,:) ! (gC/m3/s) vertically-resolved decomposing C fire loss - - real(r8), pointer :: m_leafn_to_fire(:) ! (gN/m2/s) fire N emissions from leafn - real(r8), pointer :: m_leafn_storage_to_fire(:) ! (gN/m2/s) fire N emissions from leafn_storage - real(r8), pointer :: m_leafn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from leafn_xfer - real(r8), pointer :: m_livestemn_to_fire(:) ! (gN/m2/s) fire N emissions from livestemn - real(r8), pointer :: m_livestemn_storage_to_fire(:) ! (gN/m2/s) fire N emissions from livestemn_storage - real(r8), pointer :: m_livestemn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from livestemn_xfer - real(r8), pointer :: m_deadstemn_to_fire(:) ! (gN/m2/s) fire N emissions from deadstemn - real(r8), pointer :: m_deadstemn_storage_to_fire(:) ! (gN/m2/s) fire N emissions from deadstemn_storage - real(r8), pointer :: m_deadstemn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from deadstemn_xfer - real(r8), pointer :: m_frootn_to_fire(:) ! (gN/m2/s) fire N emissions from frootn - real(r8), pointer :: m_frootn_storage_to_fire(:) ! (gN/m2/s) fire N emissions from frootn_storage - real(r8), pointer :: m_frootn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from frootn_xfer - real(r8), pointer :: m_livecrootn_to_fire(:) ! (gN/m2/s) fire N emissions from m_livecrootn_to_fire - real(r8), pointer :: m_livecrootn_storage_to_fire(:)! (gN/m2/s) fire N emissions from livecrootn_storage - real(r8), pointer :: m_livecrootn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from livecrootn_xfer - real(r8), pointer :: m_deadcrootn_to_fire(:) ! (gN/m2/s) fire N emissions from deadcrootn - real(r8), pointer :: m_deadcrootn_storage_to_fire(:)! (gN/m2/s) fire N emissions from deadcrootn_storage - real(r8), pointer :: m_deadcrootn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from deadcrootn_xfer - real(r8), pointer :: m_retransn_to_fire(:) ! (gN/m2/s) fire N emissions from retransn - real(r8), pointer :: m_decomp_npools_to_fire_vr(:,:,:) ! vertically-resolved decomposing N fire loss (gN/m3/s) - -! (gC/m2/s) C transfers from various C pools to litter and cwd pools due to fire mortality - real(r8), pointer :: m_leafc_to_litter_fire(:) - real(r8), pointer :: m_leafc_storage_to_litter_fire(:) - real(r8), pointer :: m_leafc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemc_to_litter_fire(:) - real(r8), pointer :: m_livestemc_storage_to_litter_fire(:) - real(r8), pointer :: m_livestemc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemc_to_deadstemc_fire(:) - real(r8), pointer :: m_deadstemc_to_litter_fire(:) - real(r8), pointer :: m_deadstemc_storage_to_litter_fire(:) - real(r8), pointer :: m_deadstemc_xfer_to_litter_fire(:) - real(r8), pointer :: m_frootc_to_litter_fire(:) - real(r8), pointer :: m_frootc_storage_to_litter_fire(:) - real(r8), pointer :: m_frootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_storage_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_to_deadcrootc_fire(:) - real(r8), pointer :: m_deadcrootc_to_litter_fire(:) - real(r8), pointer :: m_deadcrootc_storage_to_litter_fire(:) - real(r8), pointer :: m_deadcrootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_gresp_storage_to_litter_fire(:) - real(r8), pointer :: m_gresp_xfer_to_litter_fire(:) - real(r8), pointer :: m_c_to_litr_met_fire(:,:) - real(r8), pointer :: m_c_to_litr_cel_fire(:,:) - real(r8), pointer :: m_c_to_litr_lig_fire(:,:) - -! (gN/m2/s) N transfers from various C pools to litter and cwd pools due to fire mortality - real(r8), pointer :: m_leafn_to_litter_fire(:) - real(r8), pointer :: m_leafn_storage_to_litter_fire(:) - real(r8), pointer :: m_leafn_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemn_to_litter_fire(:) - real(r8), pointer :: m_livestemn_storage_to_litter_fire(:) - real(r8), pointer :: m_livestemn_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemn_to_deadstemn_fire(:) - real(r8), pointer :: m_deadstemn_to_litter_fire(:) - real(r8), pointer :: m_deadstemn_storage_to_litter_fire(:) - real(r8), pointer :: m_deadstemn_xfer_to_litter_fire(:) - real(r8), pointer :: m_frootn_to_litter_fire(:) - real(r8), pointer :: m_frootn_storage_to_litter_fire(:) - real(r8), pointer :: m_frootn_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootn_to_litter_fire(:) - real(r8), pointer :: m_livecrootn_storage_to_litter_fire(:) - real(r8), pointer :: m_livecrootn_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootn_to_deadcrootn_fire(:) - real(r8), pointer :: m_deadcrootn_to_litter_fire(:) - real(r8), pointer :: m_deadcrootn_storage_to_litter_fire(:) - real(r8), pointer :: m_deadcrootn_xfer_to_litter_fire(:) - real(r8), pointer :: m_retransn_to_litter_fire(:) - real(r8), pointer :: m_n_to_litr_met_fire(:,:) - real(r8), pointer :: m_n_to_litr_cel_fire(:,:) - real(r8), pointer :: m_n_to_litr_lig_fire(:,:) - - logical, pointer :: is_cwd(:) ! TRUE => pool is a cwd pool - logical, pointer :: is_litter(:) ! TRUE => pool is a litter pool - real(r8), pointer :: froot_prof(:,:) ! (1/m) profile of fine roots - real(r8), pointer :: croot_prof(:,:) ! (1/m) profile of coarse roots - real(r8), pointer :: stem_prof(:,:) ! (1/m) profile of stems - real(r8), pointer :: leaf_prof(:,:) ! (1/m) profile of leaves - - real(r8), pointer :: cc_dstem(:) ! Combustion completeness factor for dead stem (0 to 1) - real(r8), pointer :: cc_leaf(:) ! Combustion completeness factor for leaf (0 to 1) - real(r8), pointer :: cc_lstem(:) ! Combustion completeness factor for live stem (0 to 1) - real(r8), pointer :: cc_other(:) ! Combustion completeness factor for other plant (0 to 1) - real(r8), pointer :: fm_leaf(:) ! Fire-related mortality factor for leaf (0 to 1) - real(r8), pointer :: fm_lstem(:) ! Fire-related mortality factor for live stem (0 to 1) - real(r8), pointer :: fm_other(:) ! Fire-related mortality factor for other plant (0 to 1) - real(r8), pointer :: fm_root(:) ! Fire-related mortality factor for fine roots (0 to 1) - real(r8), pointer :: fm_lroot(:) ! Fire-related mortality factor for live roots (0 to 1) - real(r8), pointer :: fm_droot(:) ! Fire-related mortality factor for dead roots (0 to 1) - real(r8), pointer :: lf_flab(:) ! leaf litter labile fraction - real(r8), pointer :: lf_fcel(:) ! leaf litter cellulose fraction - real(r8), pointer :: lf_flig(:) ! leaf litter lignin fraction - real(r8), pointer :: fr_flab(:) ! fine root litter labile fraction - real(r8), pointer :: fr_fcel(:) ! fine root litter cellulose fraction - real(r8), pointer :: fr_flig(:) ! fine root litter lignin fraction -! -! !OTHER 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):: dt ! time step variable (s) - real(r8):: dayspyr ! days per year -!EOP -!----------------------------------------------------------------------- - - ! assign local pointers - -#if (defined CNDV) - nind => pdgvs%nind -#endif - pcolumn =>pft%column - cgridcell =>col%gridcell - farea_burned => cps%farea_burned - woody => pftcon%woody - fire_mortality_c_to_cwdc => ccf%fire_mortality_c_to_cwdc - fire_mortality_n_to_cwdn => cnf%fire_mortality_n_to_cwdn - - lfc => cps%lfc - lfc2 => cps%lfc2 - fbac1 => cps%fbac1 - fbac => cps%fbac - baf_crop => cps%baf_crop - baf_peatf => cps%baf_peatf - leafcmax => pcs%leafcmax - latdeg => grc%latdeg - wtcol =>pft%wtcol - pfti =>col%pfti - cropf_col => cps%cropf_col - - ivt =>pft%itype - npfts =>col%npfts - - trotr1_col => cps%trotr1_col - trotr2_col => cps%trotr2_col - dtrotr_col => cps%dtrotr_col - - - somc_fire => ccf%somc_fire - totsomc => ccs%totsomc - decomp_cpools_vr => ccs%decomp_cpools_vr - decomp_npools_vr => cns%decomp_npools_vr - - leafc => pcs%leafc - leafc_storage => pcs%leafc_storage - leafc_xfer => pcs%leafc_xfer - livestemc => pcs%livestemc - livestemc_storage => pcs%livestemc_storage - livestemc_xfer => pcs%livestemc_xfer - deadstemc => pcs%deadstemc - deadstemc_storage => pcs%deadstemc_storage - deadstemc_xfer => pcs%deadstemc_xfer - frootc => pcs%frootc - frootc_storage => pcs%frootc_storage - frootc_xfer => pcs%frootc_xfer - livecrootc => pcs%livecrootc - livecrootc_storage => pcs%livecrootc_storage - livecrootc_xfer => pcs%livecrootc_xfer - deadcrootc => pcs%deadcrootc - deadcrootc_storage => pcs%deadcrootc_storage - deadcrootc_xfer => pcs%deadcrootc_xfer - gresp_storage => pcs%gresp_storage - gresp_xfer => pcs%gresp_xfer - - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - retransn => pns%retransn - pactive => pft%active - - m_leafc_to_fire => pcf%m_leafc_to_fire - m_leafc_storage_to_fire => pcf%m_leafc_storage_to_fire - m_leafc_xfer_to_fire => pcf%m_leafc_xfer_to_fire - m_livestemc_to_fire => pcf%m_livestemc_to_fire - m_livestemc_storage_to_fire => pcf%m_livestemc_storage_to_fire - m_livestemc_xfer_to_fire => pcf%m_livestemc_xfer_to_fire - m_deadstemc_to_fire => pcf%m_deadstemc_to_fire - m_deadstemc_storage_to_fire => pcf%m_deadstemc_storage_to_fire - m_deadstemc_xfer_to_fire => pcf%m_deadstemc_xfer_to_fire - m_frootc_to_fire => pcf%m_frootc_to_fire - m_frootc_storage_to_fire => pcf%m_frootc_storage_to_fire - m_frootc_xfer_to_fire => pcf%m_frootc_xfer_to_fire - m_livecrootc_to_fire => pcf%m_livecrootc_to_fire - m_livecrootc_storage_to_fire => pcf%m_livecrootc_storage_to_fire - m_livecrootc_xfer_to_fire => pcf%m_livecrootc_xfer_to_fire - m_deadcrootc_to_fire => pcf%m_deadcrootc_to_fire - m_deadcrootc_storage_to_fire => pcf%m_deadcrootc_storage_to_fire - m_deadcrootc_xfer_to_fire => pcf%m_deadcrootc_xfer_to_fire - m_gresp_storage_to_fire => pcf%m_gresp_storage_to_fire - m_gresp_xfer_to_fire => pcf%m_gresp_xfer_to_fire - - m_leafn_to_fire => pnf%m_leafn_to_fire - m_leafn_storage_to_fire => pnf%m_leafn_storage_to_fire - m_leafn_xfer_to_fire => pnf%m_leafn_xfer_to_fire - m_livestemn_to_fire => pnf%m_livestemn_to_fire - m_livestemn_storage_to_fire => pnf%m_livestemn_storage_to_fire - m_livestemn_xfer_to_fire => pnf%m_livestemn_xfer_to_fire - m_deadstemn_to_fire => pnf%m_deadstemn_to_fire - m_deadstemn_storage_to_fire => pnf%m_deadstemn_storage_to_fire - m_deadstemn_xfer_to_fire => pnf%m_deadstemn_xfer_to_fire - m_frootn_to_fire => pnf%m_frootn_to_fire - m_frootn_storage_to_fire => pnf%m_frootn_storage_to_fire - m_frootn_xfer_to_fire => pnf%m_frootn_xfer_to_fire - m_livecrootn_to_fire => pnf%m_livecrootn_to_fire - m_livecrootn_storage_to_fire => pnf%m_livecrootn_storage_to_fire - m_livecrootn_xfer_to_fire => pnf%m_livecrootn_xfer_to_fire - m_deadcrootn_to_fire => pnf%m_deadcrootn_to_fire - m_deadcrootn_storage_to_fire => pnf%m_deadcrootn_storage_to_fire - m_deadcrootn_xfer_to_fire => pnf%m_deadcrootn_xfer_to_fire - m_retransn_to_fire => pnf%m_retransn_to_fire - - m_leafc_to_litter_fire => pcf%m_leafc_to_litter_fire - m_leafc_storage_to_litter_fire => pcf%m_leafc_storage_to_litter_fire - m_leafc_xfer_to_litter_fire => pcf%m_leafc_xfer_to_litter_fire - m_livestemc_to_litter_fire => pcf%m_livestemc_to_litter_fire - m_livestemc_storage_to_litter_fire => pcf%m_livestemc_storage_to_litter_fire - m_livestemc_xfer_to_litter_fire => pcf%m_livestemc_xfer_to_litter_fire - m_livestemc_to_deadstemc_fire => pcf%m_livestemc_to_deadstemc_fire - m_deadstemc_to_litter_fire => pcf%m_deadstemc_to_litter_fire - m_deadstemc_storage_to_litter_fire => pcf%m_deadstemc_storage_to_litter_fire - m_deadstemc_xfer_to_litter_fire => pcf%m_deadstemc_xfer_to_litter_fire - m_frootc_to_litter_fire => pcf%m_frootc_to_litter_fire - m_frootc_storage_to_litter_fire => pcf%m_frootc_storage_to_litter_fire - m_frootc_xfer_to_litter_fire => pcf%m_frootc_xfer_to_litter_fire - m_livecrootc_to_litter_fire => pcf%m_livecrootc_to_litter_fire - m_livecrootc_storage_to_litter_fire => pcf%m_livecrootc_storage_to_litter_fire - m_livecrootc_xfer_to_litter_fire => pcf%m_livecrootc_xfer_to_litter_fire - m_livecrootc_to_deadcrootc_fire => pcf%m_livecrootc_to_deadcrootc_fire - m_deadcrootc_to_litter_fire => pcf%m_deadcrootc_to_litter_fire - m_deadcrootc_storage_to_litter_fire => pcf%m_deadcrootc_storage_to_litter_fire - m_deadcrootc_xfer_to_litter_fire => pcf%m_deadcrootc_xfer_to_litter_fire - m_gresp_storage_to_litter_fire => pcf%m_gresp_storage_to_litter_fire - m_gresp_xfer_to_litter_fire => pcf%m_gresp_xfer_to_litter_fire - m_decomp_cpools_to_fire_vr => ccf%m_decomp_cpools_to_fire_vr - m_c_to_litr_met_fire => ccf%m_c_to_litr_met_fire - m_c_to_litr_cel_fire => ccf%m_c_to_litr_cel_fire - m_c_to_litr_lig_fire => ccf%m_c_to_litr_lig_fire - - m_leafn_to_litter_fire => pnf%m_leafn_to_litter_fire - m_leafn_storage_to_litter_fire => pnf%m_leafn_storage_to_litter_fire - m_leafn_xfer_to_litter_fire => pnf%m_leafn_xfer_to_litter_fire - m_livestemn_to_litter_fire => pnf%m_livestemn_to_litter_fire - m_livestemn_storage_to_litter_fire => pnf%m_livestemn_storage_to_litter_fire - m_livestemn_xfer_to_litter_fire => pnf%m_livestemn_xfer_to_litter_fire - m_livestemn_to_deadstemn_fire => pnf%m_livestemn_to_deadstemn_fire - m_deadstemn_to_litter_fire => pnf%m_deadstemn_to_litter_fire - m_deadstemn_storage_to_litter_fire => pnf%m_deadstemn_storage_to_litter_fire - m_deadstemn_xfer_to_litter_fire =>pnf%m_deadstemn_xfer_to_litter_fire - m_frootn_to_litter_fire => pnf%m_frootn_to_litter_fire - m_frootn_storage_to_litter_fire => pnf%m_frootn_storage_to_litter_fire - m_frootn_xfer_to_litter_fire => pnf%m_frootn_xfer_to_litter_fire - m_livecrootn_to_litter_fire => pnf%m_livecrootn_to_litter_fire - m_livecrootn_storage_to_litter_fire => pnf%m_livecrootn_storage_to_litter_fire - m_livecrootn_xfer_to_litter_fire => pnf%m_livecrootn_xfer_to_litter_fire - m_livecrootn_to_deadcrootn_fire => pnf%m_livecrootn_to_deadcrootn_fire - m_deadcrootn_to_litter_fire => pnf%m_deadcrootn_to_litter_fire - m_deadcrootn_storage_to_litter_fire => pnf%m_deadcrootn_storage_to_litter_fire - m_deadcrootn_xfer_to_litter_fire => pnf%m_deadcrootn_xfer_to_litter_fire - m_retransn_to_litter_fire => pnf%m_retransn_to_litter_fire - m_decomp_npools_to_fire_vr => cnf%m_decomp_npools_to_fire_vr - m_n_to_litr_met_fire => cnf%m_n_to_litr_met_fire - m_n_to_litr_cel_fire => cnf%m_n_to_litr_cel_fire - m_n_to_litr_lig_fire => cnf%m_n_to_litr_lig_fire - - is_cwd => decomp_cascade_con%is_cwd - is_litter => decomp_cascade_con%is_litter - croot_prof => pps%croot_prof - stem_prof => pps%stem_prof - froot_prof => pps%froot_prof - leaf_prof => pps%leaf_prof - - cc_dstem => pftcon%cc_dstem - cc_leaf => pftcon%cc_leaf - cc_lstem => pftcon%cc_lstem - cc_other => pftcon%cc_other - fm_leaf => pftcon%fm_leaf - fm_lstem => pftcon%fm_lstem - fm_other => pftcon%fm_other - fm_root => pftcon%fm_root - fm_lroot => pftcon%fm_lroot - fm_droot => pftcon%fm_droot - lf_flab => pftcon%lf_flab - lf_fcel => pftcon%lf_fcel - lf_flig => pftcon%lf_flig - fr_flab => pftcon%fr_flab - fr_fcel => pftcon%fr_fcel - fr_flig => pftcon%fr_flig - - ! Get model step size - ! calculate burned area fraction per sec - dt = real( get_step_size(), r8 ) - - dayspyr = get_days_per_year() - ! - ! pft loop - ! - do fp = 1,num_soilp - p = filter_soilp(fp) - c = pcolumn(p) - - ! For non-crop (bare-soil and natural vegetation) - ! modified according to clm4_6_00, fzeng, 7 May 2019 - if( ivt(p) .lt. nc3crop .and. cropf_col(c) < 1.0_r8)then - if (fpftdyn /= ' ') then !true when landuse data is used - 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 pft state variables to get flux rates - ! biomass burning - ! carbon fluxes - m_leafc_to_fire(p) = leafc(p) * f * cc_leaf(ivt(p)) - m_leafc_storage_to_fire(p) = leafc_storage(p) * f * cc_other(ivt(p)) - m_leafc_xfer_to_fire(p) = leafc_xfer(p) * f * cc_other(ivt(p)) - m_livestemc_to_fire(p) = livestemc(p) * f * cc_lstem(ivt(p)) - m_livestemc_storage_to_fire(p) = livestemc_storage(p) * f * cc_other(ivt(p)) - m_livestemc_xfer_to_fire(p) = livestemc_xfer(p) * f * cc_other(ivt(p)) - m_deadstemc_to_fire(p) = deadstemc(p) * f * cc_dstem(ivt(p)) - m_deadstemc_storage_to_fire(p) = deadstemc_storage(p) * f * cc_other(ivt(p)) - m_deadstemc_xfer_to_fire(p) = deadstemc_xfer(p) * f * cc_other(ivt(p)) - m_frootc_to_fire(p) = frootc(p) * f * 0._r8 - m_frootc_storage_to_fire(p) = frootc_storage(p) * f * cc_other(ivt(p)) - m_frootc_xfer_to_fire(p) = frootc_xfer(p) * f * cc_other(ivt(p)) - m_livecrootc_to_fire(p) = livecrootc(p) * f * 0._r8 - m_livecrootc_storage_to_fire(p) = livecrootc_storage(p) * f * cc_other(ivt(p)) - m_livecrootc_xfer_to_fire(p) = livecrootc_xfer(p) * f * cc_other(ivt(p)) - m_deadcrootc_to_fire(p) = deadcrootc(p) * f * 0._r8 - m_deadcrootc_storage_to_fire(p) = deadcrootc_storage(p) * f* cc_other(ivt(p)) - m_deadcrootc_xfer_to_fire(p) = deadcrootc_xfer(p) * f * cc_other(ivt(p)) - m_gresp_storage_to_fire(p) = gresp_storage(p) * f * cc_other(ivt(p)) - m_gresp_xfer_to_fire(p) = gresp_xfer(p) * f * cc_other(ivt(p)) - - - ! nitrogen fluxes - m_leafn_to_fire(p) = leafn(p) * f * cc_leaf(ivt(p)) - m_leafn_storage_to_fire(p) = leafn_storage(p) * f * cc_other(ivt(p)) - m_leafn_xfer_to_fire(p) = leafn_xfer(p) * f * cc_other(ivt(p)) - m_livestemn_to_fire(p) = livestemn(p) * f * cc_lstem(ivt(p)) - m_livestemn_storage_to_fire(p) = livestemn_storage(p) * f * cc_other(ivt(p)) - m_livestemn_xfer_to_fire(p) = livestemn_xfer(p) * f * cc_other(ivt(p)) - m_deadstemn_to_fire(p) = deadstemn(p) * f * cc_dstem(ivt(p)) - m_deadstemn_storage_to_fire(p) = deadstemn_storage(p) * f * cc_other(ivt(p)) - m_deadstemn_xfer_to_fire(p) = deadstemn_xfer(p) * f * cc_other(ivt(p)) - m_frootn_to_fire(p) = frootn(p) * f * 0._r8 - m_frootn_storage_to_fire(p) = frootn_storage(p) * f * cc_other(ivt(p)) - m_frootn_xfer_to_fire(p) = frootn_xfer(p) * f * cc_other(ivt(p)) - m_livecrootn_to_fire(p) = livecrootn(p) * f * 0._r8 - m_livecrootn_storage_to_fire(p) = livecrootn_storage(p) * f * cc_other(ivt(p)) - m_livecrootn_xfer_to_fire(p) = livecrootn_xfer(p) * f * cc_other(ivt(p)) - m_deadcrootn_to_fire(p) = deadcrootn(p) * f * 0._r8 - m_deadcrootn_xfer_to_fire(p) = deadcrootn_xfer(p) * f * cc_other(ivt(p)) - m_deadcrootn_storage_to_fire(p) = deadcrootn_storage(p) * f * cc_other(ivt(p)) - m_retransn_to_fire(p) = retransn(p) * f * cc_other(ivt(p)) - - ! mortality due to fire - ! carbon bool - m_leafc_to_litter_fire(p) = leafc(p) * f * & - (1._r8 - cc_leaf(ivt(p))) * & - fm_leaf(ivt(p)) - m_leafc_storage_to_litter_fire(p) = leafc_storage(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_leafc_xfer_to_litter_fire(p) = leafc_xfer(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_livestemc_to_litter_fire(p) = livestemc(p) * f * & - (1._r8 - cc_lstem(ivt(p))) * & - fm_droot(ivt(p)) - m_livestemc_storage_to_litter_fire(p) = livestemc_storage(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_livestemc_xfer_to_litter_fire(p) = livestemc_xfer(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_livestemc_to_deadstemc_fire(p) = livestemc(p) * f * & - (1._r8 - cc_lstem(ivt(p))) * & - (fm_lstem(ivt(p))-fm_droot(ivt(p))) - m_deadstemc_to_litter_fire(p) = deadstemc(p) * f * & - (1._r8 - cc_dstem(ivt(p))) * & - fm_droot(ivt(p)) - m_deadstemc_storage_to_litter_fire(p) = deadstemc_storage(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_deadstemc_xfer_to_litter_fire(p) = deadstemc_xfer(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_frootc_to_litter_fire(p) = frootc(p) * f * & - fm_root(ivt(p)) - m_frootc_storage_to_litter_fire(p) = frootc_storage(p) * f * & - fm_other(ivt(p)) - m_frootc_xfer_to_litter_fire(p) = frootc_xfer(p) * f * & - fm_other(ivt(p)) - m_livecrootc_to_litter_fire(p) = livecrootc(p) * f * & - fm_droot(ivt(p)) - m_livecrootc_storage_to_litter_fire(p) = livecrootc_storage(p) * f * & - fm_other(ivt(p)) - m_livecrootc_xfer_to_litter_fire(p) = livecrootc_xfer(p) * f * & - fm_other(ivt(p)) - m_livecrootc_to_deadcrootc_fire(p) = livecrootc(p) * f * & - (fm_lroot(ivt(p))-fm_droot(ivt(p))) - m_deadcrootc_to_litter_fire(p) = deadcrootc(p) * f * & - fm_droot(ivt(p)) - m_deadcrootc_storage_to_litter_fire(p) = deadcrootc_storage(p) * f * & - fm_other(ivt(p)) - m_deadcrootc_xfer_to_litter_fire(p) = deadcrootc_xfer(p) * f * & - fm_other(ivt(p)) - m_gresp_storage_to_litter_fire(p) = gresp_storage(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_gresp_xfer_to_litter_fire(p) = gresp_xfer(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - - - - ! nitrogen pools - m_leafn_to_litter_fire(p) = leafn(p) * f * & - (1._r8 - cc_leaf(ivt(p))) * & - fm_leaf(ivt(p)) - m_leafn_storage_to_litter_fire(p) = leafn_storage(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_leafn_xfer_to_litter_fire(p) = leafn_xfer(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_livestemn_to_litter_fire(p) = livestemn(p) * f * & - (1._r8 - cc_lstem(ivt(p))) * & - fm_droot(ivt(p)) - m_livestemn_storage_to_litter_fire(p) = livestemn_storage(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_livestemn_xfer_to_litter_fire(p) = livestemn_xfer(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - m_livestemn_to_deadstemn_fire(p) = livestemn(p) * f * & - (1._r8 - cc_lstem(ivt(p))) * & - (fm_lstem(ivt(p))-fm_droot(ivt(p))) - m_frootn_to_litter_fire(p) = frootn(p) * f * & - fm_root(ivt(p)) - m_frootn_storage_to_litter_fire(p) = frootn_storage(p) * f * & - fm_other(ivt(p)) - m_frootn_xfer_to_litter_fire(p) = frootn_xfer(p) * f * & - fm_other(ivt(p)) - m_livecrootn_to_litter_fire(p) = livecrootn(p) * f * & - fm_droot(ivt(p)) - m_livecrootn_storage_to_litter_fire(p) = livecrootn_storage(p) * f * & - fm_other(ivt(p)) - m_livecrootn_xfer_to_litter_fire(p) = livecrootn_xfer(p) * f * & - fm_other(ivt(p)) - m_livecrootn_to_deadcrootn_fire(p) = livecrootn(p) * f * & - (fm_lroot(ivt(p))-fm_droot(ivt(p))) - m_deadcrootn_to_litter_fire(p) = deadcrootn(p) * f * & - fm_droot(ivt(p)) - m_deadcrootn_storage_to_litter_fire(p) = deadcrootn_storage(p) * f * & - fm_other(ivt(p)) - m_deadcrootn_xfer_to_litter_fire(p) = deadcrootn_xfer(p) * f * & - fm_other(ivt(p)) - m_retransn_to_litter_fire(p) = retransn(p) * f * & - (1._r8 - cc_other(ivt(p))) * & - fm_other(ivt(p)) - -#if (defined CNDV) - if ( woody(ivt(p)) == 1._r8 )then - if ( livestemc(p)+deadstemc(p) > 0._r8 )then - nind(p) = nind(p)*(1._r8-1._r8*fm_droot(ivt(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 (ivt(p) == noveg) leafcmax(p) = 0._r8 -#endif - - end do ! end of pfts loop - ! - ! fire-affected carbon to litter and cwd - ! - do j = 1,nlevdecomp - do pi = 1,max_pft_per_col - do fc = 1,num_soilc - c = filter_soilc(fc) - if (pi <= npfts(c)) then - p = pfti(c) + pi - 1 - if ( pactive(p) ) then - - fire_mortality_c_to_cwdc(c,j) = fire_mortality_c_to_cwdc(c,j) + & - m_deadstemc_to_litter_fire(p) * 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) * 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) * 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) * 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) * 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) * 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) * 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) * 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(ivt(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(ivt(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))* 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(ivt(p))*leaf_prof(p,j) + & - m_frootc_to_litter_fire(p)*fr_fcel(ivt(p))*froot_prof(p,j))* 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(ivt(p))*leaf_prof(p,j) + & - m_frootc_to_litter_fire(p)*fr_flig(ivt(p))*froot_prof(p,j))* 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(ivt(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(ivt(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))* 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(ivt(p))*leaf_prof(p,j) + & - m_frootn_to_litter_fire(p)*fr_fcel(ivt(p))*froot_prof(p,j))* 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(ivt(p))*leaf_prof(p,j) + & - m_frootn_to_litter_fire(p)*fr_flig(ivt(p))*froot_prof(p,j))* wtcol(p) - end if - end if - end do - end do - end do - ! - ! vertically-resolved decomposing C/N fire loss - ! column loop, modified according to clm4_6_00, fzeng, 7 May 2019 - ! - do fc = 1,num_soilc - c = filter_soilc(fc) - - f = farea_burned(c) - - ! apply this rate to the column state variables to get flux rates - ! 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), fzeng, 7 May 2019 - - 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 - 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 - 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 - ! modified according to clm4_6_00, fzeng, 7 May 2019 - ! - if (fpftdyn /= ' ') then !true when landuse data is used - 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 clm4 soil carbon was very low in peatland areas - ! Fang Li has not checked clm45 soil carbon in peatland areas - ! - ! modified according to clm4_6_00, fzeng, 7 May 2019 - - do fc = 1,num_soilc - c = filter_soilc(fc) - g = cgridcell(c) - if( grc%latdeg(g) .lt. 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 subroutine CNFireFluxes - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: hdm_init -! -! !INTERFACE: -!subroutine hdm_init( begg, endg ) -! -! !DESCRIPTION: -! -! Initialize data stream information for population density. - -! Not used in Catchment-CN. fzeng -! -! !USES: -! use clm_varctl , only : inst_name -! use clm_time_manager , only : get_calendar -! use ncdio_pio , only : pio_subsystem -! use shr_pio_mod , only : shr_pio_getiotype -! use clm_nlUtilsMod , only : find_nlgroup_name -! use ndepStreamMod , only : clm_domain_mct -! use histFileMod , only : hist_addfld1d -! -! !ARGUMENTS: -! implicit none -! integer, intent(IN) :: begg, endg ! gridcell index bounds -! -! !LOCAL VARIABLES: -! integer :: stream_year_first_popdens ! first year in pop. dens. stream to use -! integer :: stream_year_last_popdens ! last year in pop. dens. stream to use -! integer :: model_year_align_popdens ! align stream_year_first_hdm with -! integer :: nu_nml ! unit for namelist file -! integer :: nml_error ! namelist i/o error flag -! type(mct_ggrid) :: dom_clm ! domain information -! character(len=CL) :: stream_fldFileName_popdens ! population density streams filename -! character(len=CL) :: popdensmapalgo = 'bilinear' ! mapping alogrithm for population density -! character(*), parameter :: subName = "('hdmdyn_init')" -! character(*), parameter :: F00 = "('(hdmdyn_init) ',4a)" -!----------------------------------------------------------------------- -! namelist /popd_streams/ & -! stream_year_first_popdens, & -! stream_year_last_popdens, & -! model_year_align_popdens, & -! popdensmapalgo, & -! stream_fldFileName_popdens -!EOP -!----------------------------------------------------------------------- - -! ! Allocate pop dens forcing data -! allocate( forc_hdm(begg:endg) ) - -! ! Default values for namelist -! stream_year_first_popdens = 1 ! first year in stream to use -! stream_year_last_popdens = 1 ! last year in stream to use -! model_year_align_popdens = 1 ! align stream_year_first_popdens with this model year -! stream_fldFileName_popdens = ' ' - -! ! Read popd_streams namelist -! if (masterproc) then -! nu_nml = getavu() -! open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) -! call find_nlgroup_name(nu_nml, 'popd_streams', status=nml_error) -! if (nml_error == 0) then -! read(nu_nml, nml=popd_streams,iostat=nml_error) -! if (nml_error /= 0) then -! call endrun(subname // ':: ERROR reading popd_streams namelist') -! stop 'ERROR reading popd_streams namelist' -! end if -! end if -! close(nu_nml) -! call relavu( nu_nml ) -! endif - -! call shr_mpi_bcast(stream_year_first_popdens, mpicom) -! call shr_mpi_bcast(stream_year_last_popdens, mpicom) -! call shr_mpi_bcast(model_year_align_popdens, mpicom) -! call shr_mpi_bcast(stream_fldFileName_popdens, mpicom) - -! if (masterproc) then -! write(iulog,*) ' ' -! write(iulog,*) 'popdens_streams settings:' -! write(iulog,*) ' stream_year_first_popdens = ',stream_year_first_popdens -! write(iulog,*) ' stream_year_last_popdens = ',stream_year_last_popdens -! write(iulog,*) ' model_year_align_popdens = ',model_year_align_popdens -! write(iulog,*) ' stream_fldFileName_popdens = ',stream_fldFileName_popdens -! write(iulog,*) ' ' -! endif - -! call clm_domain_mct (dom_clm) - -! call shr_strdata_create(sdat_hdm,name="clmhdm", & -! pio_subsystem=pio_subsystem, & -! pio_iotype=shr_pio_getiotype(inst_name), & -! mpicom=mpicom, compid=comp_id, & -! gsmap=gsmap_lnd_gdc2glo, ggrid=dom_clm, & -! nxg=ldomain%ni, nyg=ldomain%nj, & -! yearFirst=stream_year_first_popdens, & -! yearLast=stream_year_last_popdens, & -! yearAlign=model_year_align_popdens, & -! offset=0, & -! domFilePath='', & -! domFileName=trim(stream_fldFileName_popdens), & -! domTvarName='time', & -! domXvarName='lon' , & -! domYvarName='lat' , & -! domAreaName='area', & -! domMaskName='mask', & -! filePath='', & -! filename=(/trim(stream_fldFileName_popdens)/), & -! fldListFile='hdm', & -! fldListModel='hdm', & -! fillalgo='none', & -! mapalgo=popdensmapalgo, & -! calendar=get_calendar(), & -! tintalgo='nearest', & -! taxmode='extend' ) - -! if (masterproc) then -! call shr_strdata_print(sdat_hdm,'population density data') -! endif - -! ! Add history fields -! call hist_addfld1d (fname='HDM', units='counts/km^2', & -! avgflag='A', long_name='human population density', & -! ptr_lnd=forc_hdm, default='inactive') - -!end subroutine hdm_init - -!================================================================ - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: hdm_interp -! -! !INTERFACE: -!subroutine hdm_interp( ) -! -! !DESCRIPTION: -! -! Interpolate data stream information for population density. - -! Not used in Catchment-CN. fzeng -! -! !USES: -! use decompMod , only : get_proc_bounds -! use clm_time_manager, only : get_curr_date -! -! !ARGUMENTS: -! implicit none -! -! !LOCAL VARIABLES: -! integer :: g, ig, begg, endg -! 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 :: mcdate ! Current model date (yyyymmdd) -!EOP -!----------------------------------------------------------------------- - -! call get_curr_date(year, mon, day, sec) -! mcdate = year*10000 + mon*100 + day - -! call shr_strdata_advance(sdat_hdm, mcdate, sec, mpicom, 'hdmdyn') - -! call get_proc_bounds(begg, endg) -! ig = 0 -! do g = begg,endg -! ig = ig+1 -! forc_hdm(g) = sdat_hdm%avs(1)%rAttr(1,ig) -! end do -! -!end subroutine hdm_interp - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: lnfm_init -! -! !INTERFACE: -!subroutine lnfm_init( begg, endg ) -! -! !DESCRIPTION: -! -! Initialize data stream information for Lightning. - -! Not used in Catchment-CN. fzeng -! -! !USES: -! use clm_varctl , only : inst_name -! use clm_time_manager , only : get_calendar -! use ncdio_pio , only : pio_subsystem -! use shr_pio_mod , only : shr_pio_getiotype -! use clm_nlUtilsMod , only : find_nlgroup_name -! use ndepStreamMod , only : clm_domain_mct -! use histFileMod , only : hist_addfld1d -! -! !ARGUMENTS: -! implicit none -! integer, intent(IN) :: begg, endg ! gridcell index bounds -! -! !LOCAL VARIABLES: -! integer :: stream_year_first_lightng ! first year in Lightning stream to use -! integer :: stream_year_last_lightng ! last year in Lightning stream to use -! integer :: model_year_align_lightng ! align stream_year_first_lnfm with -! integer :: nu_nml ! unit for namelist file -! integer :: nml_error ! namelist i/o error flag -! type(mct_ggrid) :: dom_clm ! domain information -! character(len=CL) :: stream_fldFileName_lightng ! lightning stream filename to read -! character(len=CL) :: lightngmapalgo = 'bilinear'! Mapping alogrithm -! character(*), parameter :: subName = "('lnfmdyn_init')" -! character(*), parameter :: F00 = "('(lnfmdyn_init) ',4a)" -!----------------------------------------------------------------------- -! namelist /light_streams/ & -! stream_year_first_lightng, & -! stream_year_last_lightng, & -! model_year_align_lightng, & -! lightngmapalgo, & -! stream_fldFileName_lightng -!EOP -!----------------------------------------------------------------------- -! ! Allocate lightning forcing data -! allocate( forc_lnfm(begg:endg) ) - -! ! Default values for namelist -! stream_year_first_lightng = 1 ! first year in stream to use -! stream_year_last_lightng = 1 ! last year in stream to use -! model_year_align_lightng = 1 ! align stream_year_first_lnfm with this model year -! stream_fldFileName_lightng = ' ' - -! ! Read light_streams namelist -! if (masterproc) then -! nu_nml = getavu() -! open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) -! call find_nlgroup_name(nu_nml, 'light_streams', status=nml_error) -! if (nml_error == 0) then -! read(nu_nml, nml=light_streams,iostat=nml_error) -! if (nml_error /= 0) then -! call endrun(subname // ':: ERROR reading light_streams namelist') -! stop 'ERROR reading light_streams namelist' -! end if -! end if -! close(nu_nml) -! call relavu( nu_nml ) -! endif - -! call shr_mpi_bcast(stream_year_first_lightng, mpicom) -! call shr_mpi_bcast(stream_year_last_lightng, mpicom) -! call shr_mpi_bcast(model_year_align_lightng, mpicom) -! call shr_mpi_bcast(stream_fldFileName_lightng, mpicom) - -! if (masterproc) then -! write(iulog,*) ' ' -! write(iulog,*) 'light_stream settings:' -! write(iulog,*) ' stream_year_first_lightng = ',stream_year_first_lightng -! write(iulog,*) ' stream_year_last_lightng = ',stream_year_last_lightng -! write(iulog,*) ' model_year_align_lightng = ',model_year_align_lightng -! write(iulog,*) ' stream_fldFileName_lightng = ',stream_fldFileName_lightng -! write(iulog,*) ' ' -! endif -! write(iulog,*) ' stream_year_last_lightng = ',stream_year_last_lightng -! write(iulog,*) ' stream_year_last_lightng = ',stream_year_last_lightng -! write(iulog,*) ' model_year_align_lightng = ',model_year_align_lightng -! write(iulog,*) ' stream_fldFileName_lightng = ',stream_fldFileName_lightng -! write(iulog,*) ' ' -! endif - -! call clm_domain_mct (dom_clm) - -! call shr_strdata_create(sdat_lnfm,name="clmlnfm", & -! pio_subsystem=pio_subsystem, & -! pio_iotype=shr_pio_getiotype(inst_name), & -! mpicom=mpicom, compid=comp_id, & -! gsmap=gsmap_lnd_gdc2glo, ggrid=dom_clm, & -! nxg=ldomain%ni, nyg=ldomain%nj, & -! yearFirst=stream_year_first_lightng, & -! yearLast=stream_year_last_lightng, & -! yearAlign=model_year_align_lightng, & -! offset=0, & -! domFilePath='', & -! domFileName=trim(stream_fldFileName_lightng), & -! domTvarName='time', & -! domXvarName='lon' , & -! domYvarName='lat' , & -! domAreaName='area', & -! domMaskName='mask', & -! filePath='', & -! filename=(/trim(stream_fldFileName_lightng)/),& -! fldListFile='lnfm', & -! fldListModel='lnfm', & -! fillalgo='none', & -! mapalgo=lightngmapalgo, & -! calendar=get_calendar(), & -! taxmode='cycle' ) - -! if (masterproc) then -! call shr_strdata_print(sdat_lnfm,'Lightning data') -! endif - -! ! Add history fields -! call hist_addfld1d (fname='LNFM', units='counts/km^2/hr', & -! avgflag='A', long_name='Lightning frequency', & -! ptr_lnd=forc_lnfm, default='inactive') - -!end subroutine lnfm_init - -!================================================================ - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: lnfm_interp -! -! !INTERFACE: -!subroutine lnfm_interp( ) -! -! !DESCRIPTION: -! -! Interpolate data stream information for Lightning. - -! Not used in Catchment-CN. fzeng -! -! !USES: -! use decompMod , only : get_proc_bounds -! use clm_time_manager, only : get_curr_date -! -! !ARGUMENTS: -! implicit none -! -! !LOCAL VARIABLES: -! integer :: g, ig, begg, endg -! 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 :: mcdate ! Current model date (yyyymmdd) -!EOP -!----------------------------------------------------------------------- - -! call get_curr_date(year, mon, day, sec) -! mcdate = year*10000 + mon*100 + day - -! call shr_strdata_advance(sdat_lnfm, mcdate, sec, mpicom, 'lnfmdyn') - -! call get_proc_bounds(begg, endg) -! ig = 0 -! do g = begg,endg -! ig = ig+1 -! forc_lnfm(g) = sdat_lnfm%avs(1)%rAttr(1,ig) -! end do -! -!end subroutine lnfm_interp - -!----------------------------------------------------------------------- -!#endif - -end module CNFireMod 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 deleted file mode 100644 index d4fd23386..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNGRespMod.F90 +++ /dev/null @@ -1,228 +0,0 @@ -module CNGRespMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNGRespMod -! -! !DESCRIPTION: -! Module for growth respiration fluxes, -! for coupled carbon-nitrogen code. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: CNGResp -! -! !REVISION HISTORY: -! 9/12/03: Created by Peter Thornton -! 10/27/03, Peter Thornton: migrated to vector data structures -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNGResp -! -! !INTERFACE: -subroutine CNGResp(num_soilp, filter_soilp) -! -! !DESCRIPTION: -! On the radiation time step, update all the prognostic carbon state -! variables -! -! !USES: - use clmtype - use pftvarcon, only : npcropmin -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn, in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 8/1/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: cpool_to_leafc(:) - real(r8), pointer :: cpool_to_leafc_storage(:) - real(r8), pointer :: cpool_to_frootc(:) - real(r8), pointer :: cpool_to_frootc_storage(:) - real(r8), pointer :: cpool_to_livestemc(:) - real(r8), pointer :: cpool_to_livestemc_storage(:) - real(r8), pointer :: cpool_to_deadstemc(:) - real(r8), pointer :: cpool_to_deadstemc_storage(:) - real(r8), pointer :: cpool_to_livecrootc(:) - real(r8), pointer :: cpool_to_livecrootc_storage(:) - real(r8), pointer :: cpool_to_deadcrootc(:) ! allocation to dead coarse root C (gC/m2/s) - real(r8), pointer :: cpool_to_deadcrootc_storage(:) ! allocation to dead coarse root C storage (gC/m2/s) - real(r8), pointer :: cpool_to_grainc(:) ! allocation to grain C (gC/m2/s) - real(r8), pointer :: cpool_to_grainc_storage(:) ! allocation to grain C storage (gC/m2/s) - real(r8), pointer :: grainc_xfer_to_grainc(:) ! grain C growth from storage (gC/m2/s) - real(r8), pointer :: leafc_xfer_to_leafc(:) ! leaf C growth from storage (gC/m2/s) - real(r8), pointer :: frootc_xfer_to_frootc(:) ! fine root C growth from storage (gC/m2/s) - real(r8), pointer :: livestemc_xfer_to_livestemc(:) ! live stem C growth from storage (gC/m2/s) - real(r8), pointer :: deadstemc_xfer_to_deadstemc(:) ! dead stem C growth from storage (gC/m2/s) - real(r8), pointer :: livecrootc_xfer_to_livecrootc(:) ! live coarse root C growth from storage (gC/m2/s) - real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:) ! dead coarse root C growth from storage (gC/m2/s) - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: grperc(:) ! Growth respiration factor (unitless) - real(r8), pointer :: grpnow(:) ! Growth respiration factor (unitless) -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: cpool_grain_gr(:) - real(r8), pointer :: cpool_grain_storage_gr(:) - real(r8), pointer :: transfer_grain_gr(:) - real(r8), pointer :: cpool_leaf_gr(:) - real(r8), pointer :: cpool_leaf_storage_gr(:) - real(r8), pointer :: transfer_leaf_gr(:) - real(r8), pointer :: cpool_froot_gr(:) - real(r8), pointer :: cpool_froot_storage_gr(:) - real(r8), pointer :: transfer_froot_gr(:) - real(r8), pointer :: cpool_livestem_gr(:) - real(r8), pointer :: cpool_livestem_storage_gr(:) - real(r8), pointer :: transfer_livestem_gr(:) - real(r8), pointer :: cpool_deadstem_gr(:) - real(r8), pointer :: cpool_deadstem_storage_gr(:) - real(r8), pointer :: transfer_deadstem_gr(:) - real(r8), pointer :: cpool_livecroot_gr(:) - real(r8), pointer :: cpool_livecroot_storage_gr(:) - real(r8), pointer :: transfer_livecroot_gr(:) - real(r8), pointer :: cpool_deadcroot_gr(:) - real(r8), pointer :: cpool_deadcroot_storage_gr(:) - real(r8), pointer :: transfer_deadcroot_gr(:) -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: p ! indices - integer :: fp ! lake filter pft index - -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - ivt =>pft%itype - cpool_to_leafc => pcf%cpool_to_leafc - cpool_to_leafc_storage => pcf%cpool_to_leafc_storage - cpool_to_frootc => pcf%cpool_to_frootc - cpool_to_frootc_storage => pcf%cpool_to_frootc_storage - cpool_to_livestemc => pcf%cpool_to_livestemc - cpool_to_livestemc_storage => pcf%cpool_to_livestemc_storage - cpool_to_deadstemc => pcf%cpool_to_deadstemc - cpool_to_deadstemc_storage => pcf%cpool_to_deadstemc_storage - cpool_to_livecrootc => pcf%cpool_to_livecrootc - cpool_to_livecrootc_storage => pcf%cpool_to_livecrootc_storage - cpool_to_deadcrootc => pcf%cpool_to_deadcrootc - cpool_to_deadcrootc_storage => pcf%cpool_to_deadcrootc_storage - cpool_to_grainc => pcf%cpool_to_grainc - cpool_to_grainc_storage => pcf%cpool_to_grainc_storage - grainc_xfer_to_grainc => pcf%grainc_xfer_to_grainc - leafc_xfer_to_leafc => pcf%leafc_xfer_to_leafc - frootc_xfer_to_frootc => pcf%frootc_xfer_to_frootc - livestemc_xfer_to_livestemc => pcf%livestemc_xfer_to_livestemc - deadstemc_xfer_to_deadstemc => pcf%deadstemc_xfer_to_deadstemc - livecrootc_xfer_to_livecrootc => pcf%livecrootc_xfer_to_livecrootc - deadcrootc_xfer_to_deadcrootc => pcf%deadcrootc_xfer_to_deadcrootc - woody => pftcon%woody - grperc => pftcon%grperc - grpnow => pftcon%grpnow - - ! Assign local pointers to derived type arrays (out) - cpool_grain_gr => pcf%cpool_grain_gr - cpool_grain_storage_gr => pcf%cpool_grain_storage_gr - transfer_grain_gr => pcf%transfer_grain_gr - cpool_leaf_gr => pcf%cpool_leaf_gr - cpool_leaf_storage_gr => pcf%cpool_leaf_storage_gr - transfer_leaf_gr => pcf%transfer_leaf_gr - cpool_froot_gr => pcf%cpool_froot_gr - cpool_froot_storage_gr => pcf%cpool_froot_storage_gr - transfer_froot_gr => pcf%transfer_froot_gr - cpool_livestem_gr => pcf%cpool_livestem_gr - cpool_livestem_storage_gr => pcf%cpool_livestem_storage_gr - transfer_livestem_gr => pcf%transfer_livestem_gr - cpool_deadstem_gr => pcf%cpool_deadstem_gr - cpool_deadstem_storage_gr => pcf%cpool_deadstem_storage_gr - transfer_deadstem_gr => pcf%transfer_deadstem_gr - cpool_livecroot_gr => pcf%cpool_livecroot_gr - cpool_livecroot_storage_gr => pcf%cpool_livecroot_storage_gr - transfer_livecroot_gr => pcf%transfer_livecroot_gr - cpool_deadcroot_gr => pcf%cpool_deadcroot_gr - cpool_deadcroot_storage_gr => pcf%cpool_deadcroot_storage_gr - transfer_deadcroot_gr => pcf%transfer_deadcroot_gr - - ! Loop through pfts - ! start pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - cpool_livestem_gr(p) = cpool_to_livestemc(p) * grperc(ivt(p)) - cpool_livestem_storage_gr(p) = cpool_to_livestemc_storage(p) * & - grperc(ivt(p)) * grpnow(ivt(p)) - transfer_livestem_gr(p) = livestemc_xfer_to_livestemc(p) * & - grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) - 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)) - cpool_leaf_storage_gr(p) = cpool_to_leafc_storage(p) * grperc(ivt(p)) * & - grpnow(ivt(p)) - transfer_leaf_gr(p) = leafc_xfer_to_leafc(p) * grperc(ivt(p)) * & - (1._r8 - grpnow(ivt(p))) - cpool_froot_gr(p) = cpool_to_frootc(p) * grperc(ivt(p)) - cpool_froot_storage_gr(p) = cpool_to_frootc_storage(p) * grperc(ivt(p)) * & - grpnow(ivt(p)) - transfer_froot_gr(p) = frootc_xfer_to_frootc(p) * grperc(ivt(p)) * & - (1._r8 - grpnow(ivt(p))) - - if (woody(ivt(p)) == 1._r8) then - cpool_livestem_gr(p) = cpool_to_livestemc(p) * grperc(ivt(p)) - cpool_livestem_storage_gr(p) = cpool_to_livestemc_storage(p) * & - grperc(ivt(p)) * grpnow(ivt(p)) - transfer_livestem_gr(p) = livestemc_xfer_to_livestemc(p) * & - grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) - 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)) - cpool_livecroot_storage_gr(p) = cpool_to_livecrootc_storage(p) * & - grperc(ivt(p)) * grpnow(ivt(p)) - transfer_livecroot_gr(p) = livecrootc_xfer_to_livecrootc(p) * & - grperc(ivt(p)) * (1._r8 - grpnow(ivt(p))) - 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 subroutine CNGResp - -!#endif - -end module CNGRespMod 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 deleted file mode 100644 index 5e323c4be..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNGapMortalityMod.F90 +++ /dev/null @@ -1,646 +0,0 @@ - -module CNGapMortalityMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNGapMortalityMod -! -! !DESCRIPTION: -! Module holding routines used in gap mortality for coupled carbon -! nitrogen code. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: CNGapMortality -! -! !REVISION HISTORY: -! 3/29/04: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNGapMortality -! -! !INTERFACE: -subroutine CNGapMortality (num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! Gap-phase mortality routine for coupled carbon-nitrogen code (CN) -! -! !USES: - use clmtype - use clm_time_manager, only: get_days_per_year - use clm_varcon , only: secspday - use pftvarcon , only: npcropmin -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! column filter for soil points - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! pft filter for soil points -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 3/29/04: Created by Peter Thornton -! F. Li and S. Levis (11/06/12) -! !LOCAL VARIABLES: -! -! local pointers to implicit in arrays - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: woody(:) ! binary flag for woody lifeform - ! (1=woody, 0=not woody) - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer -#if (defined CNDV) - real(r8), pointer :: greffic(:) - real(r8), pointer :: heatstress(:) - real(r8), pointer :: nind(:) ! number of individuals (#/m2) added by F. Li and S. Levis -#endif -! -! local pointers to implicit in/out arrays -! -! local pointers to implicit out arrays - real(r8), pointer :: m_leafc_to_litter(:) - real(r8), pointer :: m_frootc_to_litter(:) - real(r8), pointer :: m_livestemc_to_litter(:) - real(r8), pointer :: m_deadstemc_to_litter(:) - real(r8), pointer :: m_livecrootc_to_litter(:) - real(r8), pointer :: m_deadcrootc_to_litter(:) - real(r8), pointer :: m_leafc_storage_to_litter(:) - real(r8), pointer :: m_frootc_storage_to_litter(:) - real(r8), pointer :: m_livestemc_storage_to_litter(:) - real(r8), pointer :: m_deadstemc_storage_to_litter(:) - real(r8), pointer :: m_livecrootc_storage_to_litter(:) - real(r8), pointer :: m_deadcrootc_storage_to_litter(:) - real(r8), pointer :: m_gresp_storage_to_litter(:) - real(r8), pointer :: m_leafc_xfer_to_litter(:) - real(r8), pointer :: m_frootc_xfer_to_litter(:) - real(r8), pointer :: m_livestemc_xfer_to_litter(:) - real(r8), pointer :: m_deadstemc_xfer_to_litter(:) - real(r8), pointer :: m_livecrootc_xfer_to_litter(:) - real(r8), pointer :: m_deadcrootc_xfer_to_litter(:) - real(r8), pointer :: m_gresp_xfer_to_litter(:) - real(r8), pointer :: m_leafn_to_litter(:) - real(r8), pointer :: m_frootn_to_litter(:) - real(r8), pointer :: m_livestemn_to_litter(:) - real(r8), pointer :: m_deadstemn_to_litter(:) - real(r8), pointer :: m_livecrootn_to_litter(:) - real(r8), pointer :: m_deadcrootn_to_litter(:) - real(r8), pointer :: m_retransn_to_litter(:) - real(r8), pointer :: m_leafn_storage_to_litter(:) - real(r8), pointer :: m_frootn_storage_to_litter(:) - real(r8), pointer :: m_livestemn_storage_to_litter(:) - real(r8), pointer :: m_deadstemn_storage_to_litter(:) - real(r8), pointer :: m_livecrootn_storage_to_litter(:) - real(r8), pointer :: m_deadcrootn_storage_to_litter(:) - real(r8), pointer :: m_leafn_xfer_to_litter(:) - real(r8), pointer :: m_frootn_xfer_to_litter(:) - real(r8), pointer :: m_livestemn_xfer_to_litter(:) - real(r8), pointer :: m_deadstemn_xfer_to_litter(:) - real(r8), pointer :: m_livecrootn_xfer_to_litter(:) - real(r8), pointer :: m_deadcrootn_xfer_to_litter(:) -! -! !OTHER LOCAL VARIABLES: - integer :: p ! pft index - integer :: fp ! pft filter index - real(r8):: am ! rate for fractional mortality (1/yr) - real(r8):: m ! rate for fractional mortality (1/s) - real(r8):: mort_max ! asymptotic max mortality rate (/yr) - real(r8), parameter :: k_mort = 0.3 !coeff of growth efficiency in mortality equation - -!EOP -!----------------------------------------------------------------------- - - ! assign local pointers - woody => pftcon%woody - - ! assign local pointers to pft-level arrays - ivt =>pft%itype - leafc => pcs%leafc - frootc => pcs%frootc - livestemc => pcs%livestemc - deadstemc => pcs%deadstemc - livecrootc => pcs%livecrootc - deadcrootc => pcs%deadcrootc - leafc_storage => pcs%leafc_storage - frootc_storage => pcs%frootc_storage - livestemc_storage => pcs%livestemc_storage - deadstemc_storage => pcs%deadstemc_storage - livecrootc_storage => pcs%livecrootc_storage - deadcrootc_storage => pcs%deadcrootc_storage - gresp_storage => pcs%gresp_storage - leafc_xfer => pcs%leafc_xfer - frootc_xfer => pcs%frootc_xfer - livestemc_xfer => pcs%livestemc_xfer - deadstemc_xfer => pcs%deadstemc_xfer - livecrootc_xfer => pcs%livecrootc_xfer - deadcrootc_xfer => pcs%deadcrootc_xfer - gresp_xfer => pcs%gresp_xfer - leafn => pns%leafn - frootn => pns%frootn - livestemn => pns%livestemn - deadstemn => pns%deadstemn - livecrootn => pns%livecrootn - deadcrootn => pns%deadcrootn - retransn => pns%retransn - leafn_storage => pns%leafn_storage - frootn_storage => pns%frootn_storage - livestemn_storage => pns%livestemn_storage - deadstemn_storage => pns%deadstemn_storage - livecrootn_storage => pns%livecrootn_storage - deadcrootn_storage => pns%deadcrootn_storage - leafn_xfer => pns%leafn_xfer - frootn_xfer => pns%frootn_xfer - livestemn_xfer => pns%livestemn_xfer - deadstemn_xfer => pns%deadstemn_xfer - livecrootn_xfer => pns%livecrootn_xfer - deadcrootn_xfer => pns%deadcrootn_xfer - m_leafc_to_litter => pcf%m_leafc_to_litter - m_frootc_to_litter => pcf%m_frootc_to_litter - m_livestemc_to_litter => pcf%m_livestemc_to_litter - m_deadstemc_to_litter => pcf%m_deadstemc_to_litter - m_livecrootc_to_litter => pcf%m_livecrootc_to_litter - m_deadcrootc_to_litter => pcf%m_deadcrootc_to_litter - m_leafc_storage_to_litter => pcf%m_leafc_storage_to_litter - m_frootc_storage_to_litter => pcf%m_frootc_storage_to_litter - m_livestemc_storage_to_litter => pcf%m_livestemc_storage_to_litter - m_deadstemc_storage_to_litter => pcf%m_deadstemc_storage_to_litter - m_livecrootc_storage_to_litter => pcf%m_livecrootc_storage_to_litter - m_deadcrootc_storage_to_litter => pcf%m_deadcrootc_storage_to_litter - m_gresp_storage_to_litter => pcf%m_gresp_storage_to_litter - m_leafc_xfer_to_litter => pcf%m_leafc_xfer_to_litter - m_frootc_xfer_to_litter => pcf%m_frootc_xfer_to_litter - m_livestemc_xfer_to_litter => pcf%m_livestemc_xfer_to_litter - m_deadstemc_xfer_to_litter => pcf%m_deadstemc_xfer_to_litter - m_livecrootc_xfer_to_litter => pcf%m_livecrootc_xfer_to_litter - m_deadcrootc_xfer_to_litter => pcf%m_deadcrootc_xfer_to_litter - m_gresp_xfer_to_litter => pcf%m_gresp_xfer_to_litter - m_leafn_to_litter => pnf%m_leafn_to_litter - m_frootn_to_litter => pnf%m_frootn_to_litter - m_livestemn_to_litter => pnf%m_livestemn_to_litter - m_deadstemn_to_litter => pnf%m_deadstemn_to_litter - m_livecrootn_to_litter => pnf%m_livecrootn_to_litter - m_deadcrootn_to_litter => pnf%m_deadcrootn_to_litter - m_retransn_to_litter => pnf%m_retransn_to_litter - m_leafn_storage_to_litter => pnf%m_leafn_storage_to_litter - m_frootn_storage_to_litter => pnf%m_frootn_storage_to_litter - m_livestemn_storage_to_litter => pnf%m_livestemn_storage_to_litter - m_deadstemn_storage_to_litter => pnf%m_deadstemn_storage_to_litter - m_livecrootn_storage_to_litter => pnf%m_livecrootn_storage_to_litter - m_deadcrootn_storage_to_litter => pnf%m_deadcrootn_storage_to_litter - m_leafn_xfer_to_litter => pnf%m_leafn_xfer_to_litter - m_frootn_xfer_to_litter => pnf%m_frootn_xfer_to_litter - m_livestemn_xfer_to_litter => pnf%m_livestemn_xfer_to_litter - m_deadstemn_xfer_to_litter => pnf%m_deadstemn_xfer_to_litter - m_livecrootn_xfer_to_litter => pnf%m_livecrootn_xfer_to_litter - m_deadcrootn_xfer_to_litter => pnf%m_deadcrootn_xfer_to_litter -#if (defined CNDV) - greffic => pdgvs%greffic - heatstress => pdgvs%heatstress - nind => pdgvs%nind ! F. Li and S. Levis -#endif - - ! set the mortality rate based on annual rate - am = 0.02_r8 - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - -#if (defined CNDV) - ! Stress mortality from lpj's subr Mortality. - - if (woody(ivt(p)) == 1._r8) then - - if (ivt(p) == 8) then - mort_max = 0.03_r8 ! BDT boreal - else - mort_max = 0.01_r8 ! original value for all pfts - end if - - ! heatstress and greffic calculated in Establishment once/yr - - ! Mortality rate inversely related to growth efficiency - ! (Prentice et al 1993) - am = mort_max / (1._r8 + k_mort * greffic(p)) - - am = min(1._r8, am + heatstress(p)) - else ! lpj didn't set this for grasses; cn does - ! set the mortality rate based on annual rate - am = 0.02_r8 - end if -#endif - - m = am/(get_days_per_year() * secspday) - - ! pft-level gap mortality carbon fluxes - ! displayed pools - m_leafc_to_litter(p) = leafc(p) * m - m_frootc_to_litter(p) = frootc(p) * m - m_livestemc_to_litter(p) = livestemc(p) * m - m_deadstemc_to_litter(p) = deadstemc(p) * m - m_livecrootc_to_litter(p) = livecrootc(p) * m - m_deadcrootc_to_litter(p) = deadcrootc(p) * m - - ! storage pools - m_leafc_storage_to_litter(p) = leafc_storage(p) * m - m_frootc_storage_to_litter(p) = frootc_storage(p) * m - m_livestemc_storage_to_litter(p) = livestemc_storage(p) * m - m_deadstemc_storage_to_litter(p) = deadstemc_storage(p) * m - m_livecrootc_storage_to_litter(p) = livecrootc_storage(p) * m - m_deadcrootc_storage_to_litter(p) = deadcrootc_storage(p) * m - m_gresp_storage_to_litter(p) = gresp_storage(p) * m - - ! transfer pools - m_leafc_xfer_to_litter(p) = leafc_xfer(p) * m - m_frootc_xfer_to_litter(p) = frootc_xfer(p) * m - m_livestemc_xfer_to_litter(p) = livestemc_xfer(p) * m - m_deadstemc_xfer_to_litter(p) = deadstemc_xfer(p) * m - m_livecrootc_xfer_to_litter(p) = livecrootc_xfer(p) * m - m_deadcrootc_xfer_to_litter(p) = deadcrootc_xfer(p) * m - m_gresp_xfer_to_litter(p) = gresp_xfer(p) * m - - ! pft-level gap mortality nitrogen fluxes - ! displayed pools - m_leafn_to_litter(p) = leafn(p) * m - m_frootn_to_litter(p) = frootn(p) * m - m_livestemn_to_litter(p) = livestemn(p) * m - m_deadstemn_to_litter(p) = deadstemn(p) * m - m_livecrootn_to_litter(p) = livecrootn(p) * m - m_deadcrootn_to_litter(p) = deadcrootn(p) * m - if (ivt(p) < npcropmin) m_retransn_to_litter(p) = retransn(p) * m - - ! storage pools - m_leafn_storage_to_litter(p) = leafn_storage(p) * m - m_frootn_storage_to_litter(p) = frootn_storage(p) * m - m_livestemn_storage_to_litter(p) = livestemn_storage(p) * m - m_deadstemn_storage_to_litter(p) = deadstemn_storage(p) * m - m_livecrootn_storage_to_litter(p) = livecrootn_storage(p) * m - m_deadcrootn_storage_to_litter(p) = deadcrootn_storage(p) * m - - ! transfer pools - m_leafn_xfer_to_litter(p) = leafn_xfer(p) * m - m_frootn_xfer_to_litter(p) = frootn_xfer(p) * m - m_livestemn_xfer_to_litter(p) = livestemn_xfer(p) * m - m_deadstemn_xfer_to_litter(p) = deadstemn_xfer(p) * m - m_livecrootn_xfer_to_litter(p) = livecrootn_xfer(p) * m - m_deadcrootn_xfer_to_litter(p) = deadcrootn_xfer(p) * m - -! added by F. Li and S. Levis -#if (defined CNDV) - if (woody(ivt(p)) == 1._r8)then - if (livestemc(p)+deadstemc(p)> 0._r8)then - nind(p)=nind(p)*(1._r8-m) - else - nind(p) = 0._r8 - end if - end if -#endif - - end do ! end of pft loop - - ! gather all pft-level litterfall fluxes to the column - ! for litter C and N inputs - - call CNGapPftToColumn(num_soilc, filter_soilc) - -end subroutine CNGapMortality -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNGapPftToColumn -! -! !INTERFACE: -subroutine CNGapPftToColumn (num_soilc, filter_soilc) -! -! !DESCRIPTION: -! called in the middle of CNGapMoratlity to gather all pft-level gap mortality fluxes -! to the column level and assign them to the three litter pools -! -! !USES: - use clmtype - use clm_varpar, only : maxpatch_pft, nlevdecomp -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! soil column filter -! -! !CALLED FROM: -! subroutine CNphenology -! -! !REVISION HISTORY: -! 9/8/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! -! local pointers to implicit in scalars - logical , pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details) - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: wtcol(:) ! pft weight relative to column (0-1) - real(r8), pointer :: lf_flab(:) ! leaf litter labile fraction - real(r8), pointer :: lf_fcel(:) ! leaf litter cellulose fraction - real(r8), pointer :: lf_flig(:) ! leaf litter lignin fraction - real(r8), pointer :: fr_flab(:) ! fine root litter labile fraction - real(r8), pointer :: fr_fcel(:) ! fine root litter cellulose fraction - real(r8), pointer :: fr_flig(:) ! fine root litter lignin fraction - integer , pointer :: npfts(:) ! number of pfts for each column - integer , pointer :: pfti(:) ! beginning pft index for each column - real(r8), pointer :: m_leafc_to_litter(:) - real(r8), pointer :: m_frootc_to_litter(:) - real(r8), pointer :: m_livestemc_to_litter(:) - real(r8), pointer :: m_deadstemc_to_litter(:) - real(r8), pointer :: m_livecrootc_to_litter(:) - real(r8), pointer :: m_deadcrootc_to_litter(:) - real(r8), pointer :: m_leafc_storage_to_litter(:) - real(r8), pointer :: m_frootc_storage_to_litter(:) - real(r8), pointer :: m_livestemc_storage_to_litter(:) - real(r8), pointer :: m_deadstemc_storage_to_litter(:) - real(r8), pointer :: m_livecrootc_storage_to_litter(:) - real(r8), pointer :: m_deadcrootc_storage_to_litter(:) - real(r8), pointer :: m_gresp_storage_to_litter(:) - real(r8), pointer :: m_leafc_xfer_to_litter(:) - real(r8), pointer :: m_frootc_xfer_to_litter(:) - real(r8), pointer :: m_livestemc_xfer_to_litter(:) - real(r8), pointer :: m_deadstemc_xfer_to_litter(:) - real(r8), pointer :: m_livecrootc_xfer_to_litter(:) - real(r8), pointer :: m_deadcrootc_xfer_to_litter(:) - real(r8), pointer :: m_gresp_xfer_to_litter(:) - real(r8), pointer :: m_leafn_to_litter(:) - real(r8), pointer :: m_frootn_to_litter(:) - real(r8), pointer :: m_livestemn_to_litter(:) - real(r8), pointer :: m_deadstemn_to_litter(:) - real(r8), pointer :: m_livecrootn_to_litter(:) - real(r8), pointer :: m_deadcrootn_to_litter(:) - real(r8), pointer :: m_retransn_to_litter(:) - real(r8), pointer :: m_leafn_storage_to_litter(:) - real(r8), pointer :: m_frootn_storage_to_litter(:) - real(r8), pointer :: m_livestemn_storage_to_litter(:) - real(r8), pointer :: m_deadstemn_storage_to_litter(:) - real(r8), pointer :: m_livecrootn_storage_to_litter(:) - real(r8), pointer :: m_deadcrootn_storage_to_litter(:) - real(r8), pointer :: m_leafn_xfer_to_litter(:) - real(r8), pointer :: m_frootn_xfer_to_litter(:) - real(r8), pointer :: m_livestemn_xfer_to_litter(:) - real(r8), pointer :: m_deadstemn_xfer_to_litter(:) - real(r8), pointer :: m_livecrootn_xfer_to_litter(:) - real(r8), pointer :: m_deadcrootn_xfer_to_litter(:) - real(r8), pointer :: gap_mortality_c_to_litr_met_c(:,:) ! C fluxes associated with gap mortality to litter metabolic pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_litr_cel_c(:,:) ! C fluxes associated with gap mortality to litter cellulose pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_litr_lig_c(:,:) ! C fluxes associated with gap mortality to litter lignin pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_cwdc(:,:) ! C fluxes associated with gap mortality to CWD pool (gC/m3/s) - real(r8), pointer :: gap_mortality_n_to_litr_met_n(:,:) ! N fluxes associated with gap mortality to litter metabolic pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_litr_cel_n(:,:) ! N fluxes associated with gap mortality to litter cellulose pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_litr_lig_n(:,:) ! N fluxes associated with gap mortality to litter lignin pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_cwdn(:,:) ! N fluxes associated with gap mortality to CWD pool (gN/m3/s) -! -! local pointers to implicit in/out arrays - real(r8), pointer :: leaf_prof(:,:) ! (1/m) profile of leaves - real(r8), pointer :: froot_prof(:,:) ! (1/m) profile of fine roots - real(r8), pointer :: croot_prof(:,:) ! (1/m) profile of coarse roots - real(r8), pointer :: stem_prof(:,:) ! (1/m) profile of stems - -! -! local pointers to implicit out arrays -! -! -! !OTHER LOCAL VARIABLES: - integer :: fc,c,pi,p,j ! indices -!EOP -!----------------------------------------------------------------------- - - ! assign local pointers - lf_flab => pftcon%lf_flab - lf_fcel => pftcon%lf_fcel - lf_flig => pftcon%lf_flig - fr_flab => pftcon%fr_flab - fr_fcel => pftcon%fr_fcel - fr_flig => pftcon%fr_flig - - ! assign local pointers to column-level arrays - npfts =>col%npfts - pfti =>col%pfti - - ! assign local pointers to pft-level arrays - pactive => pft%active - ivt =>pft%itype - wtcol =>pft%wtcol - m_leafc_to_litter => pcf%m_leafc_to_litter - m_frootc_to_litter => pcf%m_frootc_to_litter - m_livestemc_to_litter => pcf%m_livestemc_to_litter - m_deadstemc_to_litter => pcf%m_deadstemc_to_litter - m_livecrootc_to_litter => pcf%m_livecrootc_to_litter - m_deadcrootc_to_litter => pcf%m_deadcrootc_to_litter - m_leafc_storage_to_litter => pcf%m_leafc_storage_to_litter - m_frootc_storage_to_litter => pcf%m_frootc_storage_to_litter - m_livestemc_storage_to_litter => pcf%m_livestemc_storage_to_litter - m_deadstemc_storage_to_litter => pcf%m_deadstemc_storage_to_litter - m_livecrootc_storage_to_litter => pcf%m_livecrootc_storage_to_litter - m_deadcrootc_storage_to_litter => pcf%m_deadcrootc_storage_to_litter - m_gresp_storage_to_litter => pcf%m_gresp_storage_to_litter - m_leafc_xfer_to_litter => pcf%m_leafc_xfer_to_litter - m_frootc_xfer_to_litter => pcf%m_frootc_xfer_to_litter - m_livestemc_xfer_to_litter => pcf%m_livestemc_xfer_to_litter - m_deadstemc_xfer_to_litter => pcf%m_deadstemc_xfer_to_litter - m_livecrootc_xfer_to_litter => pcf%m_livecrootc_xfer_to_litter - m_deadcrootc_xfer_to_litter => pcf%m_deadcrootc_xfer_to_litter - m_gresp_xfer_to_litter => pcf%m_gresp_xfer_to_litter - m_leafn_to_litter => pnf%m_leafn_to_litter - m_frootn_to_litter => pnf%m_frootn_to_litter - m_livestemn_to_litter => pnf%m_livestemn_to_litter - m_deadstemn_to_litter => pnf%m_deadstemn_to_litter - m_livecrootn_to_litter => pnf%m_livecrootn_to_litter - m_deadcrootn_to_litter => pnf%m_deadcrootn_to_litter - m_retransn_to_litter => pnf%m_retransn_to_litter - m_leafn_storage_to_litter => pnf%m_leafn_storage_to_litter - m_frootn_storage_to_litter => pnf%m_frootn_storage_to_litter - m_livestemn_storage_to_litter => pnf%m_livestemn_storage_to_litter - m_deadstemn_storage_to_litter => pnf%m_deadstemn_storage_to_litter - m_livecrootn_storage_to_litter => pnf%m_livecrootn_storage_to_litter - m_deadcrootn_storage_to_litter => pnf%m_deadcrootn_storage_to_litter - m_leafn_xfer_to_litter => pnf%m_leafn_xfer_to_litter - m_frootn_xfer_to_litter => pnf%m_frootn_xfer_to_litter - m_livestemn_xfer_to_litter => pnf%m_livestemn_xfer_to_litter - m_deadstemn_xfer_to_litter => pnf%m_deadstemn_xfer_to_litter - m_livecrootn_xfer_to_litter => pnf%m_livecrootn_xfer_to_litter - m_deadcrootn_xfer_to_litter => pnf%m_deadcrootn_xfer_to_litter - gap_mortality_c_to_litr_met_c => ccf%gap_mortality_c_to_litr_met_c - gap_mortality_c_to_litr_cel_c => ccf%gap_mortality_c_to_litr_cel_c - gap_mortality_c_to_litr_lig_c => ccf%gap_mortality_c_to_litr_lig_c - gap_mortality_c_to_cwdc => ccf%gap_mortality_c_to_cwdc - gap_mortality_n_to_litr_met_n => cnf%gap_mortality_n_to_litr_met_n - gap_mortality_n_to_litr_cel_n => cnf%gap_mortality_n_to_litr_cel_n - gap_mortality_n_to_litr_lig_n => cnf%gap_mortality_n_to_litr_lig_n - gap_mortality_n_to_cwdn => cnf%gap_mortality_n_to_cwdn - leaf_prof => pps%leaf_prof - froot_prof => pps%froot_prof - croot_prof => pps%croot_prof - stem_prof => pps%stem_prof - - - do j = 1,nlevdecomp - do pi = 1,maxpatch_pft - do fc = 1,num_soilc - c = filter_soilc(fc) - - if (pi <= npfts(c)) then - p = pfti(c) + pi - 1 - - if (pactive(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 subroutine CNGapPftToColumn -!----------------------------------------------------------------------- - -!#endif - -end module CNGapMortalityMod 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 deleted file mode 100644 index 35b76661e..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNMRespMod.F90 +++ /dev/null @@ -1,204 +0,0 @@ -module CNMRespMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNMRespMod -! -! !DESCRIPTION: -! Module holding maintenance respiration routines for coupled carbon -! nitrogen code. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varpar , only: nlevgrnd - use shr_const_mod, only: SHR_CONST_TKFRZ - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: CNMResp -! -! !REVISION HISTORY: -! 8/14/03: Created by Peter Thornton -! 10/23/03, Peter Thornton: Migrated all subroutines to vector data structures. -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNMResp -! -! !INTERFACE: -subroutine CNMResp(lbc, ubc, num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! -! !USES: - use clmtype - use pftvarcon , only : npcropmin -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column-index bounds - integer, intent(in) :: num_soilc ! number of soil points in column filter - integer, intent(in) :: filter_soilc(:) ! column filter for soil points - integer, intent(in) :: num_soilp ! number of soil points in pft filter - integer, intent(in) :: filter_soilp(:) ! pft filter for soil points -! -! !CALLED FROM: -! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 8/14/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in arrays -! - ! column level - real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) - ! pft level - real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (Kelvin) - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: grainn(:) ! (kgN/m2) grain N - real(r8), pointer :: rootfr(:,:) ! fraction of roots in each soil layer (nlevgrnd) - integer , pointer :: ivt(:) ! pft vegetation type - integer , pointer :: pcolumn(:) ! index into column level quantities - integer , pointer :: plandunit(:) ! index into landunit level quantities - integer , pointer :: clandunit(:) ! index into landunit level quantities - integer , pointer :: itypelun(:) ! landunit type - ! ecophysiological constants - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - logical , pointer :: croplive(:) ! Flag, true if planted, not harvested -! -! local pointers to implicit in/out arrays -! - ! pft level - real(r8), pointer :: leaf_mr(:) - real(r8), pointer :: froot_mr(:) - real(r8), pointer :: livestem_mr(:) - real(r8), pointer :: livecroot_mr(:) - real(r8), pointer :: grain_mr(:) - real(r8), pointer :: lmrsun(:) ! sunlit leaf maintenance respiration rate (umol CO2/m**2/s) - real(r8), pointer :: lmrsha(:) ! shaded leaf maintenance respiration rate (umol CO2/m**2/s) - real(r8), pointer :: laisun(:) ! sunlit projected leaf area index - real(r8), pointer :: laisha(:) ! shaded projected leaf area index - integer , pointer :: frac_veg_nosno(:) ! fraction of vegetation not covered by snow (0 OR 1) [-] -! -! !OTHER LOCAL VARIABLES: - integer :: c,p,j ! indices - integer :: fp ! soil filter pft index - integer :: fc ! soil filter column index - real(r8):: mr ! maintenance respiration (gC/m2/s) - real(r8):: br ! base rate (gC/gN/s) - real(r8):: q10 ! temperature dependence - real(r8):: tc ! temperature correction, 2m air temp (unitless) - real(r8):: tcsoi(lbc:ubc,nlevgrnd) ! temperature correction by soil layer (unitless) -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays - t_soisno => ces%t_soisno - t_ref2m => pes%t_ref2m - leafn => pns%leafn - frootn => pns%frootn - livestemn => pns%livestemn - livecrootn => pns%livecrootn - grainn => pns%grainn - rootfr => pps%rootfr - leaf_mr => pcf%leaf_mr - froot_mr => pcf%froot_mr - livestem_mr => pcf%livestem_mr - livecroot_mr => pcf%livecroot_mr - grain_mr => pcf%grain_mr - lmrsun => pcf%lmrsun - lmrsha => pcf%lmrsha - laisun => pps%laisun - laisha => pps%laisha - frac_veg_nosno => pps%frac_veg_nosno - ivt =>pft%itype - pcolumn =>pft%column - plandunit =>pft%landunit - clandunit =>col%landunit - itypelun => lun%itype - woody => pftcon%woody - croplive => pps%croplive - - ! base rate for maintenance respiration is from: - ! M. Ryan, 1991. Effects of climate change on plant respiration. - ! Ecological Applications, 1(2), 157-167. - ! Original expression is br = 0.0106 molC/(molN h) - ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) - br = 2.525e-6_r8 - ! Peter Thornton: 3/13/09 - ! Q10 was originally set to 2.0, an arbitrary choice, but reduced to 1.5 as part of the tuning - ! to improve seasonal cycle of atmospheric CO2 concentration in global - ! simulatoins - q10 = 1.5_r8 - - ! column loop to calculate temperature factors in each soil layer - do j=1,nlevgrnd - do fc = 1, num_soilc - c = filter_soilc(fc) - - ! calculate temperature corrections for each soil layer, for use in - ! estimating fine root maintenance respiration with depth - - tcsoi(c,j) = q10**((t_soisno(c,j)-SHR_CONST_TKFRZ - 20.0_r8)/10.0_r8) - end do - end do - - ! pft loop for leaves and live wood - 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) - 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 - 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*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 pft loop for fine root - do j = 1,nlevgrnd - do fp = 1,num_soilp - p = filter_soilp(fp) - c = pcolumn(p) - - ! Fine root MR - ! rootfr(j) sums to 1.0 over all soil layers, and - ! describes the fraction of root mass that is in each - ! layer. This is used with the layer temperature correction - ! to estimate the total fine root maintenance respiration as a - ! function of temperature and N content. - - froot_mr(p) = froot_mr(p) + frootn(p)*br*tcsoi(c,j)*rootfr(p,j) - end do - end do - -end subroutine CNMResp - -!#endif - -end module CNMRespMod 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 deleted file mode 100644 index 062d7d0ab..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNDynamicsMod.F90 +++ /dev/null @@ -1,657 +0,0 @@ - -module CNNDynamicsMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNNDynamicsMod -! -! !DESCRIPTION: -! Module for mineral nitrogen dynamics (deposition, fixation, leaching) -! for coupled carbon-nitrogen code. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varcon, only: dzsoi_decomp, zisoi - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: CNNDeposition - public :: CNNFixation - public :: CNNLeaching - public :: CNNFert - public :: CNSoyfix - -#ifndef NITRIF_DENITRIF - real(r8), public :: nfix_timeconst = 0._r8 ! (days) time over which to exponentially relax the npp flux for N fixation term (if .le. 0. or .ge. 365; use old annual method) -#else - real(r8), public :: nfix_timeconst = 10._r8 ! (days) time over which to exponentially relax the npp flux for N fixation term (if .le. 0. or .ge. 365; use old annual method) -#endif - -! -! !REVISION HISTORY: -! 6/1/04: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNNDeposition -! -! !INTERFACE: -subroutine CNNDeposition( lbc, ubc ) -! -! !DESCRIPTION: -! On the radiation time step, update the nitrogen deposition rate -! from atmospheric forcing. For now it is assumed that all the atmospheric -! N deposition goes to the soil mineral N pool. -! This could be updated later to divide the inputs between mineral N absorbed -! directly into the canopy and mineral N entering the soil pool. -! -! !USES: - use clmtype -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds -! -! !CALLED FROM: -! subroutine CNEcosystemDyn, in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 6/1/04: Created by Peter Thornton -! 11/06/09: Copy to all columns NOT just over soil. S. Levis -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - real(r8), pointer :: forc_ndep(:) ! nitrogen deposition rate (gN/m2/s) - integer , pointer :: gridcell(:) ! index into gridcell level quantities -! -! local pointers to implicit out scalars -! - real(r8), pointer :: ndep_to_sminn(:) -! -! !OTHER LOCAL VARIABLES: - integer :: g,c ! indices - -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - forc_ndep => grc%forc_ndep - gridcell => col%gridcell - - ! Assign local pointers to derived type arrays (out) - ndep_to_sminn => cnf%ndep_to_sminn - - ! Loop through columns - do c = lbc, ubc - g = gridcell(c) - - ndep_to_sminn(c) = forc_ndep(g) - - end do - -end subroutine CNNDeposition - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNNFixation -! -! !INTERFACE: -subroutine CNNFixation(num_soilc, filter_soilc) -! -! !DESCRIPTION: -! On the radiation time step, update the nitrogen fixation rate -! as a function of annual total NPP. This rate gets updated once per year. -! All N fixation goes to the soil mineral N pool. -! -! !USES: - use clmtype - use clm_time_manager, only: get_days_per_year, get_step_size - use clm_varcon , only: secspday, spval - - -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns -! -! !CALLED FROM: -! subroutine CNEcosystemDyn, in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 6/1/04: Created by Peter Thornton -! 2/14/05, PET: After looking at a number of point simulations, -! it looks like a constant Nfix might be more efficient and -! maybe more realistic - setting to constant 0.4 gN/m2/yr. -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - real(r8), pointer :: cannsum_npp(:) ! nitrogen deposition rate (gN/m2/s) -! -! local pointers to implicit out scalars -! - real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) - real(r8), pointer :: col_lag_npp(:) ! (gC/m2/s) lagged net primary production - -! -! !OTHER LOCAL VARIABLES: - integer :: c,fc ! indices - real(r8) :: t ! temporary - real(r8) :: dayspyr ! days per year - -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - cannsum_npp => cps%cannsum_npp - - ! Assign local pointers to derived type arrays (out) - nfix_to_sminn => cnf%nfix_to_sminn - - if (nfix_timeconst .gt. 0._r8 .and. nfix_timeconst .lt. 500._r8 ) then - col_lag_npp => cps%col_lag_npp - endif - - dayspyr = get_days_per_year() - - if ( nfix_timeconst .gt. 0._r8 .and. nfix_timeconst .lt. 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) .ne. 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) - - ! the value 0.001666 is set to give 100 TgN/yr when global - ! NPP = 60 PgC/yr. (Cleveland et al., 1999) - ! Convert from gN/m2/yr -> gN/m2/s - !t = cannsum_npp(c) * 0.001666_r8 / (secspday * dayspyr) - t = (1.8_r8 * (1._r8 - exp(-0.003_r8 * cannsum_npp(c))))/(secspday * dayspyr) - nfix_to_sminn(c) = max(0._r8,t) - ! PET 2/14/05: commenting out the dependence on NPP, and - ! forcing Nfix to global constant = 0.4 gN/m2/yr - !nfix_to_sminn(c) = 0.4 / (secspday*dayspyr) - - end do - endif - -end subroutine CNNFixation - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNNLeaching -! -! !INTERFACE: -subroutine CNNLeaching(lbc, ubc, num_soilc, filter_soilc) -! -! !DESCRIPTION: -! On the radiation time step, update the nitrogen leaching rate -! as a function of soluble mineral N and total soil water outflow. -! -! !USES: - use clmtype - use clm_varpar , only : nlevdecomp, nlevsoi - use clm_time_manager , only : get_step_size -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 6/9/04: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s) - !!! awaiting_new_frozen_hydrolgy real(r8), pointer :: qflx_drain_perched(:) ! sub-surface runoff from perched wt (mm H2O /s) - real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s) - real(r8), pointer :: sminn_vr(:,:) ! (gN/m3) soil mineral N -! -! local pointers to implicit out scalars -! -#ifndef NITRIF_DENITRIF - real(r8), pointer :: sminn_leached_vr(:,:) ! rate of mineral N leaching (gN/m3/s) -#else - real(r8), pointer :: smin_no3_leached_vr(:,:) ! rate of mineral NO3 leaching (gN/m3/s) - real(r8), pointer :: smin_no3_runoff_vr(:,:) ! rate of mineral NO3 loss with runoff (gN/m3/s) - real(r8), pointer :: smin_no3_vr(:,:) -#endif - real(r8), pointer :: dz(:,:) !layer thickness (m) -! -! !OTHER LOCAL VARIABLES: - integer :: j,c,fc ! indices - real(r8) :: dt ! radiation time step (seconds) - real(r8) :: tot_water(lbc:ubc) ! total column liquid water (kg water/m2) - real(r8) :: surface_water(lbc:ubc) ! liquid water to shallow surface depth (kg water/m2) -#ifndef NITRIF_DENITRIF - real(r8) :: sf ! soluble fraction of mineral N (unitless) -#else - real(r8) :: sf_no3 ! soluble fraction of NO3 (unitless) -#endif - real(r8) :: disn_conc ! dissolved mineral N concentration - ! (gN/kg water) - ! - ! - real(r8), parameter :: depth_runoff_Nloss = 0.05 ! (m) depth over which runoff mixes with soil water for N loss to runoff - real(r8) :: drain_tot(lbc:ubc) ! total drainage flux (mm H2O /s) - ! - ! - -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - h2osoi_liq => cws%h2osoi_liq - qflx_drain => cwf%qflx_drain - !!! awaiting_new_frozen_hydrolgy qflx_drain_perched => cwf%qflx_drain_perched - qflx_surf => cwf%qflx_surf - sminn_vr => cns%sminn_vr - ! Assign local pointers to derived type arrays (out) -#ifndef NITRIF_DENITRIF - sminn_leached_vr => cnf%sminn_leached_vr -#else - smin_no3_leached_vr => cnf%smin_no3_leached_vr - smin_no3_runoff_vr => cnf%smin_no3_runoff_vr - smin_no3_vr => cns%smin_no3_vr -#endif - dz => cps%dz - - - ! set time steps - dt = real( get_step_size(), r8 ) - -#ifndef NITRIF_DENITRIF - ! Assume that 10% of the soil mineral N is in a soluble form - sf = 0.1_r8 -#else - ! Assume that 100% of the soil NO3 is in a soluble form - sf_no3 = 1.0_r8 -#endif - - ! calculate the total soil water - tot_water(lbc:ubc) = 0._r8 - do j = 1,nlevsoi - do fc = 1,num_soilc - c = filter_soilc(fc) - tot_water(c) = tot_water(c) + h2osoi_liq(c,j) - end do - end do - - ! for runoff calculation; calculate total water to a given depth - surface_water(lbc:ubc) = 0._r8 - do j = 1,nlevsoi - if ( zisoi(j) .le. 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) .lt. 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)) / dz(c,j)) - end do - endif - end do - - !!! awaiting_new_frozen_hydrolgy ! Loop through columns - !!! awaiting_new_frozen_hydrolgy do fc = 1,num_soilc - !!! awaiting_new_frozen_hydrolgy c = filter_soilc(fc) - !!! awaiting_new_frozen_hydrolgy drain_tot(c) = qflx_drain(c) + qflx_drain_perched(c) - !!! awaiting_new_frozen_hydrolgy end do - ! Loop through columns - do fc = 1,num_soilc - c = filter_soilc(fc) - drain_tot(c) = qflx_drain(c) - end do - - -#ifndef NITRIF_DENITRIF - do j = 1,nlevdecomp - ! Loop through columns - do fc = 1,num_soilc - c = filter_soilc(fc) - -#ifndef VERTSOILC - ! 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) * 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) * dz(c,j) ) - -#endif - ! 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------------- - do j = 1,nlevdecomp - ! Loop through columns - do fc = 1,num_soilc - c = filter_soilc(fc) - -#ifndef VERTSOILC - ! 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) * 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) * 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) .le. depth_runoff_Nloss ) then - smin_no3_runoff_vr(c,j) = disn_conc * qflx_surf(c) * h2osoi_liq(c,j) / ( surface_water(c) * dz(c,j) ) - elseif ( zisoi(j-1) .lt. 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)) / & - 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 subroutine CNNLeaching - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNNFert -! -! !INTERFACE: -subroutine CNNFert(num_soilc, filter_soilc) -! -! !DESCRIPTION: -! On the radiation time step, update the nitrogen fertilizer for crops -! All fertilizer goes into the soil mineral N pool. -! -! !USES: - use clmtype - use subgridAveMod, only: p2c - -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns -! -! !CALLED FROM: -! subroutine CNEcosystemDyn, in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 4/27/09: Created by Beth Drewniak -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - real(r8), pointer :: fert(:) ! nitrogen fertilizer rate (gN/m2/s) -! -! local pointers to implicit out scalars -! - real(r8), pointer :: fert_to_sminn(:) -! -! !OTHER LOCAL VARIABLES: - integer :: c,fc ! indices - -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - fert => pnf%fert -! - ! Assign local pointers to derived type arrays (out) - fert_to_sminn => cnf%fert_to_sminn -! - call p2c(num_soilc,filter_soilc,fert,fert_to_sminn) -! -! DEBUG... -! do fc = 1,num_soilc -! c = filter_soilc(fc) -! write(*,*) "fert_to_sminn = ",c, fert_to_sminn(c), fert(p) -! end do - -end subroutine CNNFert -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSoyfix -! -! !INTERFACE: -subroutine CNSoyfix (num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !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 clmtype - use pftvarcon, only: nsoybean - use subgridAveMod, only: p2c - -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - -! -! !CALLED FROM: -! subroutine CNEcosystemDyn, in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 10/27/03: Created by Beth Drewniak -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: ivt(:) ! pft vegetation type - integer , pointer :: pcolumn(:) ! pft's column index - real(r8), pointer :: fpg(:) ! fraction of potential gpp (no units) - real(r8), pointer :: wf(:) ! soil water as frac. of whc for top 0.5 m - real(r8), pointer :: plant_ndemand(:) ! N flux required to support initial GPP (gN/m2/s) - real(r8), pointer :: sminn(:) ! (kgN/m2) soil mineral N - real(r8), pointer :: hui(:) ! =gdd since planting (gddplant) - real(r8), pointer :: gddmaturity(:) ! gdd needed to harvest - logical , pointer :: croplive(:) ! true if planted and not harvested - -! local pointers to implicit out arrays - real(r8), pointer :: soyfixn(:) ! nitrogen fixed to each soybean crop - real(r8), pointer :: soyfixn_to_sminn(:) - -! !OTHER 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 -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - ivt =>pft%itype - pcolumn =>pft%column - fpg => cps%fpg - wf => cps%wf - plant_ndemand => pepv%plant_ndemand - sminn => cns%sminn - hui => pps%gddplant - gddmaturity => pps%gddmaturity - croplive => pps%croplive - - ! Assign local pointers to derived type arrays (out) - soyfixn => pnf%soyfixn - soyfixn_to_sminn => cnf%soyfixn_to_sminn - - 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 = pcolumn(p) - - ! if soybean currently growing then calculate fixation - - if (ivt(p) == nsoybean .and. croplive(p)) 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 .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 - 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(num_soilc,filter_soilc,soyfixn,soyfixn_to_sminn) - -end subroutine CNSoyfix - -!#endif - -end module CNNDynamicsMod 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 deleted file mode 100644 index 859ce6a54..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate1Mod.F90 +++ /dev/null @@ -1,603 +0,0 @@ -module CNNStateUpdate1Mod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: NStateUpdate1Mod -! -! !DESCRIPTION: -! Module for nitrogen state variable updates, non-mortality fluxes. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: NStateUpdate1 -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: NStateUpdate1 -! -! !INTERFACE: -subroutine NStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp, tileid_soilp) -! -! !DESCRIPTION: -! On the radiation time step, update all the prognostic nitrogen state -! variables (except for gap-phase mortality and fire fluxes) -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varpar , only: nlevdecomp, ndecomp_pools, ndecomp_cascade_transitions - use clm_varctl , only: iulog - use clm_varpar , only: i_met_lit, i_cel_lit, i_lig_lit, i_cwd -#ifdef NITRIF_DENITRIF - use clm_varcon, only: nitrif_n2o_loss_frac -#endif - use pftvarcon , only: npcropmin - use clm_varctl , only: crop_prog -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - integer, intent(in) :: tileid_soilp(:) ! tile index for debugging -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 8/1/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: ndep_to_sminn(:) - real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) - real(r8), pointer :: fert_to_sminn(:) - real(r8), pointer :: soyfixn_to_sminn(:) - real(r8), pointer :: sminn_to_denit_excess_vr(:,:) - real(r8), pointer :: sminn_to_denit_decomp_cascade_vr(:,:,:) ! vertically-resolved denitrification along decomp cascade (gN/m3/s) - real(r8), pointer :: sminn_to_plant_vr(:,:) - real(r8), pointer :: supplement_to_sminn_vr(:,:) - real(r8), pointer :: deadcrootn_storage_to_xfer(:) - real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:) - real(r8), pointer :: deadstemn_storage_to_xfer(:) - real(r8), pointer :: deadstemn_xfer_to_deadstemn(:) - real(r8), pointer :: frootn_storage_to_xfer(:) - real(r8), pointer :: frootn_to_litter(:) - real(r8), pointer :: frootn_xfer_to_frootn(:) - real(r8), pointer :: frootn_to_retransn(:) - real(r8), pointer :: leafn_storage_to_xfer(:) - real(r8), pointer :: leafn_to_litter(:) - real(r8), pointer :: leafn_to_retransn(:) - real(r8), pointer :: leafn_xfer_to_leafn(:) - real(r8), pointer :: livecrootn_storage_to_xfer(:) - real(r8), pointer :: livecrootn_to_deadcrootn(:) - real(r8), pointer :: livecrootn_to_retransn(:) - real(r8), pointer :: livecrootn_xfer_to_livecrootn(:) - real(r8), pointer :: livestemn_storage_to_xfer(:) - real(r8), pointer :: livestemn_to_deadstemn(:) - real(r8), pointer :: livestemn_to_retransn(:) - real(r8), pointer :: livestemn_xfer_to_livestemn(:) - real(r8), pointer :: npool_to_deadcrootn(:) - real(r8), pointer :: npool_to_deadcrootn_storage(:) - real(r8), pointer :: npool_to_deadstemn(:) - real(r8), pointer :: npool_to_deadstemn_storage(:) - real(r8), pointer :: npool_to_frootn(:) - real(r8), pointer :: npool_to_frootn_storage(:) - real(r8), pointer :: npool_to_leafn(:) - real(r8), pointer :: npool_to_leafn_storage(:) - real(r8), pointer :: npool_to_livecrootn(:) - real(r8), pointer :: npool_to_livecrootn_storage(:) - real(r8), pointer :: npool_to_livestemn(:) ! allocation to live stem N (gN/m2/s) - real(r8), pointer :: npool_to_livestemn_storage(:) ! allocation to live stem N storage (gN/m2/s) - real(r8), pointer :: retransn_to_npool(:) ! deployment of retranslocated N (gN/m2/s) - real(r8), pointer :: sminn_to_npool(:) ! deployment of soil mineral N uptake (gN/m2/s) - real(r8), pointer :: grainn_storage_to_xfer(:) ! grain N shift storage to transfer (gN/m2/s) - real(r8), pointer :: grainn_to_food(:) ! grain N to food (gN/m2/s) - real(r8), pointer :: grainn_xfer_to_grainn(:) ! grain N growth from storage (gN/m2/s) - real(r8), pointer :: livestemn_to_litter(:) ! livestem N to litter (gN/m2/s) - real(r8), pointer :: npool_to_grainn(:) ! allocation to grain N (gN/m2/s) - real(r8), pointer :: npool_to_grainn_storage(:) ! allocation to grain N storage (gN/m2/s) -! -! local pointers to implicit in/out scalars - real(r8), pointer :: sminn_vr(:,:) ! (gN/m3) soil mineral N -#ifdef NITRIF_DENITRIF - real(r8), pointer :: smin_no3_vr(:,:) ! (gN/m3) soil NO3 - real(r8), pointer :: smin_nh4_vr(:,:) ! (gN/m3) soil NH4 - real(r8), pointer :: f_nit_vr(:,:) ! (gN/m3/s) soil nitrification flux - real(r8), pointer :: f_denit_vr(:,:) ! (gN/m3/s) soil denitrification flux - real(r8), pointer :: actual_immob_no3_vr(:,:) ! (gN/m3/s) - real(r8), pointer :: actual_immob_nh4_vr(:,:) ! (gN/m3/s) - real(r8), pointer :: smin_no3_to_plant_vr(:,:) ! (gN/m3/s) - real(r8), pointer :: smin_nh4_to_plant_vr(:,:) ! (gN/m3/s) - real(r8), pointer :: gross_nmin_vr(:,:) ! (gN/m3/s) -#endif - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: decomp_npools_sourcesink(:,:,:) ! (gC/m3) change in decomposing N pools over a timestep. Used to update concentrations concurrently with vertical transport - real(r8), pointer :: decomp_cascade_ntransfer_vr(:,:,:) ! vert-res transfer of N from donor to receiver pool along decomp. cascade (gN/m3/s) - real(r8), pointer :: decomp_cascade_sminn_flux_vr(:,:,:) ! vert-res mineral N flux for transition along decomposition cascade (gN/m3/s) - 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 - real(r8), pointer :: ndep_prof(:,:) ! profile over which N deposition is distributed through column (1/m) - real(r8), pointer :: nfixation_prof(:,:) ! profile over which N fixation is distributed through column (1/m) - real(r8), pointer :: grainn(:) ! (gN/m2) grain N - real(r8), pointer :: grainn_storage(:) ! (gN/m2) grain N storage - real(r8), pointer :: grainn_xfer(:) ! (gN/m2) grain N transfer - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N - real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool - real(r8), pointer :: phenology_n_to_litr_met_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gN/m3/s) - real(r8), pointer :: phenology_n_to_litr_cel_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gN/m3/s) - real(r8), pointer :: phenology_n_to_litr_lig_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter lignin pool (gN/m3/s) - - -! local pointers for dynamic landcover fluxes and states - real(r8), pointer :: dwt_seedn_to_leaf(:) - real(r8), pointer :: dwt_seedn_to_deadstem(:) - real(r8), pointer :: dwt_frootn_to_litr_met_n(:,:) - real(r8), pointer :: dwt_frootn_to_litr_cel_n(:,:) - real(r8), pointer :: dwt_frootn_to_litr_lig_n(:,:) - real(r8), pointer :: dwt_livecrootn_to_cwdn(:,:) - real(r8), pointer :: dwt_deadcrootn_to_cwdn(:,:) - real(r8), pointer :: seedn(:) - -! -! local pointers to implicit out scalars - real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) - real(r8), pointer :: pft_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) -! -! !OTHER LOCAL VARIABLES: - integer :: c,p,j,l,k ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers - woody => pftcon%woody - - ! assign local pointers at the column level - ndep_to_sminn => cnf%ndep_to_sminn - nfix_to_sminn => cnf%nfix_to_sminn - fert_to_sminn => cnf%fert_to_sminn - soyfixn_to_sminn => cnf%soyfixn_to_sminn -#ifndef NITRIF_DENITRIF - sminn_to_denit_excess_vr => cnf%sminn_to_denit_excess_vr - sminn_to_denit_decomp_cascade_vr => cnf%sminn_to_denit_decomp_cascade_vr -#else - smin_no3_vr => cns%smin_no3_vr - smin_nh4_vr => cns%smin_nh4_vr - f_nit_vr => cnf%f_nit_vr - f_denit_vr => cnf%f_denit_vr - actual_immob_no3_vr => cnf%actual_immob_no3_vr - actual_immob_nh4_vr => cnf%actual_immob_nh4_vr - smin_no3_to_plant_vr => cnf%smin_no3_to_plant_vr - smin_nh4_to_plant_vr => cnf%smin_nh4_to_plant_vr - gross_nmin_vr => cnf%gross_nmin_vr -#endif - sminn_to_plant_vr => cnf%sminn_to_plant_vr - decomp_cascade_sminn_flux_vr => cnf%decomp_cascade_sminn_flux_vr - decomp_cascade_ntransfer_vr => cnf%decomp_cascade_ntransfer_vr - cascade_donor_pool => decomp_cascade_con%cascade_donor_pool - cascade_receiver_pool => decomp_cascade_con%cascade_receiver_pool - supplement_to_sminn_vr => cnf%supplement_to_sminn_vr - decomp_npools_vr => cns%decomp_npools_vr - decomp_npools_sourcesink => cnf%decomp_npools_sourcesink - sminn_vr => cns%sminn_vr - ndep_prof => cps%ndep_prof - nfixation_prof => cps%nfixation_prof - phenology_n_to_litr_met_n => cnf%phenology_n_to_litr_met_n - phenology_n_to_litr_cel_n => cnf%phenology_n_to_litr_cel_n - phenology_n_to_litr_lig_n => cnf%phenology_n_to_litr_lig_n - - ! new pointers for dynamic landcover - dwt_seedn_to_leaf => cnf%dwt_seedn_to_leaf - dwt_seedn_to_deadstem => cnf%dwt_seedn_to_deadstem - dwt_frootn_to_litr_met_n => cnf%dwt_frootn_to_litr_met_n - dwt_frootn_to_litr_cel_n => cnf%dwt_frootn_to_litr_cel_n - dwt_frootn_to_litr_lig_n => cnf%dwt_frootn_to_litr_lig_n - dwt_livecrootn_to_cwdn => cnf%dwt_livecrootn_to_cwdn - dwt_deadcrootn_to_cwdn => cnf%dwt_deadcrootn_to_cwdn - seedn => cns%seedn - - - ! assign local pointers at the pft level - ivt =>pft%itype - deadcrootn_storage_to_xfer => pnf%deadcrootn_storage_to_xfer - deadcrootn_xfer_to_deadcrootn => pnf%deadcrootn_xfer_to_deadcrootn - deadstemn_storage_to_xfer => pnf%deadstemn_storage_to_xfer - deadstemn_xfer_to_deadstemn => pnf%deadstemn_xfer_to_deadstemn - frootn_storage_to_xfer => pnf%frootn_storage_to_xfer - frootn_to_litter => pnf%frootn_to_litter - frootn_to_retransn => pnf%frootn_to_retransn - frootn_xfer_to_frootn => pnf%frootn_xfer_to_frootn - leafn_storage_to_xfer => pnf%leafn_storage_to_xfer - leafn_to_litter => pnf%leafn_to_litter - leafn_to_retransn => pnf%leafn_to_retransn - leafn_xfer_to_leafn => pnf%leafn_xfer_to_leafn - livecrootn_storage_to_xfer => pnf%livecrootn_storage_to_xfer - livecrootn_to_deadcrootn => pnf%livecrootn_to_deadcrootn - livecrootn_to_retransn => pnf%livecrootn_to_retransn - livecrootn_xfer_to_livecrootn => pnf%livecrootn_xfer_to_livecrootn - livestemn_storage_to_xfer => pnf%livestemn_storage_to_xfer - livestemn_to_deadstemn => pnf%livestemn_to_deadstemn - livestemn_to_retransn => pnf%livestemn_to_retransn - livestemn_xfer_to_livestemn => pnf%livestemn_xfer_to_livestemn - npool_to_deadcrootn => pnf%npool_to_deadcrootn - npool_to_deadcrootn_storage => pnf%npool_to_deadcrootn_storage - npool_to_deadstemn => pnf%npool_to_deadstemn - npool_to_deadstemn_storage => pnf%npool_to_deadstemn_storage - npool_to_frootn => pnf%npool_to_frootn - npool_to_frootn_storage => pnf%npool_to_frootn_storage - npool_to_leafn => pnf%npool_to_leafn - npool_to_leafn_storage => pnf%npool_to_leafn_storage - npool_to_livecrootn => pnf%npool_to_livecrootn - npool_to_livecrootn_storage => pnf%npool_to_livecrootn_storage - npool_to_livestemn => pnf%npool_to_livestemn - npool_to_livestemn_storage => pnf%npool_to_livestemn_storage - retransn_to_npool => pnf%retransn_to_npool - sminn_to_npool => pnf%sminn_to_npool - grainn_storage_to_xfer => pnf%grainn_storage_to_xfer - grainn_to_food => pnf%grainn_to_food - grainn_xfer_to_grainn => pnf%grainn_xfer_to_grainn - livestemn_to_litter => pnf%livestemn_to_litter - npool_to_grainn => pnf%npool_to_grainn - npool_to_grainn_storage => pnf%npool_to_grainn_storage - grainn => pns%grainn - grainn_storage => pns%grainn_storage - grainn_xfer => pns%grainn_xfer - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - npool => pns%npool - retransn => pns%retransn - - ! set time steps - dt = real( get_step_size(), r8 ) - ! column-level fluxes - - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - ! seeding fluxes, from dynamic landcover - seedn(c) = seedn(c) - dwt_seedn_to_leaf(c) * dt - seedn(c) = seedn(c) - dwt_seedn_to_deadstem(c) * dt - end do - - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - -#ifndef NITRIF_DENITRIF - ! N deposition and fixation - sminn_vr(c,j) = sminn_vr(c,j) + ndep_to_sminn(c)*dt * ndep_prof(c,j) - sminn_vr(c,j) = sminn_vr(c,j) + nfix_to_sminn(c)*dt * nfixation_prof(c,j) -#else - ! N deposition and fixation (put all into NH4 pool) - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) + ndep_to_sminn(c)*dt * ndep_prof(c,j) - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) + nfix_to_sminn(c)*dt * nfixation_prof(c,j) -#endif - - ! plant to litter fluxes - ! phenology and dynamic landcover fluxes - decomp_npools_sourcesink(c,j,i_met_lit) = ( phenology_n_to_litr_met_n(c,j) + dwt_frootn_to_litr_met_n(c,j) ) *dt - decomp_npools_sourcesink(c,j,i_cel_lit) = ( phenology_n_to_litr_cel_n(c,j) + dwt_frootn_to_litr_cel_n(c,j) ) *dt - decomp_npools_sourcesink(c,j,i_lig_lit) = ( phenology_n_to_litr_lig_n(c,j) + dwt_frootn_to_litr_lig_n(c,j) ) *dt - decomp_npools_sourcesink(c,j,i_cwd) = ( dwt_livecrootn_to_cwdn(c,j) + dwt_deadcrootn_to_cwdn(c,j) )*dt - - end do - end do - - ! repeating N dep and fixation for crops - if ( crop_prog )then - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) -#ifndef NITRIF_DENITRIF - ! N deposition and fixation - sminn_vr(c,j) = sminn_vr(c,j) + fert_to_sminn(c)*dt * ndep_prof(c,j) - sminn_vr(c,j) = sminn_vr(c,j) + soyfixn_to_sminn(c)*dt * nfixation_prof(c,j) -#else - ! N deposition and fixation (put all into NH4 pool) - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) + fert_to_sminn(c)*dt * ndep_prof(c,j) - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) + soyfixn_to_sminn(c)*dt * nfixation_prof(c,j) -#endif - end do - end do - end if - - ! decomposition fluxes - do k = 1, ndecomp_cascade_transitions - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools_sourcesink(c,j,cascade_donor_pool(k)) = decomp_npools_sourcesink(c,j,cascade_donor_pool(k)) - & - decomp_cascade_ntransfer_vr(c,j,k) * dt - end do - end do - end do - do k = 1, ndecomp_cascade_transitions - if ( cascade_receiver_pool(k) .ne. 0 ) then ! skip terminal transitions - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools_sourcesink(c,j,cascade_receiver_pool(k)) = decomp_npools_sourcesink(c,j,cascade_receiver_pool(k)) + & - (decomp_cascade_ntransfer_vr(c,j,k) + decomp_cascade_sminn_flux_vr(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) - decomp_npools_sourcesink(c,j,cascade_donor_pool(k)) = decomp_npools_sourcesink(c,j,cascade_donor_pool(k)) - & - decomp_cascade_sminn_flux_vr(c,j,k) * dt - end do - end do - end if - end do - -#ifndef NITRIF_DENITRIF - ! 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) .ne. 0 ) then ! skip terminal transitions - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - sminn_vr(c,j) = sminn_vr(c,j) - & - (sminn_to_denit_decomp_cascade_vr(c,j,k) + decomp_cascade_sminn_flux_vr(c,j,k))* dt - end do - end do - else - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - sminn_vr(c,j) = sminn_vr(c,j) - sminn_to_denit_decomp_cascade_vr(c,j,k)* dt - sminn_vr(c,j) = sminn_vr(c,j) + decomp_cascade_sminn_flux_vr(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" - sminn_vr(c,j) = sminn_vr(c,j) - sminn_to_denit_excess_vr(c,j) * dt - - ! total plant uptake from mineral N - sminn_vr(c,j) = sminn_vr(c,j) - sminn_to_plant_vr(c,j)*dt - - ! flux that prevents N limitation (when Carbon_only is set) - sminn_vr(c,j) = sminn_vr(c,j) + supplement_to_sminn_vr(c,j)*dt - end do - end do - -#else !------------- NITRIF_DENITRIF -------------------- - - 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) - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) + gross_nmin_vr(c,j)*dt - - ! immobilization fluxes - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) - actual_immob_nh4_vr(c,j)*dt - smin_no3_vr(c,j) = smin_no3_vr(c,j) - actual_immob_no3_vr(c,j)*dt - - ! plant uptake fluxes - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) - smin_nh4_to_plant_vr(c,j)*dt - smin_no3_vr(c,j) = smin_no3_vr(c,j) - smin_no3_to_plant_vr(c,j)*dt - - ! Account for nitrification fluxes - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) - f_nit_vr(c,j) * dt - smin_no3_vr(c,j) = smin_no3_vr(c,j) + f_nit_vr(c,j) * dt * (1._r8 - nitrif_n2o_loss_frac) - ! Account for denitrification fluxes - smin_no3_vr(c,j) = smin_no3_vr(c,j) - f_denit_vr(c,j) * dt - - ! flux that prevents N limitation (when Carbon_only is set; put all into NH4) - smin_nh4_vr(c,j) = smin_nh4_vr(c,j) + supplement_to_sminn_vr(c,j)*dt - - ! update diagnostic total - sminn_vr(c,j) = smin_nh4_vr(c,j) + smin_no3_vr(c,j) - - end do ! end of column loop - end do -#endif - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! phenology: transfer growth fluxes - leafn(p) = leafn(p) + leafn_xfer_to_leafn(p)*dt - leafn_xfer(p) = leafn_xfer(p) - leafn_xfer_to_leafn(p)*dt - frootn(p) = frootn(p) + frootn_xfer_to_frootn(p)*dt - frootn_xfer(p) = frootn_xfer(p) - frootn_xfer_to_frootn(p)*dt - if (woody(ivt(p)) == 1.0_r8) then - livestemn(p) = livestemn(p) + livestemn_xfer_to_livestemn(p)*dt - livestemn_xfer(p) = livestemn_xfer(p) - livestemn_xfer_to_livestemn(p)*dt - deadstemn(p) = deadstemn(p) + deadstemn_xfer_to_deadstemn(p)*dt - deadstemn_xfer(p) = deadstemn_xfer(p) - deadstemn_xfer_to_deadstemn(p)*dt - livecrootn(p) = livecrootn(p) + livecrootn_xfer_to_livecrootn(p)*dt - livecrootn_xfer(p) = livecrootn_xfer(p) - livecrootn_xfer_to_livecrootn(p)*dt - deadcrootn(p) = deadcrootn(p) + deadcrootn_xfer_to_deadcrootn(p)*dt - deadcrootn_xfer(p) = deadcrootn_xfer(p) - deadcrootn_xfer_to_deadcrootn(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - ! lines here for consistency; the transfer terms are zero - livestemn(p) = livestemn(p) + livestemn_xfer_to_livestemn(p)*dt - livestemn_xfer(p) = livestemn_xfer(p) - livestemn_xfer_to_livestemn(p)*dt - grainn(p) = grainn(p) + grainn_xfer_to_grainn(p)*dt - grainn_xfer(p) = grainn_xfer(p) - grainn_xfer_to_grainn(p)*dt - end if - - ! phenology: litterfall and retranslocation fluxes - leafn(p) = leafn(p) - leafn_to_litter(p)*dt - frootn(p) = frootn(p) - frootn_to_litter(p)*dt - leafn(p) = leafn(p) - leafn_to_retransn(p)*dt - retransn(p) = retransn(p) + leafn_to_retransn(p)*dt - - ! live wood turnover and retranslocation fluxes - if (woody(ivt(p)) == 1._r8) then - livestemn(p) = livestemn(p) - livestemn_to_deadstemn(p)*dt - deadstemn(p) = deadstemn(p) + livestemn_to_deadstemn(p)*dt - livestemn(p) = livestemn(p) - livestemn_to_retransn(p)*dt - retransn(p) = retransn(p) + livestemn_to_retransn(p)*dt - livecrootn(p) = livecrootn(p) - livecrootn_to_deadcrootn(p)*dt - deadcrootn(p) = deadcrootn(p) + livecrootn_to_deadcrootn(p)*dt - livecrootn(p) = livecrootn(p) - livecrootn_to_retransn(p)*dt - retransn(p) = retransn(p) + livecrootn_to_retransn(p)*dt - end if - if (ivt(p) >= npcropmin) then ! Beth adds retrans from froot - frootn(p) = frootn(p) - frootn_to_retransn(p)*dt - retransn(p) = retransn(p) + frootn_to_retransn(p)*dt - livestemn(p) = livestemn(p) - livestemn_to_litter(p)*dt - livestemn(p) = livestemn(p) - livestemn_to_retransn(p)*dt - retransn(p) = retransn(p) + livestemn_to_retransn(p)*dt - grainn(p) = grainn(p) - grainn_to_food(p)*dt - end if - - ! uptake from soil mineral N pool - npool(p) = npool(p) + sminn_to_npool(p)*dt - - ! deployment from retranslocation pool - npool(p) = npool(p) + retransn_to_npool(p)*dt - retransn(p) = retransn(p) - retransn_to_npool(p)*dt - - ! allocation fluxes - npool(p) = npool(p) - npool_to_leafn(p)*dt - leafn(p) = leafn(p) + npool_to_leafn(p)*dt - npool(p) = npool(p) - npool_to_leafn_storage(p)*dt - leafn_storage(p) = leafn_storage(p) + npool_to_leafn_storage(p)*dt - npool(p) = npool(p) - npool_to_frootn(p)*dt - frootn(p) = frootn(p) + npool_to_frootn(p)*dt - npool(p) = npool(p) - npool_to_frootn_storage(p)*dt - frootn_storage(p) = frootn_storage(p) + npool_to_frootn_storage(p)*dt - if (woody(ivt(p)) == 1._r8) then - npool(p) = npool(p) - npool_to_livestemn(p)*dt - livestemn(p) = livestemn(p) + npool_to_livestemn(p)*dt - npool(p) = npool(p) - npool_to_livestemn_storage(p)*dt - livestemn_storage(p) = livestemn_storage(p) + npool_to_livestemn_storage(p)*dt - npool(p) = npool(p) - npool_to_deadstemn(p)*dt - deadstemn(p) = deadstemn(p) + npool_to_deadstemn(p)*dt - npool(p) = npool(p) - npool_to_deadstemn_storage(p)*dt - deadstemn_storage(p) = deadstemn_storage(p) + npool_to_deadstemn_storage(p)*dt - npool(p) = npool(p) - npool_to_livecrootn(p)*dt - livecrootn(p) = livecrootn(p) + npool_to_livecrootn(p)*dt - npool(p) = npool(p) - npool_to_livecrootn_storage(p)*dt - livecrootn_storage(p) = livecrootn_storage(p) + npool_to_livecrootn_storage(p)*dt - npool(p) = npool(p) - npool_to_deadcrootn(p)*dt - deadcrootn(p) = deadcrootn(p) + npool_to_deadcrootn(p)*dt - npool(p) = npool(p) - npool_to_deadcrootn_storage(p)*dt - deadcrootn_storage(p) = deadcrootn_storage(p) + npool_to_deadcrootn_storage(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - npool(p) = npool(p) - npool_to_livestemn(p)*dt - livestemn(p) = livestemn(p) + npool_to_livestemn(p)*dt - npool(p) = npool(p) - npool_to_livestemn_storage(p)*dt - livestemn_storage(p) = livestemn_storage(p) + npool_to_livestemn_storage(p)*dt - npool(p) = npool(p) - npool_to_grainn(p)*dt - grainn(p) = grainn(p) + npool_to_grainn(p)*dt - npool(p) = npool(p) - npool_to_grainn_storage(p)*dt - grainn_storage(p) = grainn_storage(p) + npool_to_grainn_storage(p)*dt - end if - - ! move storage pools into transfer pools - leafn_storage(p) = leafn_storage(p) - leafn_storage_to_xfer(p)*dt - leafn_xfer(p) = leafn_xfer(p) + leafn_storage_to_xfer(p)*dt - frootn_storage(p) = frootn_storage(p) - frootn_storage_to_xfer(p)*dt - frootn_xfer(p) = frootn_xfer(p) + frootn_storage_to_xfer(p)*dt - if (woody(ivt(p)) == 1._r8) then - livestemn_storage(p) = livestemn_storage(p) - livestemn_storage_to_xfer(p)*dt - livestemn_xfer(p) = livestemn_xfer(p) + livestemn_storage_to_xfer(p)*dt - deadstemn_storage(p) = deadstemn_storage(p) - deadstemn_storage_to_xfer(p)*dt - deadstemn_xfer(p) = deadstemn_xfer(p) + deadstemn_storage_to_xfer(p)*dt - livecrootn_storage(p) = livecrootn_storage(p) - livecrootn_storage_to_xfer(p)*dt - livecrootn_xfer(p) = livecrootn_xfer(p) + livecrootn_storage_to_xfer(p)*dt - deadcrootn_storage(p) = deadcrootn_storage(p) - deadcrootn_storage_to_xfer(p)*dt - deadcrootn_xfer(p) = deadcrootn_xfer(p) + deadcrootn_storage_to_xfer(p)*dt - end if - if (ivt(p) >= npcropmin) then ! skip 2 generic crops - ! lines here for consistency; the transfer terms are zero - livestemn_storage(p) = livestemn_storage(p) - livestemn_storage_to_xfer(p)*dt - livestemn_xfer(p) = livestemn_xfer(p) + livestemn_storage_to_xfer(p)*dt - grainn_storage(p) = grainn_storage(p) - grainn_storage_to_xfer(p)*dt - grainn_xfer(p) = grainn_xfer(p) + grainn_storage_to_xfer(p)*dt - end if - -! if (livestemn(p)<0) then -! print *, 'tileid_soilp(p),ivt(p),livestemn(p),livestemn_xfer_to_livestemn(p)',tileid_soilp(p),ivt(p),livestemn(p),livestemn_xfer_to_livestemn(p) -! print *, 'livestemn_to_litter(p),livestemn_to_retransn(p)',livestemn_to_litter(p),livestemn_to_retransn(p) -! print *, 'npool_to_livestemn(p)',npool_to_livestemn(p) -! stop -! end if - - end do - -end subroutine NStateUpdate1 -!----------------------------------------------------------------------- - -!#endif - -end module CNNStateUpdate1Mod 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 deleted file mode 100644 index 28dd8fe4a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate2Mod.F90 +++ /dev/null @@ -1,412 +0,0 @@ - -module CNNStateUpdate2Mod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: NStateUpdate2Mod -! -! !DESCRIPTION: -! Module for nitrogen state variable update, mortality fluxes. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varpar , only: nlevsoi, nlevdecomp - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: NStateUpdate2 - public:: NStateUpdate2h -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: NStateUpdate2 -! -! !INTERFACE: -subroutine NStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! On the radiation time step, update all the prognostic nitrogen state -! variables affected by gap-phase mortality fluxes -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varctl , only: iulog - use clm_varpar , only: i_met_lit, i_cel_lit, i_lig_lit, i_cwd -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 8/1/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - real(r8), pointer :: gap_mortality_n_to_litr_met_n(:,:) ! N fluxes associated with gap mortality to litter metabolic pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_litr_cel_n(:,:) ! N fluxes associated with gap mortality to litter cellulose pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_litr_lig_n(:,:) ! N fluxes associated with gap mortality to litter lignin pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_cwdn(:,:) ! N fluxes associated with gap mortality to CWD pool (gN/m3/s) - real(r8), pointer :: m_deadcrootn_storage_to_litter(:) - real(r8), pointer :: m_deadcrootn_to_litter(:) - real(r8), pointer :: m_deadcrootn_xfer_to_litter(:) - real(r8), pointer :: m_deadstemn_storage_to_litter(:) - real(r8), pointer :: m_deadstemn_to_litter(:) - real(r8), pointer :: m_deadstemn_xfer_to_litter(:) - real(r8), pointer :: m_frootn_storage_to_litter(:) - real(r8), pointer :: m_frootn_to_litter(:) - real(r8), pointer :: m_frootn_xfer_to_litter(:) - real(r8), pointer :: m_leafn_storage_to_litter(:) - real(r8), pointer :: m_leafn_to_litter(:) - real(r8), pointer :: m_leafn_xfer_to_litter(:) - real(r8), pointer :: m_livecrootn_storage_to_litter(:) - real(r8), pointer :: m_livecrootn_to_litter(:) - real(r8), pointer :: m_livecrootn_xfer_to_litter(:) - real(r8), pointer :: m_livestemn_storage_to_litter(:) - real(r8), pointer :: m_livestemn_to_litter(:) - real(r8), pointer :: m_livestemn_xfer_to_litter(:) - real(r8), pointer :: m_retransn_to_litter(:) -! -! local pointers to implicit in/out scalars - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: c,p,j,l ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers at the column level - gap_mortality_n_to_litr_met_n => cnf%gap_mortality_n_to_litr_met_n - gap_mortality_n_to_litr_cel_n => cnf%gap_mortality_n_to_litr_cel_n - gap_mortality_n_to_litr_lig_n => cnf%gap_mortality_n_to_litr_lig_n - gap_mortality_n_to_cwdn => cnf%gap_mortality_n_to_cwdn - decomp_npools_vr => cns%decomp_npools_vr - ! assign local pointers at the pft level - m_deadcrootn_storage_to_litter => pnf%m_deadcrootn_storage_to_litter - m_deadcrootn_to_litter => pnf%m_deadcrootn_to_litter - m_deadcrootn_xfer_to_litter => pnf%m_deadcrootn_xfer_to_litter - m_deadstemn_storage_to_litter => pnf%m_deadstemn_storage_to_litter - m_deadstemn_to_litter => pnf%m_deadstemn_to_litter - m_deadstemn_xfer_to_litter => pnf%m_deadstemn_xfer_to_litter - m_frootn_storage_to_litter => pnf%m_frootn_storage_to_litter - m_frootn_to_litter => pnf%m_frootn_to_litter - m_frootn_xfer_to_litter => pnf%m_frootn_xfer_to_litter - m_leafn_storage_to_litter => pnf%m_leafn_storage_to_litter - m_leafn_to_litter => pnf%m_leafn_to_litter - m_leafn_xfer_to_litter => pnf%m_leafn_xfer_to_litter - m_livecrootn_storage_to_litter => pnf%m_livecrootn_storage_to_litter - m_livecrootn_to_litter => pnf%m_livecrootn_to_litter - m_livecrootn_xfer_to_litter => pnf%m_livecrootn_xfer_to_litter - m_livestemn_storage_to_litter => pnf%m_livestemn_storage_to_litter - m_livestemn_to_litter => pnf%m_livestemn_to_litter - m_livestemn_xfer_to_litter => pnf%m_livestemn_xfer_to_litter - m_retransn_to_litter => pnf%m_retransn_to_litter - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - retransn => pns%retransn - - ! set time steps - dt = real( get_step_size(), r8 ) - - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! column-level nitrogen fluxes from gap-phase mortality - decomp_npools_vr(c,j,i_met_lit) = decomp_npools_vr(c,j,i_met_lit) + gap_mortality_n_to_litr_met_n(c,j) * dt - decomp_npools_vr(c,j,i_cel_lit) = decomp_npools_vr(c,j,i_cel_lit) + gap_mortality_n_to_litr_cel_n(c,j) * dt - decomp_npools_vr(c,j,i_lig_lit) = decomp_npools_vr(c,j,i_lig_lit) + gap_mortality_n_to_litr_lig_n(c,j) * dt - decomp_npools_vr(c,j,i_cwd) = decomp_npools_vr(c,j,i_cwd) + gap_mortality_n_to_cwdn(c,j) * dt - - end do ! end of column loop - end do - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! pft-level nitrogen fluxes from gap-phase mortality - ! displayed pools - leafn(p) = leafn(p) - m_leafn_to_litter(p) * dt - frootn(p) = frootn(p) - m_frootn_to_litter(p) * dt - livestemn(p) = livestemn(p) - m_livestemn_to_litter(p) * dt - deadstemn(p) = deadstemn(p) - m_deadstemn_to_litter(p) * dt - livecrootn(p) = livecrootn(p) - m_livecrootn_to_litter(p) * dt - deadcrootn(p) = deadcrootn(p) - m_deadcrootn_to_litter(p) * dt - retransn(p) = retransn(p) - m_retransn_to_litter(p) * dt - - ! storage pools - leafn_storage(p) = leafn_storage(p) - m_leafn_storage_to_litter(p) * dt - frootn_storage(p) = frootn_storage(p) - m_frootn_storage_to_litter(p) * dt - livestemn_storage(p) = livestemn_storage(p) - m_livestemn_storage_to_litter(p) * dt - deadstemn_storage(p) = deadstemn_storage(p) - m_deadstemn_storage_to_litter(p) * dt - livecrootn_storage(p) = livecrootn_storage(p) - m_livecrootn_storage_to_litter(p) * dt - deadcrootn_storage(p) = deadcrootn_storage(p) - m_deadcrootn_storage_to_litter(p) * dt - - ! transfer pools - leafn_xfer(p) = leafn_xfer(p) - m_leafn_xfer_to_litter(p) * dt - frootn_xfer(p) = frootn_xfer(p) - m_frootn_xfer_to_litter(p) * dt - livestemn_xfer(p) = livestemn_xfer(p) - m_livestemn_xfer_to_litter(p) * dt - deadstemn_xfer(p) = deadstemn_xfer(p) - m_deadstemn_xfer_to_litter(p) * dt - livecrootn_xfer(p) = livecrootn_xfer(p) - m_livecrootn_xfer_to_litter(p) * dt - deadcrootn_xfer(p) = deadcrootn_xfer(p) - m_deadcrootn_xfer_to_litter(p) * dt - - end do - -end subroutine NStateUpdate2 -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: NStateUpdate2h -! -! !INTERFACE: -subroutine NStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! Update all the prognostic nitrogen state -! variables affected by harvest mortality fluxes -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varpar , only: i_met_lit, i_cel_lit, i_lig_lit, i_cwd -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 8/1/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - real(r8), pointer :: harvest_n_to_litr_met_n(:,:) ! N fluxes associated with harvest to litter metabolic pool (gN/m3/s) - real(r8), pointer :: harvest_n_to_litr_cel_n(:,:) ! N fluxes associated with harvest to litter cellulose pool (gN/m3/s) - real(r8), pointer :: harvest_n_to_litr_lig_n(:,:) ! N fluxes associated with harvest to litter lignin pool (gN/m3/s) - real(r8), pointer :: harvest_n_to_cwdn(:,:) ! N fluxes associated with harvest to CWD pool (gN/m3/s) - real(r8), pointer :: hrv_deadcrootn_storage_to_litter(:) - real(r8), pointer :: hrv_deadcrootn_to_litter(:) - real(r8), pointer :: hrv_deadcrootn_xfer_to_litter(:) - real(r8), pointer :: hrv_deadstemn_storage_to_litter(:) - real(r8), pointer :: hrv_deadstemn_to_prod10n(:) - real(r8), pointer :: hrv_deadstemn_to_prod100n(:) - real(r8), pointer :: hrv_deadstemn_xfer_to_litter(:) - real(r8), pointer :: hrv_frootn_storage_to_litter(:) - real(r8), pointer :: hrv_frootn_to_litter(:) - real(r8), pointer :: hrv_frootn_xfer_to_litter(:) - real(r8), pointer :: hrv_leafn_storage_to_litter(:) - real(r8), pointer :: hrv_leafn_to_litter(:) - real(r8), pointer :: hrv_leafn_xfer_to_litter(:) - real(r8), pointer :: hrv_livecrootn_storage_to_litter(:) - real(r8), pointer :: hrv_livecrootn_to_litter(:) - real(r8), pointer :: hrv_livecrootn_xfer_to_litter(:) - real(r8), pointer :: hrv_livestemn_storage_to_litter(:) - real(r8), pointer :: hrv_livestemn_to_litter(:) - real(r8), pointer :: hrv_livestemn_xfer_to_litter(:) - real(r8), pointer :: hrv_retransn_to_litter(:) -! -! local pointers to implicit in/out scalars - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: c,p,j,l ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers at the column level - harvest_n_to_litr_met_n => cnf%harvest_n_to_litr_met_n - harvest_n_to_litr_cel_n => cnf%harvest_n_to_litr_cel_n - harvest_n_to_litr_lig_n => cnf%harvest_n_to_litr_lig_n - harvest_n_to_cwdn => cnf%harvest_n_to_cwdn - decomp_npools_vr => cns%decomp_npools_vr - - ! assign local pointers at the pft level - hrv_deadcrootn_storage_to_litter => pnf%hrv_deadcrootn_storage_to_litter - hrv_deadcrootn_to_litter => pnf%hrv_deadcrootn_to_litter - hrv_deadcrootn_xfer_to_litter => pnf%hrv_deadcrootn_xfer_to_litter - hrv_deadstemn_storage_to_litter => pnf%hrv_deadstemn_storage_to_litter - hrv_deadstemn_to_prod10n => pnf%hrv_deadstemn_to_prod10n - hrv_deadstemn_to_prod100n => pnf%hrv_deadstemn_to_prod100n - hrv_deadstemn_xfer_to_litter => pnf%hrv_deadstemn_xfer_to_litter - hrv_frootn_storage_to_litter => pnf%hrv_frootn_storage_to_litter - hrv_frootn_to_litter => pnf%hrv_frootn_to_litter - hrv_frootn_xfer_to_litter => pnf%hrv_frootn_xfer_to_litter - hrv_leafn_storage_to_litter => pnf%hrv_leafn_storage_to_litter - hrv_leafn_to_litter => pnf%hrv_leafn_to_litter - hrv_leafn_xfer_to_litter => pnf%hrv_leafn_xfer_to_litter - hrv_livecrootn_storage_to_litter => pnf%hrv_livecrootn_storage_to_litter - hrv_livecrootn_to_litter => pnf%hrv_livecrootn_to_litter - hrv_livecrootn_xfer_to_litter => pnf%hrv_livecrootn_xfer_to_litter - hrv_livestemn_storage_to_litter => pnf%hrv_livestemn_storage_to_litter - hrv_livestemn_to_litter => pnf%hrv_livestemn_to_litter - hrv_livestemn_xfer_to_litter => pnf%hrv_livestemn_xfer_to_litter - hrv_retransn_to_litter => pnf%hrv_retransn_to_litter - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - retransn => pns%retransn - - ! set time steps - dt = real( get_step_size(), r8 ) - - do j = 1,nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! column-level nitrogen fluxes from harvest mortality - decomp_npools_vr(c,j,i_met_lit) = decomp_npools_vr(c,j,i_met_lit) + harvest_n_to_litr_met_n(c,j) * dt - decomp_npools_vr(c,j,i_cel_lit) = decomp_npools_vr(c,j,i_cel_lit) + harvest_n_to_litr_cel_n(c,j) * dt - decomp_npools_vr(c,j,i_lig_lit) = decomp_npools_vr(c,j,i_lig_lit) + harvest_n_to_litr_lig_n(c,j) * dt - decomp_npools_vr(c,j,i_cwd) = decomp_npools_vr(c,j,i_cwd) + harvest_n_to_cwdn(c,j) * dt - - end do ! end of column loop - end do - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! pft-level nitrogen fluxes from harvest mortality - ! displayed pools - leafn(p) = leafn(p) - hrv_leafn_to_litter(p) * dt - frootn(p) = frootn(p) - hrv_frootn_to_litter(p) * dt - livestemn(p) = livestemn(p) - hrv_livestemn_to_litter(p) * dt - deadstemn(p) = deadstemn(p) - hrv_deadstemn_to_prod10n(p) * dt - deadstemn(p) = deadstemn(p) - hrv_deadstemn_to_prod100n(p)* dt - livecrootn(p) = livecrootn(p) - hrv_livecrootn_to_litter(p) * dt - deadcrootn(p) = deadcrootn(p) - hrv_deadcrootn_to_litter(p) * dt - retransn(p) = retransn(p) - hrv_retransn_to_litter(p) * dt - - ! storage pools - leafn_storage(p) = leafn_storage(p) - hrv_leafn_storage_to_litter(p) * dt - frootn_storage(p) = frootn_storage(p) - hrv_frootn_storage_to_litter(p) * dt - livestemn_storage(p) = livestemn_storage(p) - hrv_livestemn_storage_to_litter(p) * dt - deadstemn_storage(p) = deadstemn_storage(p) - hrv_deadstemn_storage_to_litter(p) * dt - livecrootn_storage(p) = livecrootn_storage(p) - hrv_livecrootn_storage_to_litter(p) * dt - deadcrootn_storage(p) = deadcrootn_storage(p) - hrv_deadcrootn_storage_to_litter(p) * dt - - ! transfer pools - leafn_xfer(p) = leafn_xfer(p) - hrv_leafn_xfer_to_litter(p) * dt - frootn_xfer(p) = frootn_xfer(p) - hrv_frootn_xfer_to_litter(p) * dt - livestemn_xfer(p) = livestemn_xfer(p) - hrv_livestemn_xfer_to_litter(p) * dt - deadstemn_xfer(p) = deadstemn_xfer(p) - hrv_deadstemn_xfer_to_litter(p) * dt - livecrootn_xfer(p) = livecrootn_xfer(p) - hrv_livecrootn_xfer_to_litter(p) * dt - deadcrootn_xfer(p) = deadcrootn_xfer(p) - hrv_deadcrootn_xfer_to_litter(p) * dt - - end do - -end subroutine NStateUpdate2h -!----------------------------------------------------------------------- - -!#endif - -end module CNNStateUpdate2Mod 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 deleted file mode 100644 index 9b9ac68b5..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNStateUpdate3Mod.F90 +++ /dev/null @@ -1,332 +0,0 @@ - -module CNNStateUpdate3Mod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: NStateUpdate3Mod -! -! !DESCRIPTION: -! Module for nitrogen state variable update, mortality fluxes. -! Also, sminn leaching flux. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varpar , only: nlevdecomp, ndecomp_pools - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: NStateUpdate3 -! -! !REVISION HISTORY: -! 7/27/2004: Created by Peter Thornton -! F. Li and S. Levis (11/06/12) -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: NStateUpdate3 -! -! !INTERFACE: -subroutine NStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! On the radiation time step, update all the prognostic nitrogen state -! variables affected by gap-phase mortality fluxes. Also the Sminn leaching flux. -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varctl , only: iulog - use clm_varpar , only: i_cwd, i_met_lit, i_cel_lit, i_lig_lit -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 8/1/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -#ifndef NITRIF_DENITRIF - real(r8), pointer :: sminn_leached_vr(:,:) -#else - real(r8), pointer :: smin_no3_leached_vr(:,:) - real(r8), pointer :: smin_no3_runoff_vr(:,:) ! vertically-resolved rate of mineral NO3 loss with runoff (gN/m3/s) - real(r8), pointer :: smin_no3_vr(:,:) - real(r8), pointer :: smin_nh4_vr(:,:) -#endif - real(r8), pointer :: m_leafn_to_fire(:) - real(r8), pointer :: m_leafn_storage_to_fire(:) - real(r8), pointer :: m_leafn_xfer_to_fire(:) - real(r8), pointer :: m_livestemn_to_fire(:) - real(r8), pointer :: m_livestemn_storage_to_fire(:) - real(r8), pointer :: m_livestemn_xfer_to_fire(:) - real(r8), pointer :: m_deadstemn_to_fire(:) - real(r8), pointer :: m_deadstemn_storage_to_fire(:) - real(r8), pointer :: m_deadstemn_xfer_to_fire(:) - real(r8), pointer :: m_frootn_to_fire(:) - real(r8), pointer :: m_frootn_storage_to_fire(:) - real(r8), pointer :: m_frootn_xfer_to_fire(:) - real(r8), pointer :: m_livecrootn_to_fire(:) - real(r8), pointer :: m_livecrootn_storage_to_fire(:) - real(r8), pointer :: m_livecrootn_xfer_to_fire(:) - real(r8), pointer :: m_deadcrootn_to_fire(:) - real(r8), pointer :: m_deadcrootn_storage_to_fire(:) - real(r8), pointer :: m_deadcrootn_xfer_to_fire(:) - real(r8), pointer :: m_retransn_to_fire(:) - real(r8), pointer :: m_decomp_npools_to_fire_vr(:,:,:) - - real(r8), pointer :: m_leafn_to_litter_fire(:) - real(r8), pointer :: m_leafn_storage_to_litter_fire(:) - real(r8), pointer :: m_leafn_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemn_to_litter_fire(:) - real(r8), pointer :: m_livestemn_storage_to_litter_fire(:) - real(r8), pointer :: m_livestemn_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemn_to_deadstemn_fire(:) - real(r8), pointer :: m_deadstemn_to_litter_fire(:) - real(r8), pointer :: m_deadstemn_storage_to_litter_fire(:) - real(r8), pointer :: m_deadstemn_xfer_to_litter_fire(:) - real(r8), pointer :: m_frootn_to_litter_fire(:) - real(r8), pointer :: m_frootn_storage_to_litter_fire(:) - real(r8), pointer :: m_frootn_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootn_to_litter_fire(:) - real(r8), pointer :: m_livecrootn_storage_to_litter_fire(:) - real(r8), pointer :: m_livecrootn_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootn_to_deadcrootn_fire(:) - real(r8), pointer :: m_deadcrootn_to_litter_fire(:) - real(r8), pointer :: m_deadcrootn_storage_to_litter_fire(:) - real(r8), pointer :: m_deadcrootn_xfer_to_litter_fire(:) - real(r8), pointer :: m_retransn_to_litter_fire(:) - real(r8), pointer :: m_n_to_litr_met_fire(:,:) - real(r8), pointer :: m_n_to_litr_cel_fire(:,:) - real(r8), pointer :: m_n_to_litr_lig_fire(:,:) - real(r8), pointer :: fire_mortality_n_to_cwdn(:,:) ! N fluxes associated with fire mortality to CWD pool (gN/m3/s) -! -! local pointers to implicit in/out scalars - real(r8), pointer :: sminn_vr(:,:) ! (gN/m3) soil mineral N - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: - integer :: c,p,j,l,k ! indices - integer :: fp,fc ! lake filter indices - real(r8):: dt ! radiation time step (seconds) - -!EOP -!----------------------------------------------------------------------- - - ! assign local pointers at the column level - fire_mortality_n_to_cwdn => cnf%fire_mortality_n_to_cwdn -#ifndef NITRIF_DENITRIF - sminn_leached_vr => cnf%sminn_leached_vr -#else - smin_no3_leached_vr => cnf%smin_no3_leached_vr - smin_no3_runoff_vr => cnf%smin_no3_runoff_vr - smin_no3_vr => cns%smin_no3_vr - smin_nh4_vr => cns%smin_nh4_vr -#endif - m_decomp_npools_to_fire_vr => cnf%m_decomp_npools_to_fire_vr - m_n_to_litr_met_fire => cnf%m_n_to_litr_met_fire - m_n_to_litr_cel_fire => cnf%m_n_to_litr_cel_fire - m_n_to_litr_lig_fire => cnf%m_n_to_litr_lig_fire - - decomp_npools_vr => cns%decomp_npools_vr - sminn_vr => cns%sminn_vr - - ! assign local pointers at the pft level - m_leafn_to_fire => pnf%m_leafn_to_fire - m_leafn_storage_to_fire => pnf%m_leafn_storage_to_fire - m_leafn_xfer_to_fire => pnf%m_leafn_xfer_to_fire - m_livestemn_to_fire => pnf%m_livestemn_to_fire - m_livestemn_storage_to_fire => pnf%m_livestemn_storage_to_fire - m_livestemn_xfer_to_fire => pnf%m_livestemn_xfer_to_fire - m_deadstemn_to_fire => pnf%m_deadstemn_to_fire - m_deadstemn_storage_to_fire => pnf%m_deadstemn_storage_to_fire - m_deadstemn_xfer_to_fire => pnf%m_deadstemn_xfer_to_fire - m_frootn_to_fire => pnf%m_frootn_to_fire - m_frootn_storage_to_fire => pnf%m_frootn_storage_to_fire - m_frootn_xfer_to_fire => pnf%m_frootn_xfer_to_fire - m_livecrootn_to_fire => pnf%m_livecrootn_to_fire - m_livecrootn_storage_to_fire => pnf%m_livecrootn_storage_to_fire - m_livecrootn_xfer_to_fire => pnf%m_livecrootn_xfer_to_fire - m_deadcrootn_to_fire => pnf%m_deadcrootn_to_fire - m_deadcrootn_storage_to_fire => pnf%m_deadcrootn_storage_to_fire - m_deadcrootn_xfer_to_fire => pnf%m_deadcrootn_xfer_to_fire - m_retransn_to_fire => pnf%m_retransn_to_fire - m_leafn_to_litter_fire => pnf%m_leafn_to_litter_fire - m_leafn_storage_to_litter_fire => pnf%m_leafn_storage_to_litter_fire - m_leafn_xfer_to_litter_fire => pnf%m_leafn_xfer_to_litter_fire - m_livestemn_to_litter_fire => pnf%m_livestemn_to_litter_fire - m_livestemn_storage_to_litter_fire => pnf%m_livestemn_storage_to_litter_fire - m_livestemn_xfer_to_litter_fire => pnf%m_livestemn_xfer_to_litter_fire - m_livestemn_to_deadstemn_fire => pnf%m_livestemn_to_deadstemn_fire - m_deadstemn_to_litter_fire => pnf%m_deadstemn_to_litter_fire - m_deadstemn_storage_to_litter_fire => pnf%m_deadstemn_storage_to_litter_fire - m_deadstemn_xfer_to_litter_fire =>pnf%m_deadstemn_xfer_to_litter_fire - m_frootn_to_litter_fire => pnf%m_frootn_to_litter_fire - m_frootn_storage_to_litter_fire => pnf%m_frootn_storage_to_litter_fire - m_frootn_xfer_to_litter_fire => pnf%m_frootn_xfer_to_litter_fire - m_livecrootn_to_litter_fire => pnf%m_livecrootn_to_litter_fire - m_livecrootn_storage_to_litter_fire => pnf%m_livecrootn_storage_to_litter_fire - m_livecrootn_xfer_to_litter_fire => pnf%m_livecrootn_xfer_to_litter_fire - m_livecrootn_to_deadcrootn_fire => pnf%m_livecrootn_to_deadcrootn_fire - m_deadcrootn_to_litter_fire => pnf%m_deadcrootn_to_litter_fire - m_deadcrootn_storage_to_litter_fire => pnf%m_deadcrootn_storage_to_litter_fire - m_deadcrootn_xfer_to_litter_fire => pnf%m_deadcrootn_xfer_to_litter_fire - m_retransn_to_litter_fire => pnf%m_retransn_to_litter_fire - - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - retransn => pns%retransn - - ! set time steps - dt = real( get_step_size(), r8 ) - - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - -#ifndef NITRIF_DENITRIF - ! mineral N loss due to leaching - sminn_vr(c,j) = sminn_vr(c,j) - sminn_leached_vr(c,j) * dt -#else - ! mineral N loss due to leaching and runoff - smin_no3_vr(c,j) = max(smin_no3_vr(c,j) - ( smin_no3_leached_vr(c,j) + smin_no3_runoff_vr(c,j) ) * dt, 0._r8) - sminn_vr(c,j) = smin_no3_vr(c,j) + smin_nh4_vr(c,j) -#endif - - ! column level nitrogen fluxes from fire - ! pft-level wood to column-level CWD (uncombusted wood) - decomp_npools_vr(c,j,i_cwd) = decomp_npools_vr(c,j,i_cwd) + fire_mortality_n_to_cwdn(c,j) * dt - - ! pft-level wood to column-level litter (uncombusted wood) - decomp_npools_vr(c,j,i_met_lit) = decomp_npools_vr(c,j,i_met_lit) + m_n_to_litr_met_fire(c,j)* dt - decomp_npools_vr(c,j,i_cel_lit) = decomp_npools_vr(c,j,i_cel_lit) + m_n_to_litr_cel_fire(c,j)* dt - decomp_npools_vr(c,j,i_lig_lit) = decomp_npools_vr(c,j,i_lig_lit) + m_n_to_litr_lig_fire(c,j)* dt - end do ! end of column loop - end do - - ! litter and CWD losses to fire - do l = 1, ndecomp_pools - do j = 1, nlevdecomp - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools_vr(c,j,l) = decomp_npools_vr(c,j,l) - m_decomp_npools_to_fire_vr(c,j,l) * dt - end do - end do - end do - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! pft-level nitrogen fluxes from fire - ! displayed pools - leafn(p) = leafn(p) - m_leafn_to_fire(p) * dt - frootn(p) = frootn(p) - m_frootn_to_fire(p) * dt - livestemn(p) = livestemn(p) - m_livestemn_to_fire(p) * dt - deadstemn(p) = deadstemn(p) - m_deadstemn_to_fire(p) * dt - livecrootn(p) = livecrootn(p) - m_livecrootn_to_fire(p) * dt - deadcrootn(p) = deadcrootn(p) - m_deadcrootn_to_fire(p) * dt - - leafn(p) = leafn(p) - m_leafn_to_litter_fire(p) * dt - frootn(p) = frootn(p) - m_frootn_to_litter_fire(p) * dt - livestemn(p) = livestemn(p) - m_livestemn_to_litter_fire(p) * dt - deadstemn(p) = deadstemn(p) - m_deadstemn_to_litter_fire(p) * dt - livecrootn(p) = livecrootn(p) - m_livecrootn_to_litter_fire(p) * dt - deadcrootn(p) = deadcrootn(p) - m_deadcrootn_to_litter_fire(p) * dt - - ! storage pools - leafn_storage(p) = leafn_storage(p) - m_leafn_storage_to_fire(p) * dt - frootn_storage(p) = frootn_storage(p) - m_frootn_storage_to_fire(p) * dt - livestemn_storage(p) = livestemn_storage(p) - m_livestemn_storage_to_fire(p) * dt - deadstemn_storage(p) = deadstemn_storage(p) - m_deadstemn_storage_to_fire(p) * dt - livecrootn_storage(p) = livecrootn_storage(p) - m_livecrootn_storage_to_fire(p) * dt - deadcrootn_storage(p) = deadcrootn_storage(p) - m_deadcrootn_storage_to_fire(p) * dt - - leafn_storage(p) = leafn_storage(p) - m_leafn_storage_to_litter_fire(p) * dt - frootn_storage(p) = frootn_storage(p) - m_frootn_storage_to_litter_fire(p) * dt - livestemn_storage(p) = livestemn_storage(p) - m_livestemn_storage_to_litter_fire(p) * dt - deadstemn_storage(p) = deadstemn_storage(p) - m_deadstemn_storage_to_litter_fire(p) * dt - livecrootn_storage(p) = livecrootn_storage(p) - m_livecrootn_storage_to_litter_fire(p) * dt - deadcrootn_storage(p) = deadcrootn_storage(p) - m_deadcrootn_storage_to_litter_fire(p) * dt - - - ! transfer pools - leafn_xfer(p) = leafn_xfer(p) - m_leafn_xfer_to_fire(p) * dt - frootn_xfer(p) = frootn_xfer(p) - m_frootn_xfer_to_fire(p) * dt - livestemn_xfer(p) = livestemn_xfer(p) - m_livestemn_xfer_to_fire(p) * dt - deadstemn_xfer(p) = deadstemn_xfer(p) - m_deadstemn_xfer_to_fire(p) * dt - livecrootn_xfer(p) = livecrootn_xfer(p) - m_livecrootn_xfer_to_fire(p) * dt - deadcrootn_xfer(p) = deadcrootn_xfer(p) - m_deadcrootn_xfer_to_fire(p) * dt - - leafn_xfer(p) = leafn_xfer(p) - m_leafn_xfer_to_litter_fire(p) * dt - frootn_xfer(p) = frootn_xfer(p) - m_frootn_xfer_to_litter_fire(p) * dt - livestemn_xfer(p) = livestemn_xfer(p) - m_livestemn_xfer_to_litter_fire(p) * dt - deadstemn_xfer(p) = deadstemn_xfer(p) - m_deadstemn_xfer_to_litter_fire(p) * dt - livecrootn_xfer(p) = livecrootn_xfer(p) - m_livecrootn_xfer_to_litter_fire(p) * dt - deadcrootn_xfer(p) = deadcrootn_xfer(p) - m_deadcrootn_xfer_to_litter_fire(p) * dt - - ! retranslocated N pool - retransn(p) = retransn(p) - m_retransn_to_fire(p) * dt - retransn(p) = retransn(p) - m_retransn_to_litter_fire(p) * dt - - end do - -end subroutine NStateUpdate3 -!----------------------------------------------------------------------- -!#endif - -end module CNNStateUpdate3Mod 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 deleted file mode 100644 index 8a8475d38..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNNitrifDenitrifMod.F90 +++ /dev/null @@ -1,382 +0,0 @@ -module CNNitrifDenitrifMod -!#ifdef CN -#ifdef NITRIF_DENITRIF - -!----------------------------------------------------------------------- -!BOP -! -! -! !MODULE: CNNitrifDenitrifMod -! -! !DESCRIPTION: -! -! Calculate nitrification and denitrification rates -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use shr_const_mod, only: SHR_CONST_TKFRZ - use clm_varcon , only: secspday - - - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: nitrif_denitrif - logical, public :: no_frozen_nitrif_denitrif = .false. ! stop nitrification and denitrification in frozen soils -!EOP -!----------------------------------------------------------------------- - - -contains - - -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: nitrif_denitrif -! -! !INTERFACE: -subroutine nitrif_denitrif(lbc, ubc, num_soilc, filter_soilc) -! -! !DESCRIPTION: -! -! calculate nitrification and denitrification rates -! -! !USES: - use clmtype - use clm_varpar , only : nlevgrnd,nlevdecomp - use clm_time_manager , only : get_curr_date, get_step_size - use shr_const_mod, only: SHR_CONST_TKFRZ - use clm_varctl , only: iulog - use clm_varcon, only: rpi, denh2o, dzsoi, zisoi, grav -#ifdef LCH4 - use clm_varcon, only: d_con_g, d_con_w - use ch4varcon, only : organic_max -#ifdef CENTURY_DECOMP - use CNDecompCascadeMod_CENTURY, only: anoxia_wtsat -#else - use CNDecompCascadeMod_BGC, only: anoxia_wtsat -#endif -#endif - use clm_varcon, only : spval - - ! -! !ARGUMENTS: - implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns -! -! !CALLED FROM: -! -! -! !REVISION HISTORY: -! -! -! !LOCAL VARIABLES: - integer :: c, fc, reflev, j -! local pointers to implicit in scalars -! - ! column level - real(r8) :: soil_hr_vr(lbc:ubc,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 - - ! put on clm structure for diagnostic purposes - real(r8), pointer :: smin_no3_massdens_vr(:,:) ! (ugN / g soil) soil nitrate concentration - real(r8), pointer :: k_nitr_t_vr(:,:) - real(r8), pointer :: k_nitr_ph_vr(:,:) - real(r8), pointer :: k_nitr_h2o_vr(:,:) - real(r8), pointer :: k_nitr_vr(:,:) - real(r8), pointer :: wfps_vr(:,:) - real(r8), pointer :: fmax_denit_carbonsubstrate_vr(:,:) - real(r8), pointer :: fmax_denit_nitrate_vr(:,:) - real(r8), pointer :: f_denit_base_vr(:,:) - - real(r8) :: k_nitr_max ! maximum nitrification rate constant (1/s) - real(r8) :: mu, sigma - real(r8) :: t - real(r8) :: pH(lbc:ubc) - real(r8), pointer :: phr_vr(:,:) ! potential hr (not N-limited) - real(r8), pointer :: w_scalar(:,:) ! soil water scalar for decomp - real(r8), pointer :: t_scalar(:,:) ! temperature scalar for decomp - real(r8), pointer :: h2osoi_vol(:,:) ! volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (nlevgrnd) - real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity) (nlevgrnd) - real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: smin_nh4_vr(:,:) ! (gN/m3) soil mineral NH4 pool - real(r8), pointer :: smin_no3_vr(:,:) ! (gN/m3) soil mineral NO3 pool - real(r8), pointer :: bd(:,:) ! bulk density of dry soil material [kg/m3] - real(r8), pointer :: dz(:,:) ! layer thickness (m) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: tmean_monthly_max_vr(:,:) ! maximumn monthly-mean soil temperature - real(r8), pointer :: tmean_monthly_vr(:,:) ! monthly-mean soil temperature - real(r8), pointer :: pot_f_nit_vr(:,:) ! (gN/m3/s) potential soil nitrification flux - real(r8), pointer :: pot_f_denit_vr(:,:) ! (gN/m3/s) potential soil denitrification flux - real(r8), pointer :: watfc(:,:) ! volumetric soil water at field capacity (nlevsoi) - real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b" (nlevgrnd) - real(r8), pointer :: n2_n2o_ratio_denit_vr(:,:) ! ratio of N2 to N2O production by denitrification [gN/gN] - - !debug-- put these in clmtype for outing to hist files - real(r8), pointer :: diffus(:,:) !diffusivity (unitless fraction of total diffusivity) - real(r8), pointer :: ratio_k1(:,:) - real(r8), pointer :: ratio_no3_co2(:,:) - real(r8), pointer :: soil_co2_prod(:,:) ! (ug C / g soil / day) - real(r8), pointer :: fr_WFPS(:,:) - real(r8), pointer :: soil_bulkdensity(:,:) ! (kg soil / m3) bulk density of soil (including water) - - - real(r8) :: co2diff_con(2) ! diffusion constants for CO2 - real(r8) :: eps - real(r8) :: f_a - - real(r8) :: surface_tension_water = 73.e-3_r8 ! (J/m^2), Arah and Vinten 1995 - - real(r8) :: rij_kro_a = 1.5e-10_r8 ! Arah and Vinten 1995 - real(r8) :: rij_kro_alpha = 1.26_r8 ! Arah and Vinten 1995 - real(r8) :: rij_kro_beta = 0.6_r8 ! Arah and Vinten 1995 - real(r8) :: rij_kro_gamma = 0.6_r8 ! Arah and Vinten 1995 - real(r8) :: rij_kro_delta = 0.85_r8 ! Arah and Vinten 1995 - - real(r8) :: rho_w = 1.e3_r8 ! (kg/m3) - real(r8) :: r_max - real(r8) :: r_min(lbc:ubc,1:nlevdecomp) - real(r8) :: ratio_diffusivity_water_gas(lbc:ubc,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), pointer :: r_psi(:,:) - real(r8), pointer :: anaerobic_frac(:,:) - - real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) - real(r8), pointer :: o2_decomp_depth_unsat(:,:)! O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) - real(r8), pointer :: conc_o2_unsat(:,:) ! O2 conc in each soil layer (mol/m3) (nlevsoi) - real(r8), pointer :: o2_decomp_depth_sat(:,:) ! O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) - real(r8), pointer :: conc_o2_sat(:,:) ! O2 conc in each soil layer (mol/m3) (nlevsoi) - real(r8), pointer :: finundated(:) ! fractional inundated area in soil column (excluding dedicated wetland columns) - real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm) - - real(r8), pointer :: cellorg(:,:) ! column 3D org (kg/m3 organic matter) (nlevgrnd) - character(len=32) :: subname='nitrif_denitrif' ! subroutine name - - !-- implicit in -! #ifdef LCH4 -! pH => cps%pH -! #endif - phr_vr => ccf%phr_vr - w_scalar => ccf%w_scalar - t_scalar => ccf%t_scalar - h2osoi_vol => cws%h2osoi_vol - h2osoi_liq => cws%h2osoi_liq - watsat => cps%watsat - t_soisno => ces%t_soisno - smin_nh4_vr => cns%smin_nh4_vr - smin_no3_vr => cns%smin_no3_vr - bd => cps%bd - dz => cps%dz - watfc => cps%watfc - bsw => cps%bsw - - soilpsi => cps%soilpsi -#ifdef LCH4 - o2_decomp_depth_unsat => cch4%o2_decomp_depth_unsat - conc_o2_unsat => cch4%conc_o2_unsat - o2_decomp_depth_sat => cch4%o2_decomp_depth_sat - conc_o2_sat => cch4%conc_o2_sat - finundated => cws%finundated -#endif - sucsat => cps%sucsat - - r_psi => cnf%r_psi - anaerobic_frac => cnf%anaerobic_frac - - ! ! subsets of the n flux calcs (for diagnostic/debugging purposes) - smin_no3_massdens_vr => cnf%smin_no3_massdens_vr - k_nitr_t_vr => cnf%k_nitr_t_vr - k_nitr_ph_vr => cnf%k_nitr_ph_vr - k_nitr_h2o_vr => cnf%k_nitr_h2o_vr - k_nitr_vr => cnf%k_nitr_vr - wfps_vr => cnf%wfps_vr - fmax_denit_carbonsubstrate_vr => cnf%fmax_denit_carbonsubstrate_vr - fmax_denit_nitrate_vr => cnf%fmax_denit_nitrate_vr - f_denit_base_vr => cnf%f_denit_base_vr - diffus => cnf%diffus - ratio_k1 => cnf%ratio_k1 - ratio_no3_co2 => cnf%ratio_no3_co2 - soil_co2_prod => cnf%soil_co2_prod - fr_WFPS => cnf%fr_WFPS - soil_bulkdensity => cnf%soil_bulkdensity - - cellorg => cps%cellorg - - !-- implicit out - pot_f_nit_vr => cnf%pot_f_nit_vr - pot_f_denit_vr => cnf%pot_f_denit_vr - n2_n2o_ratio_denit_vr => cnf%n2_n2o_ratio_denit_vr - - k_nitr_max = 0.1_r8 / secspday ! [1/sec] 10%/day Parton et al., 2001 - - pH(lbc:ubc) = 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 -#ifdef LCH4 - 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) .ne. spval .and. conc_o2_unsat(c,j) .ne. spval & - .and. o2_decomp_depth_unsat(c,j) .gt. 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 - - if (anoxia_wtsat) then ! Average saturated fraction values into anaerobic_frac(c,j). - r_min_sat = 2._r8 * surface_tension_water / (rho_w * grav * abs(grav * 1.e-6_r8 * sucsat(c,j))) - r_psi_sat = sqrt(r_min_sat * r_max) - if (o2_decomp_depth_sat(c,j) .ne. spval .and. conc_o2_sat(c,j) .ne. spval & - .and. o2_decomp_depth_sat(c,j) .gt. 0._r8) then - anaerobic_frac_sat = exp(-rij_kro_a * r_psi_sat**(-rij_kro_alpha) * o2_decomp_depth_sat(c,j)**(-rij_kro_beta) * & - conc_o2_sat(c,j)**rij_kro_gamma * (watsat(c,j) + ratio_diffusivity_water_gas(c,j) * & - watsat(c,j))**rij_kro_delta) - else - anaerobic_frac_sat = 0._r8 - endif - anaerobic_frac(c,j) = (1._r8 - finundated(c))*anaerobic_frac(c,j) + finundated(c)*anaerobic_frac_sat - end if - -#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( trim(subname)//' ERROR: NITRIF_DENITRIF requires Methane model to be active' ) -#endif - - - !---------------- 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 - k_nitr_vr(c,j) = k_nitr_max * 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)/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) = (0.1_r8 * (soil_co2_prod(c,j)**1.3_r8)) & - / g_per_m3_sec__to__ug_per_gsoil_day - ! - fmax_denit_nitrate_vr(c,j) = (1.15_r8 * smin_no3_massdens_vr(c,j)**0.57_r8) & - / 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) .gt. 0 ) 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) -#ifdef LCH4 - if (anoxia_wtsat) then - fr_WFPS(c,j) = fr_WFPS(c,j)*(1._r8 - finundated(c)) + finundated(c)*1.18_r8 - end if -#endif - - ! 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 subroutine nitrif_denitrif -#endif -!#endif - - -end module CNNitrifDenitrifMod 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 deleted file mode 100644 index b2301bd84..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNPhenologyMod.F90 +++ /dev/null @@ -1,2861 +0,0 @@ -module CNPhenologyMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNPhenologyMod -! -! !DESCRIPTION: -! Module holding routines used in phenology model for coupled carbon -! nitrogen code. -! -! !USES: - use clmtype - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varcon , only: tfrz - use clm_varctl , only: iulog - use clm_varpar , only: numpft - - implicit none - save - private - -! !PUBLIC MEMBER FUNCTIONS: - public :: CNPhenologyInit ! Initialization - public :: CNPhenology ! Update -! -! !REVISION HISTORY: -! 8/1/03: Created by Peter Thornton -! 10/23/03, Peter Thornton: migrated all routines to vector data structures -! 2/4/08, slevis: adding crop phenology from AgroIBIS - -! !PRIVATE DATA MEMBERS: - - 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) - ! - ! 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 pft is in - integer :: minplantjday(0:numpft,inSH) ! minimum planting julian day - integer :: maxplantjday(0:numpft,inSH) ! maximum planting julian day - integer :: jdayyrstart(inSH) ! julian day of start of year - -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNPhenology -! -! !INTERFACE: -subroutine CNPhenology (num_soilc, filter_soilc, num_soilp, filter_soilp, & - num_pcropp, filter_pcropp, doalb) -! -! !DESCRIPTION: -! Dynamic phenology routine for coupled carbon-nitrogen code (CN) -! 1. grass phenology -! -! !USES: -! -! !ARGUMENTS: - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - integer, intent(in) :: num_pcropp ! number of prog. crop pfts in filter - integer, intent(in) :: filter_pcropp(:)! filter for prognostic crop pfts - logical, intent(in) :: doalb ! true if time for sfc albedo calc -! -! !CALLED FROM: -! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 7/28/03: Created by Peter Thornton -! 9/05/03, Peter Thornton: moved from call with (p) to call with (c) -! 10/3/03, Peter Thornton: added subroutine calls for different phenology types -! 11/7/03, Peter Thornton: moved phenology type tests into phenology type -! routines, and moved onset, offset, background litfall routines into -! main phenology call. -! !LOCAL VARIABLES: -! local pointers to implicit in arrays -! -! local pointers to implicit in/out scalars -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: -!EOP -!----------------------------------------------------------------------- - - ! each of the following phenology type routines includes a filter - ! to operate only on the relevant pfts - - call CNPhenologyClimate(num_soilp, filter_soilp, num_pcropp, filter_pcropp) - - call CNEvergreenPhenology(num_soilp, filter_soilp) - - call CNSeasonDecidPhenology(num_soilp, filter_soilp) - - call CNStressDecidPhenology(num_soilp, filter_soilp) - - if (doalb .and. num_pcropp > 0 ) call CropPhenology(num_pcropp, filter_pcropp) - - ! the same onset and offset routines are called regardless of - ! phenology type - they depend only on onset_flag, offset_flag, bglfr, and bgtr - - call CNOnsetGrowth(num_soilp, filter_soilp) - - call CNOffsetLitterfall(num_soilp, filter_soilp) - - call CNBackgroundLitterfall(num_soilp, filter_soilp) - - call CNLivewoodTurnover(num_soilp, filter_soilp) - - ! gather all pft-level litterfall fluxes to the column - ! for litter C and N inputs - - call CNLitterToColumn(num_soilc, filter_soilc) - -end subroutine CNPhenology - -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNPhenologyInit -! -! !INTERFACE: -subroutine CNPhenologyInit( begp, endp ) -! -! !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 - use clm_varctl , only: crop_prog - use clm_varcon , only: secspday -! -! !ARGUMENTS: - implicit none - integer, intent(IN) :: begp, endp ! Beginning and ending PFT index -! !CALLED FROM: -! subroutine CNEcosystemDynInit in CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 3/28/11: Created by Erik Kluzek -! -! !LOCAL VARIABLES: -!EOP -!------------------------------------------------------------------------ - - ! - ! Get time-step and what fraction of a day it is - ! - dt = real( get_step_size(), r8 ) - fracday = dt/secspday - - ! set some local parameters - these will be moved into - ! parameter file after testing - - ! ----------------------------------------- - ! Constants for CNSeasonDecidPhenology - ! ----------------------------------------- - ! - ! critical daylength from Biome-BGC, v4.1.2 - crit_dayl = 39300._r8 - - ! ----------------------------------------- - ! Constants for CNSeasonDecidPhenology and CNStressDecidPhenology - ! ----------------------------------------- - ndays_on = 30._r8 - ndays_off = 15._r8 - - ! transfer parameters - fstor2tran = 0.5_r8 - ! ----------------------------------------- - ! Constants for CNStressDecidPhenology - ! ----------------------------------------- - - ! onset parameters -! crit_onset_fdd = 15.0_r8 - crit_onset_fdd = 7.0 ! this may prevent "January thaw" growth spurt, fzeng, 22 Mar 2017 - ! critical onset gdd now being calculated as a function of annual - ! average 2m temp. - ! crit_onset_gdd = 150.0 ! c3 grass value - ! crit_onset_gdd = 1000.0 ! c4 grass value - crit_onset_swi = 15.0_r8 - soilpsi_on = -2.0_r8 - - ! offset parameters - crit_offset_fdd = 15.0_r8 - crit_offset_swi = 15.0_r8 - soilpsi_off = -2.0_r8 - - ! ----------------------------------------- - ! 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 = 0.7_r8 / 31536000.0_r8 - - ! ----------------------------------------- - ! Call any subroutine specific initialization routines - ! ----------------------------------------- - - if ( crop_prog ) call CropPhenologyInit( begp, endp ) - -end subroutine CNPhenologyInit -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNPhenologyClimate -! -! !INTERFACE: -subroutine CNPhenologyClimate (num_soilp, filter_soilp, num_pcropp, filter_pcropp) -! -! !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 -! use CropRestMod , only: CropRestYear, CropRestIncYear -! -! !ARGUMENTS: - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - integer, intent(in) :: num_pcropp ! number of prognostic crops in filter - integer, intent(in) :: filter_pcropp(:)! filter for prognostic crop pfts -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 3/13/07: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: ivt(:) ! pft vegetation type - ! ecophysiological constants - real(r8), pointer :: t_ref2m(:) ! 2m air temperature (K) - real(r8), pointer :: tempavg_t2m(:) ! temp. avg 2m air temperature (K) - real(r8), pointer :: gdd0(:) ! growing deg. days base 0 deg C (ddays) - real(r8), pointer :: gdd8(:) ! " " " " 8 " " " - real(r8), pointer :: gdd10(:) ! " " " " 10 " " " - real(r8), pointer :: gdd020(:) ! 20-yr mean of gdd0 (ddays) - real(r8), pointer :: gdd820(:) ! 20-yr mean of gdd8 (ddays) - real(r8), pointer :: gdd1020(:) ! 20-yr mean of gdd10 (ddays) - integer , pointer :: pgridcell(:) ! pft's gridcell index -! -! local pointers to implicit in/out scalars -! -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: - integer :: p ! indices - integer :: fp ! lake filter pft index - integer, save :: nyrs = -999 ! number of years prognostic crop has run - 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 - - logical, parameter :: init_gdd20 = .false. ! Always set to .FALSE.!! Will spin up and discard at least 2 years anyways. fzeng, July 2017 - -!EOP -!----------------------------------------------------------------------- - - ! assign local pointers to derived type arrays - ivt =>pft%itype - t_ref2m => pes%t_ref2m - tempavg_t2m => pepv%tempavg_t2m - - gdd0 => pps%gdd0 - gdd8 => pps%gdd8 - gdd10 => pps%gdd10 - gdd020 => pps%gdd020 - gdd820 => pps%gdd820 - gdd1020 => pps%gdd1020 - pgridcell =>pft%gridcell - - ! 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) - if ( nyrs == -999 ) then - ! fzeng: this is done in such way to exclude restyear (i.e. nyrs here) in the restart file, Apr 2017 -! nyrs = CropRestYear() - if(init_gdd20) then - nyrs = 0 - else - nyrs = 2 - endif - else - if (kmo == 1 .and. kda == 1 .and. mcsec == 0) nyrs = nyrs + 1 ! call CropRestIncYear( nyrs ) ! fzeng: temporary fix to make it compile - end if - end if - - do fp = 1,num_pcropp - p = filter_pcropp(fp) - if (kmo == 1 .and. kda == 1 .and. nyrs == 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 == 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 subroutine CNPhenologyClimate -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNEvergreenPhenology -! -! !INTERFACE: -subroutine CNEvergreenPhenology (num_soilp, filter_soilp) -! -! !DESCRIPTION: -! For coupled carbon-nitrogen code (CN). -! -! !USES: - use clm_varcon , only: secspday - use clm_time_manager, only: get_days_per_year -! -! !ARGUMENTS: - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 10/2/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: ivt(:) ! pft vegetation type - ! ecophysiological constants - real(r8), pointer :: evergreen(:) ! binary flag for evergreen leaf habit (0 or 1) - real(r8), pointer :: leaf_long(:) ! leaf longevity (yrs) -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s) - real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s) - real(r8), pointer :: lgsf(:) ! long growing season factor [0-1] -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: - real(r8):: dayspyr ! Days per year - integer :: p ! indices - integer :: fp ! lake filter pft index -!EOP -!----------------------------------------------------------------------- - - ! assign local pointers to derived type arrays - ivt =>pft%itype - evergreen => pftcon%evergreen - leaf_long => pftcon%leaf_long - bglfr => pepv%bglfr - bgtr => pepv%bgtr - lgsf => pepv%lgsf - 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 - -end subroutine CNEvergreenPhenology -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSeasonDecidPhenology -! -! !INTERFACE: -subroutine CNSeasonDecidPhenology (num_soilp, filter_soilp) -! -! !DESCRIPTION: -! For coupled carbon-nitrogen code (CN). -! This routine handles the seasonal deciduous phenology code (temperate -! deciduous vegetation that has only one growing season per year). -! -! !USES: - use shr_const_mod , only: SHR_CONST_TKFRZ - use clm_varcon , only: secspday -! -! !ARGUMENTS: - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 10/6/03: Created by Peter Thornton -! 10/24/03, Peter Thornton: migrated to vector data structures -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars - integer , pointer :: ivt(:) ! pft vegetation type - integer , pointer :: pcolumn(:) ! pft's column index - integer , pointer :: pgridcell(:) ! pft's gridcell index -! real(r8), pointer :: latdeg(:) ! latitude (radians) -! real(r8), pointer :: decl(:) ! solar declination (radians) - real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin) - ! ecophysiological constants - real(r8), pointer :: season_decid(:) ! binary flag for seasonal-deciduous leaf habit (0 or 1) - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) -! -! local pointers to implicit in/out scalars - real(r8), pointer :: dormant_flag(:) ! dormancy flag - real(r8), pointer :: days_active(:) ! number of days since last dormancy - real(r8), pointer :: onset_flag(:) ! onset flag - real(r8), pointer :: onset_counter(:) ! onset counter (seconds) - real(r8), pointer :: onset_gddflag(:) ! onset freeze flag - real(r8), pointer :: onset_gdd(:) ! onset growing degree days - real(r8), pointer :: offset_flag(:) ! offset flag - real(r8), pointer :: offset_counter(:) ! offset counter (seconds) - real(r8), pointer :: dayl(:) ! daylength (seconds) - real(r8), pointer :: prev_dayl(:) ! daylength from previous albedo timestep (seconds) - real(r8), pointer :: annavg_t2m(:) ! annual average 2m air temperature (K) - real(r8), pointer :: prev_leafc_to_litter(:) ! previous timestep leaf C litterfall flux (gC/m2/s) - real(r8), pointer :: prev_frootc_to_litter(:) ! previous timestep froot C litterfall flux (gC/m2/s) - real(r8), pointer :: lgsf(:) ! long growing season factor [0-1] - real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s) - real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s) - real(r8), pointer :: leafc_xfer_to_leafc(:) - real(r8), pointer :: frootc_xfer_to_frootc(:) - real(r8), pointer :: livestemc_xfer_to_livestemc(:) - real(r8), pointer :: deadstemc_xfer_to_deadstemc(:) - real(r8), pointer :: livecrootc_xfer_to_livecrootc(:) - real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:) - real(r8), pointer :: leafn_xfer_to_leafn(:) - real(r8), pointer :: frootn_xfer_to_frootn(:) - real(r8), pointer :: livestemn_xfer_to_livestemn(:) - real(r8), pointer :: deadstemn_xfer_to_deadstemn(:) - real(r8), pointer :: livecrootn_xfer_to_livecrootn(:) - real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:) - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: leafc_storage_to_xfer(:) - real(r8), pointer :: frootc_storage_to_xfer(:) - real(r8), pointer :: livestemc_storage_to_xfer(:) - real(r8), pointer :: deadstemc_storage_to_xfer(:) - real(r8), pointer :: livecrootc_storage_to_xfer(:) - real(r8), pointer :: deadcrootc_storage_to_xfer(:) - real(r8), pointer :: gresp_storage_to_xfer(:) - real(r8), pointer :: leafn_storage_to_xfer(:) - real(r8), pointer :: frootn_storage_to_xfer(:) - real(r8), pointer :: livestemn_storage_to_xfer(:) - real(r8), pointer :: deadstemn_storage_to_xfer(:) - real(r8), pointer :: livecrootn_storage_to_xfer(:) - real(r8), pointer :: deadcrootn_storage_to_xfer(:) -#if (defined CNDV) - logical , pointer :: pftmayexist(:) ! exclude seasonal decid pfts from tropics -#endif -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: - integer :: c,p !indices - integer :: fp !lake filter pft index - real(r8):: ws_flag !winter-summer solstice flag (0 or 1) - real(r8):: crit_onset_gdd !critical onset growing degree-day sum - real(r8):: soilt -! real(r8):: lat !latitude (radians) -! real(r8):: temp !temporary variable for daylength calculation - -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - ivt =>pft%itype - pcolumn =>pft%column - pgridcell =>pft%gridcell -! latdeg => grc%latdeg -! decl => cps%decl - t_soisno => ces%t_soisno - t_grnd => ces%t_grnd - leafc_storage => pcs%leafc_storage - frootc_storage => pcs%frootc_storage - livestemc_storage => pcs%livestemc_storage - deadstemc_storage => pcs%deadstemc_storage - livecrootc_storage => pcs%livecrootc_storage - deadcrootc_storage => pcs%deadcrootc_storage - gresp_storage => pcs%gresp_storage - leafn_storage => pns%leafn_storage - frootn_storage => pns%frootn_storage - livestemn_storage => pns%livestemn_storage - deadstemn_storage => pns%deadstemn_storage - livecrootn_storage => pns%livecrootn_storage - deadcrootn_storage => pns%deadcrootn_storage - season_decid => pftcon%season_decid - woody => pftcon%woody - - ! Assign local pointers to derived type arrays (out) - dormant_flag => pepv%dormant_flag - days_active => pepv%days_active - onset_flag => pepv%onset_flag - onset_counter => pepv%onset_counter - onset_gddflag => pepv%onset_gddflag - onset_gdd => pepv%onset_gdd - offset_flag => pepv%offset_flag - offset_counter => pepv%offset_counter - dayl => pepv%dayl - prev_dayl => pepv%prev_dayl - annavg_t2m => pepv%annavg_t2m - prev_leafc_to_litter => pepv%prev_leafc_to_litter - prev_frootc_to_litter => pepv%prev_frootc_to_litter - bglfr => pepv%bglfr - bgtr => pepv%bgtr - lgsf => pepv%lgsf - leafc_xfer_to_leafc => pcf%leafc_xfer_to_leafc - frootc_xfer_to_frootc => pcf%frootc_xfer_to_frootc - livestemc_xfer_to_livestemc => pcf%livestemc_xfer_to_livestemc - deadstemc_xfer_to_deadstemc => pcf%deadstemc_xfer_to_deadstemc - livecrootc_xfer_to_livecrootc => pcf%livecrootc_xfer_to_livecrootc - deadcrootc_xfer_to_deadcrootc => pcf%deadcrootc_xfer_to_deadcrootc - leafn_xfer_to_leafn => pnf%leafn_xfer_to_leafn - frootn_xfer_to_frootn => pnf%frootn_xfer_to_frootn - livestemn_xfer_to_livestemn => pnf%livestemn_xfer_to_livestemn - deadstemn_xfer_to_deadstemn => pnf%deadstemn_xfer_to_deadstemn - livecrootn_xfer_to_livecrootn => pnf%livecrootn_xfer_to_livecrootn - deadcrootn_xfer_to_deadcrootn => pnf%deadcrootn_xfer_to_deadcrootn - leafc_xfer => pcs%leafc_xfer - frootc_xfer => pcs%frootc_xfer - livestemc_xfer => pcs%livestemc_xfer - deadstemc_xfer => pcs%deadstemc_xfer - livecrootc_xfer => pcs%livecrootc_xfer - deadcrootc_xfer => pcs%deadcrootc_xfer - leafn_xfer => pns%leafn_xfer - frootn_xfer => pns%frootn_xfer - livestemn_xfer => pns%livestemn_xfer - deadstemn_xfer => pns%deadstemn_xfer - livecrootn_xfer => pns%livecrootn_xfer - deadcrootn_xfer => pns%deadcrootn_xfer - leafc_storage_to_xfer => pcf%leafc_storage_to_xfer - frootc_storage_to_xfer => pcf%frootc_storage_to_xfer - livestemc_storage_to_xfer => pcf%livestemc_storage_to_xfer - deadstemc_storage_to_xfer => pcf%deadstemc_storage_to_xfer - livecrootc_storage_to_xfer => pcf%livecrootc_storage_to_xfer - deadcrootc_storage_to_xfer => pcf%deadcrootc_storage_to_xfer - gresp_storage_to_xfer => pcf%gresp_storage_to_xfer - leafn_storage_to_xfer => pnf%leafn_storage_to_xfer - frootn_storage_to_xfer => pnf%frootn_storage_to_xfer - livestemn_storage_to_xfer => pnf%livestemn_storage_to_xfer - deadstemn_storage_to_xfer => pnf%deadstemn_storage_to_xfer - livecrootn_storage_to_xfer => pnf%livecrootn_storage_to_xfer - deadcrootn_storage_to_xfer => pnf%deadcrootn_storage_to_xfer -#if (defined CNDV) - pftmayexist => pdgvs%pftmayexist -#endif - - ! start pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - c = pcolumn(p) - - if (season_decid(ivt(p)) == 1._r8) then - - ! set background litterfall rate, background transfer rate, and - ! long growing season factor to 0 for seasonal deciduous types - bglfr(p) = 0._r8 - bgtr(p) = 0._r8 - lgsf(p) = 0._r8 - - ! onset gdd sum from Biome-BGC, v4.1.2 - crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_t2m(p) - SHR_CONST_TKFRZ)) - - ! use solar declination information stored during Surface Albedo() - ! and latitude from gps to calcluate daylength (convert latitude from degrees to radians) - ! the constant 13750.9871 is the number of seconds per radian of hour-angle - - ! Calculation of dayl and prev_dayl moved to CN_DriverMod.F90, fzeng, 22 Mar 2017 -! prev_dayl(p) = dayl(p) -! lat = (SHR_CONST_PI/180._r8)*grc%latdeg(pgridcell(p)) -! temp = -(sin(lat)*sin(decl(c)))/(cos(lat) * cos(decl(c))) -! temp = min(1._r8,max(-1._r8,temp)) -! dayl(p) = 2.0_r8 * 13750.9871_r8 * acos(temp) - - ! set flag for solstice period (winter->summer = 1, summer->winter = 0) - if (dayl(p) >= prev_dayl(p)) then - ws_flag = 1._r8 - else - ws_flag = 0._r8 - end if - - ! update offset_counter and test for the end of the offset period - if (offset_flag(p) == 1.0_r8) then - ! decrement counter for offset period - offset_counter(p) = offset_counter(p) - dt - - ! if this is the end of the offset_period, reset phenology - ! flags and indices - if (offset_counter(p) <= 0.0_r8) then - ! this code block was originally handled by call cn_offset_cleanup(p) - ! inlined during vectorization - - offset_flag(p) = 0._r8 - offset_counter(p) = 0._r8 - dormant_flag(p) = 1._r8 - days_active(p) = 0._r8 -#if (defined CNDV) - pftmayexist(p) = .true. -#endif - - ! reset the previous timestep litterfall flux memory - prev_leafc_to_litter(p) = 0._r8 - prev_frootc_to_litter(p) = 0._r8 - end if - end if - - ! update onset_counter and test for the end of the onset period - if (onset_flag(p) == 1.0_r8) then - ! decrement counter for onset period - onset_counter(p) = onset_counter(p) - dt - - ! if this is the end of the onset period, reset phenology - ! flags and indices - if (onset_counter(p) <= 0.0_r8) then - ! this code block was originally handled by call cn_onset_cleanup(p) - ! inlined during vectorization - - onset_flag(p) = 0.0_r8 - onset_counter(p) = 0.0_r8 - ! set all transfer growth rates to 0.0 - leafc_xfer_to_leafc(p) = 0.0_r8 - frootc_xfer_to_frootc(p) = 0.0_r8 - leafn_xfer_to_leafn(p) = 0.0_r8 - frootn_xfer_to_frootn(p) = 0.0_r8 - if (woody(ivt(p)) == 1.0_r8) then - livestemc_xfer_to_livestemc(p) = 0.0_r8 - deadstemc_xfer_to_deadstemc(p) = 0.0_r8 - livecrootc_xfer_to_livecrootc(p) = 0.0_r8 - deadcrootc_xfer_to_deadcrootc(p) = 0.0_r8 - livestemn_xfer_to_livestemn(p) = 0.0_r8 - deadstemn_xfer_to_deadstemn(p) = 0.0_r8 - livecrootn_xfer_to_livecrootn(p) = 0.0_r8 - deadcrootn_xfer_to_deadcrootn(p) = 0.0_r8 - end if - ! set transfer pools to 0.0 - leafc_xfer(p) = 0.0_r8 - leafn_xfer(p) = 0.0_r8 - frootc_xfer(p) = 0.0_r8 - frootn_xfer(p) = 0.0_r8 - if (woody(ivt(p)) == 1.0_r8) then - livestemc_xfer(p) = 0.0_r8 - livestemn_xfer(p) = 0.0_r8 - deadstemc_xfer(p) = 0.0_r8 - deadstemn_xfer(p) = 0.0_r8 - livecrootc_xfer(p) = 0.0_r8 - livecrootn_xfer(p) = 0.0_r8 - deadcrootc_xfer(p) = 0.0_r8 - deadcrootn_xfer(p) = 0.0_r8 - end if - end if - end if - - ! test for switching from dormant period to growth period - if (dormant_flag(p) == 1.0_r8) then - - ! Test to turn on growing degree-day sum, if off. - ! switch on the growing degree day sum on the winter solstice - - if (onset_gddflag(p) == 0._r8 .and. ws_flag == 1._r8) then - onset_gddflag(p) = 1._r8 - onset_gdd(p) = 0._r8 - end if - - ! Test to turn off growing degree-day sum, if on. - ! This test resets the growing degree day sum if it gets past - ! the summer solstice without reaching the threshold value. - ! In that case, it will take until the next winter solstice - ! before the growing degree-day summation starts again. - - if (onset_gddflag(p) == 1._r8 .and. ws_flag == 0._r8) then - onset_gddflag(p) = 0._r8 - onset_gdd(p) = 0._r8 - end if - - ! if the gdd flag is set, and if the soil is above freezing - ! then accumulate growing degree days for onset trigger - -! soilt = t_soisno(c,3) - soilt = max(t_grnd(c),t_soisno(c,1)) ! use TP1 or weighted TG & TP1 - if (onset_gddflag(p) == 1.0_r8 .and. soilt > SHR_CONST_TKFRZ) then - onset_gdd(p) = onset_gdd(p) + (soilt-SHR_CONST_TKFRZ)*fracday - end if - - ! set onset_flag if critical growing degree-day sum is exceeded - if (onset_gdd(p) > crit_onset_gdd) then - onset_flag(p) = 1.0_r8 - dormant_flag(p) = 0.0_r8 - onset_gddflag(p) = 0.0_r8 - onset_gdd(p) = 0.0_r8 - onset_counter(p) = ndays_on * 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 - leafc_storage_to_xfer(p) = fstor2tran * leafc_storage(p)/dt - frootc_storage_to_xfer(p) = fstor2tran * frootc_storage(p)/dt - if (woody(ivt(p)) == 1.0_r8) then - livestemc_storage_to_xfer(p) = fstor2tran * livestemc_storage(p)/dt - deadstemc_storage_to_xfer(p) = fstor2tran * deadstemc_storage(p)/dt - livecrootc_storage_to_xfer(p) = fstor2tran * livecrootc_storage(p)/dt - deadcrootc_storage_to_xfer(p) = fstor2tran * deadcrootc_storage(p)/dt - gresp_storage_to_xfer(p) = fstor2tran * gresp_storage(p)/dt - end if - - ! set nitrogen fluxes for shifting storage pools to transfer pools - leafn_storage_to_xfer(p) = fstor2tran * leafn_storage(p)/dt - frootn_storage_to_xfer(p) = fstor2tran * frootn_storage(p)/dt - if (woody(ivt(p)) == 1.0_r8) then - livestemn_storage_to_xfer(p) = fstor2tran * livestemn_storage(p)/dt - deadstemn_storage_to_xfer(p) = fstor2tran * deadstemn_storage(p)/dt - livecrootn_storage_to_xfer(p) = fstor2tran * livecrootn_storage(p)/dt - deadcrootn_storage_to_xfer(p) = fstor2tran * deadcrootn_storage(p)/dt - end if - end if - - ! test for switching from growth period to offset period - else if (offset_flag(p) == 0.0_r8) then -#if (defined CNDV) - ! If days_active > 355, then remove pft in - ! CNDVEstablishment at the end of the year. - ! days_active > 355 is a symptom of seasonal decid. pfts occurring in - ! gridcells where dayl never drops below crit_dayl. - ! This results in TLAI>1e4 in a few gridcells. - days_active(p) = days_active(p) + fracday - if (days_active(p) > 355._r8) pftmayexist(p) = .false. -#endif - - ! only begin to test for offset daylength once past the summer sol - if (ws_flag == 0._r8 .and. dayl(p) < crit_dayl) then - offset_flag(p) = 1._r8 - offset_counter(p) = ndays_off * 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 pft loop - -end subroutine CNSeasonDecidPhenology -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNStressDecidPhenology -! -! !INTERFACE: -subroutine CNStressDecidPhenology (num_soilp, filter_soilp) -! -! !DESCRIPTION: -! This routine handles phenology for vegetation types, such as grasses and -! tropical drought deciduous trees, that respond to cold and drought stress -! signals and that can have multiple growing seasons in a given year. -! This routine allows for the possibility that leaves might persist year-round -! in the absence of a suitable stress trigger, by switching to an essentially -! evergreen habit, but maintaining a deciduous leaf longevity, while waiting -! for the next stress trigger. This is in contrast to the seasonal deciduous -! algorithm (for temperate deciduous trees) that forces a single growing season -! per year. -! -! !USES: - use clm_time_manager, only: get_days_per_year - use clm_varcon , only: secspday - use shr_const_mod , only: SHR_CONST_TKFRZ -! -! !ARGUMENTS: - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 10/27/03: Created by Peter Thornton -! 01/29/04: Made onset_gdd critical sum a function of temperature, as in -! seasonal deciduous algorithm. -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: ivt(:) ! pft vegetation type - integer , pointer :: pcolumn(:) ! pft's column index - integer , pointer :: pgridcell(:) ! pft's gridcell index -! real(r8), pointer :: latdeg(:) ! latitude (radians) -! real(r8), pointer :: decl(:) ! solar declination (radians) - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) - real(r8), pointer :: psiwilt(:) ! root-zone soil water potential at wilting point (MPa) - real(r8), pointer :: leaf_long(:) ! leaf longevity (yrs) - real(r8), pointer :: stress_decid(:) ! binary flag for stress-deciduous leaf habit (0 or 1) - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin) - -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: dormant_flag(:) ! dormancy flag - real(r8), pointer :: days_active(:) ! number of days since last dormancy - real(r8), pointer :: onset_flag(:) ! onset flag - real(r8), pointer :: onset_counter(:) ! onset counter (seconds) - real(r8), pointer :: onset_gddflag(:) ! onset freeze flag - real(r8), pointer :: onset_fdd(:) ! onset freezing degree days counter - real(r8), pointer :: onset_gdd(:) ! onset growing degree days - real(r8), pointer :: onset_swi(:) ! onset soil water index - real(r8), pointer :: offset_flag(:) ! offset flag - real(r8), pointer :: offset_counter(:) ! offset counter (seconds) - real(r8), pointer :: prev_dayl(:) ! daylength from previous albedo timestep (seconds) - real(r8), pointer :: dayl(:) ! daylength (seconds) - real(r8), pointer :: offset_fdd(:) ! offset freezing degree days counter - real(r8), pointer :: offset_swi(:) ! offset soil water index - real(r8), pointer :: annavg_t2m(:) ! annual average 2m air temperature (K) - real(r8), pointer :: lgsf(:) ! long growing season factor [0-1] - real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s) - real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s) - real(r8), pointer :: prev_leafc_to_litter(:) ! previous timestep leaf C litterfall flux (gC/m2/s) - real(r8), pointer :: prev_frootc_to_litter(:) ! previous timestep froot C litterfall flux (gC/m2/s) - real(r8), pointer :: leafc_xfer_to_leafc(:) - real(r8), pointer :: frootc_xfer_to_frootc(:) - real(r8), pointer :: livestemc_xfer_to_livestemc(:) - real(r8), pointer :: deadstemc_xfer_to_deadstemc(:) - real(r8), pointer :: livecrootc_xfer_to_livecrootc(:) - real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:) - real(r8), pointer :: leafn_xfer_to_leafn(:) - real(r8), pointer :: frootn_xfer_to_frootn(:) - real(r8), pointer :: livestemn_xfer_to_livestemn(:) - real(r8), pointer :: deadstemn_xfer_to_deadstemn(:) - real(r8), pointer :: livecrootn_xfer_to_livecrootn(:) - real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:) - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: leafc_storage_to_xfer(:) - real(r8), pointer :: frootc_storage_to_xfer(:) - real(r8), pointer :: livestemc_storage_to_xfer(:) - real(r8), pointer :: deadstemc_storage_to_xfer(:) - real(r8), pointer :: livecrootc_storage_to_xfer(:) - real(r8), pointer :: deadcrootc_storage_to_xfer(:) - real(r8), pointer :: gresp_storage_to_xfer(:) - real(r8), pointer :: leafn_storage_to_xfer(:) - real(r8), pointer :: frootn_storage_to_xfer(:) - real(r8), pointer :: livestemn_storage_to_xfer(:) - real(r8), pointer :: deadstemn_storage_to_xfer(:) - real(r8), pointer :: livecrootn_storage_to_xfer(:) - real(r8), pointer :: deadcrootn_storage_to_xfer(:) -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - real(r8),parameter :: secspqtrday = secspday / 4 ! seconds per quarter day - integer :: c,p ! indices - integer :: fp ! lake filter pft index - real(r8):: ws_flag ! winter-summer solstice flag (0 or 1) - 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):: lat !latitude (radians) -! real(r8):: temp !temporary variable for daylength calculation -!EOP -!----------------------------------------------------------------------- - ! Assign local pointers to derived type arrays (in) - ivt =>pft%itype - pcolumn =>pft%column - pgridcell =>pft%gridcell -! latdeg => grc%latdeg -! decl => cps%decl - leafc_storage => pcs%leafc_storage - frootc_storage => pcs%frootc_storage - livestemc_storage => pcs%livestemc_storage - deadstemc_storage => pcs%deadstemc_storage - livecrootc_storage => pcs%livecrootc_storage - deadcrootc_storage => pcs%deadcrootc_storage - gresp_storage => pcs%gresp_storage - leafn_storage => pns%leafn_storage - frootn_storage => pns%frootn_storage - livestemn_storage => pns%livestemn_storage - deadstemn_storage => pns%deadstemn_storage - livecrootn_storage => pns%livecrootn_storage - deadcrootn_storage => pns%deadcrootn_storage - soilpsi => cps%soilpsi - psiwilt => cps%psiwilt - t_soisno => ces%t_soisno - t_grnd => ces%t_grnd - leaf_long => pftcon%leaf_long - woody => pftcon%woody - stress_decid => pftcon%stress_decid - - ! Assign local pointers to derived type arrays (out) - dormant_flag => pepv%dormant_flag - days_active => pepv%days_active - onset_flag => pepv%onset_flag - onset_counter => pepv%onset_counter - onset_gddflag => pepv%onset_gddflag - onset_fdd => pepv%onset_fdd - onset_gdd => pepv%onset_gdd - onset_swi => pepv%onset_swi - offset_flag => pepv%offset_flag - offset_counter => pepv%offset_counter - dayl => pepv%dayl - prev_dayl => pepv%prev_dayl - offset_fdd => pepv%offset_fdd - offset_swi => pepv%offset_swi - annavg_t2m => pepv%annavg_t2m - prev_leafc_to_litter => pepv%prev_leafc_to_litter - prev_frootc_to_litter => pepv%prev_frootc_to_litter - lgsf => pepv%lgsf - bglfr => pepv%bglfr - bgtr => pepv%bgtr - leafc_xfer_to_leafc => pcf%leafc_xfer_to_leafc - frootc_xfer_to_frootc => pcf%frootc_xfer_to_frootc - livestemc_xfer_to_livestemc => pcf%livestemc_xfer_to_livestemc - deadstemc_xfer_to_deadstemc => pcf%deadstemc_xfer_to_deadstemc - livecrootc_xfer_to_livecrootc => pcf%livecrootc_xfer_to_livecrootc - deadcrootc_xfer_to_deadcrootc => pcf%deadcrootc_xfer_to_deadcrootc - leafn_xfer_to_leafn => pnf%leafn_xfer_to_leafn - frootn_xfer_to_frootn => pnf%frootn_xfer_to_frootn - livestemn_xfer_to_livestemn => pnf%livestemn_xfer_to_livestemn - deadstemn_xfer_to_deadstemn => pnf%deadstemn_xfer_to_deadstemn - livecrootn_xfer_to_livecrootn => pnf%livecrootn_xfer_to_livecrootn - deadcrootn_xfer_to_deadcrootn => pnf%deadcrootn_xfer_to_deadcrootn - leafc_xfer => pcs%leafc_xfer - frootc_xfer => pcs%frootc_xfer - livestemc_xfer => pcs%livestemc_xfer - deadstemc_xfer => pcs%deadstemc_xfer - livecrootc_xfer => pcs%livecrootc_xfer - deadcrootc_xfer => pcs%deadcrootc_xfer - leafn_xfer => pns%leafn_xfer - frootn_xfer => pns%frootn_xfer - livestemn_xfer => pns%livestemn_xfer - deadstemn_xfer => pns%deadstemn_xfer - livecrootn_xfer => pns%livecrootn_xfer - deadcrootn_xfer => pns%deadcrootn_xfer - leafc_storage_to_xfer => pcf%leafc_storage_to_xfer - frootc_storage_to_xfer => pcf%frootc_storage_to_xfer - livestemc_storage_to_xfer => pcf%livestemc_storage_to_xfer - deadstemc_storage_to_xfer => pcf%deadstemc_storage_to_xfer - livecrootc_storage_to_xfer => pcf%livecrootc_storage_to_xfer - deadcrootc_storage_to_xfer => pcf%deadcrootc_storage_to_xfer - gresp_storage_to_xfer => pcf%gresp_storage_to_xfer - leafn_storage_to_xfer => pnf%leafn_storage_to_xfer - frootn_storage_to_xfer => pnf%frootn_storage_to_xfer - livestemn_storage_to_xfer => pnf%livestemn_storage_to_xfer - deadstemn_storage_to_xfer => pnf%deadstemn_storage_to_xfer - livecrootn_storage_to_xfer => pnf%livecrootn_storage_to_xfer - deadcrootn_storage_to_xfer => pnf%deadcrootn_storage_to_xfer - - ! set time steps - dayspyr = get_days_per_year() - - do fp = 1,num_soilp - p = filter_soilp(fp) - c = pcolumn(p) - - if (stress_decid(ivt(p)) == 1._r8) then -! soilt = t_soisno(c,3) - soilt = max(t_grnd(c),t_soisno(c,1)) ! use TP1 or weighted TG & TP1 -! psi = soilpsi(c,3) - psi = soilpsi(c,1) ! use root-zone - - soilpsi_on = psiwilt(c) ! use catchment wilting point, fzeng, 22 Mar 2017 - soilpsi_off = psiwilt(c) ! use catchment wilting point, fzeng, 22 Mar 2017 - - ! use solar declination information stored during Surface Albedo() - ! and latitude from gps to calcluate daylength (convert latitude from degrees to radians) - ! the constant 13750.9871 is the number of seconds per radian of hour-angle - - ! Calculation of dayl moved to CN_DriverMod.F90, fzeng, 22 Mar 2017 -! lat = (SHR_CONST_PI/180._r8)*grc%latdeg(pgridcell(p)) -! temp = -(sin(lat)*sin(decl(c)))/(cos(lat) * cos(decl(c))) -! temp = min(1._r8,max(-1._r8,temp)) -! dayl(p) = 2.0_r8 * 13750.9871_r8 * acos(temp) - - ! set flag for solstice period (winter->summer = 1, summer->winter = 0) - if (dayl(p) >= prev_dayl(p)) then - ws_flag = 1. - else - ws_flag = 0. - end if - - ! 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)) - - crit_offset_fdd = 15.0 - if(ivt(p)==14 .or. ivt(p)==18 .or. ivt(p)==10 .or. ivt(p)==16) crit_offset_fdd = 999.0 ! no T stress trigger - if(ivt(p)==15 .or. ivt(p)==19 .or. ivt(p)==11 .or. ivt(p)==17) crit_offset_fdd = 999.0 ! no T stress trigger - - ! update offset_counter and test for the end of the offset period - if (offset_flag(p) == 1._r8) then - ! decrement counter for offset period - offset_counter(p) = offset_counter(p) - dt - - ! if this is the end of the offset_period, reset phenology - ! flags and indices - if (offset_counter(p) <= 0._r8) then - ! this code block was originally handled by call cn_offset_cleanup(p) - ! inlined during vectorization - offset_flag(p) = 0._r8 - offset_counter(p) = 0._r8 - dormant_flag(p) = 1._r8 - days_active(p) = 0._r8 - - ! reset the previous timestep litterfall flux memory - prev_leafc_to_litter(p) = 0._r8 - prev_frootc_to_litter(p) = 0._r8 - end if - end if - - ! update onset_counter and test for the end of the onset period - if (onset_flag(p) == 1.0_r8) then - ! decrement counter for onset period - onset_counter(p) = onset_counter(p) - dt - - ! if this is the end of the onset period, reset phenology - ! flags and indices - if (onset_counter(p) <= 0.0_r8) then - ! this code block was originally handled by call cn_onset_cleanup(p) - ! inlined during vectorization - onset_flag(p) = 0._r8 - onset_counter(p) = 0._r8 - ! set all transfer growth rates to 0.0 - leafc_xfer_to_leafc(p) = 0._r8 - frootc_xfer_to_frootc(p) = 0._r8 - leafn_xfer_to_leafn(p) = 0._r8 - frootn_xfer_to_frootn(p) = 0._r8 - if (woody(ivt(p)) == 1.0_r8) then - livestemc_xfer_to_livestemc(p) = 0._r8 - deadstemc_xfer_to_deadstemc(p) = 0._r8 - livecrootc_xfer_to_livecrootc(p) = 0._r8 - deadcrootc_xfer_to_deadcrootc(p) = 0._r8 - livestemn_xfer_to_livestemn(p) = 0._r8 - deadstemn_xfer_to_deadstemn(p) = 0._r8 - livecrootn_xfer_to_livecrootn(p) = 0._r8 - deadcrootn_xfer_to_deadcrootn(p) = 0._r8 - end if - ! set transfer pools to 0.0 - leafc_xfer(p) = 0._r8 - leafn_xfer(p) = 0._r8 - frootc_xfer(p) = 0._r8 - frootn_xfer(p) = 0._r8 - if (woody(ivt(p)) == 1.0_r8) then - livestemc_xfer(p) = 0._r8 - livestemn_xfer(p) = 0._r8 - deadstemc_xfer(p) = 0._r8 - deadstemn_xfer(p) = 0._r8 - livecrootc_xfer(p) = 0._r8 - livecrootn_xfer(p) = 0._r8 - deadcrootc_xfer(p) = 0._r8 - deadcrootn_xfer(p) = 0._r8 - end if - end if - end if - - ! test for switching from dormant period to growth period - if (dormant_flag(p) == 1._r8) then - - ! keep track of the number of freezing degree days in this - ! dormancy period (only if the freeze flag has not previously been set - ! for this dormancy period - - if (onset_gddflag(p) == 0._r8 .and. soilt < SHR_CONST_TKFRZ) onset_fdd(p) = onset_fdd(p) + fracday - - ! if the number of freezing degree days exceeds a critical value, - ! then onset will require both wet soils and a critical soil - ! temperature sum. If this case is triggered, reset any previously - ! accumulated value in onset_swi, so that onset now depends on - ! the accumulated soil water index following the freeze trigger - - if (onset_fdd(p) > crit_onset_fdd) then - onset_gddflag(p) = 1._r8 - onset_fdd(p) = 0._r8 - onset_swi(p) = 0._r8 - end if - - if (ivt(p)==14 .or. ivt(p)==18 .or. ivt(p)==10 .or. ivt(p)==16) then ! fzeng: special case; seasonal deciduous - -! after winter solstice, allow check for new growth - if (onset_gddflag(p) == 0. .and. ws_flag == 1.) then - onset_gddflag(p) = 1. - onset_gdd(p) = 0. - onset_fdd(p) = 999. - onset_swi(p) = 0. - end if - -! before winter solstice, prevent growth onset - if (ws_flag == 0.) then - if (onset_flag(p) == 1. .or. dormant_flag(p) == 1. .or. onset_gddflag(p) == 1.) then - onset_flag(p) = 0. - onset_gddflag(p) = 0. - onset_gdd(p) = 0. - onset_fdd(p) = 999. - onset_swi(p) = 0. - end if - endif - - endif - - ! if the freeze flag is set, and if the soil is above freezing - ! then accumulate growing degree days for onset trigger - - if (onset_gddflag(p) == 1._r8 .and. soilt > SHR_CONST_TKFRZ) then - onset_gdd(p) = onset_gdd(p) + (soilt-SHR_CONST_TKFRZ)*fracday - end if - - ! if soils are wet, accumulate soil water index for onset trigger - if (psi > soilpsi_on) onset_swi(p) = onset_swi(p) + fracday - - ! if critical soil water index is exceeded, set onset_flag, and - ! then test for soil temperature criteria - - if (onset_swi(p) > crit_onset_swi) then - onset_flag(p) = 1._r8 - - ! only check soil temperature criteria if freeze flag set since - ! beginning of last dormancy. If freeze flag set and growing - ! degree day sum (since freeze trigger) is lower than critical - ! value, then override the onset_flag set from soil water. - - if (onset_gddflag(p) == 1._r8 .and. onset_gdd(p) < crit_onset_gdd) onset_flag(p) = 0._r8 - end if - - ! only allow onset if dayl > 6hrs - if (onset_flag(p) == 1._r8 .and. dayl(p) <= 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 - leafc_storage_to_xfer(p) = fstor2tran * leafc_storage(p)/dt - frootc_storage_to_xfer(p) = fstor2tran * frootc_storage(p)/dt - if (woody(ivt(p)) == 1.0_r8) then - livestemc_storage_to_xfer(p) = fstor2tran * livestemc_storage(p)/dt - deadstemc_storage_to_xfer(p) = fstor2tran * deadstemc_storage(p)/dt - livecrootc_storage_to_xfer(p) = fstor2tran * livecrootc_storage(p)/dt - deadcrootc_storage_to_xfer(p) = fstor2tran * deadcrootc_storage(p)/dt - gresp_storage_to_xfer(p) = fstor2tran * gresp_storage(p)/dt - end if - - ! set nitrogen fluxes for shifting storage pools to transfer pools - leafn_storage_to_xfer(p) = fstor2tran * leafn_storage(p)/dt - frootn_storage_to_xfer(p) = fstor2tran * frootn_storage(p)/dt - if (woody(ivt(p)) == 1.0_r8) then - livestemn_storage_to_xfer(p) = fstor2tran * livestemn_storage(p)/dt - deadstemn_storage_to_xfer(p) = fstor2tran * deadstemn_storage(p)/dt - livecrootn_storage_to_xfer(p) = fstor2tran * livecrootn_storage(p)/dt - deadcrootn_storage_to_xfer(p) = fstor2tran * deadcrootn_storage(p)/dt - end if - end if - - ! test for switching from growth period to offset period - else if (offset_flag(p) == 0._r8) then - - ! if soil water potential lower than critical value, accumulate - ! as stress in offset soil water index - - if (psi <= soilpsi_off) then - offset_swi(p) = offset_swi(p) + fracday - - ! if the offset soil water index exceeds critical value, and - ! if this is not the middle of a previously initiated onset period, - ! then set flag to start the offset period and reset index variables - - if (offset_swi(p) >= crit_offset_swi .and. onset_flag(p) == 0._r8) offset_flag(p) = 1._r8 - - ! if soil water potential higher than critical value, reduce the - ! offset water stress index. By this mechanism, there must be a - ! sustained period of water stress to initiate offset. - - else if (psi > soilpsi_on) then - offset_swi(p) = offset_swi(p) - fracday - offset_swi(p) = max(offset_swi(p),0._r8) - end if - - ! decrease freezing day accumulator for warm soil - if (offset_fdd(p) > 0._r8 .and. soilt > SHR_CONST_TKFRZ) then - offset_fdd(p) = offset_fdd(p) - fracday - offset_fdd(p) = max(0._r8, offset_fdd(p)) - end if - - ! increase freezing day accumulator for cold soil - if (soilt <= SHR_CONST_TKFRZ) then - offset_fdd(p) = offset_fdd(p) + fracday - - ! if freezing degree day sum is greater than critical value, initiate offset - if (offset_fdd(p) > crit_offset_fdd .and. onset_flag(p) == 0._r8) offset_flag(p) = 1._r8 - end if - - ! force offset if daylength is < 6 hrs - if (dayl(p) <= secspqtrday) then - offset_flag(p) = 1._r8 - end if - - ! only begin to test for offset daylength once past the summer sol - if( ivt(p)==14 .or. ivt(p)==18 .or. ivt(p)==10 .or. ivt(p)==16) then ! fzeng: special case - if (ws_flag == 0. .and. dayl(p) < crit_dayl) then - offset_flag(p) = 1. - end if - endif - - ! 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((days_active(p)-dayspyr)/dayspyr, 1._r8),0._r8) - - ! set background litterfall rate, when not in the phenological offset period - if (offset_flag(p) == 1._r8) then - bglfr(p) = 0._r8 - else - ! calculate the background litterfall rate (bglfr) - ! in units 1/s, based on leaf longevity (yrs) and correction for long growing season - - bglfr(p) = (1._r8/(leaf_long(ivt(p))*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 - - leafc_storage_to_xfer(p) = leafc_storage(p) * bgtr(p) - frootc_storage_to_xfer(p) = frootc_storage(p) * bgtr(p) - if (woody(ivt(p)) == 1.0_r8) then - livestemc_storage_to_xfer(p) = livestemc_storage(p) * bgtr(p) - deadstemc_storage_to_xfer(p) = deadstemc_storage(p) * bgtr(p) - livecrootc_storage_to_xfer(p) = livecrootc_storage(p) * bgtr(p) - deadcrootc_storage_to_xfer(p) = deadcrootc_storage(p) * bgtr(p) - gresp_storage_to_xfer(p) = gresp_storage(p) * bgtr(p) - end if - - ! set nitrogen fluxes for shifting storage pools to transfer pools - leafn_storage_to_xfer(p) = leafn_storage(p) * bgtr(p) - frootn_storage_to_xfer(p) = frootn_storage(p) * bgtr(p) - if (woody(ivt(p)) == 1.0_r8) then - livestemn_storage_to_xfer(p) = livestemn_storage(p) * bgtr(p) - deadstemn_storage_to_xfer(p) = deadstemn_storage(p) * bgtr(p) - livecrootn_storage_to_xfer(p) = livecrootn_storage(p) * bgtr(p) - deadcrootn_storage_to_xfer(p) = deadcrootn_storage(p) * bgtr(p) - end if - end if - - end if ! end if stress deciduous - - end do ! end of pft loop - -end subroutine CNStressDecidPhenology -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CropPhenology -! -! !INTERFACE: -subroutine CropPhenology(num_pcropp, filter_pcropp) - -! !DESCRIPTION: -! Code from AgroIBIS to determine crop phenology and code from CN to -! handle CN fluxes during the phenological onset & offset periods. - -! !USES: - use clm_time_manager, only : get_curr_date, get_curr_calday, get_days_per_year - use pftvarcon , only : ncorn, nscereal, nwcereal, nsoybean, & - nwcerealirrig, nsoybeanirrig, ncornirrig, nscerealirrig - use clm_varcon , only : spval, secspday - -! !ARGUMENTS: - integer, intent(in) :: num_pcropp ! number of prog crop pfts in filter - integer, intent(in) :: filter_pcropp(:) ! filter for prognostic crop pfts - -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 2/5/08: slevis created according to AgroIBIS subroutines of Kucharik et al. -! 7/14/08: slevis adapted crop cycles to southern hemisphere -! 3/29/11: ekluzek simply logic using pftvarcon arrays - -!EOP - -! 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 ! pft indices - integer c ! column indices - integer g ! gridcell indices - integer h ! hemisphere indices - integer idpp ! number of days past planting - real(r8) dayspyr ! days per year - real(r8) crmcorn ! comparitive relative maturity for corn - real(r8) ndays_on ! number of days to fertilize - -! local pointers to implicit in scalars - - integer , pointer :: pgridcell(:)! pft's gridcell index - integer , pointer :: pcolumn(:) ! pft's column index - integer , pointer :: ivt(:) ! pft - real(r8), pointer :: hui(:) ! =gdd since planting (gddplant) - real(r8), pointer :: leafout(:) ! =gdd from top soil layer temperature - real(r8), pointer :: tlai(:) ! one-sided leaf area index, no burying by snow - real(r8), pointer :: gdd020(:) ! 20 yr mean of gdd0 - real(r8), pointer :: gdd820(:) ! 20 yr mean of gdd8 - real(r8), pointer :: gdd1020(:) ! 20 yr mean of gdd10 - real(r8), pointer :: a5tmin(:) ! 5-day running mean of min 2-m temperature - real(r8), pointer :: a10tmin(:) ! 10-day running mean of min 2-m temperature - real(r8), pointer :: t10(:) ! 10-day running mean of the 2 m temperature (K) - real(r8), pointer :: t_ref2m_min(:) !daily minimum of average 2 m height surface air temperature (K) - real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s) - real(r8), pointer :: lgsf(:) ! long growing season factor [0-1] - real(r8), pointer :: offset_flag(:) ! offset flag - real(r8), pointer :: offset_counter(:) ! offset counter - real(r8), pointer :: leaf_long(:) ! leaf longevity (yrs) - real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN) - real(r8), pointer :: fertnitro(:) ! max fertilizer to be applied in total (kgN/m2) - real(r8), pointer :: gddmin(:) ! Minimim growing degree days used in CNPhenology - real(r8), pointer :: hybgdd(:) ! Growing Degree Days for maturity used in CNPhenology - real(r8), pointer :: lfemerg(:) ! Leaf emergence parameter used in CNPhenology (unitless) - real(r8), pointer :: grnfill(:) ! Grain fill parameter used in CNPhenology (unitless) - real(r8), pointer :: mxmat(:) ! Maximum number of days to maturity parameter in CNPhenology (days) - real(r8), pointer :: minplanttemp(:) ! Average 5 day daily minimum temperature needed for planting (K) - real(r8), pointer :: planttemp(:) ! Average 10 day temperature needed for planting (K) - -! local pointers to implicit out scalars - integer , pointer :: idop(:) ! date of planting - integer , pointer :: harvdate(:) ! harvest date - logical , pointer :: croplive(:) ! Flag, true if planted, not harvested - logical , pointer :: cropplant(:) ! Flag, true if crop may be planted - real(r8), pointer :: cumvd(:) ! cumulative vernalization d?ependence? - real(r8), pointer :: hdidx(:) ! cold hardening index? - real(r8), pointer :: vf(:) ! vernalization factor - real(r8), pointer :: gddmaturity(:) ! gdd needed to harvest - real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s) - real(r8), pointer :: huileaf(:) ! heat unit index needed from planting to leaf emergence - real(r8), pointer :: huigrain(:) ! same to reach vegetative maturity - real(r8), pointer :: onset_flag(:) ! onset flag - real(r8), pointer :: onset_counter(:) ! onset counter - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: dwt_seedc_to_leaf(:) ! (gC/m2/s) seed source to PFT-level - real(r8), pointer :: dwt_seedn_to_leaf(:) ! (gN/m2/s) seed source to PFT-level - real(r8), pointer :: fert_counter(:) ! >0 fertilize; <=0 not (seconds) - real(r8), pointer :: fert(:) ! fertilizer applied each timestep (gN/m2/s) -!------------------------------------------------------------------------ - - pgridcell =>pft%gridcell - pcolumn =>pft%column - ivt =>pft%itype - idop => pps%idop - harvdate => pps%harvdate - croplive => pps%croplive - cropplant => pps%cropplant - gddmaturity => pps%gddmaturity - huileaf => pps%huileaf - huigrain => pps%huigrain - hui => pps%gddplant - leafout => pps%gddtsoi - tlai => pps%tlai - gdd020 => pps%gdd020 - gdd820 => pps%gdd820 - gdd1020 => pps%gdd1020 - a5tmin => pes%a5tmin - a10tmin => pes%a10tmin - t10 => pes%t10 - cumvd => pps%cumvd - hdidx => pps%hdidx - vf => pps%vf - t_ref2m_min => pes%t_ref2m_min - bglfr => pepv%bglfr - bgtr => pepv%bgtr - lgsf => pepv%lgsf - onset_flag => pepv%onset_flag - offset_flag => pepv%offset_flag - onset_counter => pepv%onset_counter - offset_counter => pepv%offset_counter - fert_counter => pepv%fert_counter - leafc_xfer => pcs%leafc_xfer - leafn_xfer => pns%leafn_xfer - fert => pnf%fert - leaf_long => pftcon%leaf_long - leafcn => pftcon%leafcn - fertnitro => pftcon%fertnitro - dwt_seedc_to_leaf => ccf%dwt_seedc_to_leaf - dwt_seedn_to_leaf => cnf%dwt_seedn_to_leaf - gddmin => pftcon%gddmin - hybgdd => pftcon%hybgdd - lfemerg => pftcon%lfemerg - grnfill => pftcon%grnfill - mxmat => pftcon%mxmat - minplanttemp => pftcon%minplanttemp - planttemp => pftcon%planttemp - -! --------------------------------------- - - ! get time info - dayspyr = get_days_per_year() - jday = get_curr_calday() - call get_curr_date(kyr, kmo, kda, mcsec) - - ndays_on = 20._r8 ! number of days to fertilize - - do fp = 1, num_pcropp - p = filter_pcropp(fp) - c = pcolumn(p) - g = pgridcell(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 (e.g. winter temperate cereal) - - if (.not. croplive(p)) then - cropplant(p) = .false. - idop(p) = NOT_Planted - - ! keep next for continuous, annual winter temperate cereal type 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) == nwcereal .or. ivt(p) == nwcerealirrig)) 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) == nwcereal .or. ivt(p) == nwcerealirrig) 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 pfts 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) = 1._r8 ! initial seed at planting to appear - leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset - dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) + leafc_xfer(p)/dt - dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) + leafn_xfer(p)/dt - - ! latest possible date to plant winter 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) = 1._r8 ! initial seed at planting to appear - leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset - dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) + leafc_xfer(p)/dt - dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) + leafn_xfer(p)/dt - else - gddmaturity(p) = 0._r8 - end if - - else ! not winter 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)==nsoybean .or. ivt(p) == nsoybeanirrig) gddmaturity(p)=min(gdd1020(p),hybgdd(ivt(p))) - if (ivt(p)==ncorn .or. ivt(p)==ncornirrig) 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)==nscereal .or. ivt(p) == nscerealirrig) gddmaturity(p)=min(gdd020(p),hybgdd(ivt(p))) - - leafc_xfer(p) = 1._r8 ! initial seed at planting to appear - leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset - dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) + leafc_xfer(p)/dt - dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) + leafn_xfer(p)/dt - - ! 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)==nsoybean .or. ivt(p) == nsoybeanirrig) gddmaturity(p)=min(gdd1020(p),hybgdd(ivt(p))) - if (ivt(p)==ncorn .or. ivt(p)==ncornirrig) gddmaturity(p)=max(950._r8, min(gdd820(p)*0.85_r8, hybgdd(ivt(p)))) - if (ivt(p)==nscereal .or. ivt(p) == nscerealirrig) gddmaturity(p)=min(gdd020(p),hybgdd(ivt(p))) - - leafc_xfer(p) = 1._r8 ! initial seed at planting to appear - leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset - dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) + leafc_xfer(p)/dt - dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) + leafn_xfer(p)/dt - - else - gddmaturity(p) = 0._r8 - end if - end if ! crop pft distinction - - ! crop phenology (gdd thresholds) controlled by gdd needed for - ! maturity (physiological) which is based on the average gdd - ! accumulation and hybrids in United States from April 1 - Sept 30 - - ! calculate threshold from phase 1 to phase 2: - ! threshold for attaining leaf emergence (based on fraction of - ! gdd(i) -- climatological average) - ! Hayhoe and Dwyer, 1990, Can. J. Soil Sci 70:493-497 - ! Carlson and Gage, 1989, Agric. For. Met., 45: 313-324 - ! J.T. Ritchie, 1991: Modeling Plant and Soil systems - - huileaf(p) = lfemerg(ivt(p)) * gddmaturity(p) ! 3-7% in 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) == ncorn .or. ivt(p)==ncornirrig) 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 - - ! 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) == nwcereal .or. ivt(p) == nwcerealirrig)) then - call vernalization(p) - 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 (leafout(p) >= huileaf(p) .and. hui(p) < huigrain(p) .and. idpp < mxmat(ivt(p))) then - if (abs(onset_counter(p)) > 1.e-6_r8) then - onset_flag(p) = 1._r8 - onset_counter(p) = dt - fert_counter(p) = ndays_on * secspday - fert(p) = fertnitro(ivt(p)) * 1000._r8 / fert_counter(p) - 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 - if (tlai(p) > 0._r8) then ! plant had emerged before harvest - offset_flag(p) = 1._r8 - offset_counter(p) = dt - else ! plant never emerged from the ground - dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) - leafc_xfer(p)/dt - dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) - leafn_xfer(p)/dt - leafc_xfer(p) = 0._r8 ! revert planting transfers - leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) - end if - - ! enter phase 3 while previous criteria fail and next is true; - ! in terms of order, phase 3 occurs before harvest, but when - ! harvest *can* occur, we want it to have first priority. - ! AgroIBIS uses a complex formula for lai decline. - ! Use CN's simple formula at least as a place holder (slevis) - - else if (hui(p) >= huigrain(p)) then - bglfr(p) = 1._r8/(leaf_long(ivt(p))*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) - dt - end if - - else ! crop not live - ! next 2 lines conserve mass if leaf*_xfer > 0 due to interpinic - dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) - leafc_xfer(p)/dt - dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) - leafn_xfer(p)/dt - onset_counter(p) = 0._r8 - leafc_xfer(p) = 0._r8 - leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) - end if ! croplive - - end do ! prognostic crops loop - -end subroutine CropPhenology -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CropPhenologyInit -! -! !INTERFACE: -subroutine CropPhenologyInit( begp, endp ) - -! !DESCRIPTION: -! Initialization of CropPhenology. Must be called after time-manager is -! initialized, and after pftcon file is read in. -! -! !USES: - use pftvarcon , only: npcropmin, npcropmax - use clm_time_manager, only: get_calday -! -! !ARGUMENTS: - implicit none - integer, intent(IN) :: begp, endp ! Beginning and ending PFT index -! -! !REVISION HISTORY: -! Created by Erik Kluzek -! -!EOP - -! LOCAL VARAIBLES: - real(r8), pointer :: latdeg(:) ! latitude (radians) - integer , pointer :: pgridcell(:) ! pft's gridcell index - integer :: p,g,n,i ! indices -!------------------------------------------------------------------------ - latdeg => grc%latdeg - pgridcell =>pft%gridcell - - allocate( inhemi(begp:endp) ) - - ! 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 - minplantjday(n,inNH) = int( get_calday( pftcon%mnNHplantdate(n), 0 ) ) - maxplantjday(n,inNH) = int( get_calday( pftcon%mxNHplantdate(n), 0 ) ) - end do - do n = npcropmin, npcropmax - minplantjday(n,inSH) = int( get_calday( pftcon%mnSHplantdate(n), 0 ) ) - maxplantjday(n,inSH) = int( get_calday( pftcon%mxSHplantdate(n), 0 ) ) - end do - - ! Figure out what hemisphere each PFT is in - do p = begp, endp - g = pgridcell(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 - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: vernalization -! -! !INTERFACE: - subroutine vernalization(p) -! -! !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: - implicit none - integer, intent(in) :: p ! PFT index running over -! -! !REVISION HISTORY: -! Created by Sam Levis from AGROIBIS -! -!EOP - -! LOCAL VARAIBLES: - real(r8) tcrown ! ? - real(r8) vd, vd1, vd2 ! vernalization dependence - real(r8) tkil ! Freeze kill threshold - integer c,g ! indices -! local pointers to implicit in scalars - integer , pointer :: pcolumn(:) ! pft's column index - logical , pointer :: croplive(:) ! Flag, true if planted, not harvested - real(r8), pointer :: tlai(:) ! one-sided leaf area index, no burying by snow - real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (K) - real(r8), pointer :: t_ref2m_min(:) !daily minimum of average 2 m height surface air temperature (K) - real(r8), pointer :: t_ref2m_max(:) !daily maximum of average 2 m height surface air temperature (K) - real(r8), pointer :: snow_depth(:) ! snow height (m) -! local pointers to implicit out scalars - real(r8), pointer :: vf(:) ! vernalization factor for cereal - real(r8), pointer :: cumvd(:) ! cumulative vernalization d?ependence? - real(r8), pointer :: gddmaturity(:) ! gdd needed to harvest - real(r8), pointer :: huigrain(:) ! heat unit index needed to reach vegetative maturity - real(r8), pointer :: hdidx(:) ! cold hardening index? -!------------------------------------------------------------------------ - - pcolumn =>pft%column - croplive => pps%croplive - hdidx => pps%hdidx - cumvd => pps%cumvd - vf => pps%vf - gddmaturity => pps%gddmaturity - huigrain => pps%huigrain - tlai => pps%tlai - t_ref2m => pes%t_ref2m - t_ref2m_min => pes%t_ref2m_min - t_ref2m_max => pes%t_ref2m_max - snow_depth => cps%snow_depth - - c = pcolumn(p) - - ! for all equations - temperatures must be in degrees (C) - ! calculate temperature of crown of crop (e.g., 3 cm soil temperature) - ! snow depth in centimeters - - if (t_ref2m(p) < tfrz) then !slevis: t_ref2m inst of td=daily avg (K) - tcrown = 2._r8 + (t_ref2m(p) - tfrz) * (0.4_r8 + 0.0018_r8 * & - (min(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 subroutine vernalization - -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNOnsetGrowth -! -! !INTERFACE: -subroutine CNOnsetGrowth (num_soilp, filter_soilp) -! -! !DESCRIPTION: -! Determines the flux of stored C and N from transfer pools to display -! pools during the phenological onset period. -! -! !USES: -! -! !ARGUMENTS: - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 10/27/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: onset_flag(:) ! onset flag - real(r8), pointer :: onset_counter(:) ! onset days counter - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s) -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: leafc_xfer_to_leafc(:) - real(r8), pointer :: frootc_xfer_to_frootc(:) - real(r8), pointer :: livestemc_xfer_to_livestemc(:) - real(r8), pointer :: deadstemc_xfer_to_deadstemc(:) - real(r8), pointer :: livecrootc_xfer_to_livecrootc(:) - real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:) - real(r8), pointer :: leafn_xfer_to_leafn(:) - real(r8), pointer :: frootn_xfer_to_frootn(:) - real(r8), pointer :: livestemn_xfer_to_livestemn(:) - real(r8), pointer :: deadstemn_xfer_to_deadstemn(:) - real(r8), pointer :: livecrootn_xfer_to_livecrootn(:) - real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:) -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: - integer :: p ! indices - integer :: fp ! lake filter pft index - real(r8):: t1 ! temporary variable - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers to derived type arrays (in) - ivt =>pft%itype - onset_flag => pepv%onset_flag - onset_counter => pepv%onset_counter - leafc_xfer => pcs%leafc_xfer - frootc_xfer => pcs%frootc_xfer - livestemc_xfer => pcs%livestemc_xfer - deadstemc_xfer => pcs%deadstemc_xfer - livecrootc_xfer => pcs%livecrootc_xfer - deadcrootc_xfer => pcs%deadcrootc_xfer - leafn_xfer => pns%leafn_xfer - frootn_xfer => pns%frootn_xfer - livestemn_xfer => pns%livestemn_xfer - deadstemn_xfer => pns%deadstemn_xfer - livecrootn_xfer => pns%livecrootn_xfer - deadcrootn_xfer => pns%deadcrootn_xfer - bgtr => pepv%bgtr - woody => pftcon%woody - - ! assign local pointers to derived type arrays (out) - leafc_xfer_to_leafc => pcf%leafc_xfer_to_leafc - frootc_xfer_to_frootc => pcf%frootc_xfer_to_frootc - livestemc_xfer_to_livestemc => pcf%livestemc_xfer_to_livestemc - deadstemc_xfer_to_deadstemc => pcf%deadstemc_xfer_to_deadstemc - livecrootc_xfer_to_livecrootc => pcf%livecrootc_xfer_to_livecrootc - deadcrootc_xfer_to_deadcrootc => pcf%deadcrootc_xfer_to_deadcrootc - leafn_xfer_to_leafn => pnf%leafn_xfer_to_leafn - frootn_xfer_to_frootn => pnf%frootn_xfer_to_frootn - livestemn_xfer_to_livestemn => pnf%livestemn_xfer_to_livestemn - deadstemn_xfer_to_deadstemn => pnf%deadstemn_xfer_to_deadstemn - livecrootn_xfer_to_livecrootn => pnf%livecrootn_xfer_to_livecrootn - deadcrootn_xfer_to_deadcrootn => pnf%deadcrootn_xfer_to_deadcrootn - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! only calculate these fluxes during onset period - if (onset_flag(p) == 1._r8) then - - ! The transfer rate is a linearly decreasing function of time, - ! going to zero on the last timestep of the onset period - - if (onset_counter(p) == dt) then - t1 = 1.0_r8 / dt - else - t1 = 2.0_r8 / (onset_counter(p)) - end if - leafc_xfer_to_leafc(p) = t1 * leafc_xfer(p) - frootc_xfer_to_frootc(p) = t1 * frootc_xfer(p) - leafn_xfer_to_leafn(p) = t1 * leafn_xfer(p) - frootn_xfer_to_frootn(p) = t1 * frootn_xfer(p) - if (woody(ivt(p)) == 1.0_r8) then - livestemc_xfer_to_livestemc(p) = t1 * livestemc_xfer(p) - deadstemc_xfer_to_deadstemc(p) = t1 * deadstemc_xfer(p) - livecrootc_xfer_to_livecrootc(p) = t1 * livecrootc_xfer(p) - deadcrootc_xfer_to_deadcrootc(p) = t1 * deadcrootc_xfer(p) - livestemn_xfer_to_livestemn(p) = t1 * livestemn_xfer(p) - deadstemn_xfer_to_deadstemn(p) = t1 * deadstemn_xfer(p) - livecrootn_xfer_to_livecrootn(p) = t1 * livecrootn_xfer(p) - deadcrootn_xfer_to_deadcrootn(p) = t1 * deadcrootn_xfer(p) - end if - - end if ! end if onset period - - ! calculate the background rate of transfer growth (used for stress - ! deciduous algorithm). In this case, all of the mass in the transfer - ! pools should be moved to displayed growth in each timestep. - - if (bgtr(p) > 0._r8) then - leafc_xfer_to_leafc(p) = leafc_xfer(p) / dt - frootc_xfer_to_frootc(p) = frootc_xfer(p) / dt - leafn_xfer_to_leafn(p) = leafn_xfer(p) / dt - frootn_xfer_to_frootn(p) = frootn_xfer(p) / dt - if (woody(ivt(p)) == 1.0_r8) then - livestemc_xfer_to_livestemc(p) = livestemc_xfer(p) / dt - deadstemc_xfer_to_deadstemc(p) = deadstemc_xfer(p) / dt - livecrootc_xfer_to_livecrootc(p) = livecrootc_xfer(p) / dt - deadcrootc_xfer_to_deadcrootc(p) = deadcrootc_xfer(p) / dt - livestemn_xfer_to_livestemn(p) = livestemn_xfer(p) / dt - deadstemn_xfer_to_deadstemn(p) = deadstemn_xfer(p) / dt - livecrootn_xfer_to_livecrootn(p) = livecrootn_xfer(p) / dt - deadcrootn_xfer_to_deadcrootn(p) = deadcrootn_xfer(p) / dt - end if - end if ! end if bgtr - - end do ! end pft loop - -end subroutine CNOnsetGrowth -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNOffsetLitterfall -! -! !INTERFACE: -subroutine CNOffsetLitterfall (num_soilp, filter_soilp) -! -! !DESCRIPTION: -! Determines the flux of C and N from displayed pools to litter -! pools during the phenological offset period. -! -! !USES: - use pftvarcon , only: npcropmin -! -! !ARGUMENTS: - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 10/27/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: offset_flag(:) ! offset flag - real(r8), pointer :: offset_counter(:) ! offset days counter - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: cpool_to_leafc(:) ! allocation to leaf C (gC/m2/s) - real(r8), pointer :: cpool_to_frootc(:) ! allocation to fine root C (gC/m2/s) -! integer , pointer :: pcolumn(:) ! pft's column index - real(r8), pointer :: grainc(:) ! (gC/m2) grain C - real(r8), pointer :: livestemc(:) ! (gC/m2) livestem C - real(r8), pointer :: cpool_to_grainc(:) ! allocation to grain C (gC/m2/s) - real(r8), pointer :: cpool_to_livestemc(:) ! allocation to live stem C (gC/m2/s) - real(r8), pointer :: livewdcn(:) ! live wood C:N (gC/gN) - real(r8), pointer :: graincn(:) ! grain C:N (gC/gN) - real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN) - real(r8), pointer :: lflitcn(:) ! leaf litter C:N (gC/gN) - real(r8), pointer :: frootcn(:) ! fine root C:N (gC/gN) -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: prev_leafc_to_litter(:) ! previous timestep leaf C litterfall flux (gC/m2/s) - real(r8), pointer :: prev_frootc_to_litter(:) ! previous timestep froot C litterfall flux (gC/m2/s) - real(r8), pointer :: leafc_to_litter(:) ! leaf C litterfall (gC/m2/s) - real(r8), pointer :: frootc_to_litter(:) ! fine root C litterfall (gC/m2/s) - real(r8), pointer :: leafn_to_litter(:) ! leaf N litterfall (gN/m2/s) - real(r8), pointer :: leafn_to_retransn(:) ! leaf N to retranslocated N pool (gN/m2/s) - real(r8), pointer :: frootn_to_litter(:) ! fine root N litterfall (gN/m2/s) - real(r8), pointer :: livestemc_to_litter(:) ! live stem C litterfall (gC/m2/s) - real(r8), pointer :: grainc_to_food(:) ! grain C to food (gC/m2/s) - real(r8), pointer :: livestemn_to_litter(:) ! livestem N to litter (gN/m2/s) - real(r8), pointer :: grainn_to_food(:) ! grain N to food (gN/m2/s) -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: p, c ! indices - integer :: fp ! lake filter pft index - real(r8):: t1 ! temporary variable - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers to derived type arrays (in) - ivt =>pft%itype - offset_flag => pepv%offset_flag - offset_counter => pepv%offset_counter - leafc => pcs%leafc - frootc => pcs%frootc - grainc => pcs%grainc - livestemc => pcs%livestemc - cpool_to_grainc => pcf%cpool_to_grainc - cpool_to_livestemc => pcf%cpool_to_livestemc - cpool_to_leafc => pcf%cpool_to_leafc - cpool_to_frootc => pcf%cpool_to_frootc - leafcn => pftcon%leafcn - lflitcn => pftcon%lflitcn - frootcn => pftcon%frootcn - livewdcn => pftcon%livewdcn - graincn => pftcon%graincn - - ! assign local pointers to derived type arrays (out) - prev_leafc_to_litter => pepv%prev_leafc_to_litter - prev_frootc_to_litter => pepv%prev_frootc_to_litter - leafc_to_litter => pcf%leafc_to_litter - frootc_to_litter => pcf%frootc_to_litter - livestemc_to_litter => pcf%livestemc_to_litter - grainc_to_food => pcf%grainc_to_food - livestemn_to_litter => pnf%livestemn_to_litter - grainn_to_food => pnf%grainn_to_food - leafn_to_litter => pnf%leafn_to_litter - leafn_to_retransn => pnf%leafn_to_retransn - frootn_to_litter => pnf%frootn_to_litter - - ! The litterfall transfer rate starts at 0.0 and increases linearly - ! over time, with displayed growth going to 0.0 on the last day of litterfall - - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! only calculate fluxes during offset period - if (offset_flag(p) == 1._r8) then - - if (offset_counter(p) == dt) then - t1 = 1.0_r8 / dt - leafc_to_litter(p) = t1 * leafc(p) + cpool_to_leafc(p) - frootc_to_litter(p) = t1 * frootc(p) + cpool_to_frootc(p) - ! this assumes that offset_counter == dt for crops - ! if this were ever changed, we'd need to add code to the "else" - if (ivt(p) >= npcropmin) then - grainc_to_food(p) = t1 * grainc(p) + cpool_to_grainc(p) - livestemc_to_litter(p) = t1 * livestemc(p) + cpool_to_livestemc(p) - end if - else - t1 = dt * 2.0_r8 / (offset_counter(p) * offset_counter(p)) - leafc_to_litter(p) = prev_leafc_to_litter(p) + t1*(leafc(p) - prev_leafc_to_litter(p)*offset_counter(p)) - frootc_to_litter(p) = prev_frootc_to_litter(p) + t1*(frootc(p) - prev_frootc_to_litter(p)*offset_counter(p)) - end if - - ! calculate the leaf N litterfall and retranslocation - leafn_to_litter(p) = leafc_to_litter(p) / lflitcn(ivt(p)) - leafn_to_retransn(p) = (leafc_to_litter(p) / leafcn(ivt(p))) - leafn_to_litter(p) - - ! calculate fine root N litterfall (no retranslocation of fine root N) - frootn_to_litter(p) = frootc_to_litter(p) / frootcn(ivt(p)) - - if (ivt(p) >= npcropmin) then - livestemn_to_litter(p) = livestemc_to_litter(p) / livewdcn(ivt(p)) - grainn_to_food(p) = grainc_to_food(p) / graincn(ivt(p)) - end if - - ! save the current litterfall fluxes - prev_leafc_to_litter(p) = leafc_to_litter(p) - prev_frootc_to_litter(p) = frootc_to_litter(p) - - end if ! end if offset period - - end do ! end pft loop - -end subroutine CNOffsetLitterfall -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNBackgroundLitterfall -! -! !INTERFACE: -subroutine CNBackgroundLitterfall (num_soilp, filter_soilp) -! -! !DESCRIPTION: -! Determines the flux of C and N from displayed pools to litter -! pools as the result of background litter fall. -! -! !USES: -! -! !ARGUMENTS: - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 10/2/03: Created by Peter Thornton -! 10/24/03, Peter Thornton: migrated to vector data structures -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - ! pft level - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s) - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - ! ecophysiological constants - real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN) - real(r8), pointer :: lflitcn(:) ! leaf litter C:N (gC/gN) - real(r8), pointer :: frootcn(:) ! fine root C:N (gC/gN) -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: leafc_to_litter(:) - real(r8), pointer :: frootc_to_litter(:) - real(r8), pointer :: leafn_to_litter(:) - real(r8), pointer :: leafn_to_retransn(:) - real(r8), pointer :: frootn_to_litter(:) -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: p ! indices - integer :: fp ! lake filter pft index - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers to derived type arrays (in) - ivt =>pft%itype - bglfr => pepv%bglfr - leafc => pcs%leafc - frootc => pcs%frootc - leafcn => pftcon%leafcn - lflitcn => pftcon%lflitcn - frootcn => pftcon%frootcn - - ! assign local pointers to derived type arrays (out) - leafc_to_litter => pcf%leafc_to_litter - frootc_to_litter => pcf%frootc_to_litter - leafn_to_litter => pnf%leafn_to_litter - leafn_to_retransn => pnf%leafn_to_retransn - frootn_to_litter => pnf%frootn_to_litter - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! only calculate these fluxes if the background litterfall rate is non-zero - if (bglfr(p) > 0._r8) then - ! units for bglfr are already 1/s - leafc_to_litter(p) = bglfr(p) * leafc(p) - frootc_to_litter(p) = bglfr(p) * frootc(p) - - ! calculate the leaf N litterfall and retranslocation - leafn_to_litter(p) = leafc_to_litter(p) / lflitcn(ivt(p)) - leafn_to_retransn(p) = (leafc_to_litter(p) / leafcn(ivt(p))) - leafn_to_litter(p) - - ! calculate fine root N litterfall (no retranslocation of fine root N) - frootn_to_litter(p) = frootc_to_litter(p) / frootcn(ivt(p)) - - end if - - end do - -end subroutine CNBackgroundLitterfall -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNLivewoodTurnover -! -! !INTERFACE: -subroutine CNLivewoodTurnover (num_soilp, filter_soilp) -! -! !DESCRIPTION: -! Determines the flux of C and N from live wood to -! dead wood pools, for stem and coarse root. -! -! !USES: -! -! !ARGUMENTS: - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 12/5/03: created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - ! pft level - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - ! ecophysiological constants - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: livewdcn(:) ! live wood (phloem and ray parenchyma) C:N (gC/gN) - real(r8), pointer :: deadwdcn(:) ! dead wood (xylem and heartwood) C:N (gC/gN) -! -! local pointers to implicit in/out scalars -! - real(r8), pointer :: livestemc_to_deadstemc(:) - real(r8), pointer :: livecrootc_to_deadcrootc(:) - real(r8), pointer :: livestemn_to_deadstemn(:) - real(r8), pointer :: livestemn_to_retransn(:) - real(r8), pointer :: livecrootn_to_deadcrootn(:) - real(r8), pointer :: livecrootn_to_retransn(:) -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: p ! indices - integer :: fp ! lake filter pft index - real(r8):: ctovr ! temporary variable for carbon turnover - real(r8):: ntovr ! temporary variable for nitrogen turnover - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers to derived type arrays (in) - ivt =>pft%itype - livestemc => pcs%livestemc - livecrootc => pcs%livecrootc - livestemn => pns%livestemn - livecrootn => pns%livecrootn - woody => pftcon%woody - livewdcn => pftcon%livewdcn - deadwdcn => pftcon%deadwdcn - - ! assign local pointers to derived type arrays (out) - livestemc_to_deadstemc => pcf%livestemc_to_deadstemc - livecrootc_to_deadcrootc => pcf%livecrootc_to_deadcrootc - livestemn_to_deadstemn => pnf%livestemn_to_deadstemn - livestemn_to_retransn => pnf%livestemn_to_retransn - livecrootn_to_deadcrootn => pnf%livecrootn_to_deadcrootn - livecrootn_to_retransn => pnf%livecrootn_to_retransn - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! only calculate these fluxes for woody types - if (woody(ivt(p)) > 0._r8) then - - ! live stem to dead stem turnover - - ctovr = livestemc(p) * lwtop - ntovr = ctovr / livewdcn(ivt(p)) - livestemc_to_deadstemc(p) = ctovr - livestemn_to_deadstemn(p) = ctovr / deadwdcn(ivt(p)) - livestemn_to_retransn(p) = ntovr - livestemn_to_deadstemn(p) - - ! live coarse root to dead coarse root turnover - - ctovr = livecrootc(p) * lwtop - ntovr = ctovr / livewdcn(ivt(p)) - livecrootc_to_deadcrootc(p) = ctovr - livecrootn_to_deadcrootn(p) = ctovr / deadwdcn(ivt(p)) - livecrootn_to_retransn(p) = ntovr - livecrootn_to_deadcrootn(p) - - end if - - end do - -end subroutine CNLivewoodTurnover -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNLitterToColumn -! -! !INTERFACE: -subroutine CNLitterToColumn (num_soilc, filter_soilc) -! -! !DESCRIPTION: -! called at the end of cn_phenology to gather all pft-level litterfall fluxes -! to the column level and assign them to the three litter pools -! -! !USES: - use clm_varpar, only : max_pft_per_col, nlevdecomp - use pftvarcon , only : npcropmin -! -! !ARGUMENTS: - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns -! -! !CALLED FROM: -! subroutine CNPhenology -! -! !REVISION HISTORY: -! 9/8/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! - logical , pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details) - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: wtcol(:) ! weight (relative to column) for this pft (0-1) - real(r8), pointer :: leafc_to_litter(:) ! leaf C litterfall (gC/m2/s) - real(r8), pointer :: frootc_to_litter(:) ! fine root N litterfall (gN/m2/s) - real(r8), pointer :: livestemc_to_litter(:) ! live stem C litterfall (gC/m2/s) - real(r8), pointer :: grainc_to_food(:) ! grain C to food (gC/m2/s) - real(r8), pointer :: livestemn_to_litter(:) ! livestem N to litter (gN/m2/s) - real(r8), pointer :: grainn_to_food(:) ! grain N to food (gN/m2/s) - real(r8), pointer :: leafn_to_litter(:) ! leaf N litterfall (gN/m2/s) - real(r8), pointer :: frootn_to_litter(:) ! fine root N litterfall (gN/m2/s) - real(r8), pointer :: phenology_c_to_litr_met_c(:,:) ! C fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gC/m3/s) - real(r8), pointer :: phenology_c_to_litr_cel_c(:,:) ! C fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gC/m3/s) - real(r8), pointer :: phenology_c_to_litr_lig_c(:,:) ! C fluxes associated with phenology (litterfall and crop) to litter lignin pool (gC/m3/s) - real(r8), pointer :: phenology_n_to_litr_met_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gN/m3/s) - real(r8), pointer :: phenology_n_to_litr_cel_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gN/m3/s) - real(r8), pointer :: phenology_n_to_litr_lig_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter lignin pool (gN/m3/s) - real(r8), pointer :: lf_flab(:) ! leaf litter labile fraction - real(r8), pointer :: lf_fcel(:) ! leaf litter cellulose fraction - real(r8), pointer :: lf_flig(:) ! leaf litter lignin fraction - real(r8), pointer :: fr_flab(:) ! fine root litter labile fraction - real(r8), pointer :: fr_fcel(:) ! fine root litter cellulose fraction - real(r8), pointer :: fr_flig(:) ! fine root litter lignin fraction - integer , pointer :: npfts(:) ! number of pfts for each column - integer , pointer :: pfti(:) ! beginning pft index for each column -! -! local pointers to implicit in/out scalars -! - - real(r8), pointer :: leaf_prof(:,:) ! (1/m) profile of leaves - real(r8), pointer :: froot_prof(:,:) ! (1/m) profile of fine roots - -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: fc,c,pi,p,j ! indices -!EOP -!----------------------------------------------------------------------- - ! assign local pointers to derived type arrays (in) - pactive => pft%active - ivt =>pft%itype - wtcol =>pft%wtcol - leafc_to_litter => pcf%leafc_to_litter - frootc_to_litter => pcf%frootc_to_litter - livestemc_to_litter => pcf%livestemc_to_litter - grainc_to_food => pcf%grainc_to_food - livestemn_to_litter => pnf%livestemn_to_litter - grainn_to_food => pnf%grainn_to_food - leafn_to_litter => pnf%leafn_to_litter - frootn_to_litter => pnf%frootn_to_litter - npfts =>col%npfts - pfti =>col%pfti - phenology_c_to_litr_met_c => ccf%phenology_c_to_litr_met_c - phenology_c_to_litr_cel_c => ccf%phenology_c_to_litr_cel_c - phenology_c_to_litr_lig_c => ccf%phenology_c_to_litr_lig_c - phenology_n_to_litr_met_n => cnf%phenology_n_to_litr_met_n - phenology_n_to_litr_cel_n => cnf%phenology_n_to_litr_cel_n - phenology_n_to_litr_lig_n => cnf%phenology_n_to_litr_lig_n - lf_flab => pftcon%lf_flab - lf_fcel => pftcon%lf_fcel - lf_flig => pftcon%lf_flig - fr_flab => pftcon%fr_flab - fr_fcel => pftcon%fr_fcel - fr_flig => pftcon%fr_flig - - ! assign local pointers to derived type arrays (out) - - leaf_prof => pps%leaf_prof - froot_prof => pps%froot_prof - - do j = 1, nlevdecomp - do pi = 1,max_pft_per_col - do fc = 1,num_soilc - c = filter_soilc(fc) - - if ( pi <= npfts(c) ) then - p = pfti(c) + pi - 1 - if (pactive(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) - - ! 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 do - - end do - end do - -end subroutine CNLitterToColumn -!----------------------------------------------------------------------- -!#endif - -end module CNPhenologyMod 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 deleted file mode 100644 index 54849cb78..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNPrecisionControlMod.F90 +++ /dev/null @@ -1,833 +0,0 @@ -module CNPrecisionControlMod - -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNPrecisionControlMod -! -! !DESCRIPTION: -! controls on very low values in critical state variables -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varpar , only: ndecomp_pools - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: CNPrecisionControl -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNPrecisionControl -! -! !INTERFACE: -subroutine CNPrecisionControl(num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! On the radiation time step, force leaf and deadstem c and n to 0 if -! they get too small. -! -! !USES: - use clmtype - use clm_varctl, only: iulog, use_c13, use_c14 - use clm_varpar, only: nlevdecomp - use pftvarcon, only: nc3crop2 - use clm_varctl, only: crop_prog -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 8/1/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars - real(r8), pointer :: col_ctrunc_vr(:,:) ! (gC/m3) column-level sink for C truncation - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: col_ntrunc_vr(:,:) ! (gN/m3) column-level sink for N truncation - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation - real(r8), pointer :: xsmrpool(:) ! (gC/m2) execss maint resp C pool - real(r8), pointer :: grainc(:) ! (gC/m2) grain C - real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage - real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer - - !!! C13 - real(r8), pointer :: c13_col_ctrunc_vr(:,:) ! (gC/m3) column-level sink for C truncation - real(r8), pointer :: decomp_c13pools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: c13_cpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: c13_deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: c13_deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: c13_deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: c13_deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: c13_deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: c13_deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: c13_frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: c13_frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: c13_frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: c13_gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: c13_gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: c13_leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: c13_leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: c13_leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: c13_livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: c13_livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: c13_livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: c13_livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: c13_livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: c13_livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: c13_pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation - - !!! C14 - real(r8), pointer :: c14_col_ctrunc_vr(:,:) ! (gC/m3) column-level sink for C truncation - real(r8), pointer :: decomp_c14pools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: c14_cpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: c14_deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: c14_deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: c14_deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: c14_deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: c14_deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: c14_deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: c14_frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: c14_frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: c14_frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: c14_gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: c14_gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: c14_leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: c14_leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: c14_leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: c14_livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: c14_livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: c14_livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: c14_livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: c14_livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: c14_livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: c14_pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation - - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: grainn(:) ! (gC/m2) grain N - real(r8), pointer :: grainn_storage(:) ! (gC/m2) grain N storage - real(r8), pointer :: grainn_xfer(:) ! (gC/m2) grain N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool - real(r8), pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N -#ifdef NITRIF_DENITRIF - real(r8), pointer :: smin_no3_vr(:,:) ! (gN/m3) soil mineral NO3 - real(r8), pointer :: smin_nh4_vr(:,:) ! (gN/m3) soil mineral NH4 -#endif - integer , pointer :: ivt(:) ! pft vegetation type -! -! local pointers to implicit in/out scalars -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: - integer :: c,p,j,k ! indices - integer :: fp,fc ! lake filter indices - real(r8):: pc,pn ! truncation terms for pft-level corrections - real(r8):: cc,cn ! truncation terms for column-level corrections - !!! C13 - real(r8):: pc13 ! truncation terms for pft-level corrections - real(r8):: cc13 ! truncation terms for column-level corrections - !!! C14 - real(r8):: pc14 ! truncation terms for pft-level corrections - real(r8):: cc14 ! truncation terms for column-level corrections - - real(r8):: ccrit ! critical carbon state value for truncation - real(r8):: ncrit ! critical nitrogen state value for truncation - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers at the column level - col_ctrunc_vr => ccs%col_ctrunc_vr - decomp_cpools_vr => ccs%decomp_cpools_vr - col_ntrunc_vr => cns%col_ntrunc_vr - decomp_npools_vr => cns%decomp_npools_vr - ! assign local pointers at the pft level - ivt =>pft%itype - cpool => pcs%cpool - deadcrootc => pcs%deadcrootc - deadcrootc_storage => pcs%deadcrootc_storage - deadcrootc_xfer => pcs%deadcrootc_xfer - deadstemc => pcs%deadstemc - deadstemc_storage => pcs%deadstemc_storage - deadstemc_xfer => pcs%deadstemc_xfer - frootc => pcs%frootc - frootc_storage => pcs%frootc_storage - frootc_xfer => pcs%frootc_xfer - gresp_storage => pcs%gresp_storage - gresp_xfer => pcs%gresp_xfer - leafc => pcs%leafc - leafc_storage => pcs%leafc_storage - leafc_xfer => pcs%leafc_xfer - livecrootc => pcs%livecrootc - livecrootc_storage => pcs%livecrootc_storage - livecrootc_xfer => pcs%livecrootc_xfer - livestemc => pcs%livestemc - livestemc_storage => pcs%livestemc_storage - livestemc_xfer => pcs%livestemc_xfer - pft_ctrunc => pcs%pft_ctrunc - xsmrpool => pcs%xsmrpool - grainc => pcs%grainc - grainc_storage => pcs%grainc_storage - grainc_xfer => pcs%grainc_xfer - -! if ( use_c13 ) then -! c13_col_ctrunc_vr => cc13s%col_ctrunc_vr -! decomp_c13pools_vr => cc13s%decomp_cpools_vr -! c13_cpool => pc13s%cpool -! c13_deadcrootc => pc13s%deadcrootc -! c13_deadcrootc_storage => pc13s%deadcrootc_storage -! c13_deadcrootc_xfer => pc13s%deadcrootc_xfer -! c13_deadstemc => pc13s%deadstemc -! c13_deadstemc_storage => pc13s%deadstemc_storage -! c13_deadstemc_xfer => pc13s%deadstemc_xfer -! c13_frootc => pc13s%frootc -! c13_frootc_storage => pc13s%frootc_storage -! c13_frootc_xfer => pc13s%frootc_xfer -! c13_gresp_storage => pc13s%gresp_storage -! c13_gresp_xfer => pc13s%gresp_xfer -! c13_leafc => pc13s%leafc -! c13_leafc_storage => pc13s%leafc_storage -! c13_leafc_xfer => pc13s%leafc_xfer -! c13_livecrootc => pc13s%livecrootc -! c13_livecrootc_storage => pc13s%livecrootc_storage -! c13_livecrootc_xfer => pc13s%livecrootc_xfer -! c13_livestemc => pc13s%livestemc -! c13_livestemc_storage => pc13s%livestemc_storage -! c13_livestemc_xfer => pc13s%livestemc_xfer -! c13_pft_ctrunc => pc13s%pft_ctrunc -! endif -! -! if ( use_c14 ) then -! c14_col_ctrunc_vr => cc14s%col_ctrunc_vr -! decomp_c14pools_vr => cc14s%decomp_cpools_vr -! c14_cpool => pc14s%cpool -! c14_deadcrootc => pc14s%deadcrootc -! c14_deadcrootc_storage => pc14s%deadcrootc_storage -! c14_deadcrootc_xfer => pc14s%deadcrootc_xfer -! c14_deadstemc => pc14s%deadstemc -! c14_deadstemc_storage => pc14s%deadstemc_storage -! c14_deadstemc_xfer => pc14s%deadstemc_xfer -! c14_frootc => pc14s%frootc -! c14_frootc_storage => pc14s%frootc_storage -! c14_frootc_xfer => pc14s%frootc_xfer -! c14_gresp_storage => pc14s%gresp_storage -! c14_gresp_xfer => pc14s%gresp_xfer -! c14_leafc => pc14s%leafc -! c14_leafc_storage => pc14s%leafc_storage -! c14_leafc_xfer => pc14s%leafc_xfer -! c14_livecrootc => pc14s%livecrootc -! c14_livecrootc_storage => pc14s%livecrootc_storage -! c14_livecrootc_xfer => pc14s%livecrootc_xfer -! c14_livestemc => pc14s%livestemc -! c14_livestemc_storage => pc14s%livestemc_storage -! c14_livestemc_xfer => pc14s%livestemc_xfer -! c14_pft_ctrunc => pc14s%pft_ctrunc -! endif - - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - grainn => pns%grainn - grainn_storage => pns%grainn_storage - grainn_xfer => pns%grainn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - npool => pns%npool - pft_ntrunc => pns%pft_ntrunc - retransn => pns%retransn - -#ifdef NITRIF_DENITRIF - smin_nh4_vr => cns%smin_nh4_vr - smin_no3_vr => cns%smin_no3_vr -#endif - - ! set the critical carbon state value for truncation (gC/m2) - ccrit = 1.e-8_r8 - ! set the critical nitrogen state value for truncation (gN/m2) - ncrit = 1.e-8_r8 - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! initialize the pft-level C and N truncation terms - pc = 0._r8 - -! if ( use_c13 ) then -! pc13 = 0._r8 -! end if -! if ( use_c14 ) then -! pc14 = 0._r8 -! endif - - pn = 0._r8 - - ! do tests on state variables for precision control - ! for linked C-N state variables, perform precision test on - ! the C component, but truncate C, C13, and N components - - ! leaf C and N - if (abs(leafc(p)) < ccrit) then - pc = pc + leafc(p) - leafc(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_leafc(p) -! c13_leafc(p) = 0._r8 -! endif - -! if ( use_c14 ) then -! pc14 = pc14 + c14_leafc(p) -! c14_leafc(p) = 0._r8 -! endif - - pn = pn + leafn(p) - leafn(p) = 0._r8 - end if - - ! leaf storage C and N - if (abs(leafc_storage(p)) < ccrit) then - pc = pc + leafc_storage(p) - leafc_storage(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_leafc_storage(p) -! c13_leafc_storage(p) = 0._r8 -! endif - -! if ( use_c14 ) then -! pc14 = pc14 + c14_leafc_storage(p) -! c14_leafc_storage(p) = 0._r8 -! endif - - pn = pn + leafn_storage(p) - leafn_storage(p) = 0._r8 - end if - - ! leaf transfer C and N - if (abs(leafc_xfer(p)) < ccrit) then - pc = pc + leafc_xfer(p) - leafc_xfer(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_leafc_xfer(p) -! c13_leafc_xfer(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_leafc_xfer(p) -! c14_leafc_xfer(p) = 0._r8 -! endif - - pn = pn + leafn_xfer(p) - leafn_xfer(p) = 0._r8 - end if - - ! froot C and N - if (abs(frootc(p)) < ccrit) then - pc = pc + frootc(p) - frootc(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_frootc(p) -! c13_frootc(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_frootc(p) -! c14_frootc(p) = 0._r8 -! endif - - pn = pn + frootn(p) - frootn(p) = 0._r8 - end if - - ! froot storage C and N - if (abs(frootc_storage(p)) < ccrit) then - pc = pc + frootc_storage(p) - frootc_storage(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_frootc_storage(p) -! c13_frootc_storage(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_frootc_storage(p) -! c14_frootc_storage(p) = 0._r8 -! endif - - pn = pn + frootn_storage(p) - frootn_storage(p) = 0._r8 - end if - - ! froot transfer C and N - if (abs(frootc_xfer(p)) < ccrit) then - pc = pc + frootc_xfer(p) - frootc_xfer(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_frootc_xfer(p) -! c13_frootc_xfer(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_frootc_xfer(p) -! c14_frootc_xfer(p) = 0._r8 -! endif - - pn = pn + frootn_xfer(p) - frootn_xfer(p) = 0._r8 - end if - - if ( crop_prog .and. ivt(p) >= nc3crop2 )then - ! grain C and N - if (abs(grainc(p)) < ccrit) then - pc = pc + grainc(p) - grainc(p) = 0._r8 - pn = pn + grainn(p) - grainn(p) = 0._r8 - end if - - ! grain storage C and N - if (abs(grainc_storage(p)) < ccrit) then - pc = pc + grainc_storage(p) - grainc_storage(p) = 0._r8 - pn = pn + grainn_storage(p) - grainn_storage(p) = 0._r8 - end if - - ! grain transfer C and N - if (abs(grainc_xfer(p)) < ccrit) then - pc = pc + grainc_xfer(p) - grainc_xfer(p) = 0._r8 - pn = pn + grainn_xfer(p) - grainn_xfer(p) = 0._r8 - end if - end if - - ! livestem C and N - if (abs(livestemc(p)) < ccrit) then - pc = pc + livestemc(p) - livestemc(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_livestemc(p) -! c13_livestemc(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_livestemc(p) -! c14_livestemc(p) = 0._r8 -! endif - - pn = pn + livestemn(p) - livestemn(p) = 0._r8 - end if - - ! livestem storage C and N - if (abs(livestemc_storage(p)) < ccrit) then - pc = pc + livestemc_storage(p) - livestemc_storage(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_livestemc_storage(p) -! c13_livestemc_storage(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_livestemc_storage(p) -! c14_livestemc_storage(p) = 0._r8 -! endif - pn = pn + livestemn_storage(p) - livestemn_storage(p) = 0._r8 - end if - - ! livestem transfer C and N - if (abs(livestemc_xfer(p)) < ccrit) then - pc = pc + livestemc_xfer(p) - livestemc_xfer(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_livestemc_xfer(p) -! c13_livestemc_xfer(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_livestemc_xfer(p) -! c14_livestemc_xfer(p) = 0._r8 -! endif - pn = pn + livestemn_xfer(p) - livestemn_xfer(p) = 0._r8 - end if - - ! deadstem C and N - if (abs(deadstemc(p)) < ccrit) then - pc = pc + deadstemc(p) - deadstemc(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_deadstemc(p) -! c13_deadstemc(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_deadstemc(p) -! c14_deadstemc(p) = 0._r8 -! endif - pn = pn + deadstemn(p) - deadstemn(p) = 0._r8 - end if - - ! deadstem storage C and N - if (abs(deadstemc_storage(p)) < ccrit) then - pc = pc + deadstemc_storage(p) - deadstemc_storage(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_deadstemc_storage(p) -! c13_deadstemc_storage(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_deadstemc_storage(p) -! c14_deadstemc_storage(p) = 0._r8 -! endif - pn = pn + deadstemn_storage(p) - deadstemn_storage(p) = 0._r8 - end if - - ! deadstem transfer C and N - if (abs(deadstemc_xfer(p)) < ccrit) then - pc = pc + deadstemc_xfer(p) - deadstemc_xfer(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_deadstemc_xfer(p) -! c13_deadstemc_xfer(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_deadstemc_xfer(p) -! c14_deadstemc_xfer(p) = 0._r8 -! endif - pn = pn + deadstemn_xfer(p) - deadstemn_xfer(p) = 0._r8 - end if - - ! livecroot C and N - if (abs(livecrootc(p)) < ccrit) then - pc = pc + livecrootc(p) - livecrootc(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_livecrootc(p) -! c13_livecrootc(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_livecrootc(p) -! c14_livecrootc(p) = 0._r8 -! endif - pn = pn + livecrootn(p) - livecrootn(p) = 0._r8 - end if - - ! livecroot storage C and N - if (abs(livecrootc_storage(p)) < ccrit) then - pc = pc + livecrootc_storage(p) - livecrootc_storage(p) = 0._r8 - -! if ( use_c13 ) then -! pc13 = pc13 + c13_livecrootc_storage(p) -! c13_livecrootc_storage(p) = 0._r8 -! endif - -! if ( use_c14 ) then -! pc14 = pc14 + c14_livecrootc_storage(p) -! c14_livecrootc_storage(p) = 0._r8 -! endif - - pn = pn + livecrootn_storage(p) - livecrootn_storage(p) = 0._r8 - end if - - ! livecroot transfer C and N - if (abs(livecrootc_xfer(p)) < ccrit) then - pc = pc + livecrootc_xfer(p) - livecrootc_xfer(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_livecrootc_xfer(p) -! c13_livecrootc_xfer(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_livecrootc_xfer(p) -! c14_livecrootc_xfer(p) = 0._r8 -! endif - pn = pn + livecrootn_xfer(p) - livecrootn_xfer(p) = 0._r8 - end if - - ! deadcroot C and N - if (abs(deadcrootc(p)) < ccrit) then - pc = pc + deadcrootc(p) - deadcrootc(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_deadcrootc(p) -! c13_deadcrootc(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_deadcrootc(p) -! c14_deadcrootc(p) = 0._r8 -! endif - pn = pn + deadcrootn(p) - deadcrootn(p) = 0._r8 - end if - - ! deadcroot storage C and N - if (abs(deadcrootc_storage(p)) < ccrit) then - pc = pc + deadcrootc_storage(p) - deadcrootc_storage(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_deadcrootc_storage(p) -! c13_deadcrootc_storage(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_deadcrootc_storage(p) -! c14_deadcrootc_storage(p) = 0._r8 -! endif - pn = pn + deadcrootn_storage(p) - deadcrootn_storage(p) = 0._r8 - end if - - ! deadcroot transfer C and N - if (abs(deadcrootc_xfer(p)) < ccrit) then - pc = pc + deadcrootc_xfer(p) - deadcrootc_xfer(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_deadcrootc_xfer(p) -! c13_deadcrootc_xfer(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_deadcrootc_xfer(p) -! c14_deadcrootc_xfer(p) = 0._r8 -! endif - pn = pn + deadcrootn_xfer(p) - deadcrootn_xfer(p) = 0._r8 - end if - - ! gresp_storage (C only) - if (abs(gresp_storage(p)) < ccrit) then - pc = pc + gresp_storage(p) - gresp_storage(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_gresp_storage(p) -! c13_gresp_storage(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_gresp_storage(p) -! c14_gresp_storage(p) = 0._r8 -! endif - end if - - ! gresp_xfer (C only) - if (abs(gresp_xfer(p)) < ccrit) then - pc = pc + gresp_xfer(p) - gresp_xfer(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_gresp_xfer(p) -! c13_gresp_xfer(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_gresp_xfer(p) -! c14_gresp_xfer(p) = 0._r8 -! endif - end if - - ! cpool (C only) - if (abs(cpool(p)) < ccrit) then - pc = pc + cpool(p) - cpool(p) = 0._r8 -! if ( use_c13 ) then -! pc13 = pc13 + c13_cpool(p) -! c13_cpool(p) = 0._r8 -! endif -! if ( use_c14 ) then -! pc14 = pc14 + c14_cpool(p) -! c14_cpool(p) = 0._r8 -! endif - end if - - if ( crop_prog .and. ivt(p) >= nc3crop2 )then - ! xsmrpool (C only) - if (abs(xsmrpool(p)) < ccrit) then - pc = pc + xsmrpool(p) - xsmrpool(p) = 0._r8 - end if - end if - - ! retransn (N only) - if (abs(retransn(p)) < ncrit) then - pn = pn + retransn(p) - retransn(p) = 0._r8 - end if - - ! npool (N only) - if (abs(npool(p)) < ncrit) then - pn = pn + npool(p) - npool(p) = 0._r8 - end if - - pft_ctrunc(p) = pft_ctrunc(p) + pc -! if ( use_c13 ) then -! c13_pft_ctrunc(p) = c13_pft_ctrunc(p) + pc13 -! endif - -! if ( use_c14 ) then -! c14_pft_ctrunc(p) = c14_pft_ctrunc(p) + pc14 -! endif - - pft_ntrunc(p) = pft_ntrunc(p) + pn - - end do ! end of pft loop - - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - do j = 1,nlevdecomp - ! initialize the column-level C and N truncation terms - cc = 0._r8 -! if ( use_c13 ) then -! cc13 = 0._r8 -! endif -! if ( use_c14 ) then -! cc14 = 0._r8 -! endif - cn = 0._r8 - - ! do tests on state variables for precision control - ! for linked C-N state variables, perform precision test on - ! the C component, but truncate both C and N components - - ! all decomposing pools C and N - do k = 1, ndecomp_pools - - if (abs(decomp_cpools_vr(c,j,k)) < ccrit) then - cc = cc + decomp_cpools_vr(c,j,k) - decomp_cpools_vr(c,j,k) = 0._r8 -! if ( use_c13 ) then -! cc13 = cc13 + decomp_c13pools_vr(c,j,k) -! decomp_c13pools_vr(c,j,k) = 0._r8 -! endif -! if ( use_c14 ) then -! cc14 = cc14 + decomp_c14pools_vr(c,j,k) -! decomp_c14pools_vr(c,j,k) = 0._r8 -! endif - cn = cn + decomp_npools_vr(c,j,k) - decomp_npools_vr(c,j,k) = 0._r8 - end if - - end do - - ! not doing precision control on soil mineral N, since it will - ! be getting the N truncation flux anyway. - - col_ctrunc_vr(c,j) = col_ctrunc_vr(c,j) + cc -! if ( use_c13 ) then -! c13_col_ctrunc_vr(c,j) = c13_col_ctrunc_vr(c,j) + cc13 -! endif -! if ( use_c14 ) then -! c14_col_ctrunc_vr(c,j) = c14_col_ctrunc_vr(c,j) + cc14 -! endif - col_ntrunc_vr(c,j) = col_ntrunc_vr(c,j) + cn - end do - - end do ! end of column loop - -#ifdef NITRIF_DENITRIF -! 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(smin_no3_vr(c,j)) < ncrit/1e4_r8) then - if ( smin_no3_vr(c,j) .lt. 0._r8 ) then - write(iulog, *) '-10^-12 < smin_no3 < 0. resetting to zero.' - write(iulog, *) 'smin_no3_vr(c,j), c, j: ', smin_no3_vr(c,j), c, j - smin_no3_vr(c,j) = 0._r8 - endif - end if - if (abs(smin_nh4_vr(c,j)) < ncrit/1e4_r8) then - if ( smin_nh4_vr(c,j) .lt. 0._r8 ) then - write(iulog, *) '-10^-12 < smin_nh4 < 0. resetting to zero.' - write(iulog, *) 'smin_nh4_vr(c,j), c, j: ', smin_nh4_vr(c,j), c, j - smin_nh4_vr(c,j) = 0._r8 - endif - end if - end do - end do -#endif - - -end subroutine CNPrecisionControl -!----------------------------------------------------------------------- -!#endif - -end module CNPrecisionControlMod 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 deleted file mode 100644 index 932028cb4..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSetValueMod.F90 +++ /dev/null @@ -1,1444 +0,0 @@ -module CNSetValueMod - -!#if (defined CN) - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNSetValueMod -! -! !DESCRIPTION: -! contains code to set all CN variables to specified value -! Used for both initialization of special landunit values, and -! setting fluxes to 0.0 at the beginning of each time step -! 3/23/09, Peter Thornton: Added new subroutine, CNZeroFluxes_dwt(), -! which initialize flux variables used in the pftdyn -! routines. This is called from clm_driver1, as -! these variables need to be initialized outside of the clumps loop. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varpar , only: nlevgrnd, nlevdecomp_full, ndecomp_pools, ndecomp_cascade_transitions, nlevdecomp - use clm_varctl , only: iulog, use_c13, use_c14 - use clmtype - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: CNZeroFluxes - public :: CNZeroFluxes_dwt - public :: CNSetPepv - public :: CNSetPcs - public :: CNSetPns - public :: CNSetPcf - public :: CNSetPnf - public :: CNSetCps - public :: CNSetCcs - public :: CNSetCns - public :: CNSetCcf - public :: CNSetCnf -! !PRIVATE MEMBER FUNCTIONS: -! -! !REVISION HISTORY: -! 9/04/03: Created by Peter Thornton -! F. Li and S. Levis (11/06/12) -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNZeroFluxes -! -! !INTERFACE: -subroutine CNZeroFluxes(num_filterc, filterc, num_filterp, filterp) -! -! !DESCRIPTION: -! -! !USES: -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_filterc ! number of good values in filterc - integer, intent(in) :: filterc(:) ! column filter - integer, intent(in) :: num_filterp ! number of good values in filterp - integer, intent(in) :: filterp(:) ! pft filter -! -! !CALLED FROM: -! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90 -! -! !REVISION HISTORY: -! 9/04/03: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! -! -! local pointers to implicit in/out scalars -! -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: -!EOP -!----------------------------------------------------------------------- - - ! zero the column-level C and N fluxes - call CNSetCcf(num_filterc, filterc, 0._r8, ccf) - -! if ( use_c13 ) call CNSetCcf(num_filterc, filterc, 0._r8, cc13f) - -! if ( use_c14 ) call CNSetCcf(num_filterc, filterc, 0._r8, cc14f) - - call CNSetCnf(num_filterc, filterc, 0._r8, cnf) - - ! zero the column-average pft-level C and N fluxes - call CNSetPcf(num_filterc, filterc, 0._r8, pcf_a) - call CNSetPnf(num_filterc, filterc, 0._r8, pnf_a) - - ! zero the pft-level C and N fluxes - call CNSetPcf(num_filterp, filterp, 0._r8, pcf) - -! if ( use_c13 ) call CNSetPcf(num_filterp, filterp, 0._r8, pc13f) - -! if ( use_c14 ) call CNSetPcf(num_filterp, filterp, 0._r8, pc14f) - - call CNSetPnf(num_filterp, filterp, 0._r8, pnf) - -end subroutine CNZeroFluxes -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNZeroFluxes_dwt -! -! !INTERFACE: -subroutine CNZeroFluxes_dwt( begc, endc, begp, endp ) -! -! !DESCRIPTION: -! -! !USES: -! -! !ARGUMENTS: - implicit none - integer, intent(IN) :: begc, endc ! proc beginning and ending column indices - integer, intent(IN) :: begp, endp ! proc beginning and ending pft indices -! -! !CALLED FROM: -! subroutine clm_driver1 -! -! !REVISION HISTORY: -! 3/23/09: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! -! -! local pointers to implicit in/out scalars -! -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: c, p, j ! indices -!EOP -!----------------------------------------------------------------------- - - ! set column-level conversion and product pool fluxes - ! to 0 at the beginning of every timestep - - do c = begc,endc - ! C fluxes - ccf%dwt_seedc_to_leaf(c) = 0._r8 - ccf%dwt_seedc_to_deadstem(c) = 0._r8 - ccf%dwt_conv_cflux(c) = 0._r8 - ccf%lf_conv_cflux(c) = 0._r8 - ccf%dwt_prod10c_gain(c) = 0._r8 - ccf%dwt_prod100c_gain(c) = 0._r8 - - ! N fluxes - cnf%dwt_seedn_to_leaf(c) = 0._r8 - cnf%dwt_seedn_to_deadstem(c) = 0._r8 - cnf%dwt_conv_nflux(c) = 0._r8 - cnf%dwt_prod10n_gain(c) = 0._r8 - cnf%dwt_prod100n_gain(c) = 0._r8 - end do -! if ( use_c13 ) then -! do c = begc,endc -! cc13f%dwt_seedc_to_leaf(c) = 0._r8 -! cc13f%dwt_seedc_to_deadstem(c) = 0._r8 -! cc13f%dwt_conv_cflux(c) = 0._r8 -! cc13f%dwt_prod10c_gain(c) = 0._r8 -! cc13f%dwt_prod100c_gain(c) = 0._r8 -! end do -! endif - -! if ( use_c14 ) then -! do c = begc,endc -! cc14f%dwt_seedc_to_leaf(c) = 0._r8 -! cc14f%dwt_seedc_to_deadstem(c) = 0._r8 -! cc14f%dwt_conv_cflux(c) = 0._r8 -! cc14f%dwt_prod10c_gain(c) = 0._r8 -! cc14f%dwt_prod100c_gain(c) = 0._r8 -! end do -! endif - - do j = 1, nlevdecomp_full - do c = begc,endc - ! C fluxes - ccf%dwt_frootc_to_litr_met_c(c,j) = 0._r8 - ccf%dwt_frootc_to_litr_cel_c(c,j) = 0._r8 - ccf%dwt_frootc_to_litr_lig_c(c,j) = 0._r8 - ccf%dwt_livecrootc_to_cwdc(c,j) = 0._r8 - ccf%dwt_deadcrootc_to_cwdc(c,j) = 0._r8 - - ! N fluxes - cnf%dwt_frootn_to_litr_met_n(c,j) = 0._r8 - cnf%dwt_frootn_to_litr_cel_n(c,j) = 0._r8 - cnf%dwt_frootn_to_litr_lig_n(c,j) = 0._r8 - cnf%dwt_livecrootn_to_cwdn(c,j) = 0._r8 - cnf%dwt_deadcrootn_to_cwdn(c,j) = 0._r8 - end do - end do -! if ( use_c13 ) then -! do j = 1, nlevdecomp_full -! do c = begc,endc -! cc13f%dwt_frootc_to_litr_met_c(c,j) = 0._r8 -! cc13f%dwt_frootc_to_litr_cel_c(c,j) = 0._r8 -! cc13f%dwt_frootc_to_litr_lig_c(c,j) = 0._r8 -! cc13f%dwt_livecrootc_to_cwdc(c,j) = 0._r8 -! cc13f%dwt_deadcrootc_to_cwdc(c,j) = 0._r8 -! end do -! end do -! endif -! if ( use_c14 ) then -! do j = 1, nlevdecomp_full -! do c = begc,endc -! cc14f%dwt_frootc_to_litr_met_c(c,j) = 0._r8 -! cc14f%dwt_frootc_to_litr_cel_c(c,j) = 0._r8 -! cc14f%dwt_frootc_to_litr_lig_c(c,j) = 0._r8 -! cc14f%dwt_livecrootc_to_cwdc(c,j) = 0._r8 -! cc14f%dwt_deadcrootc_to_cwdc(c,j) = 0._r8 -! end do -! end do -! endif - - -!#if (defined CN) - do p = begp,endp - pcs%dispvegc(p) = 0._r8 - pcs%storvegc(p) = 0._r8 - pcs%totpftc(p) = 0._r8 - - pns%dispvegn(p) = 0._r8 - pns%storvegn(p) = 0._r8 - pns%totvegn(p) = 0._r8 - pns%totpftn(p) = 0._r8 - end do -! if ( use_c14 ) then -! do p = begp,endp -! pc14s%dispvegc(p) = 0._r8 -! pc14s%storvegc(p) = 0._r8 -! pc14s%totpftc(p) = 0._r8 -! end do -! endif -! if ( use_c13 ) then -! do p = begp,endp -! pc13s%dispvegc(p) = 0._r8 -! pc13s%storvegc(p) = 0._r8 -! pc13s%totpftc(p) = 0._r8 -! end do -! endif -!#endif - -end subroutine CNZeroFluxes_dwt -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetPepv -! -! !INTERFACE: -subroutine CNSetPepv (num, filter, val, pepv) -! -! !DESCRIPTION: -! Set pft ecophysiological variables -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (pft_epv_type), intent(inout) :: pepv -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i ! loop index -!EOP -!------------------------------------------------------------------------ - - do fi = 1,num - i = filter(fi) - pepv%dormant_flag(i) = val - pepv%days_active(i) = val - pepv%onset_flag(i) = val - pepv%onset_counter(i) = val - pepv%onset_gddflag(i) = val - pepv%onset_fdd(i) = val - pepv%onset_gdd(i) = val - pepv%onset_swi(i) = val - pepv%offset_flag(i) = val - pepv%offset_counter(i) = val - pepv%offset_fdd(i) = val - pepv%offset_swi(i) = val - pepv%fert_counter(i) = val - pepv%grain_flag(i) = val - pepv%lgsf(i) = val - pepv%bglfr(i) = val - pepv%bgtr(i) = val - pepv%dayl(i) = val - pepv%prev_dayl(i) = val - pepv%annavg_t2m(i) = val - pepv%tempavg_t2m(i) = val - pepv%gpp(i) = val - pepv%availc(i) = val - pepv%xsmrpool_recover(i) = val - pepv%alloc_pnow(i) = val - pepv%c_allometry(i) = val - pepv%n_allometry(i) = val - pepv%plant_ndemand(i) = val - pepv%tempsum_potential_gpp(i) = val - pepv%annsum_potential_gpp(i) = val - pepv%tempmax_retransn(i) = val - pepv%annmax_retransn(i) = val - pepv%avail_retransn(i) = val - pepv%plant_nalloc(i) = val - pepv%plant_calloc(i) = val - pepv%excess_cflux(i) = val - pepv%downreg(i) = val - pepv%prev_leafc_to_litter(i) = val - pepv%prev_frootc_to_litter(i) = val - pepv%tempsum_npp(i) = val - pepv%annsum_npp(i) = val - end do -#if (defined CNDV) - do fi = 1,num - i = filter(fi) - pepv%tempsum_litfall(i) = val - pepv%annsum_litfall(i) = val - end do -#endif -! if ( use_c13 ) then -! do fi = 1,num -! i = filter(fi) -! pepv%xsmrpool_c13ratio(i) = val -! end do -! endif - -end subroutine CNSetPepv -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetPcs -! -! !INTERFACE: -subroutine CNSetPcs (num, filter, val, pcs) -! -! !DESCRIPTION: -! Set pft carbon state variables -! -! !USES: - use clm_varctl, only : crop_prog -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (pft_cstate_type), intent(inout) :: pcs -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i ! loop index -!EOP -!------------------------------------------------------------------------ - - do fi = 1,num - i = filter(fi) - pcs%leafc(i) = val - pcs%leafc_storage(i) = val - pcs%leafc_xfer(i) = val - pcs%frootc(i) = val - pcs%frootc_storage(i) = val - pcs%frootc_xfer(i) = val - pcs%livestemc(i) = val - pcs%livestemc_storage(i) = val - pcs%livestemc_xfer(i) = val - pcs%deadstemc(i) = val - pcs%deadstemc_storage(i) = val - pcs%deadstemc_xfer(i) = val - pcs%livecrootc(i) = val - pcs%livecrootc_storage(i) = val - pcs%livecrootc_xfer(i) = val - pcs%deadcrootc(i) = val - pcs%deadcrootc_storage(i) = val - pcs%deadcrootc_xfer(i) = val - pcs%gresp_storage(i) = val - pcs%gresp_xfer(i) = val - pcs%cpool(i) = val - pcs%xsmrpool(i) = val - pcs%pft_ctrunc(i) = val - pcs%dispvegc(i) = val - pcs%storvegc(i) = val - pcs%totvegc(i) = val - pcs%totpftc(i) = val - pcs%woodc(i) = val - - end do - if ( crop_prog ) then - do fi = 1,num - i = filter(fi) - pcs%grainc(i) = val - pcs%grainc_storage(i) = val - pcs%grainc_xfer(i) = val - end do - endif - - -end subroutine CNSetPcs -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetPns -! -! !INTERFACE: -subroutine CNSetPns(num, filter, val, pns) -! -! !DESCRIPTION: -! Set pft nitrogen state variables -! -! !USES: - use clm_varctl, only : crop_prog -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (pft_nstate_type), intent(inout) :: pns -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i ! loop index -!EOP -!------------------------------------------------------------------------ - - do fi = 1,num - i = filter(fi) - pns%leafn(i) = val - pns%leafn_storage(i) = val - pns%leafn_xfer(i) = val - pns%frootn(i) = val - pns%frootn_storage(i) = val - pns%frootn_xfer(i) = val - pns%livestemn(i) = val - pns%livestemn_storage(i) = val - pns%livestemn_xfer(i) = val - pns%deadstemn(i) = val - pns%deadstemn_storage(i) = val - pns%deadstemn_xfer(i) = val - pns%livecrootn(i) = val - pns%livecrootn_storage(i) = val - pns%livecrootn_xfer(i) = val - pns%deadcrootn(i) = val - pns%deadcrootn_storage(i) = val - pns%deadcrootn_xfer(i) = val - pns%retransn(i) = val - pns%npool(i) = val - pns%pft_ntrunc(i) = val - pns%dispvegn(i) = val - pns%storvegn(i) = val - pns%totvegn(i) = val - pns%totpftn(i) = val - end do - if ( crop_prog )then - do fi = 1,num - i = filter(fi) - pns%grainn(i) = val - pns%grainn_storage(i) = val - pns%grainn_xfer(i) = val - end do - end if - -end subroutine CNSetPns -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetPcf -! -! !INTERFACE: -subroutine CNSetPcf(num, filter, val, pcf) -! -! !DESCRIPTION: -! Set pft carbon flux variables -! -! !USES: - use clm_varctl, only : crop_prog -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (pft_cflux_type), intent(inout) :: pcf -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i ! loop index -!EOP -!------------------------------------------------------------------------ - - do fi = 1,num - i = filter(fi) - pcf%m_leafc_to_litter(i) = val - pcf%m_frootc_to_litter(i) = val - pcf%m_leafc_storage_to_litter(i) = val - pcf%m_frootc_storage_to_litter(i) = val - pcf%m_livestemc_storage_to_litter(i) = val - pcf%m_deadstemc_storage_to_litter(i) = val - pcf%m_livecrootc_storage_to_litter(i) = val - pcf%m_deadcrootc_storage_to_litter(i) = val - pcf%m_leafc_xfer_to_litter(i) = val - pcf%m_frootc_xfer_to_litter(i) = val - pcf%m_livestemc_xfer_to_litter(i) = val - pcf%m_deadstemc_xfer_to_litter(i) = val - pcf%m_livecrootc_xfer_to_litter(i) = val - pcf%m_deadcrootc_xfer_to_litter(i) = val - pcf%m_livestemc_to_litter(i) = val - pcf%m_deadstemc_to_litter(i) = val - pcf%m_livecrootc_to_litter(i) = val - pcf%m_deadcrootc_to_litter(i) = val - pcf%m_gresp_storage_to_litter(i) = val - pcf%m_gresp_xfer_to_litter(i) = val - pcf%hrv_leafc_to_litter(i) = val - pcf%hrv_leafc_storage_to_litter(i) = val - pcf%hrv_leafc_xfer_to_litter(i) = val - pcf%hrv_frootc_to_litter(i) = val - pcf%hrv_frootc_storage_to_litter(i) = val - pcf%hrv_frootc_xfer_to_litter(i) = val - pcf%hrv_livestemc_to_litter(i) = val - pcf%hrv_livestemc_storage_to_litter(i) = val - pcf%hrv_livestemc_xfer_to_litter(i) = val - pcf%hrv_deadstemc_to_prod10c(i) = val - pcf%hrv_deadstemc_to_prod100c(i) = val - pcf%hrv_deadstemc_storage_to_litter(i) = val - pcf%hrv_deadstemc_xfer_to_litter(i) = val - pcf%hrv_livecrootc_to_litter(i) = val - pcf%hrv_livecrootc_storage_to_litter(i) = val - pcf%hrv_livecrootc_xfer_to_litter(i) = val - pcf%hrv_deadcrootc_to_litter(i) = val - pcf%hrv_deadcrootc_storage_to_litter(i) = val - pcf%hrv_deadcrootc_xfer_to_litter(i) = val - pcf%hrv_gresp_storage_to_litter(i) = val - pcf%hrv_gresp_xfer_to_litter(i) = val - pcf%hrv_xsmrpool_to_atm(i) = val - -! fire-related variables changed by F. Li and S. Levis - pcf%m_leafc_to_fire(i) = val - pcf%m_leafc_storage_to_fire(i) = val - pcf%m_leafc_xfer_to_fire(i) = val - pcf%m_livestemc_to_fire(i) = val - pcf%m_livestemc_storage_to_fire(i) = val - pcf%m_livestemc_xfer_to_fire(i) = val - pcf%m_deadstemc_to_fire(i) = val - pcf%m_deadstemc_storage_to_fire(i) = val - pcf%m_deadstemc_xfer_to_fire(i) = val - pcf%m_frootc_to_fire(i) = val - pcf%m_frootc_storage_to_fire(i) = val - pcf%m_frootc_xfer_to_fire(i) = val - pcf%m_livecrootc_to_fire(i) = val - pcf%m_livecrootc_storage_to_fire(i) = val - pcf%m_livecrootc_xfer_to_fire(i) = val - pcf%m_deadcrootc_to_fire(i) = val - pcf%m_deadcrootc_storage_to_fire(i) = val - pcf%m_deadcrootc_xfer_to_fire(i) = val - pcf%m_gresp_storage_to_fire(i) = val - pcf%m_gresp_xfer_to_fire(i) = val - - pcf%m_leafc_to_litter_fire(i) = val - pcf%m_leafc_storage_to_litter_fire(i) = val - pcf%m_leafc_xfer_to_litter_fire(i) = val - pcf%m_livestemc_to_litter_fire(i) = val - pcf%m_livestemc_storage_to_litter_fire(i) = val - pcf%m_livestemc_xfer_to_litter_fire(i) = val - pcf%m_livestemc_to_deadstemc_fire(i) = val - pcf%m_deadstemc_to_litter_fire(i) = val - pcf%m_deadstemc_storage_to_litter_fire(i) = val - pcf%m_deadstemc_xfer_to_litter_fire(i) = val - pcf%m_frootc_to_litter_fire(i) = val - pcf%m_frootc_storage_to_litter_fire(i) = val - pcf%m_frootc_xfer_to_litter_fire(i) = val - pcf%m_livecrootc_to_litter_fire(i) = val - pcf%m_livecrootc_storage_to_litter_fire(i) = val - pcf%m_livecrootc_xfer_to_litter_fire(i) = val - pcf%m_livecrootc_to_deadcrootc_fire(i) = val - pcf%m_deadcrootc_to_litter_fire(i) = val - pcf%m_deadcrootc_storage_to_litter_fire(i) = val - pcf%m_deadcrootc_xfer_to_litter_fire(i) = val - pcf%m_gresp_storage_to_litter_fire(i) = val - pcf%m_gresp_xfer_to_litter_fire(i) = val - - - pcf%leafc_xfer_to_leafc(i) = val - pcf%frootc_xfer_to_frootc(i) = val - pcf%livestemc_xfer_to_livestemc(i) = val - pcf%deadstemc_xfer_to_deadstemc(i) = val - pcf%livecrootc_xfer_to_livecrootc(i) = val - pcf%deadcrootc_xfer_to_deadcrootc(i) = val - pcf%leafc_to_litter(i) = val - pcf%frootc_to_litter(i) = val - pcf%leaf_mr(i) = val - pcf%froot_mr(i) = val - pcf%livestem_mr(i) = val - pcf%livecroot_mr(i) = val - pcf%grain_mr(i) = val - pcf%leaf_curmr(i) = val - pcf%froot_curmr(i) = val - pcf%livestem_curmr(i) = val - pcf%livecroot_curmr(i) = val - pcf%grain_curmr(i) = val - pcf%leaf_xsmr(i) = val - pcf%froot_xsmr(i) = val - pcf%livestem_xsmr(i) = val - pcf%livecroot_xsmr(i) = val - pcf%grain_xsmr(i) = val - pcf%psnsun_to_cpool(i) = val - pcf%psnshade_to_cpool(i) = val - pcf%cpool_to_xsmrpool(i) = val - pcf%cpool_to_leafc(i) = val - pcf%cpool_to_leafc_storage(i) = val - pcf%cpool_to_frootc(i) = val - pcf%cpool_to_frootc_storage(i) = val - pcf%cpool_to_livestemc(i) = val - pcf%cpool_to_livestemc_storage(i) = val - pcf%cpool_to_deadstemc(i) = val - pcf%cpool_to_deadstemc_storage(i) = val - pcf%cpool_to_livecrootc(i) = val - pcf%cpool_to_livecrootc_storage(i) = val - pcf%cpool_to_deadcrootc(i) = val - pcf%cpool_to_deadcrootc_storage(i) = val - pcf%cpool_to_gresp_storage(i) = val - pcf%cpool_leaf_gr(i) = val - pcf%cpool_leaf_storage_gr(i) = val - pcf%transfer_leaf_gr(i) = val - pcf%cpool_froot_gr(i) = val - pcf%cpool_froot_storage_gr(i) = val - pcf%transfer_froot_gr(i) = val - pcf%cpool_livestem_gr(i) = val - pcf%cpool_livestem_storage_gr(i) = val - pcf%transfer_livestem_gr(i) = val - pcf%cpool_deadstem_gr(i) = val - pcf%cpool_deadstem_storage_gr(i) = val - pcf%transfer_deadstem_gr(i) = val - pcf%cpool_livecroot_gr(i) = val - pcf%cpool_livecroot_storage_gr(i) = val - pcf%transfer_livecroot_gr(i) = val - pcf%cpool_deadcroot_gr(i) = val - pcf%cpool_deadcroot_storage_gr(i) = val - pcf%transfer_deadcroot_gr(i) = val - pcf%leafc_storage_to_xfer(i) = val - pcf%frootc_storage_to_xfer(i) = val - pcf%livestemc_storage_to_xfer(i) = val - pcf%deadstemc_storage_to_xfer(i) = val - pcf%livecrootc_storage_to_xfer(i) = val - pcf%deadcrootc_storage_to_xfer(i) = val - pcf%gresp_storage_to_xfer(i) = val - pcf%livestemc_to_deadstemc(i) = val - pcf%livecrootc_to_deadcrootc(i) = val - pcf%gpp(i) = val - pcf%mr(i) = val - pcf%current_gr(i) = val - pcf%transfer_gr(i) = val - pcf%storage_gr(i) = val - pcf%gr(i) = val - pcf%ar(i) = val - pcf%rr(i) = val - pcf%npp(i) = val - pcf%agnpp(i) = val - pcf%bgnpp(i) = val - pcf%litfall(i) = val - pcf%vegfire(i) = val - pcf%wood_harvestc(i) = val - pcf%pft_cinputs(i) = val - pcf%pft_coutputs(i) = val - pcf%pft_fire_closs(i) = val - pcf%frootc_alloc(i) = val - pcf%frootc_loss(i) = val - pcf%leafc_alloc(i) = val - pcf%leafc_loss(i) = val - pcf%woodc_alloc(i) = val - pcf%woodc_loss(i) = val - end do - if ( crop_prog )then - do fi = 1,num - i = filter(fi) - pcf%xsmrpool_to_atm(i) = val - pcf%livestemc_to_litter(i) = val - pcf%grainc_to_food(i) = val - pcf%grainc_xfer_to_grainc(i) = val - pcf%cpool_to_grainc(i) = val - pcf%cpool_to_grainc_storage(i) = val - pcf%cpool_grain_gr(i) = val - pcf%cpool_grain_storage_gr(i) = val - pcf%transfer_grain_gr(i) = val - pcf%grainc_storage_to_xfer(i) = val - end do - end if - -end subroutine CNSetPcf -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetPnf -! -! !INTERFACE: -subroutine CNSetPnf(num, filter, val, pnf) -! -! !DESCRIPTION: -! Set pft nitrogen flux variables -! -! !USES: - use clm_varctl, only : crop_prog -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (pft_nflux_type), intent(inout) :: pnf -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i ! loop index -!EOP -!------------------------------------------------------------------------ - - do fi = 1,num - i=filter(fi) - pnf%m_leafn_to_litter(i) = val - pnf%m_frootn_to_litter(i) = val - pnf%m_leafn_storage_to_litter(i) = val - pnf%m_frootn_storage_to_litter(i) = val - pnf%m_livestemn_storage_to_litter(i) = val - pnf%m_deadstemn_storage_to_litter(i) = val - pnf%m_livecrootn_storage_to_litter(i) = val - pnf%m_deadcrootn_storage_to_litter(i) = val - pnf%m_leafn_xfer_to_litter(i) = val - pnf%m_frootn_xfer_to_litter(i) = val - pnf%m_livestemn_xfer_to_litter(i) = val - pnf%m_deadstemn_xfer_to_litter(i) = val - pnf%m_livecrootn_xfer_to_litter(i) = val - pnf%m_deadcrootn_xfer_to_litter(i) = val - pnf%m_livestemn_to_litter(i) = val - pnf%m_deadstemn_to_litter(i) = val - pnf%m_livecrootn_to_litter(i) = val - pnf%m_deadcrootn_to_litter(i) = val - pnf%m_retransn_to_litter(i) = val - pnf%hrv_leafn_to_litter(i) = val - pnf%hrv_frootn_to_litter(i) = val - pnf%hrv_leafn_storage_to_litter(i) = val - pnf%hrv_frootn_storage_to_litter(i) = val - pnf%hrv_livestemn_storage_to_litter(i) = val - pnf%hrv_deadstemn_storage_to_litter(i) = val - pnf%hrv_livecrootn_storage_to_litter(i) = val - pnf%hrv_deadcrootn_storage_to_litter(i) = val - pnf%hrv_leafn_xfer_to_litter(i) = val - pnf%hrv_frootn_xfer_to_litter(i) = val - pnf%hrv_livestemn_xfer_to_litter(i) = val - pnf%hrv_deadstemn_xfer_to_litter(i) = val - pnf%hrv_livecrootn_xfer_to_litter(i) = val - pnf%hrv_deadcrootn_xfer_to_litter(i) = val - pnf%hrv_livestemn_to_litter(i) = val - pnf%hrv_deadstemn_to_prod10n(i) = val - pnf%hrv_deadstemn_to_prod100n(i) = val - pnf%hrv_livecrootn_to_litter(i) = val - pnf%hrv_deadcrootn_to_litter(i) = val - pnf%hrv_retransn_to_litter(i) = val - -! fire-related variables changed by F. Li and S. Levis - pnf%m_leafn_to_fire(i) = val - pnf%m_leafn_storage_to_fire(i) = val - pnf%m_leafn_xfer_to_fire(i) = val - pnf%m_livestemn_to_fire(i) = val - pnf%m_livestemn_storage_to_fire(i) = val - pnf%m_livestemn_xfer_to_fire(i) = val - pnf%m_deadstemn_to_fire(i) = val - pnf%m_deadstemn_storage_to_fire(i) = val - pnf%m_deadstemn_xfer_to_fire(i) = val - pnf%m_frootn_to_fire(i) = val - pnf%m_frootn_storage_to_fire(i) = val - pnf%m_frootn_xfer_to_fire(i) = val - pnf%m_livecrootn_to_fire(i) = val - pnf%m_livecrootn_storage_to_fire(i) = val - pnf%m_livecrootn_xfer_to_fire(i) = val - pnf%m_deadcrootn_to_fire(i) = val - pnf%m_deadcrootn_storage_to_fire(i) = val - pnf%m_deadcrootn_xfer_to_fire(i) = val - pnf%m_retransn_to_fire(i) = val - - - pnf%m_leafn_to_litter_fire(i) = val - pnf%m_leafn_storage_to_litter_fire(i) = val - pnf%m_leafn_xfer_to_litter_fire(i) = val - pnf%m_livestemn_to_litter_fire(i) = val - pnf%m_livestemn_storage_to_litter_fire(i) = val - pnf%m_livestemn_xfer_to_litter_fire(i) = val - pnf%m_livestemn_to_deadstemn_fire(i) = val - pnf%m_deadstemn_to_litter_fire(i) = val - pnf%m_deadstemn_storage_to_litter_fire(i) = val - pnf%m_deadstemn_xfer_to_litter_fire(i) = val - pnf%m_frootn_to_litter_fire(i) = val - pnf%m_frootn_storage_to_litter_fire(i) = val - pnf%m_frootn_xfer_to_litter_fire(i) = val - pnf%m_livecrootn_to_litter_fire(i) = val - pnf%m_livecrootn_storage_to_litter_fire(i) = val - pnf%m_livecrootn_xfer_to_litter_fire(i) = val - pnf%m_livecrootn_to_deadcrootn_fire(i) = val - pnf%m_deadcrootn_to_litter_fire(i) = val - pnf%m_deadcrootn_storage_to_litter_fire(i) = val - pnf%m_deadcrootn_xfer_to_litter_fire(i) = val - pnf%m_retransn_to_litter_fire(i) = val - - pnf%leafn_xfer_to_leafn(i) = val - pnf%frootn_xfer_to_frootn(i) = val - pnf%livestemn_xfer_to_livestemn(i) = val - pnf%deadstemn_xfer_to_deadstemn(i) = val - pnf%livecrootn_xfer_to_livecrootn(i) = val - pnf%deadcrootn_xfer_to_deadcrootn(i) = val - pnf%leafn_to_litter(i) = val - pnf%leafn_to_retransn(i) = val - pnf%frootn_to_litter(i) = val - pnf%retransn_to_npool(i) = val - pnf%sminn_to_npool(i) = val - pnf%npool_to_leafn(i) = val - pnf%npool_to_leafn_storage(i) = val - pnf%npool_to_frootn(i) = val - pnf%npool_to_frootn_storage(i) = val - pnf%npool_to_livestemn(i) = val - pnf%npool_to_livestemn_storage(i) = val - pnf%npool_to_deadstemn(i) = val - pnf%npool_to_deadstemn_storage(i) = val - pnf%npool_to_livecrootn(i) = val - pnf%npool_to_livecrootn_storage(i) = val - pnf%npool_to_deadcrootn(i) = val - pnf%npool_to_deadcrootn_storage(i) = val - pnf%leafn_storage_to_xfer(i) = val - pnf%frootn_storage_to_xfer(i) = val - pnf%livestemn_storage_to_xfer(i) = val - pnf%deadstemn_storage_to_xfer(i) = val - pnf%livecrootn_storage_to_xfer(i) = val - pnf%deadcrootn_storage_to_xfer(i) = val - pnf%livestemn_to_deadstemn(i) = val - pnf%livestemn_to_retransn(i) = val - pnf%livecrootn_to_deadcrootn(i) = val - pnf%livecrootn_to_retransn(i) = val - pnf%ndeploy(i) = val - pnf%pft_ninputs(i) = val - pnf%pft_noutputs(i) = val - pnf%wood_harvestn(i) = val - pnf%pft_fire_nloss(i) = val - end do - if ( crop_prog )then - do fi = 1,num - i=filter(fi) - pnf%livestemn_to_litter(i) = val - pnf%grainn_to_food(i) = val - pnf%grainn_xfer_to_grainn(i) = val - pnf%npool_to_grainn(i) = val - pnf%npool_to_grainn_storage(i) = val - pnf%grainn_storage_to_xfer(i) = val - pnf%soyfixn(i) = val - pnf%frootn_to_retransn(i) = val - end do - end if - -end subroutine CNSetPnf -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetCps -! -! !INTERFACE: -subroutine CNSetCps(num, filter, val, cps) -! -! !DESCRIPTION: -! Set column physical state variables -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (column_pstate_type), intent(inout) :: cps -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i,j ! loop index -!EOP -!------------------------------------------------------------------------ - - do fi = 1,num - i = filter(fi) - cps%fpi(i) = val - cps%fpg(i) = val - cps%annsum_counter(i) = val - cps%cannsum_npp(i) = val - cps%cannavg_t2m(i) = val - - ! fire related variables changed by F. Li and S. Levis - cps%wf(i) = val - cps%wf2(i) = val - cps%nfire(i) = val - cps%baf_crop(i) = val - cps%baf_peatf(i) = val - cps%fbac(i) = val - cps%fbac1(i) = val - cps%farea_burned(i) = val - end do - - do j = 1,nlevdecomp_full - do fi = 1,num - i = filter(fi) - cps%fpi_vr(i,j) = val - end do - end do - - do j = 1,nlevgrnd - do fi = 1,num - i = filter(fi) - cps%soilpsi(i,j) = val - end do - end do - - - -end subroutine CNSetCps -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetCcs -! -! !INTERFACE: -subroutine CNSetCcs(num, filter, val, ccs) -! -! !DESCRIPTION: -! Set column carbon state variables -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (column_cstate_type), intent(inout) :: ccs -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i,j,k ! loop index -!EOP -!------------------------------------------------------------------------ - - ! column only - do fi = 1,num - i = filter(fi) - ccs%cwdc(i) = val - ccs%col_ctrunc(i) = val - ccs%totlitc(i) = val - ccs%totsomc(i) = val - ccs%totecosysc(i) = val - ccs%totcolc(i) = val - ccs%rootc_col(i) = val - ccs%totvegc_col(i) = val - ccs%leafc_col(i) = val - ccs%fuelc(i) = val - ccs%fuelc_crop(i) = val - ccs%totlitc_1m(i) = val - ccs%totsomc_1m(i) = val - ccs%cpool_col(i) = val - end do - - ! column and levdecomp - do j = 1,nlevdecomp_full - do fi = 1,num - i = filter(fi) - ccs%col_ctrunc_vr(i,j) = val - end do - end do - - ! column and decomp_pools - do k = 1, ndecomp_pools - do fi = 1,num - i = filter(fi) - ccs%decomp_cpools(i,k) = val - ccs%decomp_cpools_1m(i,k) = val - end do - end do - - ! column, levdecomp, and decomp_pools - do j = 1,nlevdecomp_full - do k = 1, ndecomp_pools - do fi = 1,num - i = filter(fi) - ccs%decomp_cpools_vr(i,j,k) = val - end do - end do - end do - -end subroutine CNSetCcs -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetCns -! -! !INTERFACE: -subroutine CNSetCns(num, filter, val, cns) -! -! !DESCRIPTION: -! Set column nitrogen state variables -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (column_nstate_type), intent(inout) :: cns -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i,j,k ! loop index -!EOP -!------------------------------------------------------------------------ - - ! column only - do fi = 1,num - i = filter(fi) - cns%sminn(i) = val - cns%col_ntrunc(i) = val - cns%cwdn(i) = val -#ifdef NITRIF_DENITRIF - cns%smin_no3(i) = val - cns%smin_nh4(i) = val -#endif - cns%totlitn(i) = val - cns%totsomn(i) = val - cns%totecosysn(i) = val - cns%totcoln(i) = val - cns%totsomn_1m(i) = val - cns%totlitn_1m(i) = val - end do - - ! column and levdecomp - do j = 1,nlevdecomp_full - do fi = 1,num - i = filter(fi) - cns%sminn_vr(i,j) = val - cns%col_ntrunc_vr(i,j) = val -#ifdef NITRIF_DENITRIF - cns%smin_no3_vr(i,j) = val - cns%smin_nh4_vr(i,j) = val -#endif - end do - end do - - ! column and decomp_pools - do k = 1, ndecomp_pools - do fi = 1,num - i = filter(fi) - cns%decomp_npools(i,k) = val - cns%decomp_npools_1m(i,k) = val - end do - end do - - ! column levdecomp, and decomp_pools - do j = 1,nlevdecomp_full - do k = 1, ndecomp_pools - do fi = 1,num - i = filter(fi) - cns%decomp_npools_vr(i,j,k) = val - end do - end do - end do - -end subroutine CNSetCns -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetCcf -! -! !INTERFACE: -subroutine CNSetCcf(num, filter, val, ccf) -! -! !DESCRIPTION: -! Set column carbon flux variables -! -! !USES: - use clm_varctl, only : crop_prog -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (column_cflux_type), intent(inout) :: ccf -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i,j,k,l ! loop index -!EOP -!------------------------------------------------------------------------ - - do j = 1, nlevdecomp_full - do fi = 1,num - i = filter(fi) - ! phenology: litterfall and crop fluxes associated wit - ccf%phenology_c_to_litr_met_c(i,j) = val - ccf%phenology_c_to_litr_cel_c(i,j) = val - ccf%phenology_c_to_litr_lig_c(i,j) = val - ! gap mortality - ccf%gap_mortality_c_to_litr_met_c(i,j) = val - ccf%gap_mortality_c_to_litr_cel_c(i,j) = val - ccf%gap_mortality_c_to_litr_lig_c(i,j) = val - ccf%gap_mortality_c_to_cwdc(i,j) = val - ! fire - ccf%fire_mortality_c_to_cwdc(i,j) = val - ccf%m_c_to_litr_met_fire(i,j) = val - ccf%m_c_to_litr_cel_fire(i,j) = val - ccf%m_c_to_litr_lig_fire(i,j) = val - ! harvest - ccf%harvest_c_to_litr_met_c(i,j) = val - ccf%harvest_c_to_litr_cel_c(i,j) = val - ccf%harvest_c_to_litr_lig_c(i,j) = val - ccf%harvest_c_to_cwdc(i,j) = val - ! hr - ccf%hr_vr(i,j) = val - end do - end do - - do k = 1, ndecomp_pools - do j = 1, nlevdecomp_full - do fi = 1,num - i = filter(fi) - ccf%m_decomp_cpools_to_fire_vr(i,j,k) = val - ccf%decomp_cpools_sourcesink(i,j,k) = val - ccf%decomp_cpools_transport_tendency(i,j,k) = val - end do - end do - end do - - do l = 1, ndecomp_cascade_transitions - do fi = 1,num - i = filter(fi) - ccf%decomp_cascade_hr(i,l) = val - ccf%decomp_cascade_ctransfer(i,l) = val - end do - end do - - do l = 1, ndecomp_cascade_transitions - do j = 1, nlevdecomp_full - do fi = 1,num - i = filter(fi) - ccf%decomp_cascade_hr_vr(i,j,l) = val - ccf%decomp_cascade_ctransfer_vr(i,j,l) = val - ccf%decomp_k(i,j,l) = val - end do - end do - end do - - do k = 1, ndecomp_pools - do fi = 1,num - i = filter(fi) - ccf%decomp_cpools_leached(i,k) = val - ccf%m_decomp_cpools_to_fire(i,k) = val - end do - end do - - do fi = 1,num - i = filter(fi) - ccf%hrv_deadstemc_to_prod10c(i) = val - ccf%hrv_deadstemc_to_prod100c(i) = val - ccf%somc_fire(i) = val ! F. Li and S.Levis - ccf%prod10c_loss(i) = val - ccf%prod100c_loss(i) = val - ccf%product_closs(i) = val - ccf%somhr(i) = val - ccf%lithr(i) = val - ccf%hr(i) = val - ccf%sr(i) = val - ccf%er(i) = val - ccf%litfire(i) = val - ccf%somfire(i) = val - ccf%totfire(i) = val - ccf%nep(i) = val - ccf%nbp(i) = val - ccf%nee(i) = val - ccf%col_cinputs(i) = val - ccf%col_coutputs(i) = val - ccf%col_fire_closs(i) = val - ccf%cwdc_hr(i) = val - ccf%cwdc_loss(i) = val - ccf%litterc_loss(i) = val - ccf%som_c_leached(i) = val - end do - -end subroutine CNSetCcf -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNSetCnf -! -! !INTERFACE: -subroutine CNSetCnf(num, filter, val, cnf) -! -! !DESCRIPTION: -! Set column nitrogen flux variables -! -! !USES: - use clm_varctl, only : crop_prog -! !ARGUMENTS: - implicit none - integer , intent(in) :: num - integer , intent(in) :: filter(:) - real(r8), intent(in) :: val - type (column_nflux_type), intent(inout) :: cnf -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in/out arrays -! -! !OTHER LOCAL VARIABLES: - integer :: fi,i,j,k,l ! loop index -!EOP -!------------------------------------------------------------------------ - - - do j = 1, nlevdecomp_full - do fi = 1,num - i = filter(fi) - ! phenology: litterfall and crop fluxes associated wit - cnf%phenology_n_to_litr_met_n(i,j) = val - cnf%phenology_n_to_litr_cel_n(i,j) = val - cnf%phenology_n_to_litr_lig_n(i,j) = val - ! gap mortality - cnf%gap_mortality_n_to_litr_met_n(i,j) = val - cnf%gap_mortality_n_to_litr_cel_n(i,j) = val - cnf%gap_mortality_n_to_litr_lig_n(i,j) = val - cnf%gap_mortality_n_to_cwdn(i,j) = val - ! fire - cnf%fire_mortality_n_to_cwdn(i,j) = val - cnf%m_n_to_litr_met_fire(i,j) = val - cnf%m_n_to_litr_cel_fire(i,j) = val - cnf%m_n_to_litr_lig_fire(i,j) = val - ! harvest - cnf%harvest_n_to_litr_met_n(i,j) = val - cnf%harvest_n_to_litr_cel_n(i,j) = val - cnf%harvest_n_to_litr_lig_n(i,j) = val - cnf%harvest_n_to_cwdn(i,j) = val -#ifndef NITRIF_DENITRIF - cnf%sminn_to_denit_excess_vr(i,j) = val - cnf%sminn_leached_vr(i,j) = val -#else - cnf%f_nit_vr(i,j) = val - cnf%f_denit_vr(i,j) = val - cnf%smin_no3_leached_vr(i,j) = val - cnf%smin_no3_runoff_vr(i,j) = val - cnf%n2_n2o_ratio_denit_vr(i,j) = val - cnf%pot_f_nit_vr(i,j) = val - cnf%pot_f_denit_vr(i,j) = val - cnf%actual_immob_no3_vr(i,j) = val - cnf%actual_immob_nh4_vr(i,j) = val - cnf%smin_no3_to_plant_vr(i,j) = val - cnf%smin_nh4_to_plant_vr(i,j) = val - cnf%f_n2o_denit_vr(i,j) = val - cnf%f_n2o_nit_vr(i,j) = val - - cnf%smin_no3_massdens_vr(i,j) = val - cnf%k_nitr_t_vr(i,j) = val - cnf%k_nitr_ph_vr(i,j) = val - cnf%k_nitr_h2o_vr(i,j) = val - cnf%k_nitr_vr(i,j) = val - cnf%wfps_vr(i,j) = val - cnf%fmax_denit_carbonsubstrate_vr(i,j) = val - cnf%fmax_denit_nitrate_vr(i,j) = val - cnf%f_denit_base_vr(i,j) = val - - cnf%diffus(i,j) = val - cnf%ratio_k1(i,j) = val - cnf%ratio_no3_co2(i,j) = val - cnf%soil_co2_prod(i,j) = val - cnf%fr_WFPS(i,j) = val - cnf%soil_bulkdensity(i,j) = val - - cnf%r_psi(i,j) = val - cnf%anaerobic_frac(i,j) = val -#endif - cnf%potential_immob_vr(i,j) = val - cnf%actual_immob_vr(i,j) = val - cnf%sminn_to_plant_vr(i,j) = val - cnf%supplement_to_sminn_vr(i,j) = val - cnf%gross_nmin_vr(i,j) = val - cnf%net_nmin_vr(i,j) = val - end do - end do - - do fi = 1,num - i = filter(fi) - cnf%ndep_to_sminn(i) = val - cnf%nfix_to_sminn(i) = val - cnf%fert_to_sminn(i) = val - cnf%soyfixn_to_sminn(i) = val - cnf%hrv_deadstemn_to_prod10n(i) = val - cnf%hrv_deadstemn_to_prod100n(i) = val - cnf%prod10n_loss(i) = val - cnf%prod100n_loss(i) = val - cnf%product_nloss(i) = val - cnf%potential_immob(i) = val - cnf%actual_immob(i) = val - cnf%sminn_to_plant(i) = val - cnf%supplement_to_sminn(i) = val - cnf%gross_nmin(i) = val - cnf%net_nmin(i) = val - cnf%denit(i) = val -#ifdef NITRIF_DENITRIF - cnf%f_nit(i) = val - cnf%pot_f_nit(i) = val - cnf%f_denit(i) = val - cnf%pot_f_denit(i) = val - cnf%f_n2o_denit(i) = val - cnf%f_n2o_nit(i) = val - cnf%smin_no3_leached(i) = val - cnf%smin_no3_runoff(i) = val -#else - cnf%sminn_to_denit_excess(i) = val - cnf%sminn_leached(i) = val -#endif - cnf%col_ninputs(i) = val - cnf%col_noutputs(i) = val - cnf%col_fire_nloss(i) = val - cnf%som_n_leached(i) = val - end do - - do k = 1, ndecomp_pools - do fi = 1,num - i = filter(fi) - cnf%decomp_npools_leached(i,k) = val - cnf%m_decomp_npools_to_fire(i,k) = val - end do - end do - - do k = 1, ndecomp_pools - do j = 1, nlevdecomp_full - do fi = 1,num - i = filter(fi) - cnf%m_decomp_npools_to_fire_vr(i,j,k) = val - cnf%decomp_npools_sourcesink(i,j,k) = val - cnf%decomp_npools_transport_tendency(i,j,k) = val - end do - end do - end do - - do l = 1, ndecomp_cascade_transitions - do fi = 1,num - i = filter(fi) - cnf%decomp_cascade_ntransfer(i,l) = val - cnf%decomp_cascade_sminn_flux(i,l) = val -#ifndef NITRIF_DENITRIF - cnf%sminn_to_denit_decomp_cascade(i,l) = val -#endif - end do - end do - - do l = 1, ndecomp_cascade_transitions - do j = 1, nlevdecomp_full - do fi = 1,num - i = filter(fi) - cnf%decomp_cascade_ntransfer_vr(i,j,l) = val - cnf%decomp_cascade_sminn_flux_vr(i,j,l) = val -#ifndef NITRIF_DENITRIF - cnf%sminn_to_denit_decomp_cascade_vr(i,j,l) = val -#endif - end do - end do - end do - - -end subroutine CNSetCnf -!----------------------------------------------------------------------- - -!#endif - -end module CNSetValueMod 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 deleted file mode 100644 index dc42bc12f..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSoilLittVertTranspMod.F90 +++ /dev/null @@ -1,433 +0,0 @@ - -module CNSoilLittVertTranspMod -!#ifdef CN - - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNSoilLittVertTranspMod -! -! !DESCRIPTION: -! calculate vertical mixing of all decomposing C and N pools -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varctl , only : iulog, use_c13, use_c14, spinup_state - use clm_varcon , only : secspday -! -! !PUBLIC TYPES: - implicit none - save -! -! !PUBLIC MEMBER FUNCTIONS: - public :: CNSoilLittVertTransp -! -! !PUBLIC DATA MEMBERS: - real(r8), public :: som_diffus = 1e-4_r8 / (secspday * 365._r8) ! [m^2/sec] = 1 cm^2 / yr - real(r8), public :: som_adv_flux = 0._r8 - real(r8), public :: cryoturb_diffusion_k = 5e-4_r8 / (secspday * 365._r8) ! [m^2/sec] = 5 cm^2 / yr = 1m^2 / 200 yr - real(r8), public :: max_depth_cryoturb = 3._r8 ! (m) this is the maximum depth of cryoturbation - real(r8), public :: max_altdepth_cryoturbation = 2._r8 ! (m) maximum active layer thickness for cryoturbation to occur -! !REVISION HISTORY: -! -! -! !PRIVATE MEMBER FUNCTIONS: -! -! !PRIVATE TYPES: -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! - -! -! !IROUTINE: CNSoilLittVertTransp -! -! !INTERFACE: -subroutine CNSoilLittVertTransp(lbc, ubc, num_soilc, filter_soilc) -! -! !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 clmtype - use clm_time_manager, only: get_step_size - use clm_varpar , only: nlevdecomp, ndecomp_pools, nlevdecomp_full - use clm_varcon , only: zsoi, dzsoi_decomp, zisoi - use TridiagonalMod , only : Tridiagonal - -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: lbc, ubc ! column-index bounds - -! !LOCAL VARIABLES: -!EOP - ! real(r8) :: som_diffus_coef (lbc:ubc,1:nlevdecomp+1) ! diffusivity (m2/s) - ! real(r8) :: som_adv_coef(lbc:ubc,1:nlevdecomp+1) ! advective flux (m/s) - real(r8), pointer :: som_adv_coef(:,:) ! SOM advective flux (m/s) - real(r8), pointer :: som_diffus_coef(:,:) ! SOM diffusivity due to bio/cryo-turbation (m2/s) - real(r8) :: diffus (lbc:ubc,1:nlevdecomp+1) ! diffusivity (m2/s) (includes spinup correction, if any) - real(r8) :: adv_flux(lbc:ubc,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 (lbc:ubc,0:nlevdecomp+1) ! "a" vector for tridiagonal matrix - real(r8) :: b_tri (lbc:ubc,0:nlevdecomp+1) ! "b" vector for tridiagonal matrix - real(r8) :: c_tri (lbc:ubc,0:nlevdecomp+1) ! "c" vector for tridiagonal matrix - real(r8) :: r_tri (lbc:ubc,0:nlevdecomp+1) ! "r" vector for tridiagonal solution - real(r8) :: d_p1_zp1 (lbc:ubc,1:nlevdecomp+1) ! diffusivity/delta_z for next j - ! (set to zero for no diffusion) - real(r8) :: d_m1_zm1 (lbc:ubc,1:nlevdecomp+1) ! diffusivity/delta_z for previous j - ! (set to zero for no diffusion) - real(r8) :: f_p1 (lbc:ubc,1:nlevdecomp+1) ! water flux for next j - real(r8) :: f_m1 (lbc:ubc,1:nlevdecomp+1) ! water flux for previous j - real(r8) :: pe_p1 (lbc:ubc,1:nlevdecomp+1) ! Peclet # for next j - real(r8) :: pe_m1 (lbc:ubc,1:nlevdecomp+1) ! Peclet # for previous j - real(r8) :: dz_node(1:nlevdecomp+1) ! difference between nodes - real(r8) :: epsilon_t (lbc:ubc,1:nlevdecomp+1,1:ndecomp_pools) ! - real(r8) :: conc_trcr(lbc:ubc,0:nlevdecomp+1) - real(r8), pointer :: conc_ptr(:,:,:) ! pointer for concentration state variable being transported - real(r8), pointer :: source(:,:,:) ! pointer for source term - logical, pointer :: is_cwd(:) ! TRUE => pool is a cwd pool - real(r8) :: a_p_0 - real(r8) :: deficit - real(r8), pointer :: trcr_tendency_ptr(:,:,:) ! pointer to store the vertical tendency - ! (gain/loss due to vertical transport) - real(r8), pointer :: altmax(:) ! maximum annual depth of thaw - real(r8), pointer :: altmax_lastyear(:) ! prior year maximum annual depth of thaw - - - integer :: ntype - integer :: i_type,s,fc,c,j,l ! indices - integer :: jtop(lbc:ubc) ! top level at each column - real(r8) :: dtime ! land model time step (sec) - integer :: zerolev_diffus - real(r8), pointer :: spinup_factor(:) ! spinup accelerated decomposition factor, used to accelerate transport as well - real(r8) :: spinup_term ! spinup accelerated decomposition factor, used to accelerate transport as well - real(r8) :: epsilon ! small number - -!EOP -!----------------------------------------------------------------------- - - - - - ! 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 - - is_cwd => decomp_cascade_con%is_cwd - spinup_factor => decomp_cascade_con%spinup_factor - altmax => cps%altmax - altmax_lastyear => cps%altmax_lastyear - som_adv_coef => cps%som_adv_coef - som_diffus_coef => cps%som_diffus_coef - - - dtime = get_step_size() - - ntype = 2 -! if ( use_c13 ) then -! ntype = ntype+1 -! endif -! if ( use_c14 ) then -! ntype = ntype+1 -! endif - spinup_term = 1._r8 - epsilon = 1.e-30 - -#ifdef VERTSOILC - !------ 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)) .le. max_altdepth_cryoturbation ) & - .and. ( max(altmax(c), altmax_lastyear(c)) .gt. 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 ( zisoi(j) .lt. 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)) ) / & - ( max_depth_cryoturb - 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 - end do - elseif ( max(altmax(c), altmax_lastyear(c)) .gt. 0._r8 ) then - ! constant advection, constant diffusion - do j = 1,nlevdecomp+1 - som_adv_coef(c,j) = som_adv_flux - som_diffus_coef(c,j) = som_diffus - 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 => ccs%decomp_cpools_vr - source => ccf%decomp_cpools_sourcesink - trcr_tendency_ptr => ccf%decomp_cpools_transport_tendency - case (2) ! N - conc_ptr => cns%decomp_npools_vr - source => cnf%decomp_npools_sourcesink - trcr_tendency_ptr => cnf%decomp_npools_transport_tendency -! case (3) -! if ( use_c13 ) then -! ! C13 -! conc_ptr => cc13s%decomp_cpools_vr -! source => cc13f%decomp_cpools_sourcesink -! trcr_tendency_ptr => cc13f%decomp_cpools_transport_tendency -! else -! ! C14 -! conc_ptr => cc14s%decomp_cpools_vr -! source => cc14f%decomp_cpools_sourcesink -! trcr_tendency_ptr => cc14f%decomp_cpools_transport_tendency -! endif -! case (4) -! if ( use_c14 .and. use_c13 ) then -! ! C14 -! conc_ptr => cc14s%decomp_cpools_vr -! source => cc14f%decomp_cpools_sourcesink -! trcr_tendency_ptr => cc14f%decomp_cpools_transport_tendency -! else -! write(iulog,*) 'error. ncase = 4, but c13 and c14 not both enabled.' -! stop -! endif - end select - -#ifdef VERTSOILC - - do s = 1, ndecomp_pools - - if ( spinup_state .eq. 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. - endif - - if ( .not. is_cwd(s) ) then - - do j = 1,nlevdecomp+1 - do fc = 1, num_soilc - c = filter_soilc (fc) - ! - if ( abs(som_adv_coef(c,j)) * spinup_term .lt. 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 .lt. 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,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) .gt. 0._r8 .and. diffus(c,j) .gt. 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 == nlevdecomp+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) .gt. 0._r8 .and. diffus(c,j-1) .gt. 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) .gt. 0._r8 .and. diffus(c,j) .gt. 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) .gt. 0._r8 .and. diffus(c,j) .gt. 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 - - - ! 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) - elseif (j .lt. 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) - 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 - trcr_tendency_ptr(c,j,s) = 0.-(conc_trcr(c,j) + source(c,j,s)) - end do - end do - - ! Solve for the concentration profile for this time step - call Tridiagonal(lbc, ubc, 0, nlevdecomp+1, jtop, num_soilc, filter_soilc, & - a_tri, b_tri, c_tri, r_tri, conc_trcr(lbc:ubc,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 - ! for CWD pools, just add - do j = 1,nlevdecomp - do fc = 1, num_soilc - c = filter_soilc (fc) - conc_trcr(c,j) = conc_ptr(c,j,s) + source(c,j,s) - end do - end do - end if ! not CWD - do j = 1,nlevdecomp - do fc = 1, num_soilc - c = filter_soilc (fc) - conc_ptr(c,j,s) = conc_trcr(c,j) - end do - end do - 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 subroutine CNSoilLittVertTransp - -!#endif -end module CNSoilLittVertTranspMod - 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 deleted file mode 100644 index f03546361..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNSummaryMod.F90 +++ /dev/null @@ -1,2090 +0,0 @@ -module CNSummaryMod - -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNSummaryMod -! -! !DESCRIPTION: -! Module for carbon and nitrogen summary calculations -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varcon, only: dzsoi_decomp, zisoi - use pftvarcon , only: npcropmin - use clm_varctl , only: crop_prog - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: CSummary - public :: NSummary -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! F. Li and S. Levis (11/06/12) -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CSummary -! -! !INTERFACE: -subroutine CSummary(num_soilc, filter_soilc, num_soilp, filter_soilp, isotope) -! -! !DESCRIPTION: -! On the radiation time step, perform pft and column-level carbon -! summary calculations -! -! !USES: - use clmtype - use subgridAveMod, only: p2c - use clm_varctl, only: iulog - use clm_varpar , only: nlevdecomp,ndecomp_pools,ndecomp_cascade_transitions - use CNNDynamicsMod, only: nfix_timeconst - use clm_time_manager , only : get_step_size - use clm_varcon , only: secspday, spval -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - character(len=*), intent(in) :: isotope ! 'bulk', 'c13' or 'c14' -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 12/9/03: Created by Peter Thornton -! 11/6/12: revised by F. Li and S. Levis -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss - real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic - real(r8), pointer :: hr(:) ! (gC/m2/s) total heterotrophic respiration - real(r8), pointer :: litfire(:) ! (gC/m2/s) litter fire losses - real(r8), pointer :: lithr(:) ! (gC/m2/s) litter heterotrophic respiration - real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C - real(r8), pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation - real(r8), pointer :: decomp_cascade_hr_vr(:,:,:) - real(r8), pointer :: decomp_cascade_hr(:,:) - real(r8), pointer :: hr_vr(:,:) ! total vertically-resolved het. resp. from decomposing C pools (gC/m3/s) - real(r8), pointer :: m_decomp_cpools_to_fire_vr(:,:,:) - real(r8), pointer :: m_decomp_cpools_to_fire(:,:) - - real(r8), pointer :: decomp_cpools(:,:) ! (gC/m2) decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_cpools_1m(:,:) ! (gC/m2) decomposing (litter, cwd, soil) c pools to 1 meter - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - integer, pointer :: altmax_indx(:) ! maximum annual depth of thaw - integer, pointer :: altmax_lastyear_indx(:) ! prior year maximum annual depth of thaw - real(r8), pointer :: col_ctrunc_vr(:,:) ! (gC/m3) column-level sink for C truncation - integer, pointer :: cascade_donor_pool(:) ! which pool is C taken from for a given decomposition step - 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 :: nee(:) ! (gC/m2/s) net ecosystem exchange of carbon, includes fire, land-use, harvest, and hrv_xsmrpool flux, positive for source - real(r8), pointer :: nep(:) ! (gC/m2/s) net ecosystem production, excludes fire, land-use, and harvest flux, positive for sink - real(r8), pointer :: nbp(:) ! (gC/m2/s) net biome production, includes fire, land-use, and harvest flux, positive for sink - real(r8), pointer :: col_ar(:) ! (gC/m2/s) autotrophic respiration (MR + GR) - real(r8), pointer :: col_gpp(:) ! GPP flux before downregulation (gC/m2/s) - real(r8), pointer :: col_npp(:) ! (gC/m2/s) net primary production - real(r8), pointer :: col_lag_npp(:) ! (gC/m2/s) lagged net primary production - real(r8), pointer :: col_pft_fire_closs(:) ! (gC/m2/s) total pft-level fire C loss - real(r8), pointer :: col_litfall(:) ! (gC/m2/s) total pft-level litterfall C loss - real(r8), pointer :: col_rr(:) ! (gC/m2/s) root respiration (fine root MR + total root GR) - real(r8), pointer :: col_vegfire(:) ! (gC/m2/s) pft-level fire loss (obsolete, mark for removal) - real(r8), pointer :: col_wood_harvestc(:) - real(r8), pointer :: somfire(:) ! (gC/m2/s) soil organic matter fire losses - real(r8), pointer :: somhr(:) ! (gC/m2/s) soil organic matter heterotrophic respiration - real(r8), pointer :: sr(:) ! (gC/m2/s) total soil respiration (HR + root resp) - real(r8), pointer :: totfire(:) ! (gC/m2/s) total ecosystem fire losses - real(r8), pointer :: col_totpftc(:) ! (gC/m2) total pft-level carbon, including cpool - real(r8), pointer :: col_totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool - real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool - real(r8), pointer :: totecosysc(:) ! (gC/m2) total ecosystem carbon, incl veg but excl cpool - real(r8), pointer :: totlitc(:) ! (gC/m2) total litter carbon - real(r8), pointer :: totlitc_1m(:) ! (gC/m2) total litter carbon to 1 meter - real(r8), pointer :: totsomc(:) ! (gC/m2) total soil organic matter carbon - real(r8), pointer :: totsomc_1m(:) ! (gC/m2) total soil organic matter carbon to 1 meter - real(r8), pointer :: agnpp(:) ! (gC/m2/s) aboveground NPP - real(r8), pointer :: ar(:) ! (gC/m2/s) autotrophic respiration (MR + GR) - real(r8), pointer :: bgnpp(:) ! (gC/m2/s) belowground NPP - real(r8), pointer :: xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s) - real(r8), pointer :: cpool_grain_gr(:) ! grain growth respiration (gC/m2/s) - real(r8), pointer :: cpool_grain_storage_gr(:) ! grain growth respiration to storage (gC/m2/s) - real(r8), pointer :: cpool_to_grainc(:) ! allocation to grain C storage (gC/m2/s) - real(r8), pointer :: grainc_xfer_to_grainc(:) ! grain C growth from storage (gC/m2/s) - real(r8), pointer :: transfer_grain_gr(:) ! grain growth respiration from storage (gC/m2/s) - real(r8), pointer :: grainc_to_food(:) ! grain C to food (gC/m2/s) - real(r8), pointer :: livestemc_to_litter(:) ! live stem C litterfall (gC/m2/s) - real(r8), pointer :: grainc(:) ! (gC/m2) grain C - real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage - real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer - real(r8), pointer :: cpool_deadcroot_gr(:) ! dead coarse root growth respiration (gC/m2/s) - real(r8), pointer :: cpool_deadcroot_storage_gr(:) ! dead coarse root growth respiration to storage (gC/m2/s) - real(r8), pointer :: cpool_deadstem_gr(:) ! dead stem growth respiration (gC/m2/s) - real(r8), pointer :: cpool_deadstem_storage_gr(:) ! dead stem growth respiration to storage (gC/m2/s) - real(r8), pointer :: cpool_froot_gr(:) ! fine root growth respiration (gC/m2/s) - real(r8), pointer :: cpool_froot_storage_gr(:) ! fine root growth respiration to storage (gC/m2/s) - real(r8), pointer :: cpool_leaf_gr(:) ! leaf growth respiration (gC/m2/s) - real(r8), pointer :: cpool_leaf_storage_gr(:) ! leaf growth respiration to storage (gC/m2/s) - real(r8), pointer :: cpool_livecroot_gr(:) ! live coarse root growth respiration (gC/m2/s) - real(r8), pointer :: cpool_livecroot_storage_gr(:) ! live coarse root growth respiration to storage (gC/m2/s) - real(r8), pointer :: cpool_livestem_gr(:) ! live stem growth respiration (gC/m2/s) - real(r8), pointer :: cpool_livestem_storage_gr(:) ! live stem growth respiration to storage (gC/m2/s) - real(r8), pointer :: cpool_to_deadcrootc(:) ! allocation to dead coarse root C (gC/m2/s) - real(r8), pointer :: cpool_to_deadstemc(:) ! allocation to dead stem C (gC/m2/s) - real(r8), pointer :: cpool_to_frootc(:) ! allocation to fine root C (gC/m2/s) - real(r8), pointer :: cpool_to_leafc(:) ! allocation to leaf C (gC/m2/s) - real(r8), pointer :: cpool_to_livecrootc(:) ! allocation to live coarse root C (gC/m2/s) - real(r8), pointer :: cpool_to_livestemc(:) ! allocation to live stem C (gC/m2/s) - real(r8), pointer :: current_gr(:) ! (gC/m2/s) growth resp for new growth displayed in this timestep - real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:) - real(r8), pointer :: deadstemc_xfer_to_deadstemc(:) - real(r8), pointer :: frootc_to_litter(:) - real(r8), pointer :: frootc_xfer_to_frootc(:) - real(r8), pointer :: froot_mr(:) - real(r8), pointer :: grain_mr(:) - real(r8), pointer :: froot_curmr(:) - real(r8), pointer :: froot_xsmr(:) - real(r8), pointer :: gpp(:) !GPP flux before downregulation (gC/m2/s) - real(r8), pointer :: gr(:) ! (gC/m2/s) total growth respiration - real(r8), pointer :: leafc_to_litter(:) - real(r8), pointer :: leafc_xfer_to_leafc(:) - real(r8), pointer :: leaf_mr(:) - real(r8), pointer :: leaf_curmr(:) - real(r8), pointer :: leaf_xsmr(:) - real(r8), pointer :: litfall(:) ! (gC/m2/s) litterfall (leaves and fine roots) - real(r8), pointer :: livecrootc_xfer_to_livecrootc(:) - real(r8), pointer :: livecroot_mr(:) - real(r8), pointer :: livecroot_curmr(:) - real(r8), pointer :: livecroot_xsmr(:) - real(r8), pointer :: livestemc_xfer_to_livestemc(:) - real(r8), pointer :: livestem_mr(:) - real(r8), pointer :: livestem_curmr(:) - real(r8), pointer :: livestem_xsmr(:) - -! fire variables changed by F. Li and S. Levis - real(r8), pointer :: m_leafc_to_fire(:) - real(r8), pointer :: m_leafc_storage_to_fire(:) - real(r8), pointer :: m_leafc_xfer_to_fire(:) - real(r8), pointer :: m_livestemc_to_fire(:) - real(r8), pointer :: m_livestemc_storage_to_fire(:) - real(r8), pointer :: m_livestemc_xfer_to_fire(:) - real(r8), pointer :: m_deadstemc_to_fire(:) - real(r8), pointer :: m_deadstemc_storage_to_fire(:) - real(r8), pointer :: m_deadstemc_xfer_to_fire(:) - real(r8), pointer :: m_frootc_to_fire(:) - real(r8), pointer :: m_frootc_storage_to_fire(:) - real(r8), pointer :: m_frootc_xfer_to_fire(:) - real(r8), pointer :: m_livecrootc_to_fire(:) - real(r8), pointer :: m_livecrootc_storage_to_fire(:) - real(r8), pointer :: m_livecrootc_xfer_to_fire(:) - real(r8), pointer :: m_deadcrootc_to_fire(:) - real(r8), pointer :: m_deadcrootc_storage_to_fire(:) - real(r8), pointer :: m_deadcrootc_xfer_to_fire(:) - real(r8), pointer :: m_gresp_storage_to_fire(:) - real(r8), pointer :: m_gresp_xfer_to_fire(:) - real(r8), pointer :: m_leafc_to_litter_fire(:) - real(r8), pointer :: m_leafc_storage_to_litter_fire(:) - real(r8), pointer :: m_leafc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemc_to_litter_fire(:) - real(r8), pointer :: m_livestemc_storage_to_litter_fire(:) - real(r8), pointer :: m_livestemc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livestemc_to_deadstemc_fire(:) - real(r8), pointer :: m_deadstemc_to_litter_fire(:) - real(r8), pointer :: m_deadstemc_storage_to_litter_fire(:) - real(r8), pointer :: m_deadstemc_xfer_to_litter_fire(:) - real(r8), pointer :: m_frootc_to_litter_fire(:) - real(r8), pointer :: m_frootc_storage_to_litter_fire(:) - real(r8), pointer :: m_frootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_storage_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_livecrootc_to_deadcrootc_fire(:) - real(r8), pointer :: m_deadcrootc_to_litter_fire(:) - real(r8), pointer :: m_deadcrootc_storage_to_litter_fire(:) - real(r8), pointer :: m_deadcrootc_xfer_to_litter_fire(:) - real(r8), pointer :: m_gresp_storage_to_litter_fire(:) - real(r8), pointer :: m_gresp_xfer_to_litter_fire(:) - - real(r8), pointer :: m_deadcrootc_storage_to_litter(:) - real(r8), pointer :: m_deadcrootc_to_litter(:) - real(r8), pointer :: m_deadcrootc_xfer_to_litter(:) - real(r8), pointer :: m_deadstemc_storage_to_litter(:) - real(r8), pointer :: m_deadstemc_to_litter(:) - real(r8), pointer :: m_deadstemc_xfer_to_litter(:) - real(r8), pointer :: m_frootc_storage_to_litter(:) - real(r8), pointer :: m_frootc_to_litter(:) - real(r8), pointer :: m_frootc_xfer_to_litter(:) - real(r8), pointer :: m_gresp_storage_to_litter(:) - real(r8), pointer :: m_gresp_xfer_to_litter(:) - real(r8), pointer :: m_leafc_storage_to_litter(:) - real(r8), pointer :: m_leafc_to_litter(:) - real(r8), pointer :: m_leafc_xfer_to_litter(:) - real(r8), pointer :: m_livecrootc_storage_to_litter(:) - real(r8), pointer :: m_livecrootc_to_litter(:) - real(r8), pointer :: m_livecrootc_xfer_to_litter(:) - real(r8), pointer :: m_livestemc_storage_to_litter(:) - real(r8), pointer :: m_livestemc_to_litter(:) - real(r8), pointer :: m_livestemc_xfer_to_litter(:) - real(r8), pointer :: hrv_leafc_to_litter(:) - real(r8), pointer :: hrv_leafc_storage_to_litter(:) - real(r8), pointer :: hrv_leafc_xfer_to_litter(:) - real(r8), pointer :: hrv_frootc_to_litter(:) - real(r8), pointer :: hrv_frootc_storage_to_litter(:) - real(r8), pointer :: hrv_frootc_xfer_to_litter(:) - real(r8), pointer :: hrv_livestemc_to_litter(:) - real(r8), pointer :: hrv_livestemc_storage_to_litter(:) - real(r8), pointer :: hrv_livestemc_xfer_to_litter(:) - real(r8), pointer :: hrv_deadstemc_to_prod10c(:) - real(r8), pointer :: hrv_deadstemc_to_prod100c(:) - real(r8), pointer :: hrv_deadstemc_storage_to_litter(:) - real(r8), pointer :: hrv_deadstemc_xfer_to_litter(:) - real(r8), pointer :: hrv_livecrootc_to_litter(:) - real(r8), pointer :: hrv_livecrootc_storage_to_litter(:) - real(r8), pointer :: hrv_livecrootc_xfer_to_litter(:) - real(r8), pointer :: hrv_deadcrootc_to_litter(:) - real(r8), pointer :: hrv_deadcrootc_storage_to_litter(:) - real(r8), pointer :: hrv_deadcrootc_xfer_to_litter(:) - real(r8), pointer :: hrv_gresp_storage_to_litter(:) - real(r8), pointer :: hrv_gresp_xfer_to_litter(:) - real(r8), pointer :: hrv_xsmrpool_to_atm(:) - real(r8), pointer :: col_hrv_xsmrpool_to_atm(:) - real(r8), pointer :: mr(:) ! (gC/m2/s) maintenance respiration - real(r8), pointer :: npp(:) ! (gC/m2/s) net primary production - real(r8), pointer :: pft_fire_closs(:) ! (gC/m2/s) total pft-level fire C loss - real(r8), pointer :: psnshade_to_cpool(:) - real(r8), pointer :: psnsun_to_cpool(:) - real(r8), pointer :: rr(:) ! (gC/m2/s) root respiration (fine root MR + total root GR) - real(r8), pointer :: storage_gr(:) ! (gC/m2/s) growth resp for growth sent to storage for later display - real(r8), pointer :: transfer_deadcroot_gr(:) - real(r8), pointer :: transfer_deadstem_gr(:) - real(r8), pointer :: transfer_froot_gr(:) - real(r8), pointer :: transfer_gr(:) ! (gC/m2/s) growth resp for transfer growth displayed in this timestep - real(r8), pointer :: transfer_leaf_gr(:) - real(r8), pointer :: transfer_livecroot_gr(:) - real(r8), pointer :: transfer_livestem_gr(:) - real(r8), pointer :: wood_harvestc(:) ! (gC/m2/s) pft-level wood harvest (to product pools) - real(r8), pointer :: vegfire(:) ! (gC/m2/s) pft-level fire loss (obsolete, mark for removal) - real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: xsmrpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: dispvegc(:) ! (gC/m2) displayed veg carbon, excluding storage and cpool - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: storvegc(:) ! (gC/m2) stored vegetation carbon, excluding cpool - real(r8), pointer :: totpftc(:) ! (gC/m2) total pft-level carbon, including cpool - real(r8), pointer :: totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool - real(r8), pointer :: tempsum_npp(:) ! temporary annual sum of NPP (gC/m2/yr) -#if (defined CNDV) - real(r8), pointer :: tempsum_litfall(:) !temporary annual sum of litfall (gC/m2/yr) -#endif - ! for landcover change - real(r8), pointer :: landuseflux(:) ! (gC/m2/s) dwt_closs+product_closs - real(r8), pointer :: landuptake(:) ! (gC/m2/s) nee-landuseflux - real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from land cover conversion - real(r8), pointer :: dwt_conv_cflux(:) ! (gC/m2/s) conversion C flux (immediate loss to atm) - real(r8), pointer :: prod10c_loss(:) ! (gC/m2/s) loss from 10-yr wood product pool - real(r8), pointer :: prod100c_loss(:) ! (gC/m2/s) loss from 100-yr wood product pool - real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss - real(r8), pointer :: seedc(:) ! (gC/m2) column-level pool for seeding new PFTs - real(r8), pointer :: prod10c(:) ! (gC/m2) wood product C pool, 10-year lifespan - real(r8), pointer :: prod100c(:) ! (gC/m2) wood product C pool, 100-year lifespan - real(r8), pointer :: totprodc(:) ! (gC/m2) total wood product C - - real(r8), pointer :: frootc_alloc(:) ! fine root C allocation (gC/m2/s) - real(r8), pointer :: frootc_loss(:) ! fine root C loss (gC/m2/s) - real(r8), pointer :: leafc_alloc(:) ! leaf C allocation (gC/m2/s) - real(r8), pointer :: leafc_loss(:) ! leaf C loss (gC/m2/s) - real(r8), pointer :: woodc(:) ! wood C (gC/m2) - real(r8), pointer :: woodc_alloc(:) ! wood C allocation (gC/m2/s) - real(r8), pointer :: woodc_loss(:) ! wood C loss (gC/m2/s) - real(r8), pointer :: cwdc_hr(:) ! coarse woody debris C heterotrophic respiration (gC/m2/s) - real(r8), pointer :: cwdc_loss(:) ! coarse woody debris C loss (gC/m2/s) - real(r8), pointer :: litterc_loss(:) ! litter C loss (gC/m2/s) - real(r8), pointer :: decomp_cascade_ctransfer_vr(:,:,:) - real(r8), pointer :: decomp_cascade_ctransfer(:,:) - real(r8), pointer :: som_c_leached(:) ! total SOM C loss from vertical transport (gC/m^2/s) - real(r8), pointer :: decomp_cpools_leached(:,:) ! C loss from vertical transport from each decomposing C pool (gC/m^2/s) - real(r8), pointer :: decomp_cpools_transport_tendency(:,:,:) ! C tendency due to vertical transport in decomposing C pools (gC/m^3/s) -! !OTHER LOCAL VARIABLES: - real(r8) :: nfixlags, dtime ! temp variables for making lagged npp - integer :: c,p,j,k,l ! indices - integer :: fp,fc ! lake filter indices - real(r8) :: maxdepth ! depth to integrate soil variables - - type(pft_cflux_type), pointer :: pcisof - type(pft_cstate_type), pointer :: pcisos - type(column_cflux_type), pointer :: ccisof - type(column_cstate_type), pointer :: ccisos - type(pft_cflux_type) , pointer :: pcisof_a - type(pft_cstate_type), pointer :: pcisos_a - -!EOP -!----------------------------------------------------------------------- - ! select which isotope - select case (isotope) - case ('bulk') - pcisof => pcf - pcisos => pcs - ccisof => ccf - ccisos => ccs - pcisof_a => pcf_a - pcisos_a => pcs_a - case ('c14') - pcisof => pc14f - pcisos => pc14s - ccisof => cc14f - ccisos => cc14s - pcisof_a => pc14f_a - pcisos_a => pc14s_a - case ('c13') - pcisof => pc13f - pcisos => pc13s - ccisof => cc13f - ccisos => cc13s - pcisof_a => pc13f_a - pcisos_a => pc13s_a - case default - stop 'CNCIsoSummaryMod: iso must be bulk, c13 or c14' - end select - - ! assign local pointers - ivt =>pft%itype - col_fire_closs => ccisof%col_fire_closs - er => ccisof%er - hr => ccisof%hr - litfire => ccisof%litfire - lithr => ccisof%lithr - col_totpftc => pcisos_a%totpftc - col_totvegc => pcisos_a%totvegc - cwdc => ccisos%cwdc - col_ctrunc => ccisos%col_ctrunc - decomp_cascade_hr_vr => ccisof%decomp_cascade_hr_vr - decomp_cascade_hr => ccisof%decomp_cascade_hr - hr_vr => ccisof%hr_vr - m_decomp_cpools_to_fire_vr => ccisof%m_decomp_cpools_to_fire_vr - m_decomp_cpools_to_fire => ccisof%m_decomp_cpools_to_fire - decomp_cascade_ctransfer_vr => ccisof%decomp_cascade_ctransfer_vr - decomp_cascade_ctransfer => ccisof%decomp_cascade_ctransfer - decomp_cpools_vr => ccisos%decomp_cpools_vr - decomp_cpools => ccisos%decomp_cpools - decomp_cpools_1m => ccisos%decomp_cpools_1m - altmax_indx => cps%altmax_indx - altmax_lastyear_indx => cps%altmax_lastyear_indx - col_ctrunc_vr => ccisos%col_ctrunc_vr - cascade_donor_pool => decomp_cascade_con%cascade_donor_pool - is_litter => decomp_cascade_con%is_litter - is_soil => decomp_cascade_con%is_soil - is_cwd => decomp_cascade_con%is_cwd - nee => ccisof%nee - nep => ccisof%nep - nbp => ccisof%nbp - col_ar => pcisof_a%ar - col_gpp => pcisof_a%gpp - col_npp => pcisof_a%npp - col_pft_fire_closs => pcisof_a%pft_fire_closs - col_litfall => pcisof_a%litfall - col_rr => pcisof_a%rr - col_vegfire => pcisof_a%vegfire - col_wood_harvestc => pcisof_a%wood_harvestc - somfire => ccisof%somfire - somhr => ccisof%somhr - sr => ccisof%sr - totfire => ccisof%totfire - cwdc_hr => ccisof%cwdc_hr - cwdc_loss => ccisof%cwdc_loss - litterc_loss => ccisof%litterc_loss - ! dynamic landcover pointers - dwt_closs => ccisof%dwt_closs - landuseflux => ccisof%landuseflux - landuptake => ccisof%landuptake - dwt_conv_cflux => ccisof%dwt_conv_cflux - seedc => ccisos%seedc - - ! wood product pointers - prod10c_loss => ccisof%prod10c_loss - prod100c_loss => ccisof%prod100c_loss - product_closs => ccisof%product_closs - prod10c => ccisos%prod10c - prod100c => ccisos%prod100c - totprodc => ccisos%totprodc - - totcolc => ccisos%totcolc - totecosysc => ccisos%totecosysc - totlitc => ccisos%totlitc - totlitc_1m => ccisos%totlitc_1m - totsomc => ccisos%totsomc - totsomc_1m => ccisos%totsomc_1m - agnpp => pcisof%agnpp - ar => pcisof%ar - bgnpp => pcisof%bgnpp - xsmrpool_to_atm => pcisof%xsmrpool_to_atm - cpool_grain_gr => pcisof%cpool_grain_gr - cpool_grain_storage_gr => pcisof%cpool_grain_storage_gr - cpool_to_grainc => pcisof%cpool_to_grainc - grainc_xfer_to_grainc => pcisof%grainc_xfer_to_grainc - transfer_grain_gr => pcisof%transfer_grain_gr - grainc_to_food => pcisof%grainc_to_food - livestemc_to_litter => pcisof%livestemc_to_litter - grainc => pcisos%grainc - grainc_storage => pcisos%grainc_storage - grainc_xfer => pcisos%grainc_xfer - cpool_deadcroot_gr => pcisof%cpool_deadcroot_gr - cpool_deadcroot_storage_gr => pcisof%cpool_deadcroot_storage_gr - cpool_deadstem_gr => pcisof%cpool_deadstem_gr - cpool_deadstem_storage_gr => pcisof%cpool_deadstem_storage_gr - cpool_froot_gr => pcisof%cpool_froot_gr - cpool_froot_storage_gr => pcisof%cpool_froot_storage_gr - cpool_leaf_gr => pcisof%cpool_leaf_gr - cpool_leaf_storage_gr => pcisof%cpool_leaf_storage_gr - cpool_livecroot_gr => pcisof%cpool_livecroot_gr - cpool_livecroot_storage_gr => pcisof%cpool_livecroot_storage_gr - cpool_livestem_gr => pcisof%cpool_livestem_gr - cpool_livestem_storage_gr => pcisof%cpool_livestem_storage_gr - cpool_to_deadcrootc => pcisof%cpool_to_deadcrootc - cpool_to_deadstemc => pcisof%cpool_to_deadstemc - cpool_to_frootc => pcisof%cpool_to_frootc - cpool_to_leafc => pcisof%cpool_to_leafc - cpool_to_livecrootc => pcisof%cpool_to_livecrootc - cpool_to_livestemc => pcisof%cpool_to_livestemc - current_gr => pcisof%current_gr - deadcrootc_xfer_to_deadcrootc => pcisof%deadcrootc_xfer_to_deadcrootc - deadstemc_xfer_to_deadstemc => pcisof%deadstemc_xfer_to_deadstemc - frootc_to_litter => pcisof%frootc_to_litter - frootc_xfer_to_frootc => pcisof%frootc_xfer_to_frootc - froot_mr => pcisof%froot_mr - froot_curmr => pcisof%froot_curmr - froot_xsmr => pcisof%froot_xsmr - grain_mr => pcisof%grain_mr - gpp => pcisof%gpp - gr => pcisof%gr - leafc_to_litter => pcisof%leafc_to_litter - leafc_xfer_to_leafc => pcisof%leafc_xfer_to_leafc - leaf_mr => pcisof%leaf_mr - leaf_curmr => pcisof%leaf_curmr - leaf_xsmr => pcisof%leaf_xsmr - litfall => pcisof%litfall - livecrootc_xfer_to_livecrootc => pcisof%livecrootc_xfer_to_livecrootc - livecroot_mr => pcisof%livecroot_mr - livecroot_curmr => pcisof%livecroot_curmr - livecroot_xsmr => pcisof%livecroot_xsmr - livestemc_xfer_to_livestemc => pcisof%livestemc_xfer_to_livestemc - livestem_mr => pcisof%livestem_mr - livestem_curmr => pcisof%livestem_curmr - livestem_xsmr => pcisof%livestem_xsmr - -! fire variables changed by F. Li and S. Levis - m_leafc_to_fire => pcisof%m_leafc_to_fire - m_leafc_storage_to_fire => pcisof%m_leafc_storage_to_fire - m_leafc_xfer_to_fire => pcisof%m_leafc_xfer_to_fire - m_livestemc_to_fire => pcisof%m_livestemc_to_fire - m_livestemc_storage_to_fire => pcisof%m_livestemc_storage_to_fire - m_livestemc_xfer_to_fire => pcisof%m_livestemc_xfer_to_fire - m_deadstemc_to_fire => pcisof%m_deadstemc_to_fire - m_deadstemc_storage_to_fire => pcisof%m_deadstemc_storage_to_fire - m_deadstemc_xfer_to_fire => pcisof%m_deadstemc_xfer_to_fire - m_frootc_to_fire => pcisof%m_frootc_to_fire - m_frootc_storage_to_fire => pcisof%m_frootc_storage_to_fire - m_frootc_xfer_to_fire => pcisof%m_frootc_xfer_to_fire - m_livecrootc_to_fire => pcisof%m_livecrootc_to_fire - m_livecrootc_storage_to_fire => pcisof%m_livecrootc_storage_to_fire - m_livecrootc_xfer_to_fire => pcisof%m_livecrootc_xfer_to_fire - m_deadcrootc_to_fire => pcisof%m_deadcrootc_to_fire - m_deadcrootc_storage_to_fire => pcisof%m_deadcrootc_storage_to_fire - m_deadcrootc_xfer_to_fire => pcisof%m_deadcrootc_xfer_to_fire - m_gresp_storage_to_fire => pcisof%m_gresp_storage_to_fire - m_gresp_xfer_to_fire => pcisof%m_gresp_xfer_to_fire - m_leafc_to_litter_fire => pcisof%m_leafc_to_litter_fire - m_leafc_storage_to_litter_fire => pcisof%m_leafc_storage_to_litter_fire - m_leafc_xfer_to_litter_fire => pcisof%m_leafc_xfer_to_litter_fire - m_livestemc_to_litter_fire => pcisof%m_livestemc_to_litter_fire - m_livestemc_storage_to_litter_fire => pcisof%m_livestemc_storage_to_litter_fire - m_livestemc_xfer_to_litter_fire => pcisof%m_livestemc_xfer_to_litter_fire - m_livestemc_to_deadstemc_fire => pcisof%m_livestemc_to_deadstemc_fire - m_deadstemc_to_litter_fire => pcisof%m_deadstemc_to_litter_fire - m_deadstemc_storage_to_litter_fire => pcisof%m_deadstemc_storage_to_litter_fire - m_deadstemc_xfer_to_litter_fire => pcisof%m_deadstemc_xfer_to_litter_fire - m_frootc_to_litter_fire => pcisof%m_frootc_to_litter_fire - m_frootc_storage_to_litter_fire => pcisof%m_frootc_storage_to_litter_fire - m_frootc_xfer_to_litter_fire => pcisof%m_frootc_xfer_to_litter_fire - m_livecrootc_to_litter_fire => pcisof%m_livecrootc_to_litter_fire - m_livecrootc_storage_to_litter_fire => pcisof%m_livecrootc_storage_to_litter_fire - m_livecrootc_xfer_to_litter_fire => pcisof%m_livecrootc_xfer_to_litter_fire - m_livecrootc_to_deadcrootc_fire => pcisof%m_livecrootc_to_deadcrootc_fire - m_deadcrootc_to_litter_fire => pcisof%m_deadcrootc_to_litter_fire - m_deadcrootc_storage_to_litter_fire => pcisof%m_deadcrootc_storage_to_litter_fire - m_deadcrootc_xfer_to_litter_fire => pcisof%m_deadcrootc_xfer_to_litter_fire - m_gresp_storage_to_litter_fire => pcisof%m_gresp_storage_to_litter_fire - m_gresp_xfer_to_litter_fire => pcisof%m_gresp_xfer_to_litter_fire - - m_deadcrootc_storage_to_litter => pcisof%m_deadcrootc_storage_to_litter - m_deadcrootc_to_litter => pcisof%m_deadcrootc_to_litter - m_deadcrootc_xfer_to_litter => pcisof%m_deadcrootc_xfer_to_litter - m_deadstemc_storage_to_litter => pcisof%m_deadstemc_storage_to_litter - m_deadstemc_to_litter => pcisof%m_deadstemc_to_litter - m_deadstemc_xfer_to_litter => pcisof%m_deadstemc_xfer_to_litter - m_frootc_storage_to_litter => pcisof%m_frootc_storage_to_litter - m_frootc_to_litter => pcisof%m_frootc_to_litter - m_frootc_xfer_to_litter => pcisof%m_frootc_xfer_to_litter - m_gresp_storage_to_litter => pcisof%m_gresp_storage_to_litter - m_gresp_xfer_to_litter => pcisof%m_gresp_xfer_to_litter - m_leafc_storage_to_litter => pcisof%m_leafc_storage_to_litter - m_leafc_to_litter => pcisof%m_leafc_to_litter - m_leafc_xfer_to_litter => pcisof%m_leafc_xfer_to_litter - m_livecrootc_storage_to_litter => pcisof%m_livecrootc_storage_to_litter - m_livecrootc_to_litter => pcisof%m_livecrootc_to_litter - m_livecrootc_xfer_to_litter => pcisof%m_livecrootc_xfer_to_litter - m_livestemc_storage_to_litter => pcisof%m_livestemc_storage_to_litter - m_livestemc_to_litter => pcisof%m_livestemc_to_litter - m_livestemc_xfer_to_litter => pcisof%m_livestemc_xfer_to_litter - hrv_leafc_to_litter => pcisof%hrv_leafc_to_litter - hrv_leafc_storage_to_litter => pcisof%hrv_leafc_storage_to_litter - hrv_leafc_xfer_to_litter => pcisof%hrv_leafc_xfer_to_litter - hrv_frootc_to_litter => pcisof%hrv_frootc_to_litter - hrv_frootc_storage_to_litter => pcisof%hrv_frootc_storage_to_litter - hrv_frootc_xfer_to_litter => pcisof%hrv_frootc_xfer_to_litter - hrv_livestemc_to_litter => pcisof%hrv_livestemc_to_litter - hrv_livestemc_storage_to_litter => pcisof%hrv_livestemc_storage_to_litter - hrv_livestemc_xfer_to_litter => pcisof%hrv_livestemc_xfer_to_litter - hrv_deadstemc_to_prod10c => pcisof%hrv_deadstemc_to_prod10c - hrv_deadstemc_to_prod100c => pcisof%hrv_deadstemc_to_prod100c - hrv_deadstemc_storage_to_litter => pcisof%hrv_deadstemc_storage_to_litter - hrv_deadstemc_xfer_to_litter => pcisof%hrv_deadstemc_xfer_to_litter - hrv_livecrootc_to_litter => pcisof%hrv_livecrootc_to_litter - hrv_livecrootc_storage_to_litter => pcisof%hrv_livecrootc_storage_to_litter - hrv_livecrootc_xfer_to_litter => pcisof%hrv_livecrootc_xfer_to_litter - hrv_deadcrootc_to_litter => pcisof%hrv_deadcrootc_to_litter - hrv_deadcrootc_storage_to_litter => pcisof%hrv_deadcrootc_storage_to_litter - hrv_deadcrootc_xfer_to_litter => pcisof%hrv_deadcrootc_xfer_to_litter - hrv_gresp_storage_to_litter => pcisof%hrv_gresp_storage_to_litter - hrv_gresp_xfer_to_litter => pcisof%hrv_gresp_xfer_to_litter - hrv_xsmrpool_to_atm => pcisof%hrv_xsmrpool_to_atm - col_hrv_xsmrpool_to_atm => pcisof_a%hrv_xsmrpool_to_atm - mr => pcisof%mr - npp => pcisof%npp - pft_fire_closs => pcisof%pft_fire_closs - psnshade_to_cpool => pcisof%psnshade_to_cpool - psnsun_to_cpool => pcisof%psnsun_to_cpool - rr => pcisof%rr - storage_gr => pcisof%storage_gr - transfer_deadcroot_gr => pcisof%transfer_deadcroot_gr - transfer_deadstem_gr => pcisof%transfer_deadstem_gr - transfer_froot_gr => pcisof%transfer_froot_gr - transfer_gr => pcisof%transfer_gr - transfer_leaf_gr => pcisof%transfer_leaf_gr - transfer_livecroot_gr => pcisof%transfer_livecroot_gr - transfer_livestem_gr => pcisof%transfer_livestem_gr - vegfire => pcisof%vegfire - wood_harvestc => pcisof%wood_harvestc - frootc_alloc => pcisof%frootc_alloc - frootc_loss => pcisof%frootc_loss - leafc_alloc => pcisof%leafc_alloc - leafc_loss => pcisof%leafc_loss - woodc_alloc => pcisof%woodc_alloc - woodc_loss => pcisof%woodc_loss - cpool => pcisos%cpool - xsmrpool => pcisos%xsmrpool - pft_ctrunc => pcisos%pft_ctrunc - deadcrootc => pcisos%deadcrootc - deadcrootc_storage => pcisos%deadcrootc_storage - deadcrootc_xfer => pcisos%deadcrootc_xfer - deadstemc => pcisos%deadstemc - deadstemc_storage => pcisos%deadstemc_storage - deadstemc_xfer => pcisos%deadstemc_xfer - dispvegc => pcisos%dispvegc - frootc => pcisos%frootc - frootc_storage => pcisos%frootc_storage - frootc_xfer => pcisos%frootc_xfer - gresp_storage => pcisos%gresp_storage - gresp_xfer => pcisos%gresp_xfer - leafc => pcisos%leafc - leafc_storage => pcisos%leafc_storage - leafc_xfer => pcisos%leafc_xfer - livecrootc => pcisos%livecrootc - livecrootc_storage => pcisos%livecrootc_storage - livecrootc_xfer => pcisos%livecrootc_xfer - livestemc => pcisos%livestemc - livestemc_storage => pcisos%livestemc_storage - livestemc_xfer => pcisos%livestemc_xfer - storvegc => pcisos%storvegc - totpftc => pcisos%totpftc - totvegc => pcisos%totvegc - woodc => pcisos%woodc - tempsum_npp => pepv%tempsum_npp -#if (defined CNDV) - tempsum_litfall => pepv%tempsum_litfall -#endif - col_lag_npp => cps%col_lag_npp - som_c_leached => ccisof%som_c_leached - decomp_cpools_leached => ccisof%decomp_cpools_leached - decomp_cpools_transport_tendency => ccisof%decomp_cpools_transport_tendency - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! calculate pft-level summary carbon fluxes and states - - ! gross primary production (GPP) - gpp(p) = & - psnsun_to_cpool(p) + & - psnshade_to_cpool(p) - - - ! maintenance respiration (MR) - if ( isotope .eq. 'c13' .or. isotope .eq. 'c14') then - leaf_mr(p) = leaf_curmr(p) + leaf_xsmr(p) - froot_mr(p) = froot_curmr(p) + froot_xsmr(p) - livestem_mr(p) = livestem_curmr(p) + livestem_xsmr(p) - livecroot_mr(p) = livecroot_curmr(p) + livecroot_xsmr(p) - endif - mr(p) = & - leaf_mr(p) + & - froot_mr(p) + & - livestem_mr(p) + & - livecroot_mr(p) - - ! growth respiration (GR) - ! current GR is respired this time step for new growth displayed in this timestep - current_gr(p) = & - cpool_leaf_gr(p) + & - cpool_froot_gr(p) + & - cpool_livestem_gr(p) + & - cpool_deadstem_gr(p) + & - cpool_livecroot_gr(p) + & - cpool_deadcroot_gr(p) - - ! transfer GR is respired this time step for transfer growth displayed in this timestep - transfer_gr(p) = & - transfer_leaf_gr(p) + & - transfer_froot_gr(p) + & - transfer_livestem_gr(p) + & - transfer_deadstem_gr(p) + & - transfer_livecroot_gr(p) + & - transfer_deadcroot_gr(p) - - ! storage GR is respired this time step for growth sent to storage for later display - storage_gr(p) = & - cpool_leaf_storage_gr(p) + & - cpool_froot_storage_gr(p) + & - cpool_livestem_storage_gr(p) + & - cpool_deadstem_storage_gr(p) + & - cpool_livecroot_storage_gr(p) + & - cpool_deadcroot_storage_gr(p) - - if ( crop_prog .and. ivt(p) >= npcropmin )then - mr(p) = mr(p) + & - grain_mr(p) - current_gr(p) = current_gr(p) + & - cpool_grain_gr(p) - transfer_gr(p) = transfer_gr(p) + & - transfer_grain_gr(p) - storage_gr(p) = storage_gr(p) + & - cpool_grain_storage_gr(p) - end if - - ! GR is the sum of current + transfer + storage GR - gr(p) = & - current_gr(p) + & - transfer_gr(p) + & - storage_gr(p) - - ! autotrophic respiration (AR) - if ( crop_prog .and. ivt(p) >= npcropmin )then - ar(p) = mr(p) + gr(p) + xsmrpool_to_atm(p) ! xsmr... is -ve (slevis) - else - ar(p) = mr(p) + gr(p) - end if - - ! root respiration (RR) - rr(p) = & - froot_mr(p) + & - cpool_froot_gr(p) + & - cpool_livecroot_gr(p) + & - cpool_deadcroot_gr(p) + & - transfer_froot_gr(p) + & - transfer_livecroot_gr(p) + & - transfer_deadcroot_gr(p) + & - cpool_froot_storage_gr(p) + & - cpool_livecroot_storage_gr(p) + & - cpool_deadcroot_storage_gr(p) - - ! net primary production (NPP) - npp(p) = gpp(p) - ar(p) - - ! update the annual NPP accumulator, for use in allocation code - if (isotope == 'bulk') then - tempsum_npp(p) = tempsum_npp(p) + npp(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. - agnpp(p) = & - cpool_to_leafc(p) + & - leafc_xfer_to_leafc(p) + & - cpool_to_livestemc(p) + & - livestemc_xfer_to_livestemc(p) + & - cpool_to_deadstemc(p) + & - deadstemc_xfer_to_deadstemc(p) - - ! belowground NPP: fine root, live coarse root, dead coarse root (BGNPP) - ! This is supposed to correspond as closely as possible to - ! field measurements of BGNPP, so it ignores the storage pools - ! and only treats the fluxes into displayed pools. - bgnpp(p) = & - cpool_to_frootc(p) + & - frootc_xfer_to_frootc(p) + & - cpool_to_livecrootc(p) + & - livecrootc_xfer_to_livecrootc(p) + & - cpool_to_deadcrootc(p) + & - deadcrootc_xfer_to_deadcrootc(p) - - ! litterfall (LITFALL) - litfall(p) = & - leafc_to_litter(p) + & - frootc_to_litter(p) + & - m_leafc_to_litter(p) + & - m_leafc_storage_to_litter(p) + & - m_leafc_xfer_to_litter(p) + & - m_frootc_to_litter(p) + & - m_frootc_storage_to_litter(p) + & - m_frootc_xfer_to_litter(p) + & - m_livestemc_to_litter(p) + & - m_livestemc_storage_to_litter(p) + & - m_livestemc_xfer_to_litter(p) + & - m_deadstemc_to_litter(p) + & - m_deadstemc_storage_to_litter(p) + & - m_deadstemc_xfer_to_litter(p) + & - m_livecrootc_to_litter(p) + & - m_livecrootc_storage_to_litter(p) + & - m_livecrootc_xfer_to_litter(p) + & - m_deadcrootc_to_litter(p) + & - m_deadcrootc_storage_to_litter(p) + & - m_deadcrootc_xfer_to_litter(p) + & - m_gresp_storage_to_litter(p) + & - m_gresp_xfer_to_litter(p) + & -! F. Li and S. Levis - m_leafc_to_litter_fire(p) + & - m_leafc_storage_to_litter_fire(p) + & - m_leafc_xfer_to_litter_fire(p) + & - m_livestemc_to_litter_fire(p) + & - m_livestemc_storage_to_litter_fire(p) + & - m_livestemc_xfer_to_litter_fire(p) + & - m_deadstemc_to_litter_fire(p) + & - m_deadstemc_storage_to_litter_fire(p) + & - m_deadstemc_xfer_to_litter_fire(p) + & - m_frootc_to_litter_fire(p) + & - m_frootc_storage_to_litter_fire(p) + & - m_frootc_xfer_to_litter_fire(p) + & - m_livecrootc_to_litter_fire(p) + & - m_livecrootc_storage_to_litter_fire(p) + & - m_livecrootc_xfer_to_litter_fire(p) + & - m_deadcrootc_to_litter_fire(p) + & - m_deadcrootc_storage_to_litter_fire(p) + & - m_deadcrootc_xfer_to_litter_fire(p) + & - m_gresp_storage_to_litter_fire(p) + & - m_gresp_xfer_to_litter_fire(p) + & - - hrv_leafc_to_litter(p) + & - hrv_leafc_storage_to_litter(p) + & - hrv_leafc_xfer_to_litter(p) + & - hrv_frootc_to_litter(p) + & - hrv_frootc_storage_to_litter(p) + & - hrv_frootc_xfer_to_litter(p) + & - hrv_livestemc_to_litter(p) + & - hrv_livestemc_storage_to_litter(p) + & - hrv_livestemc_xfer_to_litter(p) + & - hrv_deadstemc_storage_to_litter(p) + & - hrv_deadstemc_xfer_to_litter(p) + & - hrv_livecrootc_to_litter(p) + & - hrv_livecrootc_storage_to_litter(p)+ & - hrv_livecrootc_xfer_to_litter(p) + & - hrv_deadcrootc_to_litter(p) + & - hrv_deadcrootc_storage_to_litter(p)+ & - hrv_deadcrootc_xfer_to_litter(p) + & - hrv_gresp_storage_to_litter(p) + & - hrv_gresp_xfer_to_litter(p) - -#if (defined CNDV) - ! update the annual litfall accumulator, for use in mortality code - tempsum_litfall(p) = tempsum_litfall(p) + leafc_to_litter(p) + frootc_to_litter(p) -#endif - - ! pft-level fire losses (VEGFIRE) - vegfire(p) = 0._r8 - - ! pft-level wood harvest - wood_harvestc(p) = & - hrv_deadstemc_to_prod10c(p) + & - hrv_deadstemc_to_prod100c(p) - - ! pft-level carbon losses to fire changed by F. Li and S. Levis - pft_fire_closs(p) = & - m_leafc_to_fire(p) + & - m_leafc_storage_to_fire(p) + & - m_leafc_xfer_to_fire(p) + & - m_frootc_to_fire(p) + & - m_frootc_storage_to_fire(p) + & - m_frootc_xfer_to_fire(p) + & - m_livestemc_to_fire(p) + & - m_livestemc_storage_to_fire(p) + & - m_livestemc_xfer_to_fire(p) + & - m_deadstemc_to_fire(p) + & - m_deadstemc_storage_to_fire(p) + & - m_deadstemc_xfer_to_fire(p) + & - m_livecrootc_to_fire(p) + & - m_livecrootc_storage_to_fire(p) + & - m_livecrootc_xfer_to_fire(p) + & - m_deadcrootc_to_fire(p) + & - m_deadcrootc_storage_to_fire(p) + & - m_deadcrootc_xfer_to_fire(p) + & - m_gresp_storage_to_fire(p) + & - m_gresp_xfer_to_fire(p) - - ! displayed vegetation carbon, excluding storage and cpool (DISPVEGC) - dispvegc(p) = & - leafc(p) + & - frootc(p) + & - livestemc(p) + & - deadstemc(p) + & - livecrootc(p) + & - deadcrootc(p) - - ! stored vegetation carbon, excluding cpool (STORVEGC) - storvegc(p) = & - cpool(p) + & - leafc_storage(p) + & - frootc_storage(p) + & - livestemc_storage(p) + & - deadstemc_storage(p) + & - livecrootc_storage(p) + & - deadcrootc_storage(p) + & - leafc_xfer(p) + & - frootc_xfer(p) + & - livestemc_xfer(p) + & - deadstemc_xfer(p) + & - livecrootc_xfer(p) + & - deadcrootc_xfer(p) + & - gresp_storage(p) + & - gresp_xfer(p) - - if ( crop_prog .and. ivt(p) >= npcropmin )then - storvegc(p) = storvegc(p) + & - grainc_storage(p) + & - grainc_xfer(p) - agnpp(p) = agnpp(p) + & - cpool_to_grainc(p) + & - grainc_xfer_to_grainc(p) - litfall(p) = litfall(p) + & - livestemc_to_litter(p) + & - grainc_to_food(p) - dispvegc(p) = dispvegc(p) + & - grainc(p) - end if - - ! total vegetation carbon, excluding cpool (TOTVEGC) - totvegc(p) = dispvegc(p) + storvegc(p) - - ! total pft-level carbon, including xsmrpool, ctrunc - totpftc(p) = totvegc(p) + xsmrpool(p) + pft_ctrunc(p) - - ! new summary variables for CLAMP - - ! (FROOTC_ALLOC) - fine root C allocation - frootc_alloc(p) = & - frootc_xfer_to_frootc(p) + & - cpool_to_frootc(p) - - ! (FROOTC_LOSS) - fine root C loss changed by F. Li and S. Levis - frootc_loss(p) = & - m_frootc_to_litter(p) + & - m_frootc_to_fire(p) + & - m_frootc_to_litter_fire(p) + & - hrv_frootc_to_litter(p) + & - frootc_to_litter(p) - - ! (LEAFC_ALLOC) - leaf C allocation - leafc_alloc(p) = & - leafc_xfer_to_leafc(p) + & - cpool_to_leafc(p) - - ! (LEAFC_LOSS) - leaf C loss changed by F. Li and S. Levis - leafc_loss(p) = & - m_leafc_to_litter(p) + & - m_leafc_to_fire(p) + & - m_leafc_to_litter_fire(p) + & - hrv_leafc_to_litter(p) + & - leafc_to_litter(p) - - ! (WOODC) - wood C - woodc(p) = & - deadstemc(p) + & - livestemc(p) + & - deadcrootc(p) + & - livecrootc(p) - - ! (WOODC_ALLOC) - wood C allocation - woodc_alloc(p) = & - livestemc_xfer_to_livestemc(p) + & - deadstemc_xfer_to_deadstemc(p) + & - livecrootc_xfer_to_livecrootc(p) + & - deadcrootc_xfer_to_deadcrootc(p) + & - cpool_to_livestemc(p) + & - cpool_to_deadstemc(p) + & - cpool_to_livecrootc(p) + & - cpool_to_deadcrootc(p) - - ! (WOODC_LOSS) - wood C loss - woodc_loss(p) = & - m_livestemc_to_litter(p) + & - m_deadstemc_to_litter(p) + & - m_livecrootc_to_litter(p) + & - m_deadcrootc_to_litter(p) + & - m_livestemc_to_fire(p) + & - m_deadstemc_to_fire(p) + & - m_livecrootc_to_fire(p) + & - m_deadcrootc_to_fire(p) + & - hrv_livestemc_to_litter(p) + & - hrv_livestemc_storage_to_litter(p) + & - hrv_livestemc_xfer_to_litter(p) + & - hrv_deadstemc_to_prod10c(p) + & - hrv_deadstemc_to_prod100c(p) + & - hrv_deadstemc_storage_to_litter(p) + & - hrv_deadstemc_xfer_to_litter(p) + & - hrv_livecrootc_to_litter(p) + & - hrv_livecrootc_storage_to_litter(p)+ & - hrv_livecrootc_xfer_to_litter(p) + & - hrv_deadcrootc_to_litter(p) + & - hrv_deadcrootc_storage_to_litter(p)+ & - hrv_deadcrootc_xfer_to_litter(p) - - end do ! end of pfts loop - - ! use p2c routine to get selected column-average pft-level fluxes and states - call p2c(num_soilc, filter_soilc, gpp, col_gpp) - call p2c(num_soilc, filter_soilc, ar, col_ar) - call p2c(num_soilc, filter_soilc, rr, col_rr) - call p2c(num_soilc, filter_soilc, npp, col_npp) - call p2c(num_soilc, filter_soilc, vegfire, col_vegfire) - call p2c(num_soilc, filter_soilc, wood_harvestc, col_wood_harvestc) - call p2c(num_soilc, filter_soilc, totvegc, col_totvegc) - call p2c(num_soilc, filter_soilc, totpftc, col_totpftc) - call p2c(num_soilc, filter_soilc, pft_fire_closs, col_pft_fire_closs) - call p2c(num_soilc, filter_soilc, litfall, col_litfall) - call p2c(num_soilc, filter_soilc, hrv_xsmrpool_to_atm, col_hrv_xsmrpool_to_atm) - - if ( isotope .eq. 'bulk') then - if (nfix_timeconst .gt. 0._r8 .and. nfix_timeconst .lt. 500._r8 ) then - ! this code is to calculate an exponentially-relaxed npp value for use in NDynamics code - dtime = get_step_size() - nfixlags = nfix_timeconst * secspday - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - if ( col_lag_npp(c) .ne. spval ) then - col_lag_npp(c) = col_lag_npp(c) * exp(-dtime/nfixlags) & - + col_npp(c) * (1._r8 - exp(-dtime/nfixlags)) - else - ! first timestep - col_lag_npp(c) = col_npp(c) - endif - end do - endif - endif - - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! some zeroing - lithr(c) = 0._r8 - somhr(c) = 0._r8 - totlitc(c) = 0._r8 - totsomc(c) = 0._r8 - cwdc(c) = 0._r8 - col_ctrunc(c) = 0._r8 - cwdc_loss(c) = 0._r8 - som_c_leached(c) = 0._r8 - do l = 1, ndecomp_pools - decomp_cpools(c,l) = 0._r8 - end do - totlitc_1m(c) = 0._r8 - totsomc_1m(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) - decomp_cascade_hr(c,k) = decomp_cascade_hr(c,k) + decomp_cascade_hr_vr(c,j,k)*dzsoi_decomp(j) - decomp_cascade_ctransfer(c,k) = decomp_cascade_ctransfer(c,k) + decomp_cascade_ctransfer_vr(c,j,k) * dzsoi_decomp(j) - end do - end do - end do - - ! litter heterotrophic respiration (LITHR) - do k = 1, ndecomp_cascade_transitions - if ( is_litter(cascade_donor_pool(k)) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - lithr(c) = lithr(c) + decomp_cascade_hr(c,k) - end do - end if - end do - - ! soil organic matter heterotrophic respiration (SOMHR) - do k = 1, ndecomp_cascade_transitions - if ( is_soil(cascade_donor_pool(k)) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - somhr(c) = somhr(c) + decomp_cascade_hr(c,k) - end do - end if - end do - - ! total heterotrophic respiration (HR) - do fc = 1,num_soilc - c = filter_soilc(fc) - hr(c) = lithr(c) + somhr(c) - end do - - ! total heterotrophic respiration, vertically resolved (HR) - do j = 1,nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - hr_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) - hr_vr(c,j) = hr_vr(c,j) + decomp_cascade_hr_vr(c,j,k) - end do - end do - end do - - do fc = 1,num_soilc - c = filter_soilc(fc) - ! total soil respiration, heterotrophic + root respiration (SR) - sr(c) = col_rr(c) + hr(c) - - ! total ecosystem respiration, autotrophic + heterotrophic (ER) - er(c) = col_ar(c) + hr(c) - - ! litter fire losses (LITFIRE) - litfire(c) = 0._r8 - - ! total wood product loss - product_closs(c) = & - prod10c_loss(c) + & - prod100c_loss(c) - - ! soil organic matter fire losses (SOMFIRE) - somfire(c) = 0._r8 - - ! total ecosystem fire losses (TOTFIRE) - totfire(c) = & - litfire(c) + & - somfire(c) + & - col_vegfire(c) - end do - - ! vertically integrate column-level carbon fire losses - do l = 1, ndecomp_pools - do j = 1,nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - m_decomp_cpools_to_fire(c,l) = m_decomp_cpools_to_fire(c,l) + & - m_decomp_cpools_to_fire_vr(c,j,l)*dzsoi_decomp(j) - end do - end do - end do - - ! column-level carbon losses to fire, including pft losses - do fc = 1,num_soilc - c = filter_soilc(fc) - col_fire_closs(c) = col_pft_fire_closs(c) - do l = 1, ndecomp_pools - col_fire_closs(c) = col_fire_closs(c) + m_decomp_cpools_to_fire(c,l) - end do - - ! column-level carbon losses due to landcover change - dwt_closs(c) = & - dwt_conv_cflux(c) - - ! net ecosystem production, excludes fire flux, landcover change, and loss from wood products, positive for sink (NEP) - nep(c) = col_gpp(c) - er(c) - - ! net biome production of carbon, includes depletion from: fire flux, landcover change flux, and loss - ! from wood products pools, positive for sink (NBP) - nbp(c) = nep(c) - col_fire_closs(c) - dwt_closs(c) - product_closs(c) - - ! net ecosystem exchange of carbon, includes fire flux, landcover change flux, loss - ! from wood products pools, and hrv_xsmrpool flux, positive for source (NEE) - nee(c) = -nep(c) + col_fire_closs(c) + dwt_closs(c) + product_closs(c) + col_hrv_xsmrpool_to_atm(c) - ! land use flux and land uptake - landuseflux(c) = dwt_closs(c) + product_closs(c) - landuptake(c) = nee(c) - landuseflux(c) - end do - - ! vertically integrate each of the decomposing C pools - do l = 1, ndecomp_pools - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_cpools(c,l) = decomp_cpools(c,l) + & - decomp_cpools_vr(c,j,l) * dzsoi_decomp(j) - end do - end do - end do - - ! for vertically-resolved soil biogeochemistry, calculate some diagnostics of carbon pools to a given depth - if ( nlevdecomp .gt. 1) then - - ! zero some pools - do l = 1, ndecomp_pools - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_cpools_1m(c,l) = 0._r8 - end do - end do - - ! vertically integrate each of the decomposing C pools to 1 meter - maxdepth = 1._r8 - do l = 1, ndecomp_pools - do j = 1, nlevdecomp - if ( zisoi(j) .le. maxdepth ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_cpools_1m(c,l) = decomp_cpools_1m(c,l) + & - decomp_cpools_vr(c,j,l) * dzsoi_decomp(j) - end do - elseif ( zisoi(j-1) .lt. maxdepth ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_cpools_1m(c,l) = decomp_cpools_1m(c,l) + & - decomp_cpools_vr(c,j,l) * (maxdepth - zisoi(j-1)) - end do - endif - end do - end do - - ! total litter carbon in the top meter (TOTLITC_1m) - do l = 1, ndecomp_pools - if ( is_litter(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - totlitc_1m(c) = totlitc_1m(c) + & - decomp_cpools_1m(c,l) - end do - endif - end do - - ! total soil organic matter carbon in the top meter (TOTSOMC_1m) - do l = 1, ndecomp_pools - if ( is_soil(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - totsomc_1m(c) = totsomc_1m(c) + & - decomp_cpools_1m(c,l) - end do - end if - end do - - endif - - ! total litter carbon (TOTLITC) - do l = 1, ndecomp_pools - if ( is_litter(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - totlitc(c) = totlitc(c) + & - decomp_cpools(c,l) - end do - endif - end do - - ! total soil organic matter carbon (TOTSOMC) - do l = 1, ndecomp_pools - if ( is_soil(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - totsomc(c) = totsomc(c) + & - decomp_cpools(c,l) - end do - end if - end do - - ! coarse woody debris carbon - do l = 1, ndecomp_pools - if ( is_cwd(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - cwdc(c) = cwdc(c) + & - decomp_cpools(c,l) - end do - end if - end do - - ! truncation carbon - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - col_ctrunc(c) = col_ctrunc(c) + & - col_ctrunc_vr(c,j) * dzsoi_decomp(j) - end do - end do - - do fc = 1,num_soilc - c = filter_soilc(fc) - ! total wood product carbon - totprodc(c) = & - prod10c(c) + & - prod100c(c) - - ! total ecosystem carbon, including veg but excluding cpool (TOTECOSYSC) - totecosysc(c) = & - cwdc(c) + & - totlitc(c) + & - totsomc(c) + & - totprodc(c) + & - col_totvegc(c) - - ! total column carbon, including veg and cpool (TOTCOLC) - ! adding col_ctrunc, seedc - totcolc(c) = & - col_totpftc(c) + & - cwdc(c) + & - totlitc(c) + & - totsomc(c) + & - totprodc(c) + & - seedc(c) + & - col_ctrunc(c) - - ! new summary variables for CLAMP - - ! (CWDC_HR) - coarse woody debris heterotrophic respiration - cwdc_hr(c) = 0._r8 - end do - - ! (CWDC_LOSS) - coarse woody debris C loss - do l = 1, ndecomp_pools - if ( is_cwd(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - cwdc_loss(c) = cwdc_loss(c) + m_decomp_cpools_to_fire(c,l) - end do - end if - end do - - do k = 1, ndecomp_cascade_transitions - if ( is_cwd(cascade_donor_pool(k)) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - cwdc_loss(c) = cwdc_loss(c) + decomp_cascade_ctransfer(c,k) - end do - end if - end do - - ! (LITTERC_LOSS) - litter C loss - do fc = 1,num_soilc - c = filter_soilc(fc) - litterc_loss(c) = lithr(c) - end do - do l = 1, ndecomp_pools - if ( is_litter(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - litterc_loss(c) = litterc_loss(c) + m_decomp_cpools_to_fire(c,l) - end do - end if - end do - do k = 1, ndecomp_cascade_transitions - if ( is_litter(cascade_donor_pool(k)) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - litterc_loss(c) = litterc_loss(c) + decomp_cascade_ctransfer(c,k) - end do - end if - 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) - decomp_cpools_leached(c,l) = 0._r8 - end do - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_cpools_leached(c,l) = decomp_cpools_leached(c,l) + decomp_cpools_transport_tendency(c,j,l) * dzsoi_decomp(j) - end do - end do - do fc = 1,num_soilc - c = filter_soilc(fc) - som_c_leached(c) = som_c_leached(c) + decomp_cpools_leached(c,l) - end do - end do - - - -end subroutine CSummary -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: NSummary -! -! !INTERFACE: -subroutine NSummary(num_soilc, filter_soilc, num_soilp, filter_soilp) -! -! !DESCRIPTION: -! On the radiation time step, perform pft and column-level nitrogen -! summary calculations -! -! !USES: - use clmtype - use subgridAveMod, only: p2c - use clm_varpar , only: nlevdecomp,ndecomp_cascade_transitions,ndecomp_pools -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 6/28/04: Created by Peter Thornton -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: col_fire_nloss(:) ! (gN/m2/s) total column-level fire N loss - real(r8), pointer :: col_wood_harvestn(:) - real(r8), pointer :: denit(:) - real(r8), pointer :: col_pft_fire_nloss(:) ! (gN/m2/s) total pft-level fire C loss - real(r8), pointer :: col_totpftn(:) ! (gN/m2) total pft-level nitrogen - real(r8), pointer :: col_totvegn(:) ! (gN/m2) total vegetation nitrogen - real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N - real(r8), pointer :: col_ntrunc(:) ! (gN/m2) column-level sink for N truncation - real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N - real(r8), pointer :: m_decomp_npools_to_fire_vr(:,:,:) - real(r8), pointer :: m_decomp_npools_to_fire(:,:) - 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 -#ifndef NITRIF_DENITRIF - real(r8), pointer :: sminn_to_denit_excess_vr(:,:) - real(r8), pointer :: sminn_to_denit_excess(:) - real(r8), pointer :: sminn_leached_vr(:,:) - real(r8), pointer :: sminn_leached(:) - real(r8), pointer :: sminn_to_denit_decomp_cascade_vr(:,:,:) ! vertically-resolved denitrification along decomp cascade (gN/m3/s) - real(r8), pointer :: sminn_to_denit_decomp_cascade(:,:) ! vertically-integrated denitrification along decomp cascade (gN/m2/s) -#else - real(r8), pointer :: smin_no3(:) - real(r8), pointer :: smin_nh4(:) - real(r8), pointer :: smin_no3_vr(:,:) - real(r8), pointer :: smin_nh4_vr(:,:) - real(r8), pointer :: f_nit_vr(:,:) - real(r8), pointer :: f_nit(:) - real(r8), pointer :: f_denit_vr(:,:) - real(r8), pointer :: f_denit(:) - real(r8), pointer :: pot_f_nit_vr(:,:) - real(r8), pointer :: pot_f_nit(:) - real(r8), pointer :: pot_f_denit_vr(:,:) - real(r8), pointer :: pot_f_denit(:) - real(r8), pointer :: f_n2o_denit_vr(:,:) ! flux of N2o from denitrification [gN/m3/s] - real(r8), pointer :: f_n2o_denit(:) ! flux of N2o from denitrification [gN/m2/s] - real(r8), pointer :: f_n2o_nit_vr(:,:) ! flux of N2o from nitrification [gN/m3/s] - real(r8), pointer :: f_n2o_nit(:) ! flux of N2o from nitrification [gN/m2/s] - real(r8), pointer :: smin_no3_leached_vr(:,:) - real(r8), pointer :: smin_no3_leached(:) - real(r8), pointer :: smin_no3_runoff_vr(:,:) - real(r8), pointer :: smin_no3_runoff(:) -#endif - real(r8), pointer :: decomp_npools(:,:) ! (gN/m2) decomposing (litter, cwd, soil) N pools - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gN/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: decomp_npools_1m(:,:) ! (gN/m2) diagnostic: decomposing (litter, cwd, soil) N pools to 1 meter - integer, pointer :: altmax_indx(:) ! maximum annual depth of thaw - integer, pointer :: altmax_lastyear_indx(:) ! prior year maximum annual depth of thaw - real(r8), pointer :: sminn_vr(:,:) ! (gN/m3) soil mineral N - real(r8), pointer :: col_ntrunc_vr(:,:) ! (gN/m3) column-level sink for N truncation - real(r8), pointer :: supplement_to_sminn(:) - real(r8), pointer :: supplement_to_sminn_vr(:,:) - real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg - real(r8), pointer :: totecosysn(:) ! (gN/m2) total ecosystem nitrogen, incl veg - real(r8), pointer :: totlitn(:) ! (gN/m2) total litter nitrogen - real(r8), pointer :: totlitn_1m(:) ! (gN/m2) total litter nitrogen to 1 meter - real(r8), pointer :: totsomn(:) ! (gN/m2) total soil organic matter nitrogen - -! fire related variables changed by F. Li and S. Levis - real(r8), pointer :: m_leafn_to_fire(:) - real(r8), pointer :: m_leafn_storage_to_fire(:) - real(r8), pointer :: m_leafn_xfer_to_fire(:) - real(r8), pointer :: m_livestemn_to_fire(:) - real(r8), pointer :: m_livestemn_storage_to_fire(:) - real(r8), pointer :: m_livestemn_xfer_to_fire(:) - real(r8), pointer :: m_deadstemn_to_fire(:) - real(r8), pointer :: m_deadstemn_storage_to_fire(:) - real(r8), pointer :: totsomn_1m(:) ! (gN/m2) total soil organic matter nitrogen to 1 meter - real(r8), pointer :: m_deadcrootn_storage_to_fire(:) - real(r8), pointer :: m_deadcrootn_to_fire(:) - real(r8), pointer :: m_deadcrootn_xfer_to_fire(:) - real(r8), pointer :: m_deadstemn_xfer_to_fire(:) - real(r8), pointer :: m_frootn_to_fire(:) - real(r8), pointer :: m_frootn_storage_to_fire(:) - real(r8), pointer :: m_frootn_xfer_to_fire(:) - real(r8), pointer :: m_livecrootn_to_fire(:) - real(r8), pointer :: m_livecrootn_storage_to_fire(:) - real(r8), pointer :: m_livecrootn_xfer_to_fire(:) - real(r8), pointer :: m_retransn_to_fire(:) - - real(r8), pointer :: hrv_deadstemn_to_prod10n(:) - real(r8), pointer :: hrv_deadstemn_to_prod100n(:) - real(r8), pointer :: ndeploy(:) - real(r8), pointer :: pft_fire_nloss(:) ! (gN/m2/s) total pft-level fire C loss - real(r8), pointer :: retransn_to_npool(:) - real(r8), pointer :: sminn_to_npool(:) - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: dispvegn(:) ! (gN/m2) displayed veg nitrogen, excluding storage - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: grainn(:) ! (gN/m2) grain N - real(r8), pointer :: grainn_storage(:) ! (gN/m2) grain N storage - real(r8), pointer :: grainn_xfer(:) ! (gN/m2) grain N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N - real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool - real(r8), pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation - real(r8), pointer :: storvegn(:) ! (gN/m2) stored vegetation nitrogen - real(r8), pointer :: totpftn(:) ! (gN/m2) total pft-level nitrogen - real(r8), pointer :: totvegn(:) ! (gN/m2) total vegetation nitrogen - ! for landcover change - real(r8), pointer :: wood_harvestn(:) ! total N losses to wood product pools (gN/m2/s) - real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion - real(r8), pointer :: dwt_conv_nflux(:) ! (gN/m2/s) conversion N flux (immediate loss to atm) - real(r8), pointer :: seedn(:) ! (gN/m2) column-level pool for seeding new PFTs - real(r8), pointer :: prod10n_loss(:) ! (gN/m2/s) loss from 10-yr wood product pool - real(r8), pointer :: prod100n_loss(:) ! (gN/m2/s) loss from 100-yr wood product pool - real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss - real(r8), pointer :: prod10n(:) ! (gN/m2) wood product N pool, 10-year lifespan - real(r8), pointer :: prod100n(:) ! (gN/m2) wood product N pool, 100-year lifespan - real(r8), pointer :: totprodn(:) ! (gN/m2) total wood product N - - real(r8), pointer :: decomp_cascade_ntransfer_vr(:,:,:) - real(r8), pointer :: decomp_cascade_ntransfer(:,:) - real(r8), pointer :: decomp_cascade_sminn_flux_vr(:,:,:) ! vert-res mineral N flux for transition along decomposition cascade (gN/m3/s) - real(r8), pointer :: decomp_cascade_sminn_flux(:,:) ! vert-int (diagnostic) mineral N flux for transition along decomposition cascade (gN/m2/s) - - real(r8), pointer :: som_n_leached(:) ! total SOM N loss from vertical transport (gN/m^2/s) - real(r8), pointer :: decomp_npools_leached(:,:) ! N loss from vertical transport from each decomposing N pool (gN/m^2/s) - real(r8), pointer :: decomp_npools_transport_tendency(:,:,:) ! N tendency due to vertical transport in decomposing N pools (gN/m^3/s) - -! -! local pointers to implicit in/out scalars -! -! local pointers to implicit out scalars -! -! !OTHER LOCAL VARIABLES: - integer :: c,p,j,k,l ! indices - integer :: fp,fc ! lake filter indices - real(r8) :: maxdepth ! depth to integrate soil variables - -!EOP -!----------------------------------------------------------------------- - ! assign local pointers - ivt =>pft%itype - col_fire_nloss => cnf%col_fire_nloss - denit => cnf%denit - col_pft_fire_nloss => pnf_a%pft_fire_nloss - cwdn => cns%cwdn - col_ntrunc => cns%col_ntrunc - sminn => cns%sminn - m_decomp_npools_to_fire_vr => cnf%m_decomp_npools_to_fire_vr - m_decomp_npools_to_fire => cnf%m_decomp_npools_to_fire - is_litter => decomp_cascade_con%is_litter - is_soil => decomp_cascade_con%is_soil - is_cwd => decomp_cascade_con%is_cwd -#ifndef NITRIF_DENITRIF - sminn_to_denit_excess_vr => cnf%sminn_to_denit_excess_vr - sminn_to_denit_excess => cnf%sminn_to_denit_excess - sminn_to_denit_decomp_cascade_vr => cnf%sminn_to_denit_decomp_cascade_vr - sminn_to_denit_decomp_cascade => cnf%sminn_to_denit_decomp_cascade - sminn_leached_vr => cnf%sminn_leached_vr - sminn_leached => cnf%sminn_leached -#else - smin_no3 => cns%smin_no3 - smin_nh4 => cns%smin_nh4 - smin_no3_vr => cns%smin_no3_vr - smin_nh4_vr => cns%smin_nh4_vr - f_nit_vr => cnf%f_nit_vr - f_nit => cnf%f_nit - f_denit_vr => cnf%f_denit_vr - f_denit => cnf%f_denit - pot_f_nit_vr => cnf%pot_f_nit_vr - pot_f_nit => cnf%pot_f_nit - pot_f_denit_vr => cnf%pot_f_denit_vr - pot_f_denit => cnf%pot_f_denit - f_n2o_denit_vr => cnf%f_n2o_denit_vr - f_n2o_nit_vr => cnf%f_n2o_nit_vr - f_n2o_denit => cnf%f_n2o_denit - f_n2o_nit => cnf%f_n2o_nit - smin_no3_leached_vr => cnf%smin_no3_leached_vr - smin_no3_leached => cnf%smin_no3_leached - smin_no3_runoff_vr => cnf%smin_no3_runoff_vr - smin_no3_runoff => cnf%smin_no3_runoff -#endif - decomp_npools => cns%decomp_npools - decomp_npools_vr => cns%decomp_npools_vr - decomp_npools_1m => cns%decomp_npools_1m - altmax_indx => cps%altmax_indx - altmax_lastyear_indx => cps%altmax_lastyear_indx - sminn_vr => cns%sminn_vr - col_ntrunc_vr => cns%col_ntrunc_vr - supplement_to_sminn => cnf%supplement_to_sminn - supplement_to_sminn_vr => cnf%supplement_to_sminn_vr - col_totpftn => pns_a%totpftn - col_totvegn => pns_a%totvegn - totcoln => cns%totcoln - totecosysn => cns%totecosysn - totlitn => cns%totlitn - totlitn_1m => cns%totlitn_1m - totsomn => cns%totsomn - m_leafn_to_fire => pnf%m_leafn_to_fire - m_leafn_storage_to_fire => pnf%m_leafn_storage_to_fire - m_leafn_xfer_to_fire => pnf%m_leafn_xfer_to_fire - m_livestemn_to_fire => pnf%m_livestemn_to_fire - m_livestemn_storage_to_fire => pnf%m_livestemn_storage_to_fire - m_livestemn_xfer_to_fire => pnf%m_livestemn_xfer_to_fire - m_deadstemn_to_fire => pnf%m_deadstemn_to_fire - totsomn_1m => cns%totsomn_1m - m_deadcrootn_storage_to_fire => pnf%m_deadcrootn_storage_to_fire - m_deadcrootn_to_fire => pnf%m_deadcrootn_to_fire - m_deadcrootn_xfer_to_fire => pnf%m_deadcrootn_xfer_to_fire - m_deadstemn_storage_to_fire => pnf%m_deadstemn_storage_to_fire - m_deadstemn_xfer_to_fire => pnf%m_deadstemn_xfer_to_fire - m_frootn_to_fire => pnf%m_frootn_to_fire - m_frootn_storage_to_fire => pnf%m_frootn_storage_to_fire - m_frootn_xfer_to_fire => pnf%m_frootn_xfer_to_fire - m_livecrootn_to_fire => pnf%m_livecrootn_to_fire - m_livecrootn_storage_to_fire => pnf%m_livecrootn_storage_to_fire - m_livecrootn_xfer_to_fire => pnf%m_livecrootn_xfer_to_fire - m_deadcrootn_to_fire => pnf%m_deadcrootn_to_fire - m_deadcrootn_storage_to_fire => pnf%m_deadcrootn_storage_to_fire - m_deadcrootn_xfer_to_fire => pnf%m_deadcrootn_xfer_to_fire - m_retransn_to_fire => pnf%m_retransn_to_fire - - - hrv_deadstemn_to_prod10n => pnf%hrv_deadstemn_to_prod10n - hrv_deadstemn_to_prod100n => pnf%hrv_deadstemn_to_prod100n - ndeploy => pnf%ndeploy - pft_fire_nloss => pnf%pft_fire_nloss - retransn_to_npool => pnf%retransn_to_npool - sminn_to_npool => pnf%sminn_to_npool - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - dispvegn => pns%dispvegn - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - grainn => pns%grainn - grainn_storage => pns%grainn_storage - grainn_xfer => pns%grainn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - retransn => pns%retransn - npool => pns%npool - pft_ntrunc => pns%pft_ntrunc - storvegn => pns%storvegn - totpftn => pns%totpftn - totvegn => pns%totvegn - ! dynamic landcover pointers - wood_harvestn => pnf%wood_harvestn - col_wood_harvestn => pnf_a%wood_harvestn - dwt_nloss => cnf%dwt_nloss - dwt_conv_nflux => cnf%dwt_conv_nflux - prod10n_loss => cnf%prod10n_loss - prod100n_loss => cnf%prod100n_loss - product_nloss => cnf%product_nloss - seedn => cns%seedn - prod10n => cns%prod10n - prod100n => cns%prod100n - totprodn => cns%totprodn - som_n_leached => cnf%som_n_leached - decomp_npools_leached => cnf%decomp_npools_leached - decomp_npools_transport_tendency => cnf%decomp_npools_transport_tendency - decomp_cascade_ntransfer_vr => cnf%decomp_cascade_ntransfer_vr - decomp_cascade_ntransfer => cnf%decomp_cascade_ntransfer - decomp_cascade_sminn_flux_vr => cnf%decomp_cascade_sminn_flux_vr - decomp_cascade_sminn_flux => cnf%decomp_cascade_sminn_flux - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - - ! calculate pft-level summary nitrogen fluxes and states - - ! total N deployment (from sminn and retranslocated N pool) (NDEPLOY) - ndeploy(p) = & - sminn_to_npool(p) + & - retransn_to_npool(p) - - ! pft-level wood harvest - wood_harvestn(p) = & - hrv_deadstemn_to_prod10n(p) + & - hrv_deadstemn_to_prod100n(p) - - ! total pft-level fire N losses - pft_fire_nloss(p) = & - m_leafn_to_fire(p) + & - m_leafn_storage_to_fire(p) + & - m_leafn_xfer_to_fire(p) + & - m_frootn_to_fire(p) + & - m_frootn_storage_to_fire(p) + & - m_frootn_xfer_to_fire(p) + & - m_livestemn_to_fire(p) + & - m_livestemn_storage_to_fire(p) + & - m_livestemn_xfer_to_fire(p) + & - m_deadstemn_to_fire(p) + & - m_deadstemn_storage_to_fire(p) + & - m_deadstemn_xfer_to_fire(p) + & - m_livecrootn_to_fire(p) + & - m_livecrootn_storage_to_fire(p) + & - m_livecrootn_xfer_to_fire(p) + & - m_deadcrootn_to_fire(p) + & - m_deadcrootn_storage_to_fire(p) + & - m_deadcrootn_xfer_to_fire(p) + & - m_retransn_to_fire(p) - - ! displayed vegetation nitrogen, excluding storage (DISPVEGN) - dispvegn(p) = & - leafn(p) + & - frootn(p) + & - livestemn(p) + & - deadstemn(p) + & - livecrootn(p) + & - deadcrootn(p) - - ! stored vegetation nitrogen, including retranslocated N pool (STORVEGN) - storvegn(p) = & - leafn_storage(p) + & - frootn_storage(p) + & - livestemn_storage(p) + & - deadstemn_storage(p) + & - livecrootn_storage(p) + & - deadcrootn_storage(p) + & - leafn_xfer(p) + & - frootn_xfer(p) + & - livestemn_xfer(p) + & - deadstemn_xfer(p) + & - livecrootn_xfer(p) + & - deadcrootn_xfer(p) + & - npool(p) + & - retransn(p) - - if ( crop_prog .and. ivt(p) >= npcropmin )then - dispvegn(p) = dispvegn(p) + & - grainn(p) - storvegn(p) = storvegn(p) + & - grainn_storage(p) + & - grainn_xfer(p) - end if - - ! total vegetation nitrogen (TOTVEGN) - totvegn(p) = dispvegn(p) + storvegn(p) - - ! total pft-level carbon (add pft_ntrunc) - totpftn(p) = totvegn(p) + pft_ntrunc(p) - - - end do ! end of pfts loop - - ! use p2c routine to get selected column-average pft-level fluxes and states - call p2c(num_soilc, filter_soilc, pft_fire_nloss, col_pft_fire_nloss) - call p2c(num_soilc, filter_soilc, wood_harvestn, col_wood_harvestn) - call p2c(num_soilc, filter_soilc, totvegn, col_totvegn) - call p2c(num_soilc, filter_soilc, totpftn, col_totpftn) - - ! column loops - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! some zeroing - denit(c) = 0._r8 -#ifdef NITRIF_DENITRIF - smin_no3(c) = 0._r8 - smin_nh4(c) = 0._r8 -#endif - totlitn(c) = 0._r8 - totsomn(c) = 0._r8 - cwdn(c) = 0._r8 - sminn(c) = 0._r8 - col_ntrunc(c) = 0._r8 - supplement_to_sminn(c) = 0._r8 - som_n_leached(c) = 0._r8 - totlitn_1m(c) = 0._r8 - totsomn_1m(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) - decomp_cascade_ntransfer(c,k) = decomp_cascade_ntransfer(c,k) & - + decomp_cascade_ntransfer_vr(c,j,k) * dzsoi_decomp(j) - decomp_cascade_sminn_flux(c,k) = decomp_cascade_sminn_flux(c,k) & - + decomp_cascade_sminn_flux_vr(c,j,k) * dzsoi_decomp(j) - end do - end do - end do - -#ifndef NITRIF_DENITRIF - ! vertically integrate each denitrification flux - do l = 1, ndecomp_cascade_transitions - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - sminn_to_denit_decomp_cascade(c,l) = sminn_to_denit_decomp_cascade(c,l) + & - sminn_to_denit_decomp_cascade_vr(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) - sminn_to_denit_excess(c) = sminn_to_denit_excess(c) + sminn_to_denit_excess_vr(c,j) * dzsoi_decomp(j) - sminn_leached(c) = sminn_leached(c) + sminn_leached_vr(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) - denit(c) = denit(c) + sminn_to_denit_decomp_cascade(c,l) - end do - end do - - do fc = 1,num_soilc - c = filter_soilc(fc) - denit(c) = denit(c) + sminn_to_denit_excess(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 - f_nit(c) = f_nit(c) + f_nit_vr(c,j) * dzsoi_decomp(j) - f_denit(c) = f_denit(c) + f_denit_vr(c,j) * dzsoi_decomp(j) - pot_f_nit(c) = pot_f_nit(c) + pot_f_nit_vr(c,j) * dzsoi_decomp(j) - pot_f_denit(c) = pot_f_denit(c) + pot_f_denit_vr(c,j) * dzsoi_decomp(j) - f_n2o_nit(c) = f_n2o_nit(c) + f_n2o_nit_vr(c,j) * dzsoi_decomp(j) - f_n2o_denit(c) = f_n2o_denit(c) + f_n2o_denit_vr(c,j) * dzsoi_decomp(j) - - ! leaching/runoff flux - smin_no3_leached(c) = smin_no3_leached(c) + smin_no3_leached_vr(c,j) * dzsoi_decomp(j) - smin_no3_runoff(c) = smin_no3_runoff(c) + smin_no3_runoff_vr(c,j) * dzsoi_decomp(j) - - ! mineral N pools (must set to zero first since they are state rather than flux variables) - smin_no3(c) = smin_no3(c) + smin_no3_vr(c,j) * dzsoi_decomp(j) - smin_nh4(c) = smin_nh4(c) + smin_nh4_vr(c,j) * dzsoi_decomp(j) - end do - end do - - do fc = 1,num_soilc - c = filter_soilc(fc) - denit(c) = f_denit(c) - end do - -#endif - - ! 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) - m_decomp_npools_to_fire(c,k) = m_decomp_npools_to_fire(c,k) + & - m_decomp_npools_to_fire_vr(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) - col_fire_nloss(c) = col_pft_fire_nloss(c) - end do - do k = 1, ndecomp_pools - do fc = 1,num_soilc - c = filter_soilc(fc) - col_fire_nloss(c) = col_fire_nloss(c) + & - m_decomp_npools_to_fire(c,k) - end do - end do - - - ! vertically integrate each of the decomposing N pools - do l = 1, ndecomp_pools - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools(c,l) = 0._r8 - end do - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools(c,l) = decomp_npools(c,l) + & - decomp_npools_vr(c,j,l) * dzsoi_decomp(j) - end do - end do - end do - - ! for vertically-resolved soil biogeochemistry, calculate some diagnostics of carbon pools to a given depth - if ( nlevdecomp .gt. 1) then - - do l = 1, ndecomp_pools - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools_1m(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) .le. maxdepth ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools_1m(c,l) = decomp_npools_1m(c,l) + & - decomp_npools_vr(c,j,l) * dzsoi_decomp(j) - end do - elseif ( zisoi(j-1) .lt. maxdepth ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools_1m(c,l) = decomp_npools_1m(c,l) + & - decomp_npools_vr(c,j,l) * (maxdepth - zisoi(j-1)) - end do - endif - end do - end do - - - ! total litter nitrogen to 1 meter (TOTLITN_1m) - do l = 1, ndecomp_pools - if ( is_litter(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - totlitn_1m(c) = totlitn_1m(c) + & - decomp_npools_1m(c,l) - end do - end if - end do - - ! total soil organic matter nitrogen to 1 meter (TOTSOMN_1m) - do l = 1, ndecomp_pools - if ( is_soil(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - totsomn_1m(c) = totsomn_1m(c) + & - decomp_npools_1m(c,l) - end do - end if - end do - - endif - - ! total litter nitrogen (TOTLITN) - do l = 1, ndecomp_pools - if ( is_litter(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - totlitn(c) = totlitn(c) + & - decomp_npools(c,l) - end do - end if - end do - - ! total soil organic matter nitrogen (TOTSOMN) - do l = 1, ndecomp_pools - if ( is_soil(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - totsomn(c) = totsomn(c) + & - decomp_npools(c,l) - end do - end if - end do - - ! total cwdn - do l = 1, ndecomp_pools - if ( is_cwd(l) ) then - do fc = 1,num_soilc - c = filter_soilc(fc) - cwdn(c) = cwdn(c) + & - decomp_npools(c,l) - end do - end if - end do - - ! total sminn - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - sminn(c) = sminn(c) + & - sminn_vr(c,j) * dzsoi_decomp(j) - end do - end do - - ! total col_ntrunc - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - col_ntrunc(c) = col_ntrunc(c) + & - col_ntrunc_vr(c,j) * dzsoi_decomp(j) - end do - end do - - ! supplementary N supplement_to_sminn - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - supplement_to_sminn(c) = supplement_to_sminn(c) + & - supplement_to_sminn_vr(c,j) * dzsoi_decomp(j) - end do - end do - - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! column-level N losses due to landcover change - dwt_nloss(c) = & - dwt_conv_nflux(c) - - ! total wood product N loss - product_nloss(c) = & - prod10n_loss(c) + & - prod100n_loss(c) - - ! total wood product nitrogen - totprodn(c) = & - prod10n(c) + & - prod100n(c) - - ! total ecosystem nitrogen, including veg (TOTECOSYSN) - totecosysn(c) = & - cwdn(c) + & - totlitn(c) + & - totsomn(c) + & - sminn(c) + & - totprodn(c) + & - col_totvegn(c) - - ! total column nitrogen, including pft (TOTCOLN) - totcoln(c) = & - col_totpftn(c) + & - cwdn(c) + & - totlitn(c) + & - totsomn(c) + & - sminn(c) + & - totprodn(c) + & - seedn(c) + & - col_ntrunc(c) - end do - - ! 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) - decomp_npools_leached(c,l) = 0._r8 - end do - do j = 1, nlevdecomp - do fc = 1,num_soilc - c = filter_soilc(fc) - decomp_npools_leached(c,l) = decomp_npools_leached(c,l) + decomp_npools_transport_tendency(c,j,l) * dzsoi_decomp(j) - end do - end do - do fc = 1,num_soilc - c = filter_soilc(fc) - som_n_leached(c) = som_n_leached(c) + decomp_npools_leached(c,l) - end do - end do - - - -end subroutine NSummary -!----------------------------------------------------------------------- - -!#endif - -end module CNSummaryMod 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 deleted file mode 100644 index 4ec666442..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNVegStructUpdateMod.F90 +++ /dev/null @@ -1,326 +0,0 @@ -module CNVegStructUpdateMod - -!#ifdef CN -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNVegStructUpdateMod -! -! !DESCRIPTION: -! Module for vegetation structure updates (LAI, SAI, htop, hbot) -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public :: CNVegStructUpdate -! -! !REVISION HISTORY: -! 4/23/2004: Created by Peter Thornton -! F. Li and S. Levis (11/06/12) -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNVegStructUpdate -! -! !INTERFACE: -subroutine CNVegStructUpdate(num_soilp, filter_soilp) -! -! !DESCRIPTION: -! On the radiation time step, use C state variables and epc to diagnose -! vegetation structure (LAI, SAI, height) -! -! !USES: - use clmtype - use pftvarcon , only: noveg, nc3crop, nc3crop2, nbrdlf_evr_shrub, nbrdlf_dcd_brl_shrub - use pftvarcon , only: ncorn, ncornirrig, npcropmin - use clm_varctl , only: iulog - use shr_const_mod, only: SHR_CONST_PI - use clm_time_manager , only : get_rad_step_size => get_step_size -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilp ! number of column soil points in pft filter - integer, intent(in) :: filter_soilp(:) ! pft filter for soil points -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 10/28/03: Created by Peter Thornton -! 2/29/08, David Lawrence: revised snow burial fraction for short vegetation -! -! !LOCAL VARIABLES: -! local pointers to implicit in scalars -! -#if (defined CNDV) - real(r8), pointer :: allom2(:) ! ecophys const - real(r8), pointer :: allom3(:) ! ecophys const - real(r8), pointer :: nind(:) ! number of individuals (#/m**2) - real(r8), pointer :: fpcgrid(:) ! fractional area of pft (pft area/nat veg area) -#endif - integer , pointer :: ivt(:) ! pft vegetation type - integer , pointer :: pcolumn(:) ! column index associated with each pft - integer , pointer :: pgridcell(:) ! pft's gridcell index - real(r8), pointer :: snow_depth(:) ! snow height (m) - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: woody(:) !binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: slatop(:) !specific leaf area at top of canopy, projected area basis [m^2/gC] - real(r8), pointer :: dsladlai(:) !dSLA/dLAI, projected area basis [m^2/gC] - real(r8), pointer :: z0mr(:) !ratio of momentum roughness length to canopy top height (-) - real(r8), pointer :: displar(:) !ratio of displacement height to canopy top height (-) - real(r8), pointer :: forc_hgt_u_pft(:) ! observational height of wind at pft-level [m] - real(r8), pointer :: dwood(:) ! density of wood (gC/m^3) - real(r8), pointer :: laimx(:) ! Maximum Leaf Area Index used in CNVegStructUpdate - real(r8), pointer :: ztopmx(:) ! Canopy top coefficient used in CNVegStructUpdate (m) - real(r8), pointer :: farea_burned(:) !F. Li and S. Levis -! -! local pointers to implicit in/out scalars -! - integer , pointer :: frac_veg_nosno_alb(:) ! frac of vegetation not covered by snow [-] - real(r8), pointer :: tlai(:) !one-sided leaf area index, no burying by snow - real(r8), pointer :: tsai(:) !one-sided stem area index, no burying by snow - real(r8), pointer :: htop(:) !canopy top (m) - real(r8), pointer :: hbot(:) !canopy bottom (m) - real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow - real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow - real(r8), pointer :: htmx(:) ! max hgt attained by a crop during yr (m) - integer , pointer :: peaklai(:) ! 1: max allowed lai; 0: not at max - integer , pointer :: harvdate(:) ! harvest date -! -! local pointers to implicit out scalars -! -! -! !OTHER LOCAL VARIABLES: - integer :: p,c,g !indices - integer :: fp !lake filter indices - real(r8):: taper ! ratio of height:radius_breast_height (tree allometry) - real(r8):: stocking ! #stems / ha (stocking density) - real(r8):: ol ! thickness of canopy layer covered by snow (m) - real(r8):: fb ! fraction of canopy layer covered by snow - real(r8) :: tlai_old ! for use in Zeng tsai formula - real(r8) :: tsai_old ! for use in Zeng tsai formula - real(r8) :: tsai_min ! PFT derived minimum tsai - real(r8) :: tsai_alpha ! monthly decay rate of tsai - real(r8) dt ! radiation time step (sec) - - real(r8), parameter :: dtsmonth = 2592000._r8 ! number of seconds in a 30 day month (60x60x24x30) -!EOP -!----------------------------------------------------------------------- -! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 -! -! tsai(p) = max( tsai_alpha(ivt(p))*tsai_old + max(tlai_old-tlai(p),0_r8), tsai_min(ivt(p)) ) -! notes: -! * RHS tsai & tlai are from previous timestep -! * should create tsai_alpha(ivt(p)) & tsai_min(ivt(p)) in pftvarcon.F90 - slevis -! * all non-crop pfts use same values: -! crop tsai_alpha,tsai_min = 0.0,0.1 -! noncrop tsai_alpha,tsai_min = 0.5,1.0 (includes bare soil and urban) -!------------------------------------------------------------------------------- - - ! assign local pointers to derived type arrays (in) -#if (defined CNDV) - allom2 => dgv_pftcon%allom2 - allom3 => dgv_pftcon%allom3 - nind => pdgvs%nind - fpcgrid => pdgvs%fpcgrid -#endif - ivt =>pft%itype - pcolumn =>pft%column - pgridcell =>pft%gridcell - leafc => pcs%leafc - deadstemc => pcs%deadstemc - snow_depth => cps%snow_depth - woody => pftcon%woody - slatop => pftcon%slatop - dsladlai => pftcon%dsladlai - z0mr => pftcon%z0mr - displar => pftcon%displar - dwood => pftcon%dwood - laimx => pftcon%laimx - ztopmx => pftcon%ztopmx - farea_burned => cps%farea_burned - - ! assign local pointers to derived type arrays (out) - tlai => pps%tlai - tsai => pps%tsai - htop => pps%htop - hbot => pps%hbot - elai => pps%elai - esai => pps%esai - frac_veg_nosno_alb => pps%frac_veg_nosno_alb - htmx => pps%htmx - peaklai => pps%peaklai - harvdate => pps%harvdate - forc_hgt_u_pft => pps%forc_hgt_u_pft - - dt = real( get_rad_step_size(), r8 ) - - ! constant allometric parameters - taper = 200._r8 - stocking = 1000._r8 - - ! convert from stems/ha -> stems/m^2 - stocking = stocking / 10000._r8 - - ! pft loop - do fp = 1,num_soilp - p = filter_soilp(fp) - c = pcolumn(p) - g = pgridcell(p) - - if (ivt(p) /= noveg) then - - tlai_old = tlai(p) ! n-1 value - tsai_old = tsai(p) ! n-1 value - - ! update the leaf area index based on leafC and SLA - ! Eq 3 from Thornton and Zimmerman, 2007, J Clim, 20, 3902-3923. - if (dsladlai(ivt(p)) > 0._r8) then - tlai(p) = (slatop(ivt(p))*(exp(leafc(p)*dsladlai(ivt(p))) - 1._r8))/dsladlai(ivt(p)) - else - tlai(p) = slatop(ivt(p)) * leafc(p) - end if - tlai(p) = max(0._r8, tlai(p)) - - ! update the stem area index and height based on LAI, stem mass, and veg type. - ! With the exception of htop for woody vegetation, this follows the DGVM logic. - - ! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 (see notes) - ! Assumes doalb time step .eq. CLM time step, SAI min and monthly decay factor - ! alpha are set by PFT, and alpha is scaled to CLM time step by multiplying by - ! dt and dividing by dtsmonth (seconds in average 30 day month) - ! tsai_min scaled by 0.5 to match MODIS satellite derived values - if (ivt(p) == nc3crop .or. ivt(p) == nc3crop2) 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) - - if (woody(ivt(p)) == 1._r8) then - - ! trees and shrubs - - ! if shrubs have a squat taper - if (ivt(p) >= nbrdlf_evr_shrub .and. ivt(p) <= nbrdlf_dcd_brl_shrub) then - taper = 10._r8 - ! otherwise have a tall taper - else - taper = 200._r8 - end if - - ! trees and shrubs for now have a very simple allometry, with hard-wired - ! stem taper (height:radius) and hard-wired stocking density (#individuals/area) -#if (defined CNDV) - if (fpcgrid(p) > 0._r8 .and. nind(p) > 0._r8) then - stocking = nind(p)/fpcgrid(p) !#ind/m2 nat veg area -> #ind/m2 pft area - htop(p) = allom2(ivt(p)) * ( (24._r8 * deadstemc(p) / & - (SHR_CONST_PI * stocking * dwood(ivt(p)) * taper))**(1._r8/3._r8) )**allom3(ivt(p)) ! lpj's htop w/ cn's stemdiam - else - htop(p) = 0._r8 - end if -#else - htop(p) = ((3._r8 * deadstemc(p) * taper * taper)/ & - (SHR_CONST_PI * stocking * dwood(ivt(p))))**(1._r8/3._r8) -#endif - - ! Peter Thornton, 5/3/2004 - ! Adding test to keep htop from getting too close to forcing height for windspeed - ! Also added for grass, below, although it is not likely to ever be an issue. - htop(p) = min(htop(p),(forc_hgt_u_pft(p)/(displar(ivt(p))+z0mr(ivt(p))))-3._r8) - - ! Peter Thornton, 8/11/2004 - ! Adding constraint to keep htop from going to 0.0. - ! This becomes an issue when fire mortality is pushing deadstemc - ! to 0.0. - htop(p) = max(htop(p), 0.01_r8) - - hbot(p) = max(0._r8, min(3._r8, htop(p)-1._r8)) - - else if (ivt(p) >= npcropmin) then ! prognostic crops - - if (tlai(p) >= laimx(ivt(p))) peaklai(p) = 1 ! used in CNAllocation - - if (ivt(p) == ncorn .or. ivt(p) == ncornirrig) 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_pft(p)/(displar(ivt(p))+z0mr(ivt(p))))-3._r8) - - ! Peter Thornton, 8/11/2004 - ! Adding constraint to keep htop from going to 0.0. - htop(p) = max(htop(p), 0.01_r8) - - hbot(p) = max(0.0_r8, min(0.05_r8, htop(p)-0.20_r8)) - end if - - else - tlai(p) = 0._r8 - tsai(p) = 0._r8 - htop(p) = 0._r8 - hbot(p) = 0._r8 - end if - - ! adjust lai and sai for burying by snow. - - ! snow burial fraction for short vegetation (e.g. grasses) as in - ! Wang and Zeng, 2007. - if (ivt(p) > noveg .and. ivt(p) <= nbrdlf_dcd_brl_shrub ) then - ol = min( max(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),0.2_r8),0._r8)/0.2_r8 ! 0.2m is assumed - !depth of snow required for complete burial of grasses - endif - - elai(p) = max(tlai(p)*fb, 0.0_r8) - esai(p) = max(tsai(p)*fb, 0.0_r8) - - ! Fraction of vegetation free of snow - if ((elai(p) + esai(p)) > 0._r8) then - frac_veg_nosno_alb(p) = 1 - else - frac_veg_nosno_alb(p) = 0 - end if - - end do - -end subroutine CNVegStructUpdate -!----------------------------------------------------------------------- -!#endif - -end module CNVegStructUpdateMod 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 deleted file mode 100644 index c1f98370a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNVerticalProfileMod.F90 +++ /dev/null @@ -1,317 +0,0 @@ -module CNVerticalProfileMod -!#ifdef CN -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNVerticalProfileMod -! -! !DESCRIPTION: -! Module holding routines for vertical discretization of C and N inputs into deocmposing pools -! - ! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use shr_const_mod, only: SHR_CONST_TKFRZ - use clm_varctl , only: iulog - use clm_varcon, only: dzsoi_decomp - - implicit none - save - private - ! !PUBLIC MEMBER FUNCTIONS: - public:: decomp_vertprofiles - -#ifdef VERTSOILC - logical, public :: exponential_rooting_profile = .true. - logical, public :: pftspecific_rootingprofile = .true. - real(r8), public :: rootprof_exp = 3. ! parameter for how steep the profile is for root C inputs (1/ e-folding depth) (1/m) - real(r8), public :: surfprof_exp = 10. ! parameter for how steep the profile is for surface components (1/ e_folding depth) (1/m) -#endif - -! -! !REVISION HISTORY: -! 6/27/2011 Created by C. Koven -! -!EOP -!----------------------------------------------------------------------- -contains - - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: decomp_vertprofiles -! -! !INTERFACE: - subroutine decomp_vertprofiles(lbp, ubp, lbc,ubc,num_soilc,filter_soilc,num_soilp,filter_soilp) -! -! !DESCRIPTION: -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use subgridAveMod, only: p2c - use clm_varcon, only: zsoi, dzsoi, zisoi - use clm_varpar, only: nlevdecomp, nlevgrnd, nlevdecomp_full, maxpatch_pft - use pftvarcon, only : noveg - - ! - ! !ARGUMENTS: - implicit none - integer, intent(in) :: lbp, ubp ! pft-index bounds - integer, intent(in) :: lbc, ubc ! column-index bounds - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns - integer, intent(in) :: num_soilp ! number of soil pfts in filter - integer, intent(in) :: filter_soilp(:) ! filter for soil pfts - ! - ! !CALLED FROM: - ! subroutine CNDecompAlloc in module CNDecompMod.F90 - ! - ! !REVISION HISTORY: - ! 10/5/2010: created by C. Koven to calculate vertical profiles for distributing soil and litter C and N - ! - ! !LOCAL VARIABLES: - ! local pointers to implicit in scalars - ! - ! column level - real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: nfixation_prof(:,:) ! (1/m) profile for N fixation additions - real(r8), pointer :: ndep_prof(:,:) ! (1/m) profile for N fixation additions - integer, pointer :: altmax_lastyear_indx(:) ! frost table depth (m) - integer , pointer :: npfts(:) ! number of pfts for each column - integer , pointer :: pfti(:) ! beginning pft index for each column - - ! pft level - integer , pointer :: ivt(:) ! pft vegetation type - real(r8), pointer :: rootfr(:,:) ! fraction of roots in each soil layer (nlevgrnd) - integer , pointer :: pcolumn(:) ! pft's column index - real(r8), pointer :: leaf_prof(:,:) ! (1/m) profile of leaves - real(r8), pointer :: froot_prof(:,:) ! (1/m) profile of fine roots - real(r8), pointer :: croot_prof(:,:) ! (1/m) profile of coarse roots - real(r8), pointer :: stem_prof(:,:) ! (1/m) profile of stems - real(r8), pointer :: wtcol(:) ! pft weight relative to column (0-1) - logical , pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details) - - ! local variables - real(r8) :: surface_prof(1:nlevdecomp) - real(r8) :: surface_prof_tot - real(r8) :: rootfr_tot - real(r8) :: cinput_rootfr(lbp:ubp, 1:nlevdecomp_full) ! pft-native root fraction used for calculating inputs - real(r8) :: col_cinput_rootfr(lbc:ubc, 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 - character(len=32) :: subname = 'decomp_vertprofiles' - - ! assign local pointers at the column level - nfixation_prof => cps%nfixation_prof - ndep_prof => cps%ndep_prof - altmax_lastyear_indx => cps%altmax_lastyear_indx - npfts =>col%npfts - pfti =>col%pfti - - ! assign local pointers at the pft level - ivt =>pft%itype - leaf_prof => pps%leaf_prof - froot_prof => pps%froot_prof - croot_prof => pps%croot_prof - stem_prof => pps%stem_prof - pcolumn =>pft%column - rootfr => pps%rootfr - wtcol =>pft%wtcol - pactive => pft%active - - -#ifdef VERTSOILC - ! 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) - end do - - ! initialize profiles to zero - leaf_prof(:,:) = 0._r8 - froot_prof(:,:) = 0._r8 - croot_prof(:,:) = 0._r8 - stem_prof(:,:) = 0._r8 - nfixation_prof(:,:) = 0._r8 - ndep_prof(:,:) = 0._r8 - - cinput_rootfr(:,:) = 0._r8 - col_cinput_rootfr(:,:) = 0._r8 - - if ( exponential_rooting_profile ) then - if ( .not. pftspecific_rootingprofile ) then - ! define rooting profile from exponential parameters - do j = 1, nlevdecomp - do fp = 1,num_soilp - p = filter_soilp(fp) - cinput_rootfr(p,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) - end do - end do - else - ! use beta distribution parameter from Jackson et al., 1996 - do p = lbp, ubp - c = pcolumn(p) - if (ivt(p) /= noveg) then - do j = 1, nlevdecomp - cinput_rootfr(p,j) = ( rootprof_beta(ivt(p)) ** (zisoi(j-1)*100._r8) - & - rootprof_beta(ivt(p)) ** (zisoi(j)*100._r8) ) & - / dzsoi_decomp(j) - end do - else - cinput_rootfr(p,1) = 1._r8 / dzsoi_decomp(1) - endif - end do - endif - else - do j = 1, nlevdecomp - ! use standard CLM root fraction profiles - do fp = 1,num_soilp - p = filter_soilp(fp) - cinput_rootfr(p,j) = rootfr(p,j) / dzsoi_decomp(j) - end do - end do - endif - - do fp = 1,num_soilp - p = filter_soilp(fp) - c = pcolumn(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) .gt. 0) .and. (rootfr_tot .gt. 0._r8) .and. (surface_prof_tot .gt. 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 - ! 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 (lbp, ubp, lbc, ubc, nlevdecomp_full, cinput_rootfr, col_cinput_rootfr, 'unity') - do pi = 1,maxpatch_pft - do fc = 1,num_soilc - c = filter_soilc(fc) - if (pi <= npfts(c)) then - p = pfti(c) + pi - 1 - if (pactive(p)) then - do j = 1,nlevdecomp - col_cinput_rootfr(c,j) = col_cinput_rootfr(c,j) + cinput_rootfr(p,j) * wtcol(p) - end do - end if - 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) .gt. 0) .and. (rootfr_tot .gt. 0._r8) .and. (surface_prof_tot .gt. 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(:,:) = 1._r8 - froot_prof(:,:) = 1._r8 - croot_prof(:,:) = 1._r8 - stem_prof(:,:) = 1._r8 - nfixation_prof(:,:) = 1._r8 - ndep_prof(:,:) = 1._r8 - -#endif - - - ! 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) .gt. delta ) .or. ( abs(nfixation_prof_sum - 1._r8) .gt. 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): ', npfts(c) - do p = pfti(c), pfti(c) + npfts(c) -1 - write(iulog, *) 'p, ivt(p), wtcol(p): ', p, ivt(p), wtcol(p) - write(iulog, *) 'cinput_rootfr(p,:): ', cinput_rootfr(p,:) - end do - stop 'decomp_vertprofiles ERROR: _prof_sum-1>delta' - 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) .gt. delta ) .or. ( abs(croot_prof_sum - 1._r8) .gt. delta ) .or. & - ( abs(stem_prof_sum - 1._r8) .gt. delta ) .or. ( abs(leaf_prof_sum - 1._r8) .gt. delta ) ) then - write(iulog, *) 'profile sums: ', froot_prof_sum, croot_prof_sum, leaf_prof_sum, stem_prof_sum - stop 'decomp_vertprofiles ERROR: sum-1 > delta' - endif - end do - - - end subroutine decomp_vertprofiles - - -!#endif - -end module CNVerticalProfileMod 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 deleted file mode 100644 index 9ab3584f5..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNWoodProductsMod.F90 +++ /dev/null @@ -1,164 +0,0 @@ -module CNWoodProductsMod -!#ifdef CN - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CNWoodProductsMod -! -! !DESCRIPTION: -! Calculate loss fluxes from wood products pools, and update product pool state variables -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - implicit none - save - private -! !PUBLIC MEMBER FUNCTIONS: - public:: CNWoodProducts -! -! !REVISION HISTORY: -! 5/20/2009: Created by Peter Thornton -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNWoodProducts -! -! !INTERFACE: -subroutine CNWoodProducts(num_soilc, filter_soilc) -! -! !DESCRIPTION: -! Update all loss fluxes from wood product pools, and update product pool state variables -! for both loss and gain terms. Gain terms are calculated in pftdyn_cnbal() for gains associated -! with changes in landcover, and in CNHarvest(), for gains associated with wood harvest. -! -! !USES: - use clmtype - use clm_time_manager, only: get_step_size - use clm_varctl, only: use_c13, use_c14 -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: num_soilc ! number of soil columns in filter - integer, intent(in) :: filter_soilc(:) ! filter for soil columns -! -! !CALLED FROM: -! subroutine CNEcosystemDyn -! -! !REVISION HISTORY: -! 5/21/09: Created by Peter Thornton -! -! !LOCAL VARIABLES: - - integer :: fc ! lake filter indices - integer :: c ! indices - real(r8):: dt ! time step (seconds) - real(r8) :: kprod10 ! decay constant for 10-year product pool - real(r8) :: kprod100 ! decay constant for 100-year product pool - -!EOP -!----------------------------------------------------------------------- - - - ! calculate column-level losses from product pools - ! the following (1/s) rate constants result in ~90% loss of initial state over 10 and 100 years, - ! respectively, using a discrete-time fractional decay algorithm. - kprod10 = 7.2e-9 - kprod100 = 7.2e-10 - - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! calculate fluxes (1/sec) - ccf%prod10c_loss(c) = ccs%prod10c(c) * kprod10 - ccf%prod100c_loss(c) = ccs%prod100c(c) * kprod100 - -! if ( use_c13 ) then -! cc13f%prod10c_loss(c) = cc13s%prod10c(c) * kprod10 -! cc13f%prod100c_loss(c) = cc13s%prod100c(c) * kprod100 -! endif -! -! if ( use_c14 ) then -! cc14f%prod10c_loss(c) = cc14s%prod10c(c) * kprod10 -! cc14f%prod100c_loss(c) = cc14s%prod100c(c) * kprod100 -! endif - - cnf%prod10n_loss(c) = cns%prod10n(c) * kprod10 - cnf%prod100n_loss(c) = cns%prod100n(c) * kprod100 - end do - - ! set time steps - dt = real( get_step_size(), r8 ) - - ! update wood product state variables - ! column loop - do fc = 1,num_soilc - c = filter_soilc(fc) - - ! column-level fluxes - - ! fluxes into wood product pools, from landcover change - ccs%prod10c(c) = ccs%prod10c(c) + ccf%dwt_prod10c_gain(c)*dt - ccs%prod100c(c) = ccs%prod100c(c) + ccf%dwt_prod100c_gain(c)*dt - -! if ( use_c13 ) then -! cc13s%prod10c(c) = cc13s%prod10c(c) + cc13f%dwt_prod10c_gain(c)*dt -! cc13s%prod100c(c) = cc13s%prod100c(c) + cc13f%dwt_prod100c_gain(c)*dt -! endif - -! if ( use_c14 ) then -! cc14s%prod10c(c) = cc14s%prod10c(c) + cc14f%dwt_prod10c_gain(c)*dt -! cc14s%prod100c(c) = cc14s%prod100c(c) + cc14f%dwt_prod100c_gain(c)*dt -! endif - - cns%prod10n(c) = cns%prod10n(c) + cnf%dwt_prod10n_gain(c)*dt - cns%prod100n(c) = cns%prod100n(c) + cnf%dwt_prod100n_gain(c)*dt - - ! fluxes into wood product pools, from harvest - ccs%prod10c(c) = ccs%prod10c(c) + ccf%hrv_deadstemc_to_prod10c(c)*dt - ccs%prod100c(c) = ccs%prod100c(c) + ccf%hrv_deadstemc_to_prod100c(c)*dt - -! if ( use_c13 ) then -! cc13s%prod10c(c) = cc13s%prod10c(c) + cc13f%hrv_deadstemc_to_prod10c(c)*dt -! cc13s%prod100c(c) = cc13s%prod100c(c) + cc13f%hrv_deadstemc_to_prod100c(c)*dt -! endif - -! if ( use_c14 ) then -! cc14s%prod10c(c) = cc14s%prod10c(c) + cc14f%hrv_deadstemc_to_prod10c(c)*dt -! cc14s%prod100c(c) = cc14s%prod100c(c) + cc14f%hrv_deadstemc_to_prod100c(c)*dt -! endif - - cns%prod10n(c) = cns%prod10n(c) + cnf%hrv_deadstemn_to_prod10n(c)*dt - cns%prod100n(c) = cns%prod100n(c) + cnf%hrv_deadstemn_to_prod100n(c)*dt - - ! fluxes out of wood product pools, from decomposition - ccs%prod10c(c) = ccs%prod10c(c) - ccf%prod10c_loss(c)*dt - ccs%prod100c(c) = ccs%prod100c(c) - ccf%prod100c_loss(c)*dt - -! if ( use_c13 ) then -! cc13s%prod10c(c) = cc13s%prod10c(c) - cc13f%prod10c_loss(c)*dt -! cc13s%prod100c(c) = cc13s%prod100c(c) - cc13f%prod100c_loss(c)*dt -! endif - -! if ( use_c14 ) then -! cc14s%prod10c(c) = cc14s%prod10c(c) - cc14f%prod10c_loss(c)*dt -! cc14s%prod100c(c) = cc14s%prod100c(c) - cc14f%prod100c_loss(c)*dt -! endif - - cns%prod10n(c) = cns%prod10n(c) - cnf%prod10n_loss(c)*dt - cns%prod100n(c) = cns%prod100n(c) - cnf%prod100n_loss(c)*dt - - end do ! end of column loop - -end subroutine CNWoodProducts -!----------------------------------------------------------------------- - -!#endif - -end module CNWoodProductsMod 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 deleted file mode 100644 index a9769a60f..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CN_DriverMod.F90 +++ /dev/null @@ -1,1672 +0,0 @@ -module CN_DriverMod - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: CN_Driver -! -! !DESCRIPTION: -! Driver for CN model. Interface between GEOS5 and CLM4 data structures -! -! !USES: - use clmtype - use clmtypeInitMod - use CNEcosystemDynMod - use nanMod - use clm_varcon, only: grav, denh2o - use clm_varcon, only: clm_varcon_init - use clm_varpar, only: clm_varpar_init, numpft - use CNSetValueMod, only: CNZeroFluxes_dwt - use CNAnnualUpdateMod, only: CNAnnualUpdate - use CNBalanceCheckMod, only: BeginCBalance, BeginNBalance, & - CBalanceCheck, NBalanceCheck - use pftvarcon, only: noveg - use clm_time_manager, only: get_step_size, get_nstep, get_curr_date - use shr_const_mod, only: SHR_CONST_TKFRZ, SHR_CONST_CDAY - use pftvarcon, only: npcropmin, ntree, nbrdlf_dcd_trp_tree -#ifndef CENTURY_DECOMP - use CNDecompCascadeMod_BGC, only : init_decompcascade -#else - use CNDecompCascadeMod_CENTURY, only : init_decompcascade -#endif - use catch_constants, only: DZTSURF=>CATCH_DZTSURF, DZGT=>CATCH_DZGT - use SurfParams, only: LAND_FIX -! use update_model_para4cn, only : LocalTileID, upd_tileid ! useful for debugging - - implicit none - private - -! local variables to the whole module - -! !PUBLIC MEMBER FUNCTIONS: - public :: CN_Driver - public :: CN_init - public :: CN_exit - public :: get_CN_LAI -! -! !REVISION HISTORY: -! 2011-2015: Created by Greg Walker NASA/GSFC GMAO -! -!EOP -!----------------------------------------------------------------------- - -contains - - subroutine CN_Driver(istep,nch,nveg,nzone,daylength, & - tgw,tp1,tp2,tp3,tp4,tp5,tp6,sfm,rzm, & - wpwet,psis,bee,poros,vgwmax,bflow,totwat, & - runsrf,tm,rhm,windm,rainfm,snowfm, & - prec10d,prec60d,t10d, & - psun,psha,lmrsunm,lmrsham,lsun,lsha, & - car1m,btran2x_rz,btran2x_sf,latitude,longitude, & - ityp,fveg,wtzone,sndzn,asnow,ndep,abm,peatf, & - gdp,hdm,field_cap,lnfm,zlai,zsai,ztai,colc,tile_id, & - ann_t2m,nppg,gppg,srg,neeg,root,padd,vegc,xsmr, & - burn,closs,nfire,som_closs, & - 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 - - integer*8, intent(in) :: istep ! number of CN time steps run - integer, intent(in) :: nch ! number of tiles - integer, intent(in) :: nveg ! number of vegetation types per zone - integer, intent(in) :: nzone ! number of stress zones per tile - real*4, dimension(nch), intent(in) :: daylength ! daylength (seconds) - real*4, dimension(nch,nzone), intent(in) :: tgw ! soil surface layer temperature (K) - real*4, dimension(nch,nzone), intent(in) :: rzm ! weighted root-zone moisture content as frac of WHC - real*4, dimension(nch,nzone), intent(in) :: sfm ! weighted surface moisture content as frac of WHC - real*4, dimension(nch), intent(in) :: tp1,tp2,tp3,tp4,tp5,tp6 ! soil temperatures (K) - real*4, dimension(nch), intent(in) :: wpwet,psis,bee,poros,vgwmax,bflow,totwat ! soil water & parameters - real*4, dimension(nch), intent(in) :: tm ! air temperature (K) - real*4, dimension(nch), intent(in) :: rhm ! relative humidity (%) - real*4, dimension(nch), intent(in) :: windm ! wind speed (m/s) - real*4, dimension(nch), intent(in) :: rainfm ! rainfall (convective + largescale) (kg/m2/s) - real*4, dimension(nch), intent(in) :: snowfm ! snowfall (kg/m2/s) - real*4, dimension(nch), intent(in) :: prec10d ! 10-day running mean of total precipitation (mm H2O/s) - real*4, dimension(nch), intent(in) :: prec60d ! 60-day running mean of total precipitation (mm H2O/s) - real*4, dimension(nch), intent(in) :: t10d ! 10-day running mean of 2-m temperature (K) - real*4, dimension(nch), intent(in) :: runsrf ! surface runoff (kg/m2/s) - real*4, dimension(nch), intent(in) :: ndep ! nitrogen deposition - real*4, dimension(nch), intent(in) :: abm ! Peak month for agricultural fire, unitless - real*4, dimension(nch), intent(in) :: peatf ! Fraction of peatland, unitless (0-1) - real*4, dimension(nch), intent(in) :: gdp ! Real GDP (K 1995US$/capita) - real*4, dimension(nch), intent(in) :: hdm ! Human population density in 2010 (individual/km2) - real*4, dimension(nch), intent(in) :: field_cap ! Field capacity (m3/m3) - real*4, dimension(nch), intent(in) :: lnfm ! Lightning frequency [Flashes/km^2/day] - real*4, dimension(nch), intent(in) :: sndzn ! snow height of snow covered area (m) - real*4, dimension(nch), intent(in) :: asnow ! areal snow coverage [0-1] - real*4, dimension(nch), intent(in) :: car1m ! fraction of tile that is saturated area - real*4, dimension(nch,nzone), intent(in) :: btran2x_rz ! root zone soil wetness, used to calculate btran2 for CNFireMod - real*4, dimension(nch,nzone), intent(in) :: btran2x_sf ! surface soil wetness, used to calculate btran2 for CNFireMod - real*4, dimension(nch), intent(in) :: latitude ! center-of-mass latitude (degree) - real*4, dimension(nch), intent(in) :: longitude ! center-of-mass longitude (degree) - integer, dimension(nch,nveg,nzone), intent(in) :: ityp ! CLM PFT index - real, dimension(nch,nveg,nzone), intent(in) :: fveg ! catchment vegetation fractions - real, dimension(nch,nzone), intent(in) :: wtzone ! zone fractions - real*4, dimension(nch,nveg,nzone), intent(in) :: psha,psun ! photosynthesis - real*4, dimension(nch,nveg,nzone), intent(in) :: lmrsunm,lmrsham ! leaf maintenance respiration rate (umol CO2/m**2/s) - real*4, dimension(nch,nveg,nzone), intent(in) :: lsha,lsun ! LAI - integer, dimension(nch), intent(in) :: tile_id ! tile index for debugging - real*4, dimension(nch), intent(in) :: ann_t2m ! gkw: annual mean CONUS T 2m to override CN - - real*4, dimension(nch,nveg,nzone), intent(inout) :: zlai ! leaf-area index for tile (subject to burying by snow) - real*4, dimension(nch,nveg,nzone), intent(inout) :: zsai ! stem-area index for tile - real*4, dimension(nch,nveg,nzone), intent(inout) :: ztai ! leaf-area index for tile (not buried by snow) - real*4, dimension(nch,nzone), intent(out) :: colc ! column total carbon - -! PFT carbon fluxes averaged to tile - real*4, dimension(nch), intent(out) :: nppg ! (gC/m2/s) net primary production [PFT] - real*4, dimension(nch), intent(out) :: gppg ! (gC/m2/s) gross primary production [PFT] - -! column carbon fluxes averaged to tile - real*4, dimension(nch), intent(out) :: srg ! (gC/m2/s) total soil respiration (HR + root resp) [column] - real*4, 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] - -! fire diagnostics - real*4, dimension(nch), intent(out) :: burn, closs, nfire, som_closs - -! column & PFT level carbon added to sustain growth -! ------------------------------------------------- - real*4, dimension(nch), intent(out) :: padd ! (gC/m2/s) - real*4, dimension(nch), intent(out) :: root, vegc, xsmr ! (gC/m2) - -! states and fluxes to understand nitrogen cycle, fzeng, 4 April 2019 - real*4, dimension(nch), intent(out) :: ndeployg ! total N deployed to growth and storage (gN/m2/s) - real*4, dimension(nch), intent(out) :: denitg ! total rate of denitrification (gN/m2/s) - real*4, dimension(nch), intent(out) :: sminn_leachedg ! soil mineral N pool loss to leaching (gN/m2/s) - real*4, dimension(nch), intent(out) :: sminng ! (gN/m2) soil mineral N - real*4, dimension(nch), intent(out) :: col_fire_nlossg ! (gN/m2/s) total column-level fire N loss - real*4, dimension(nch), intent(out) :: leafng ! (gN/m2) leaf N - real*4, dimension(nch), intent(out) :: leafcg ! (gC/m2) leaf C - real*4, dimension(nch), intent(out) :: gross_nming ! gross rate of N mineralization (gN/m2/s) - real*4, dimension(nch), intent(out) :: net_nming ! vert-int (diagnostic) net rate of N mineralization (gN/m2/s) - real*4, dimension(nch), intent(out) :: nfix_to_sminng ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) - real*4, dimension(nch), intent(out) :: actual_immobg ! vert-int (diagnostic) actual N immobilization (gN/m2/s) - real*4, dimension(nch), intent(out) :: fpgg ! fraction of potential gpp (no units) - real*4, dimension(nch), intent(out) :: fpig ! fraction of potential immobilization (no units) - real*4, dimension(nch), intent(out) :: sminn_to_plantg ! vert-int (diagnostic) plant uptake of soil mineral N (gN/m2/s) - real*4, dimension(nch), intent(out) :: sminn_to_npoolg ! deployment of soil mineral N uptake (gN/m2/s) - real*4, dimension(nch), intent(out) :: ndep_to_sminng ! atmospheric N deposition to soil mineral N (gN/m2/s) - real*4, dimension(nch), intent(out) :: totvegng ! (gN/m2) total vegetation nitrogen - real*4, dimension(nch), intent(out) :: totlitng ! (gN/m2) total litter nitrogen - real*4, dimension(nch), intent(out) :: totsomng ! (gN/m2) total soil organic matter nitrogen - real*4, dimension(nch), intent(out) :: retransng ! (gN/m2) plant pool of retranslocated N - real*4, dimension(nch), intent(out) :: retransn_to_npoolg ! deployment of retranslocated N (gN/m2/s) - -! states and fluxes to understand the fire model, fzeng, 30 July 2019 - real*4, dimension(nch), intent(out) :: fuelcg ! fuel avalability for non-crop areas outside tropical closed broadleaf evergreen closed forests (gC/m2) - real*4, dimension(nch), intent(out) :: totlitcg ! (gC/m2) total litter carbon - real*4, dimension(nch), intent(out) :: cwdcg ! (gC/m2) coarse woody debris C - real*4, dimension(nch), intent(out) :: rootcg ! (gC/m2) total root carbon - - integer :: lbg, ubg ! grid bounds - integer :: lbl, ubl ! land-type bounds - integer :: lbc, ubc ! column bounds - integer :: lbp, ubp ! pft bounds - integer :: num_soilc ! number of soil columns in filter - integer :: num_soilp ! number of soil pfts in filter - integer :: num_pcropp ! number of prog. crop pfts in filter - - ! added from /discover/nobackup/fzeng/clm_orig/cesm1_2_2/models/lnd/clm/src/util_share/decompMod.F90, fzeng, 29 Mar 2017 - integer :: numg ! total number of gridcells on all procs - integer :: numl ! total number of landunits on all procs - integer :: numc ! total number of columns on all procs - integer :: nump ! total number of pfts on all procs - - logical, save :: doalb = .true. ! assume surface albedo calculation time step - logical, save :: spin = .false. ! true if spinup vegetation gkw: critical! - logical, save :: exit_spin = .false. ! true if this is first continuation from a spin=true run - - logical, save :: first = .true. - integer, parameter :: npft = numpft+1 - integer :: n, c, p, pft_num, idum, pf, i, j, nv, nc, nz, z, icn - real :: bare, leafc_tot - integer :: itypveg ! vegetation type - - integer, allocatable, save :: filter_soilc(:),filter_soilp(:),filter_pcropp(:) - integer, allocatable, save :: index_soilp(:),zone_soilp(:),zone_soilc(:) - real, allocatable, save :: leafc_add(:) - - integer, allocatable, save :: tileid_soilp(:) ! fzeng added for debugging - - real :: dt ! time step delta t (seconds) - integer*8 :: nstep_cn ! number of CN model steps run - integer :: curr_year, curr_mon, curr_day, curr_tod ! year, month, day, time of day (seconds past 0z) of the current CN time step - - logical, pointer :: ifspecial(:) !BOOL: true=>landunit is not vegetated - integer, pointer :: clandunit(:) !index into landunit level quantities - integer, pointer :: cgridcell(:) !index into gridcell level quantities - integer, pointer :: npfts(:) !number of pfts for each column - integer, pointer :: pfti(:) !beginning pft index for each column - integer, pointer :: pftf(:) !ending pft index for each column - integer, pointer :: pitype(:) !pft vegetation - integer, pointer :: pcolumn(:) !column type - integer, pointer :: plandunit(:) !index into landunit level quantities - integer, pointer :: pgridcell(:) !index into gridcell level quantities - real, pointer :: pwtcol(:) !weight (relative to column) - real, pointer :: pwtgcell(:) !weight (relative to gridcell) - real, pointer :: cwtgcell(:) !weight of columns relative to gridcells - - real, pointer :: t_ref2m(:) !2 m height surface air temperature (Kelvin) - real, pointer :: psnsun(:) !sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real, pointer :: psnsha(:) !shaded leaf photosynthesis (umol CO2 /m**2/ s) - real, pointer :: laisun(:) !sunlit projected leaf area index - real, pointer :: laisha(:) !shaded projected leaf area index - real, pointer :: forc_ndep(:) !nitrogen deposition rate (gN/m2/s) - real, pointer :: forc_t(:) !air temperature (K) - real, pointer :: forc_rh(:) !relative humidity (%) - real, pointer :: forc_wind(:) !wind speed (m/s) - real, pointer :: forc_rain(:) !rainfall (convective + largescale) (mm/s) - real, pointer :: forc_snow(:) !snowfall (mm/s) - real, pointer :: t_soisno(:,:) !soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) - real, pointer :: rootfr(:,:) !fraction of roots in each soil layer (nlevgrnd) - real, pointer :: dz(:,:) !layer thickness (m) (-nlevsno+1:nlevgrnd) - real, pointer :: psisat(:,:) !soil water potential at saturation for CN code (MPa) - real, pointer :: psiwilt(:) !root-zone soil water potential at wilting point (MPa) - real, pointer :: soilpsi(:,:) !soil water potential in each soil layer (MPa) - real, pointer :: h2osoi_liq(:,:) !column liquid water (kg/m2) (new) - real, pointer :: wf(:) !soil water as frac. of whc for top 0.05 m - real, pointer :: wf2(:) !soil water as frac. of whc for top 0.17 m - real, pointer :: qflx_drain(:) !sub-surface runoff (mm H2O /s) - real, pointer :: qflx_surf(:) !surface runoff (mm H2O /s) - real, pointer :: t_grnd(:) !ground temperature (Kelvin) - real, pointer :: forc_hgt_u_pft(:) !wind forcing height (10m+z0m+d) (m) - real, pointer :: dayl(:) !daylength (seconds) - real, pointer :: prev_dayl(:) !daylength from previous albedo timestep (seconds) - real, pointer :: elai(:) !one-sided leaf area index with burying by snow - real, pointer :: esai(:) !one-sided stem area index with burying by snow - real, pointer :: tlai(:) !one-sided leaf area index, no burying by snow - real, pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool - real, pointer :: annavg_t2m(:) ! annual average 2m air temperature (K) - integer, pointer :: frac_veg_nosno(:) ! fraction of vegetation not covered by snow (0 OR 1) [-] - - real, pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation - real, pointer :: totlitc(:) ! (gC/m2) total litter carbon - real, pointer :: totsomc(:) ! (gC/m2) total soil organic matter carbon - real, pointer :: leafc(:) - real, pointer :: leafc_storage(:) - real, pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real, pointer :: frootc(:) ! (gC/m2) fine root C - real, pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real, pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real, pointer :: livestemc(:) ! (gC/m2) live stem C - real, pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real, pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real, pointer :: deadstemc(:) ! (gC/m2) dead stem C - real, pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real, pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real, pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real, pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real, pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real, pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real, pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real, pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real, pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real, pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real, pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool - real, pointer :: xsmrpool(:) ! (gC/m2) abstract C pool to meet excess MR demand - real, pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation - real, pointer :: totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool - real, pointer :: cwdn(:) ! (gN/m2) coarse woody debris N - real, pointer :: litr1n(:) ! (gN/m2) litter labile N - real, pointer :: litr2n(:) ! (gN/m2) litter cellulose N - real, pointer :: litr3n(:) ! (gN/m2) litter lignin N - real, pointer :: soil1n(:) ! (gN/m2) soil organic matter N (fast pool) - real, pointer :: soil2n(:) ! (gN/m2) soil organic matter N (medium pool) - real, pointer :: soil3n(:) ! (gN/m2) soil orgainc matter N (slow pool) - real, pointer :: soil4n(:) ! (gN/m2) soil orgainc matter N (slowest pool) - real, pointer :: sminn_vr(:,:) ! (gN/m2) soil mineral N - real, pointer :: leafn(:) ! (gN/m2) leaf N - real, pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real, pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real, pointer :: frootn(:) ! (gN/m2) fine root N - real, pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real, pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real, pointer :: livestemn(:) ! (gN/m2) live stem N - real, pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real, pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real, pointer :: deadstemn(:) ! (gN/m2) dead stem N - real, pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real, pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real, pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real, pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real, pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real, pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real, pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real, pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real, pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N - real, pointer :: npool(:) ! (gN/m2) temporary plant N pool - real, pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation - real, pointer :: col_ntrunc(:) ! (gN/m2) column-level sink for N truncation - real, pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg - real, pointer :: seedc(:) ! (gC/m2) column-level pool for seeding new PFTs - real, pointer :: prod10c(:) ! (gC/m2) wood product C pool, 10-year lifespan - real, pointer :: prod100c(:) ! (gC/m2) wood product C pool, 100-year lifespan - real, pointer :: seedn(:) ! (gN/m2) column-level pool for seeding new PFTs - real, pointer :: prod10n(:) ! (gN/m2) wood product N pool, 10-year lifespan - real, pointer :: prod100n(:) ! (gN/m2) wood product N pool, 100-year lifespan - real, pointer :: gpp(:) ! (gC/m2/s) gross primary production - real, pointer :: npp(:) ! (gC/m2/s) net primary production - real, pointer :: sr(:) ! (gC/m2/s) total soil respiration (HR + root resp) - real, pointer :: nee(:) ! (gC/m2/s) net ecosystem exchange of carbon, includes fire, landuse, harvest, and hrv_xsmrpool flux, positive for source - real, pointer :: farea_burned(:) ! fractional area burned (proportion/s) - real, pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss - real, pointer :: col_nfire(:) ! (count/km2/s) column-level fire counts, valid only in Reg. C - real, pointer :: col_somc_fire(:) ! (gC/m2/s) column-level carbon emissions due to peat burning - -! grid-level - real, pointer :: latdeg(:) ! latitude (degrees) - real, pointer :: londeg(:) ! longitude (degrees) - real, pointer :: forc_hdm(:) ! Human population density (individual/km2) - real, pointer :: forc_lnfm(:) ! Lightning frequency [Flashes/km^2/day] - -! column level (need to organize the ones above here) - real, pointer :: fsat(:) ! fractional area with water table at surface - real, pointer :: tsoi17(:) ! soil temperature in top 17cm of soil (Kelvin) - real, pointer :: sucsat(:,:) ! minimum soil suction (mm) - real, pointer :: bd(:,:) ! bulk density of dry soil material [kg/m^3] - real, pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity) (nlevgrnd) - real, pointer :: bsw(:,:) ! Clapp and Hornberger "b" (nlevgrnd) - integer, pointer :: abm_lf(:) ! global peak month of crop fire emissions - real, pointer :: peatf_lf(:) ! global peatland fraction data (0-1) - real, pointer :: gdp_lf(:) ! global real gdp data (k US$/capita) - real, pointer :: watfc(:,:) ! volumetric soil water at field capacity (nlevsoi) - real, pointer :: snow_depth(:) ! column averaged snow height (m). fzeng: use column averaged snow height instead of snow height of snow covered area as in the original CLM4.5 to avoid sharp drop of LAI due to light snow - -! pft level (need to organize the ones above here) - real, pointer :: btran2(:) - real, pointer :: prec10(:) ! 10-day running mean of tot. precipitation - real, pointer :: prec60(:) ! 60-day running mean of tot. precipitation - real, pointer :: t10(:) ! 10-day running mean of 2-m temperature (K) - real, pointer :: lmrsun(:) ! sunlit leaf maintenance respiration rate (umol CO2/m**2/s) - real, pointer :: lmrsha(:) ! shaded leaf maintenance respiration rate (umol CO2/m**2/s) - logical, pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details), fzeng adopted a modified/simpler way to set pactive here - -! PFT parameters - real, pointer :: mxtmp(:) ! Max Temperature, parameter used in accFlds (degree C) - real, pointer :: baset(:) ! Base Temperature, parameter used in accFlds (degree C) - -! states and fluxes to understand nitrogen cycle, fzeng, 4 April 2019 - real, pointer :: ndeploy(:) ! total N deployed to growth and storage (gN/m2/s) - real, pointer :: denit(:) ! total rate of denitrification (gN/m2/s) - real, pointer :: sminn_leached(:) ! soil mineral N pool loss to leaching (gN/m2/s) - real, pointer :: sminn(:) ! (gN/m2) soil mineral N - real, pointer :: col_fire_nloss(:) ! (gN/m2/s) total column-level fire N loss - real, pointer :: gross_nmin(:) ! gross rate of N mineralization (gN/m2/s) - real, pointer :: net_nmin(:) ! vert-int (diagnostic) net rate of N mineralization (gN/m2/s) - real, pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) - real, pointer :: actual_immob(:) ! vert-int (diagnostic) actual N immobilization (gN/m2/s) - real, pointer :: fpg(:) ! fraction of potential gpp (no units) - real, pointer :: fpi(:) ! fraction of potential immobilization (no units) - real, pointer :: sminn_to_plant(:) ! vert-int (diagnostic) plant uptake of soil mineral N (gN/m2/s) - real, pointer :: sminn_to_npool(:) ! deployment of soil mineral N uptake (gN/m2/s) - real, pointer :: ndep_to_sminn(:) ! atmospheric N deposition to soil mineral N (gN/m2/s) - real, pointer :: totvegn(:) ! (gN/m2) total vegetation nitrogen - real, pointer :: totlitn(:) ! (gN/m2) total litter nitrogen - real, pointer :: totsomn(:) ! (gN/m2) total soil organic matter nitrogen - real, pointer :: retransn_to_npool(:) ! deployment of retranslocated N (gN/m2/s) - -! states and fluxes to understand the fire model, fzeng, 30 July 2019 - real, pointer :: fuelc(:) ! fuel avalability for non-crop areas outside tropical closed broadleaf evergreen closed forests (gC/m2) - real, pointer :: cwdc(:) ! (gC/m2) coarse woody debris C - -! define size of grid, landunit, column, and PFT -! ---------------------------------------------- - lbg = 1 ; ubg = nch - lbl = 1 ; ubl = nch - lbc = 1 ; ubc = nch*nzone - lbp = 1 ; ubp = nch*nzone*npft ! potential PFT index (0-16); actual will be set in num_soilp filter - - ! fzeng, 29 Mar 2017, correct? should move to CN_init? - numg = ubg - numl = ubl - numc = ubc - nump = ubp - - if(first) then - allocate (filter_soilc(ubc-lbc+1)) - allocate (filter_soilp(ubp-lbp+1)) - allocate (filter_pcropp(ubp-lbp+1)) - allocate (index_soilp(ubp-lbp+1)) - allocate (leafc_add(ubp-lbp+1)) - allocate (zone_soilp(ubp-lbp+1)) - allocate (zone_soilc(ubc-lbc+1)) - - allocate (tileid_soilp(ubp-lbp+1)) ! fzeng added for debugging - - endif - -! assign local pointers to derived type members - -! grid level - latdeg => grc%latdeg - londeg => grc%londeg - forc_ndep => grc%forc_ndep - forc_rh => grc%forc_rh - forc_wind => grc%forc_wind - forc_t => grc%forc_t - forc_rain => grc%forc_rain - forc_snow => grc%forc_snow - forc_hdm => grc%forc_hdm - forc_lnfm => grc%forc_lnfm - -! land level - ifspecial => lun%ifspecial - -! column level - clandunit => col%landunit - npfts => col%npfts - cgridcell => col%gridcell - cwtgcell => col%wtgcell - pfti => col%pfti - pftf => col%pftf - t_soisno => ces%t_soisno - dz => cps%dz - psisat => cps%psisat - psiwilt => cps%psiwilt - soilpsi => cps%soilpsi - h2osoi_liq => cws%h2osoi_liq - qflx_drain => cwf%qflx_drain - qflx_surf => cwf%qflx_surf - snow_depth => cps%snow_depth - t_grnd => ces%t_grnd - wf => cps%wf - wf2 => cps%wf2 - fsat => cws%fsat - tsoi17 => ces%tsoi17 - sucsat => cps%sucsat - bd => cps%bd - watsat => cps%watsat - bsw => cps%bsw - abm_lf => cps%abm_lf - peatf_lf => cps%peatf_lf - gdp_lf => cps%gdp_lf - watfc => cps%watfc - totcolc => ccs%totcolc - col_ctrunc => ccs%col_ctrunc - totlitc => ccs%totlitc - totsomc => ccs%totsomc - sminn_vr => cns%sminn_vr - col_ntrunc => cns%col_ntrunc - totcoln => cns%totcoln - seedc => ccs%seedc - prod10c => ccs%prod10c - prod100c => ccs%prod100c - seedn => cns%seedn - prod10n => cns%prod10n - prod100n => cns%prod100n - -! pft level - btran2 => pps%btran2 - prec10 => pps%prec10 - prec60 => pps%prec60 - t10 => pes%t10 - pactive => pft%active - pitype => pft%itype - pcolumn => pft%column - pwtcol => pft%wtcol - t_ref2m => pes%t_ref2m - psnsha => pcf%psnsha - psnsun => pcf%psnsun - lmrsha => pcf%lmrsha - lmrsun => pcf%lmrsun - laisha => pps%laisha - laisun => pps%laisun - plandunit => pft%landunit - pgridcell => pft%gridcell - pwtgcell => pft%wtgcell - rootfr => pps%rootfr - forc_hgt_u_pft => pps%forc_hgt_u_pft - dayl => pepv%dayl - prev_dayl => pepv%prev_dayl - elai => pps%elai - esai => pps%esai - tlai => pps%tlai - annavg_t2m => pepv%annavg_t2m - leafc => pcs%leafc - leafc_storage => pcs%leafc_storage - leafc_xfer => pcs%leafc_xfer - frootc => pcs%frootc - frootc_storage => pcs%frootc_storage - frootc_xfer => pcs%frootc_xfer - livestemc => pcs%livestemc - livestemc_storage => pcs%livestemc_storage - livestemc_xfer => pcs%livestemc_xfer - deadstemc => pcs%deadstemc - deadstemc_storage => pcs%deadstemc_storage - deadstemc_xfer => pcs%deadstemc_xfer - livecrootc => pcs%livecrootc - livecrootc_storage => pcs%livecrootc_storage - livecrootc_xfer => pcs%livecrootc_xfer - deadcrootc => pcs%deadcrootc - deadcrootc_storage => pcs%deadcrootc_storage - deadcrootc_xfer => pcs%deadcrootc_xfer - gresp_storage => pcs%gresp_storage - gresp_xfer => pcs%gresp_xfer - cpool => pcs%cpool - xsmrpool => pcs%xsmrpool - pft_ctrunc => pcs%pft_ctrunc - totvegc => pcs%totvegc - frac_veg_nosno => pps%frac_veg_nosno - - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - retransn => pns%retransn - npool => pns%npool - pft_ntrunc => pns%pft_ntrunc - -! PFT parameters - mxtmp => pftcon%mxtmp - baset => pftcon%baset - -! states and fluxes to understand nitrogen cycle, fzeng, 4 April 2019 - ndeploy => pnf%ndeploy - denit => cnf%denit - sminn_leached => cnf%sminn_leached - sminn => cns%sminn - col_fire_nloss => cnf%col_fire_nloss - leafn => pns%leafn - leafc => pcs%leafc - gross_nmin => cnf%gross_nmin - net_nmin => cnf%net_nmin - nfix_to_sminn => cnf%nfix_to_sminn - actual_immob => cnf%actual_immob - fpg => cps%fpg - fpi => cps%fpi - sminn_to_plant => cnf%sminn_to_plant - sminn_to_npool => pnf%sminn_to_npool - ndep_to_sminn => cnf%ndep_to_sminn - totvegn => pns%totvegn - totlitn => cns%totlitn - totsomn => cns%totsomn - retransn_to_npool => pnf%retransn_to_npool - -! states and fluxes to understand the fire model, fzeng, 30 July 2019 - fuelc => ccs%fuelc - cwdc => ccs%cwdc - -! define landunit & column settings -! --------------------------------- -! litype(:) = 1 ! all land-units are soil - ifspecial(:) = .false. ! no special land-units; all are soil - -! citype(:) = 1 ! all columns are soil (vegetated or bare) - clandunit(:) = 1 ! all landunits are soil - plandunit(:) = 1 ! all landunits are soil - npfts(:) = npft ! max number of PFTs per column - - num_soilc = nch*nzone ! number of columns = number of catchments*zones - -! map vegetation types into closest PFT & map PFT into column; assign PFT weight & filter -! --------------------------------------------------------------------------------------- - num_soilp = 0 ! initialize PFT filter - num_pcropp = 0 ! initialize crop PFT filter - filter_soilp(:) = 0 ! set PFT index to invalid number - filter_pcropp(:) = 0 ! set prognostic crop PFT index to invalid number - index_soilp(:) = 0 ! set veg index to invalid number - zone_soilp(:) = 0 ! set zone index to invalid number - - latdeg = latitude - londeg = longitude - - dt = real( get_step_size() ) - - ! Following CLM4.5's CNiniSpecial.F90 - frac_veg_nosno = 0 - -! loop over catchment tiles [columns] -! ----------------------------------- - n = 0 - - do nc = 1,nch - -! loop over zones -! --------------- - do nz = 1,nzone - - n = n + 1 - - filter_soilc(n) = n ! 1:1 mapping catchment to column - zone_soilc(n) = nz ! for remapping column to tile - cgridcell(n) = nc ! catchment - pfti(n) = npft*(n-1) + 1 ! starting PFT index - pftf(n) = npft*n ! ending PFT index - cwtgcell(n) = wtzone(nc,nz) ! weight of columns relative to gridcells - -! set column soil properties -! -------------------------- - dz(n,1) = 1.00 ! hydrologically active soil layer thickness (m) - psisat(n,1) = 1.e-6*psis(nc)*grav*denh2o ! saturated soil water potential m -> Mpa - sucsat(n,1) = psis(nc) * 1e3 * (-1) ! minimum soil suction (mm), psis is in (m) - soilpsi(n,1) = 1.e-6*psis(nc)*grav*denh2o*rzm(nc,nz)**(-bee(nc)) - psiwilt(n) = 1.e-6*psis(nc)*grav*denh2o*wpwet(nc)**(-bee(nc)) ! root-zone wilting soil water potential (Mpa) - bd(n,1) = (1.-poros(nc))*2.7e3 ! see iniTimeConst.F90 in CLM4.5 - watsat(n,1) = poros(nc) - bsw(n,1) = bee(nc) - watfc(n,1) = field_cap(nc) - -! soil liquid water -! ------------------ - h2osoi_liq(n,1) = totwat(nc) ! soil liquid water, kg/m2 - qflx_drain(n) = bflow(nc) ! sub-surface runoff (mm H2O /s); used for soil nitrogen leaching - qflx_surf(n) = runsrf(nc) ! surface runoff (mm H2O /s); used for soil nitrogen leaching - wf(n) = sfm(nc,nz) ! soil water as frac of WHC for top 5cm; used in CNFireMod - wf2(n) = rzm(nc,nz) ! soil water as frac of WHC for top 17cm; used in CNFireMod - -! soil temperature -! ---------------- - t_soisno(n,1) = tp1(nc) ! soil layer temperature (K) - t_grnd(n) = tgw(nc,nz) ! ground surface temperature (K) - tsoi17(n) = (DZTSURF*tgw(nc,nz)+(DZGT(1)-DZTSURF)*tp1(nc)+(0.17-DZGT(1))*tp2(nc))/0.17 ! soil temperature in top 17cm of soil (Kelvin) - ! fzeng: tgw is for the top 5cm; tp1 is for the 2nd 5cm; tp2 is for the next 10cm - ! see Koster et al., 2000, JGR - ! The depths are hard coded here. Improve this? - - -! new parameters for the fire module in CLM4.5 -! -------------------------------------------- - abm_lf(n) = abm(nc) - peatf_lf(n) = peatf(nc) - gdp_lf(n) = gdp(nc) - -! snow depth -! ---------- - snow_depth(n) = sndzn(nc)*asnow(nc) ! column averaged snow height (m) - - ! assuming nzone = 3, fzeng, 6 Mar 2017 - if(nz==1) then - fsat(n) = min(max(0.,car1m(nc)/wtzone(nc,nz)),1.) - elseif(nz==2) then - fsat(n) = min(max(0.,(car1m(nc)-wtzone(nc,1))/wtzone(nc,nz)),1.) - else - fsat(n) = min(max(0.,(car1m(nc)-wtzone(nc,1)-wtzone(nc,2))/wtzone(nc,nz)),1.) - endif - - bare = 1. ! bare soil for this tile - do nv = 1,nveg - bare = bare - fveg(nc,nv,nz)! subtract vegetated fractions - end do - if(bare .lt. 1.e-4) bare = 0. ! don't bother with small bare fractions - - pft_num = 0 ! PFT loop - do p = pfti(n),pftf(n) - pitype(p) = pft_num ! PFT index - pcolumn(p) = n ! column index for PFT - pwtcol(p) = 0. ! weight will be zero unless otherwise set - t_ref2m(p) = tm(nc) ! 2m air temperature - prec10(p) = prec10d(nc) - prec60(p) = prec60d(nc) - t10(p) = t10d(nc) - pgridcell(p) = nc ! PFT map into catchment tile - pwtgcell(p) = 0. ! PFT weight in catchment tile - pactive(p) = .false. ! pactive will be .false. unless otherwise set, fzeng - -! map bare soil if present -! ------------------------ - if(bare.gt.0. .and. pft_num.eq.0) then - num_soilp = num_soilp + 1 - filter_soilp(num_soilp) = p - pwtcol(p) = bare - psnsha(p) = 0. - psnsun(p) = 0. - lmrsha(p) = 0. - lmrsun(p) = 0. - laisha(p) = 0. - laisun(p) = 0. - forc_hgt_u_pft(p) = 30. ! gkw: may need from land model; use this for now - rootfr(p,1) = 0.0 - pwtgcell(p) = bare*wtzone(nc,nz) ! PFT weight in catchment tile - btran2(p) = 0. - endif - -! map vegetation type -! ------------------- - do nv = 1,nveg - - if(ityp(nc,nv,nz).eq.pft_num .and. fveg(nc,nv,nz).gt.1.e-4) then - - num_soilp = num_soilp + 1 - filter_soilp(num_soilp) = p - index_soilp(num_soilp) = nv ! for remapping LAI to tile - zone_soilp(num_soilp) = nz ! for remapping LAI to tile - pwtcol(p) = fveg(nc,nv,nz) - psnsha(p) = psha(nc,nv,nz) - psnsun(p) = psun(nc,nv,nz) - lmrsha(p) = lmrsham(nc,nv,nz) - lmrsun(p) = lmrsunm(nc,nv,nz) - laisha(p) = lsha(nc,nv,nz) - laisun(p) = lsun(nc,nv,nz) - forc_hgt_u_pft(p) = 30. ! gkw: may need from land model; use this for now - rootfr(p,1) = 1.0 ! gkw: affects maint resp. test sensitivity - pwtgcell(p) = fveg(nc,nv,nz)*wtzone(nc,nz) ! PFT weight in catchment tile - - ! calculate btran2 for CNFireMod - ! use btran derived from rzmc for trees except broadleaf deciduous tropical tree - ! use btran derived from sfmc for the other vegetation types - if(pft_num<=ntree .and. pft_num/=nbrdlf_dcd_trp_tree) then - btran2(p) = btran2x_rz(nc,nz) - else - btran2(p) = btran2x_sf(nc,nz) - endif - - pactive(p) = .true. ! set pactive to .true. if there is vegetation, fzeng - - tileid_soilp(p) = tile_id(nc) ! fzeng added for debugging - - ! for prog. crop. correct? fzeng, 20 Mar 2017 - if(ityp(nc,nv,nz) >= npcropmin) then - num_pcropp = num_pcropp + 1 - filter_pcropp(num_pcropp) = p - endif - - ! set daylength here (moved from CNPhenology) - if(first .and. istep==0) dayl(p) = daylength(nc) ! working fix for cold carbon start gkw: 2015-08-01 - prev_dayl(p) = dayl(p) - dayl(p) = daylength(nc) - - ! Fraction of vegetation free of snow, following CNVegStructUpdate and CLM4.5's initSurfAlbMod.F90 - if ((elai(p) + esai(p)) > 0._r8) then - frac_veg_nosno(p) = 1 - else - frac_veg_nosno(p) = 0 - end if - - endif - - end do - - pft_num = pft_num + 1 - end do ! end PFT loop - - end do ! end zone loop - - end do ! end catchment loop - -! nitrogen deposition -! ------------------- - forc_ndep(:) = ndep(:) - -! forcing for CNFireMod -! --------------------- - forc_rh(:) = rhm(:) - forc_wind(:) = windm(:) - forc_t(:) = tm(:) - forc_rain(:) = rainfm(:) - forc_snow(:) = snowfm(:) - forc_hdm(:) = hdm(:) - forc_lnfm(:) = lnfm(:) - -! Initialize CN Ecosystem Dynamics (must be after time-manager initialization) -! ---------------------------------------------------------------------------- - if(first) call CNEcosystemDynInit(lbg,ubg,lbc,ubc,lbp,ubp) - -! initialize column & PFT for cold carbon restart if istep=0 (only if no carbon restart found) -! -------------------------------------------------------------------------------------------- - if(first .and. istep==0) then - call CNiniTimeVar(lbg,ubg,lbl,ubl,lbc,ubc,lbp,ubp) ! Set arbitrary initial conditions for time varying fields used in coupled carbon-nitrogen code - print *, 'warning: CN model cold carbon state!' - endif - -! gkw: override annual mean 2m T here, since it exists on restart - n = 0 - do nc = 1,nch ! loop over catchment tiles [columns] - do nz = 1,nzone ! loop over zones - n = n + 1 - do p = pfti(n),pftf(n) - annavg_t2m(p) = ann_t2m(nc) - end do ! end PFT loop - end do ! end zone loop - end do ! end catchment loop - -! update CN time step number, fzeng, 20 Mar 2017 -! ---------------------------------------------- - nstep_cn = get_nstep(istep) ! nstep_cn is actually not being used here. By doing so, istep is passed to the CN routines whenever "nstep = get_nstep()" is called. - -! initialize balance checks -! ------------------------ - call BeginCBalance(lbc, ubc, num_soilc, filter_soilc) - call BeginNBalance(lbc, ubc, num_soilc, filter_soilc) - - call CNZeroFluxes_dwt(lbc, ubc, lbp, ubp) - - call CNEcosystemDyn(lbc, ubc, lbp, ubp, num_soilc, filter_soilc, & - num_soilp, filter_soilp, num_pcropp, filter_pcropp, doalb, tileid_soilp) - - call CNAnnualUpdate(lbc, ubc, lbp, ubp, num_soilc, filter_soilc, & - num_soilp, filter_soilp) - -! check the carbon and nitrogen balance gkw: don't do balance check on first call of cold start -! ------------------------------------- - if(.not.first) then - call CBalanceCheck(lbc, ubc, num_soilc, filter_soilc) - call NBalanceCheck(lbc, ubc, num_soilc, filter_soilc) - else - first = .false. - endif - -! keep leaf carbon above some minimum value -! ----------------------------------------- - do n = 1,num_soilp - p = filter_soilp(n) - leafc_add(p) = 0. - - leafc_tot = leafc(p) + leafc_storage(p) + leafc_xfer(p) - if(leafc_tot < 0.3333) then ! gkw: arbitrary carbon threshold (g/m2) - if (pftcon%evergreen(pitype(p)) == 1.) then - leafc(p) = max(leafc(p),0.3333) - leafc_storage(p) = max(leafc_storage(p),0.) - else - leafc(p) = max(leafc(p),0.) - leafc_storage(p) = max(leafc_storage(p),0.3333) - end if - c = pcolumn(p) ! PFT column index - - leafc_add(p) = leafc(p) + leafc_storage(p) + leafc_xfer(p) - leafc_tot - totcolc(c) = totcolc(c) + leafc_add(p)*pwtcol(p) ! correct carbon balance - leafc_add(p) = leafc_add(p)/dt - endif - end do - -! PFT level diags -! --------------- - zlai = 0. ! elai - zsai = 0. ! esai - ztai = -999. ! tlai - nppg = 0. - gppg = 0. - padd = 0. - root = 0. - vegc = 0. - xsmr = 0. - ndeployg = 0. - leafng = 0. - leafcg = 0. - sminn_to_npoolg = 0. - totvegng = 0. - retransng = 0. - retransn_to_npoolg = 0. - rootcg = 0. - - npp => pcf%npp - gpp => pcf%gpp - - do n = 1,num_soilp - p = filter_soilp(n) - i = index_soilp(n) ! veg index, 1 to 4 - z = zone_soilp(n) ! zone index, 1 to 3 - c = pgridcell(p) ! tile index, 1 to nch - if(i .gt. 0) then ! veg exists - zlai(c,i,z) = elai(p) - zsai(c,i,z) = esai(p) - ztai(c,i,z) = tlai(p) - nppg(c) = nppg(c) + npp(p)*pwtgcell(p) - gppg(c) = gppg(c) + gpp(p)*pwtgcell(p) - padd(c) = padd(c) + leafc_add(p)*pwtgcell(p) - root(c) = root(c) + (frootc(p)+frootc_storage(p)+frootc_xfer(p))*pwtgcell(p) - vegc(c) = vegc(c) + totvegc(p)*pwtgcell(p) - xsmr(c) = xsmr(c) + xsmrpool(p)*pwtgcell(p) - ndeployg(c) = ndeployg(c) + ndeploy(p)*pwtgcell(p) - leafng(c) = leafng(c) + leafn(p)*pwtgcell(p) - leafcg(c) = leafcg(c) + leafc(p)*pwtgcell(p) - sminn_to_npoolg(c) = sminn_to_npoolg(c) + sminn_to_npool(p)*pwtgcell(p) - totvegng(c) = totvegng(c) + totvegn(p)*pwtgcell(p) - retransng(c) = retransng(c) + retransn(p)*pwtgcell(p) - retransn_to_npoolg(c) = retransn_to_npoolg(c) + retransn_to_npool(p)*pwtgcell(p) - rootcg(c) = rootcg(c) + (frootc(p)+frootc_storage(p)+frootc_xfer(p)+ & - livecrootc(p)+livecrootc_storage(p)+livecrootc_xfer(p)+ & - deadcrootc(p)+deadcrootc_storage(p)+deadcrootc_xfer(p))*pwtgcell(p) - endif - end do - -! column level diags -! ------------------ - srg = 0. - neeg = 0. - burn = 0. - closs = 0. - nfire = 0. - som_closs = 0. - denitg = 0. - sminn_leachedg = 0. - sminng = 0. - col_fire_nlossg = 0. - gross_nming = 0. - net_nming = 0. - nfix_to_sminng = 0. - actual_immobg = 0. - fpgg = 0. - fpig = 0. - sminn_to_plantg = 0. - ndep_to_sminng = 0. - totlitng = 0. - totsomng = 0. - fuelcg = 0. - totlitcg = 0. - cwdcg = 0. - - sr => ccf%sr - nee => ccf%nee - farea_burned => cps%farea_burned - col_fire_closs => ccf%col_fire_closs - col_nfire => cps%nfire - col_somc_fire => ccf%somc_fire - - do n = 1,num_soilc - i = filter_soilc(n) - z = zone_soilc(n) - c = cgridcell(i) - colc(c,z) = totcolc(i) - srg(c) = srg(c) + sr(i) *wtzone(c,z) - neeg(c) = neeg(c) + nee(i)*wtzone(c,z) - burn(c) = burn(c) + farea_burned(i)*wtzone(c,z) ! burn rate (fraction per second) - closs(c) = closs(c) + col_fire_closs(i)*wtzone(c,z) - nfire(c) = nfire(c) + col_nfire(i)*wtzone(c,z) ! fire counts (count/km2/s) - som_closs(c) = som_closs(c) + col_somc_fire(i)*wtzone(c,z) - denitg(c) = denitg(c) + denit(i) * wtzone(c,z) - sminn_leachedg(c) = sminn_leachedg(c) + sminn_leached(i) * wtzone(c,z) - sminng(c) = sminng(c) + sminn(i) * wtzone(c,z) - col_fire_nlossg(c) = col_fire_nlossg(c) + col_fire_nloss(i) * wtzone(c,z) - gross_nming(c) = gross_nming(c) + gross_nmin(i) * wtzone(c,z) - net_nming(c) = net_nming(c) + net_nmin(i) * wtzone(c,z) - nfix_to_sminng(c) = nfix_to_sminng(c) + nfix_to_sminn(i) * wtzone(c,z) - actual_immobg(c) = actual_immobg(c) + actual_immob(i) * wtzone(c,z) - fpgg(c) = fpgg(c) + fpg(i) * wtzone(c,z) - fpig(c) = fpig(c) + fpi(i) * wtzone(c,z) - sminn_to_plantg(c) = sminn_to_plantg(c) + sminn_to_plant(i) * wtzone(c,z) - ndep_to_sminng(c) = ndep_to_sminng(c) + ndep_to_sminn(i) * wtzone(c,z) - totlitng(c) = totlitng(c) + totlitn(i) * wtzone(c,z) - totsomng(c) = totsomng(c) + totsomn(i) * wtzone(c,z) - fuelcg(c) = fuelcg(c) + fuelc(i) * wtzone(c,z) - totlitcg(c) = totlitcg(c) + totlitc(i) * wtzone(c,z) - cwdcg(c) = cwdcg(c) + cwdc(i) * wtzone(c,z) - end do - - if ( .not. LAND_FIX ) then ! jkolassa Oct 2020: the if-wrapper here is to toggle between the LDASsa version used by Fanwei Zeng and Eunjee Lee and current GEOSldas Catchment-CN; there is likely a better way to control this - where (zlai > 20.) zlai = 20. - where (zsai > 20.) zsai = 20. - end if - - end subroutine CN_Driver - - subroutine CN_init(istep,nch,nveg,nzone,ityp,fveg,var_col,var_pft,cncol,cnpft,skip_initCN) - - use clm_varpar, only: nlevdecomp - use clm_varcon, only: dzsoi_decomp - - integer*8, intent(in) :: istep - integer, intent(in) :: nch ! number of tiles - integer, intent(in) :: nveg ! number of vegetation types per zone - integer, intent(in) :: nzone ! number of stress zones per tile - integer, dimension(nch,nveg,nzone), intent(in) :: ityp ! PFT index - real, dimension(nch,nveg,nzone), intent(in) :: fveg ! PFT fraction - - integer, intent(in) :: var_col ! number of CN column restart variables - real*4, dimension(nch,nzone,var_col), optional, intent(in) :: cncol ! gkw: column CN restart - - integer, intent(in) :: var_pft ! number of CN PFT restart variables - real*4, dimension(nch,nzone,nveg,var_pft), optional, intent(in) :: cnpft ! gkw: PFT CN restart - logical,optional, intent(in) :: skip_initCN - - integer :: n, p, nv, nc, nz, np, j - -! PFT parameters note: index 0 is "noveg" - - real, save, dimension(0:numpft) :: qe2x,z0mx,displax,c3psx,mx,slatox,dsladlax,leafcx,flnx,fnitx,woodx,lflitcx - real, save, dimension(0:numpft) :: frootcx,livewdcx,deadwdcx,dwoox,froot_leax,stem_leax,croot_stex,flivewx,fcux - real, save, dimension(0:numpft) :: lf_flax,lf_fcex,lf_flix,fr_flax,fr_fcex,fr_flix,leaf_lonx,evergreex,resisx - real, save, dimension(0:numpft) :: stress_decix,season_decix,xlx,rholx,rhosx,taulx,tausx - real, save, dimension(0:numpft) :: cc_dstex,cc_leax,cc_lstex,cc_othex,fm_leax,fm_lstex,fm_othex,fm_roox,fm_lroox,fm_droox ! new in CLM4.5 - real, save, dimension(0:numpft) :: fd_pfx,fsr_pfx,grperx,grpnox ! new in CLM4.5 - -! real, save, dimension(0:numpft) :: fertnitrx,lfemerx,grnfilx,mxmax,hybgdx ! new in CLM4.5 -! real, save, dimension(0:numpft) :: laimxx,ztopmxx,gddmix,graincx,fleafcx,ffrootcx,fstemcx ! new in CLM4.5 -! real, save, dimension(0:numpft) :: rootprof_betx,aleafx,allconslx,allconssx,arootfx,arootix,astemx,bfacx,declfacx,fleafx ! new in CLM4.5 -! real, save, dimension(0:numpft) :: basex,mxtmx,planttemx,minplanttemx ! new in CLM4.5 -! integer, save, dimension(0:numpft) :: mnNHplantdatx,mxNHplantdatx,mnSHplantdatx,mxSHplantdatx ! new in CLM4.5 - - -! The data below is from -! https://svn-ccsm-inputdata.cgd.ucar.edu/trunk/inputdata/lnd/clm2/pftdata/pft-physiology.c130503.nc -! A copy of this file is /discover/nobackup/fzeng/clm4-to-clm4.5/data/pftdata4.5/pft-physiology.c130503.nc -! In CLM4.5, data in this file is read in pftvarcon.F90. - -! From /gpfsm/dnb02/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/DE_00720x00360_PE_0720x0360/clsm/README -! It matches that in pft-physiology.c130503.nc with 3 additional split types (i.e. 11, 15 and 17). - -! NEW pftname -! 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 C3 crop [moisture + deciduous] -! 19 C3 crop [moisture stress only] - -! fzeng: qe25 does not exist in pft-physiology.c130503.nc. Give it the same numbers (0.06 for c3 plants and 0.04 for c4 plants) as the CLM4 version here just to get the code compiling. -! Need to ask Jung-Eun Lee for the CLM4.5 version of fluorescence calculation!! -! When remove qe25 later from here and compute_rc, also need to remove it from clmtype and clmtypeInit! - -! Some of these parameters are only used for prognostic crops. Although we removed prognostic crops, keep them here for now to avoid having to check one by one which is not used. -! fzeng, 10 May 2018 - -! fzeng, 8 May 2019: updated fsr_pfx following /discover/nobackup/fzeng/clm4-to-clm4.5/data/paramdata4.5/clm_params.c140423.nc (Li et al., BG 2014) -! fzeng, 12 July 2019: modified fsr_pfx for type 6 because this type (i.e. broadleaf deciduous tropical trees in ESA) in Africa is classified as woody savanna and savanna in MODIS land cover which is more consistent with CLM4.5CN tree and grass fractions in Africa - -! pftname / 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 / - data qe2x / 0., 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.060, 0.040, 0.040, 0.060, 0.060/ - data z0mx / 0., 0.055, 0.055, 0.055, 0.075, 0.075, 0.055, 0.055, 0.055, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120/ - data displax / 0., 0.670, 0.670, 0.670, 0.670, 0.670, 0.670, 0.670, 0.670, 0.680, 0.680, 0.680, 0.680, 0.680, 0.680, 0.680, 0.680, 0.680, 0.680, 0.680/ - data c3psx / 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 0., 0., 1., 1./ - data slatox / 0., 0.010, 0.008, 0.024, 0.012, 0.012, 0.030, 0.030, 0.030, 0.012, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030/ - data dsladlax / 0.,0.00125,0.001, 0.003,0.0015,0.0015, 0.004, 0.004, 0.004, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ - data leafcx / 1., 35., 40., 25., 30., 30., 25., 25., 25., 30., 25., 25., 25., 25., 25., 25., 25., 25., 25., 25./ - data flnx / 0.,0.0509,0.0466,0.0546,0.0461,0.0515,0.0716,0.1007,0.1007,0.0517,0.0943,0.0943,0.0943,0.1365,0.1365,0.1365,0.0900,0.0900,0.1758,0.1758/ - data fnitx / 0., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1./ ! largely changed from CLM4! - data woodx / 0., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 0., 0., 0., 0., 0., 0., 0./ - data lflitcx / 1., 70., 80., 50., 60., 60., 50., 50., 50., 60., 50., 50., 50., 50., 50., 50., 50., 50., 50., 50./ - data frootcx / 1., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42., 42./ - data livewdcx / 1., 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., 0., 0., 0., 0., 0., 0., 0./ - data deadwdcx / 1., 500., 500., 500., 500., 500., 500., 500., 500., 500., 500., 500., 500., 0., 0., 0., 0., 0., 0., 0./ - data froot_leax / 0., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 2., 2., 2., 2., 2., 2./ - data stem_leax / 0., -1., -1., -1., -1., -1., -1., -1., -1., 0.2, 0.2, 0.2, 0.2, 0., 0., 0., 0., 0., 0., 0./ - data croot_stex / 0., 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0., 0., 0., 0., 0., 0., 0./ - data flivewx / 0., 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.5, 0.5, 0.5, 0.1, 0., 0., 0., 0., 0., 0., 0./ -! data fcux / 0., 1., 1., 0., 1., 1., 0., 0., 0., 1., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ ! original CLM4.5 values - data fcux / 0., 1.0, 1.0, 0.5, 1.0, 1.0, 0.5, 0.5, 0.5, 1.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5/ ! our fix, same as CLM4 Catchment-CN, fzeng, 10 May 2018 - data lf_flax / 0., 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25/ - data lf_fcex / 0., 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5/ - data lf_flix / 0., 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25/ - data fr_flax / 0., 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25/ - data fr_fcex / 0., 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5/ - data fr_flix / 0., 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25/ - data leaf_lonx / 0., 3., 6., 1., 1.5, 1.5, 1., 1., 1., 1.5, 1., 1., 1., 1., 1., 1., 1., 1., 1., 1./ - data evergreex / 0., 1., 1., 0., 1., 1., 0., 0., 0., 1., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ - data stress_decix / 0., 0., 0., 0., 0., 0., 1., 0., 0., 0., 1., 1., 0., 0., 1., 1., 1., 1., 1., 1./ - data season_decix / 0., 0., 0., 1., 0., 0., 0., 1., 1., 0., 0., 0., 1., 1., 0., 0., 0., 0., 0., 0./ - data xlx / 0., 0.01, 0.01, 0.01, 0.1, 0.1, 0.01, 0.25, 0.25, 0.01, 0.25, 0.25, 0.25, -0.3, -0.3, -0.3, -0.3, -0.3, -0.3, -0.3/ - data rholx / 0., 0.07, 0.07, 0.07, 0.1, 0.1, 0.1, 0.1, 0.1, 0.07, 0.1, 0.1, 0.1, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11/ - data rhosx / 0., 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.31, 0.31, 0.31, 0.31, 0.31, 0.31, 0.31/ - data taulx / 0., 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05/ - data tausx / 0., 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.12, 0.12, 0.12, 0.12, 0.12, 0.12, 0.12/ - -! data cc_dstex / 0., 0.22, 0.25, 0.25, 0.22, 0.22, 0.22, 0.22, 0.22, 0.3, 0.3, 0.3, 0.3, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! original CLM4.5 values -! data cc_leax / 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! original CLM4.5 values -! data cc_lstex / 0., 0.22, 0.25, 0.25, 0.22, 0.22, 0.22, 0.22, 0.22, 0.3, 0.3, 0.3, 0.3, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! original CLM4.5 values -! data cc_othex / 0., 0.45, 0.5, 0.5, 0.45, 0.45, 0.45, 0.45, 0.45, 0.55, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! original CLM4.5 values -! data fm_leax / 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! original CLM4.5 values -! data fm_lstex / 0., 0.45, 0.5, 0.5, 0.45, 0.45, 0.35, 0.35, 0.45, 0.55, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! original CLM4.5 values -! data fm_othex / 0., 0.45, 0.5, 0.5, 0.45, 0.45, 0.35, 0.35, 0.45, 0.55, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! original CLM4.5 values -! data fm_roox / 0., 0.13, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1, 0.13, 0.17, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2/ ! original CLM4.5 values -! data fm_lroox / 0., 0.13, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1, 0.13, 0.17, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2/ ! original CLM4.5 values -! data fm_droox / 0., 0.13, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1, 0.13, 0.17, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2/ ! original CLM4.5 values - - data cc_dstex / 0., 0.22, 0.25, 0.25, 0.22, 0.22, 0.60, 0.22, 0.22, 0.3, 0.3, 0.3, 0.3, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data cc_leax / 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.80, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data cc_lstex / 0., 0.22, 0.25, 0.25, 0.22, 0.22, 0.60, 0.22, 0.22, 0.3, 0.3, 0.3, 0.3, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data cc_othex / 0., 0.45, 0.5, 0.5, 0.45, 0.45, 0.68, 0.45, 0.45, 0.55, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data fm_leax / 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.80, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data fm_lstex / 0., 0.45, 0.5, 0.5, 0.45, 0.45, 0.64, 0.35, 0.45, 0.55, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data fm_othex / 0., 0.45, 0.5, 0.5, 0.45, 0.45, 0.64, 0.35, 0.45, 0.55, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data fm_roox / 0., 0.13, 0.15, 0.15, 0.13, 0.13, 0.17, 0.1, 0.13, 0.17, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data fm_lroox / 0., 0.13, 0.15, 0.15, 0.13, 0.13, 0.17, 0.1, 0.13, 0.17, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data fm_droox / 0., 0.13, 0.15, 0.15, 0.13, 0.13, 0.17, 0.1, 0.13, 0.17, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - - data fd_pfx / 0., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24., 24./ -! data fsr_pfx / 0., 0.4, 0.43, 0.43, 0.4, 0.4, 0.4, 0.4, 0.4, 0.46, 0.46, 0.46, 0.46, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55/ ! original CLM4.5 values -! data fsr_pfx / 0., 0.4, 0.43, 0.43, 0.4, 0.4, 0.4, 0.4, 0.4, 0.46, 0.46, 0.46, 0.46, 0.60, 0.60, 0.60, 0.60, 0.60, 0.60, 0.60/ ! original CLM4.5 values after bug fix in Li et al., 2014 - data fsr_pfx / 0., 0.4, 0.43, 0.43, 0.4, 0.4, 0.53, 0.4, 0.4, 0.46, 0.46, 0.46, 0.46, 0.60, 0.60, 0.60, 0.60, 0.60, 0.60, 0.60/ ! assume type 6 is 35% tree and 65% grass, fzeng, 2019 - data grperx / 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3/ - data grpnox / 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1./ - -! data fertnitrx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data lfemerx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data grnfilx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data mxmax / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data hybgdx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data laimxx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data ztopmxx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data gddmix / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data graincx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data fleafcx / 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999./ -! data ffrootcx / 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999./ -! data fstemcx / 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999., 999./ -! data rootprof_betx / 0., 0.976, 0.943, 0.943, 0.962, 0.966, 0.961, 0.966, 0.943, 0.964, 0.964, 0.964, 0.914, 0.914, 0.943, 0.943, 0.943, 0.943, 0.961, 0.961/ -! data aleafx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data allconslx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data allconssx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data arootfx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data arootix / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data astemx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data bfacx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data declfacx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data fleafx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data basex / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data mxtmx / 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ -! data planttemx /1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000./ -! data minplanttemx /1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000./ -! data mnNHplantdatx / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ -! data mxNHplantdatx / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ -! data mnSHplantdatx / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ -! data mxSHplantdatx / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ - - integer :: lbg, ubg ! grid bounds - integer :: lbl, ubl ! land-type bounds - integer :: lbc, ubc ! column bounds - integer :: lbp, ubp ! pft bounds - -! define size of grid, landunit, column, and PFT -! ---------------------------------------------- - lbg = 1 ; ubg = nch ! "grid" (tile) - lbl = 1 ; ubl = nch ! one landunit per tile - lbc = 1 ; ubc = nch*nzone ! number of zones - lbp = 1 ; ubp = nch*nzone*(numpft+1) ! potential PFT index (0-19) - -! initialize CN model -! ------------------- - call clm_varpar_init() - call clm_varcon_init() - call initClmtype(lbg,ubg,lbl,ubl,lbc,ubc,lbp,ubp) ! allocation & initialization - -! Initialize time-constant arrays of decomposition constants -! ---------------------------------------------------------- - call init_decompcascade(lbc, ubc) - -! initialize PFT parameters -! ------------------------- - pftcon%qe25 = qe2x ! quantum efficiency at 25C (umol CO2 / umol photon) - pftcon%z0mr = z0mx ! ratio of momentum roughness length to canopy top height (-) - pftcon%displar = displax ! ratio of displacement height to canopy top height (-) - pftcon%c3psn = c3psx ! photosynthetic pathway: 0. = c4, 1. = c3 - pftcon%slatop = slatox ! specific leaf area at top of canopy, projected area basis [m^2/gC] - pftcon%dsladlai = dsladlax ! dSLA/dLAI, projected area basis [m^2/gC] - pftcon%leafcn = leafcx ! leaf C:N (gC/gN) - pftcon%flnr = flnx ! fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) - pftcon%fnitr = fnitx ! foliage nitrogen limitation factor (-) - pftcon%woody = woodx ! binary flag for woody lifeform (1=woody, 0=not woody) - pftcon%lflitcn = lflitcx ! leaf litter C:N (gC/gN) - pftcon%frootcn = frootcx ! fine root C:N (gC/gN) - pftcon%livewdcn = livewdcx ! live wood (phloem and ray parenchyma) C:N (gC/gN) - pftcon%deadwdcn = deadwdcx ! dead wood (xylem and heartwood) C:N (gC/gN) - pftcon%froot_leaf = froot_leax ! allocation parameter: new fine root C per new leaf C (gC/gC) - pftcon%stem_leaf = stem_leax ! allocation parameter: new stem c per new leaf C (gC/gC) - pftcon%croot_stem = croot_stex ! allocation parameter: new coarse root C per new stem C (gC/gC) - pftcon%flivewd = flivewx ! allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units) - pftcon%fcur = fcux ! allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage - pftcon%lf_flab = lf_flax ! leaf litter labile fraction - pftcon%lf_fcel = lf_fcex ! leaf litter cellulose fraction - pftcon%lf_flig = lf_flix ! leaf litter lignin fraction - pftcon%fr_flab = fr_flax ! fine root litter labile fraction - pftcon%fr_fcel = fr_fcex ! fine root litter cellulose fraction - pftcon%fr_flig = fr_flix ! fine root litter lignin fraction - pftcon%leaf_long = leaf_lonx ! leaf longevity (yrs) - pftcon%evergreen = evergreex ! binary flag for evergreen leaf habit (0 or 1) - pftcon%stress_decid = stress_decix ! binary flag for stress-deciduous leaf habit (0 or 1) - pftcon%season_decid = season_decix ! binary flag for seasonal-deciduous leaf habit (0 or 1) - pftcon%xl = xlx ! leaf/stem orientation index - pftcon%rhol = rholx ! leaf reflectance (visible) - pftcon%rhos = rhosx ! stem reflectance (visible) - pftcon%taul = taulx ! leaf transmittance (visible) - pftcon%taus = tausx ! stem transmittance (visible) - pftcon%cc_dstem = cc_dstex ! Combustion completeness factor for dead stem (0 to 1) - pftcon%cc_leaf = cc_leax ! Combustion completeness factor for leaf (0 to 1) - pftcon%cc_lstem = cc_lstex ! Combustion completeness factor for live stem (0 to 1) - pftcon%cc_other = cc_othex ! Combustion completeness factor for other plant (0 to 1) - pftcon%fm_leaf = fm_leax ! Fire-related mortality factor for leaf (0 to 1) - pftcon%fm_lstem = fm_lstex ! Fire-related mortality factor for live stem (0 to 1) - pftcon%fm_other = fm_othex ! Fire-related mortality factor for other plant (0 to 1) - pftcon%fm_root = fm_roox ! Fire-related mortality factor for fine roots (0 to 1) - pftcon%fm_lroot = fm_lroox ! Fire-related mortality factor for live roots (0 to 1) - pftcon%fm_droot = fm_droox ! Fire-related mortality factor for dead roots (0 to 1) - pftcon%fd_pft = fd_pfx ! Fire duration (hr) - pftcon%fsr_pft = fsr_pfx ! Fire spread rate (m/s) - pftcon%grperc = grperx ! Growth respiration factor (unitless) - pftcon%grpnow = grpnox ! Growth respiration factor (unitless) - pftcon%dwood = 2.5e5 ! cn wood density (gC/m3); lpj:2.0e5; from CLM4.5 pftvarcon.F90. Values are same as in CLM4, fzeng. - -! pftcon%fertnitro = fertnitrx ! Max fertilizer to be applied in total (kg N/m2) -! pftcon%lfemerg = lfemerx ! Leaf emergence parameter used in CNPhenology (unitless) -! pftcon%grnfill = grnfilx ! Grain fill parameter used in CNPhenology (unitless) -! pftcon%mxmat = mxmax ! Maximum number of days to maturity parameter in CNPhenology (days) -! pftcon%hybgdd = hybgdx ! Growing Degree Days for maturity used in CNPhenology (unitless) -! pftcon%laimx = laimxx ! Maximum Leaf Area Index used in CNVegStructUpdate -! pftcon%ztopmx = ztopmxx ! Canopy top coefficient used in CNVegStructUpdate (m) -! pftcon%gddmin = gddmix ! Minimim growing degree days used in CNPhenology -! pftcon%graincn = graincx ! Grain C:N (gC/gN) -! pftcon%fleafcn = fleafcx ! Leaf C:N during organ fill (gC/gN) -! pftcon%ffrootcn = ffrootcx ! Fine root C:N during organ fill (gC/gN) -! pftcon%fstemcn = fstemcx ! Stem C:N during organ fill (gC/gN) -! pftcon%rootprof_beta = rootprof_betx ! Rooting beta parameter, for C and N vertical discretization (unitless) - - ! for CNAllocation -! pftcon%aleaff = aleafx ! Leaf Allocation coefficient parameter used in CNAllocation -! pftcon%allconsl = allconslx ! Leaf Allocation coefficient parameter power used in CNAllocation -! pftcon%allconss = allconssx ! Stem Allocation coefficient parameter power used in CNAllocation -! pftcon%arootf = arootfx ! Root Allocation coefficient parameter used in CNAllocation -! pftcon%arooti = arootix ! Root Allocation coefficient parameter used in CNAllocation -! pftcon%astemf = astemx ! Stem Allocation coefficient parameter used in CNAllocation -! pftcon%bfact = bfacx ! Exponential factor used in CNAllocation for fraction allocated to leaf -! pftcon%declfact = declfacx ! Decline factor for gddmaturity used in CNAllocation -! pftcon%fleafi = fleafx ! Leaf Allocation coefficient parameter fraction used in CNAllocation - -! pftcon%baset = basex ! Base Temperature, parameter used in accFlds (degree C) -! pftcon%mxtmp = mxtmx ! Max Temperature, parameter used in accFlds (degree C) -! pftcon%planttemp = planttemx ! Average 10 day temperature needed for planting (K) -! pftcon%minplanttemp = minplanttemx ! Average 5 day daily minimum temperature needed for planting (K) -! pftcon%mnNHplantdate = mnNHplantdatx ! Minimum planting date for the Northern Hemipsphere (MMDD) - ! Typical U.S. earliest planting dates according to AgroIBIS: Maize Apr 10th; soybean May 15th; spring wheat early Apr; winter wheat Sep 1st -! pftcon%mxNHplantdate = mxNHplantdatx ! Maximum planting date for the Northern Hemipsphere (MMDD) - ! Typical U.S. latest planting dates according to AgroIBIS: Maize May 10th; soybean Jun 20th; spring wheat mid-May; winter wheat early Nov. -! pftcon%mnSHplantdate = mnSHplantdatx ! Minimum planting date for the Southern Hemipsphere (MMDD), same as min_NH_planting_date, but offset by six months -! pftcon%mxSHplantdate = mxSHplantdatx ! Maximum planting date for the Southern Hemipsphere (MMDD), same as max_NH_planting_date, but offset by six months - -! transfer restart vars from to CLM data structures if restart exists -! ------------------------------------------------------------------- - if(istep /= 0) then - - n = 0 - np = 0 - do nc = 1,nch ! catchment tile loop - do nz = 1,nzone ! CN zone loop - n = n + 1 - ccs%col_ctrunc_vr (n,1) = cncol(nc,nz, 1) - ccs%decomp_cpools_vr(n,1,4) = cncol(nc,nz, 2) ! cwdc - ccs%decomp_cpools_vr(n,1,1) = cncol(nc,nz, 3) ! litr1c - ccs%decomp_cpools_vr(n,1,2) = cncol(nc,nz, 4) ! litr2c - ccs%decomp_cpools_vr(n,1,3) = cncol(nc,nz, 5) ! litr3c - ccs%totvegc_col (n) = cncol(nc,nz, 6) - ccs%prod100c (n) = cncol(nc,nz, 7) - ccs%prod10c (n) = cncol(nc,nz, 8) - ccs%seedc (n) = cncol(nc,nz, 9) - ccs%decomp_cpools_vr(n,1,5) = cncol(nc,nz,10) ! soil1c - ccs%decomp_cpools_vr(n,1,6) = cncol(nc,nz,11) ! soil2c - ccs%decomp_cpools_vr(n,1,7) = cncol(nc,nz,12) ! soil3c - ccs%decomp_cpools_vr(n,1,8) = cncol(nc,nz,13) ! soil4c - ccs%totcolc (n) = cncol(nc,nz,14) - ccs%totlitc (n) = cncol(nc,nz,15) - cns%col_ntrunc_vr (n,1) = cncol(nc,nz,16) - cns%decomp_npools_vr(n,1,4) = cncol(nc,nz,17) ! cwdn - cns%decomp_npools_vr(n,1,1) = cncol(nc,nz,18) ! litr1n - cns%decomp_npools_vr(n,1,2) = cncol(nc,nz,19) ! litr2n - cns%decomp_npools_vr(n,1,3) = cncol(nc,nz,20) ! litr3n - cns%prod100n (n) = cncol(nc,nz,21) - cns%prod10n (n) = cncol(nc,nz,22) - cns%seedn (n) = cncol(nc,nz,23) - cns%sminn_vr (n,1) = cncol(nc,nz,24) - cns%decomp_npools_vr(n,1,5) = cncol(nc,nz,25) ! soil1n - cns%decomp_npools_vr(n,1,6) = cncol(nc,nz,26) ! soil2n - cns%decomp_npools_vr(n,1,7) = cncol(nc,nz,27) ! soil3n - cns%decomp_npools_vr(n,1,8) = cncol(nc,nz,28) ! soil4n - cns%totcoln (n) = cncol(nc,nz,29) - cps%fpg (n) = cncol(nc,nz,30) - cps%annsum_counter (n) = cncol(nc,nz,31) - cps%cannavg_t2m (n) = cncol(nc,nz,32) - cps%cannsum_npp (n) = cncol(nc,nz,33) - cps%farea_burned (n) = cncol(nc,nz,34) - cps%fpi_vr (n,1) = cncol(nc,nz,35) - - ccs%decomp_cpools (n,4) = cncol(nc,nz, 2) ! cwdc - ccs%decomp_cpools (n,1) = cncol(nc,nz, 3) ! litr1c - ccs%decomp_cpools (n,2) = cncol(nc,nz, 4) ! litr2c - ccs%decomp_cpools (n,3) = cncol(nc,nz, 5) ! litr3c - ccs%decomp_cpools (n,5) = cncol(nc,nz,10) ! soil1c - ccs%decomp_cpools (n,6) = cncol(nc,nz,11) ! soil2c - ccs%decomp_cpools (n,7) = cncol(nc,nz,12) ! soil3c - ccs%decomp_cpools (n,8) = cncol(nc,nz,13) ! soil4c - - ccs%decomp_cpools_1m(n,4) = cncol(nc,nz, 2) ! cwdc - ccs%decomp_cpools_1m(n,1) = cncol(nc,nz, 3) ! litr1c - ccs%decomp_cpools_1m(n,2) = cncol(nc,nz, 4) ! litr2c - ccs%decomp_cpools_1m(n,3) = cncol(nc,nz, 5) ! litr3c - ccs%decomp_cpools_1m(n,5) = cncol(nc,nz,10) ! soil1c - ccs%decomp_cpools_1m(n,6) = cncol(nc,nz,11) ! soil2c - ccs%decomp_cpools_1m(n,7) = cncol(nc,nz,12) ! soil3c - ccs%decomp_cpools_1m(n,8) = cncol(nc,nz,13) ! soil4c - - cns%decomp_npools (n,4) = cncol(nc,nz,17) ! cwdn - cns%decomp_npools (n,1) = cncol(nc,nz,18) ! litr1n - cns%decomp_npools (n,2) = cncol(nc,nz,19) ! litr2n - cns%decomp_npools (n,3) = cncol(nc,nz,20) ! litr3n - cns%decomp_npools (n,5) = cncol(nc,nz,25) ! soil1n - cns%decomp_npools (n,6) = cncol(nc,nz,26) ! soil2n - cns%decomp_npools (n,7) = cncol(nc,nz,27) ! soil3n - cns%decomp_npools (n,8) = cncol(nc,nz,28) ! soil4n - - cns%decomp_npools_1m(n,4) = cncol(nc,nz,17) ! cwdn - cns%decomp_npools_1m(n,1) = cncol(nc,nz,18) ! litr1n - cns%decomp_npools_1m(n,2) = cncol(nc,nz,19) ! litr2n - cns%decomp_npools_1m(n,3) = cncol(nc,nz,20) ! litr3n - cns%decomp_npools_1m(n,5) = cncol(nc,nz,25) ! soil1n - cns%decomp_npools_1m(n,6) = cncol(nc,nz,26) ! soil2n - cns%decomp_npools_1m(n,7) = cncol(nc,nz,27) ! soil3n - cns%decomp_npools_1m(n,8) = cncol(nc,nz,28) ! soil4n - - ! total sminn, see CNSummaryMod.F90 - cns%sminn(n) = 0. - do j = 1, nlevdecomp - cns%sminn(n) = cns%sminn(n) + & - cns%sminn_vr(n,j) * dzsoi_decomp(j) - end do - - ! total soil organic matter carbon (TOTSOMC), see CNSummaryMod.F90 - ! compute the initial value of totsomc for CNFireFluxes, fzeng, 23 Aug 2018 - ccs%totsomc(n) = ccs%decomp_cpools(n,5) + ccs%decomp_cpools(n,6) + & - ccs%decomp_cpools(n,7) + ccs%decomp_cpools(n,8) - - do p = 0,numpft ! PFT index loop - np = np + 1 - do nv = 1,nveg ! defined veg loop - - if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then - pcs%cpool (np) = cnpft(nc,nz,nv, 1) - pcs%deadcrootc (np) = cnpft(nc,nz,nv, 2) - pcs%deadcrootc_storage (np) = cnpft(nc,nz,nv, 3) - pcs%deadcrootc_xfer (np) = cnpft(nc,nz,nv, 4) - pcs%deadstemc (np) = cnpft(nc,nz,nv, 5) - pcs%deadstemc_storage (np) = cnpft(nc,nz,nv, 6) - pcs%deadstemc_xfer (np) = cnpft(nc,nz,nv, 7) - pcs%frootc (np) = cnpft(nc,nz,nv, 8) - pcs%frootc_storage (np) = cnpft(nc,nz,nv, 9) - pcs%frootc_xfer (np) = cnpft(nc,nz,nv, 10) - pcs%gresp_storage (np) = cnpft(nc,nz,nv, 11) - pcs%gresp_xfer (np) = cnpft(nc,nz,nv, 12) - pcs%leafc (np) = cnpft(nc,nz,nv, 13) - pcs%leafc_storage (np) = cnpft(nc,nz,nv, 14) - pcs%leafc_xfer (np) = cnpft(nc,nz,nv, 15) - pcs%livecrootc (np) = cnpft(nc,nz,nv, 16) - pcs%livecrootc_storage (np) = cnpft(nc,nz,nv, 17) - pcs%livecrootc_xfer (np) = cnpft(nc,nz,nv, 18) - pcs%livestemc (np) = cnpft(nc,nz,nv, 19) - pcs%livestemc_storage (np) = cnpft(nc,nz,nv, 20) - pcs%livestemc_xfer (np) = cnpft(nc,nz,nv, 21) - pcs%pft_ctrunc (np) = cnpft(nc,nz,nv, 22) - pcs%xsmrpool (np) = cnpft(nc,nz,nv, 23) - pepv%annavg_t2m (np) = cnpft(nc,nz,nv, 24) - pepv%annmax_retransn (np) = cnpft(nc,nz,nv, 25) - pepv%annsum_npp (np) = cnpft(nc,nz,nv, 26) - pepv%annsum_potential_gpp (np) = cnpft(nc,nz,nv, 27) - pepv%dayl (np) = cnpft(nc,nz,nv, 28) - pepv%days_active (np) = cnpft(nc,nz,nv, 29) - pepv%dormant_flag (np) = cnpft(nc,nz,nv, 30) - pepv%offset_counter (np) = cnpft(nc,nz,nv, 31) - pepv%offset_fdd (np) = cnpft(nc,nz,nv, 32) - pepv%offset_flag (np) = cnpft(nc,nz,nv, 33) - pepv%offset_swi (np) = cnpft(nc,nz,nv, 34) - pepv%onset_counter (np) = cnpft(nc,nz,nv, 35) - pepv%onset_fdd (np) = cnpft(nc,nz,nv, 36) - pepv%onset_flag (np) = cnpft(nc,nz,nv, 37) - pepv%onset_gdd (np) = cnpft(nc,nz,nv, 38) - pepv%onset_gddflag (np) = cnpft(nc,nz,nv, 39) - pepv%onset_swi (np) = cnpft(nc,nz,nv, 40) - pepv%prev_frootc_to_litter(np) = cnpft(nc,nz,nv, 41) - pepv%prev_leafc_to_litter (np) = cnpft(nc,nz,nv, 42) - pepv%tempavg_t2m (np) = cnpft(nc,nz,nv, 43) - pepv%tempmax_retransn (np) = cnpft(nc,nz,nv, 44) - pepv%tempsum_npp (np) = cnpft(nc,nz,nv, 45) - pepv%tempsum_potential_gpp(np) = cnpft(nc,nz,nv, 46) - pepv%xsmrpool_recover (np) = cnpft(nc,nz,nv, 47) - pns%deadcrootn (np) = cnpft(nc,nz,nv, 48) - pns%deadcrootn_storage (np) = cnpft(nc,nz,nv, 49) - pns%deadcrootn_xfer (np) = cnpft(nc,nz,nv, 50) - pns%deadstemn (np) = cnpft(nc,nz,nv, 51) - pns%deadstemn_storage (np) = cnpft(nc,nz,nv, 52) - pns%deadstemn_xfer (np) = cnpft(nc,nz,nv, 53) - pns%frootn (np) = cnpft(nc,nz,nv, 54) - pns%frootn_storage (np) = cnpft(nc,nz,nv, 55) - pns%frootn_xfer (np) = cnpft(nc,nz,nv, 56) - pns%leafn (np) = cnpft(nc,nz,nv, 57) - pns%leafn_storage (np) = cnpft(nc,nz,nv, 58) - pns%leafn_xfer (np) = cnpft(nc,nz,nv, 59) - pns%livecrootn (np) = cnpft(nc,nz,nv, 60) - pns%livecrootn_storage (np) = cnpft(nc,nz,nv, 61) - pns%livecrootn_xfer (np) = cnpft(nc,nz,nv, 62) - pns%livestemn (np) = cnpft(nc,nz,nv, 63) - pns%livestemn_storage (np) = cnpft(nc,nz,nv, 64) - pns%livestemn_xfer (np) = cnpft(nc,nz,nv, 65) - pns%npool (np) = cnpft(nc,nz,nv, 66) - pns%pft_ntrunc (np) = cnpft(nc,nz,nv, 67) - pns%retransn (np) = cnpft(nc,nz,nv, 68) - pps%elai (np) = cnpft(nc,nz,nv, 69) - pps%esai (np) = cnpft(nc,nz,nv, 70) - pps%hbot (np) = cnpft(nc,nz,nv, 71) - pps%htop (np) = cnpft(nc,nz,nv, 72) - pps%tlai (np) = cnpft(nc,nz,nv, 73) - pps%tsai (np) = cnpft(nc,nz,nv, 74) - pepv%plant_ndemand (np) = cnpft(nc,nz,nv, 75) - - pcs%totvegc (np) = pcs%cpool (np) + & - pcs%deadcrootc (np) + & - pcs%deadcrootc_storage (np) + & - pcs%deadcrootc_xfer (np) + & - pcs%deadstemc (np) + & - pcs%deadstemc_storage (np) + & - pcs%deadstemc_xfer (np) + & - pcs%frootc (np) + & - pcs%frootc_storage (np) + & - pcs%frootc_xfer (np) + & - pcs%gresp_storage (np) + & - pcs%gresp_xfer (np) + & - pcs%leafc (np) + & - pcs%leafc_storage (np) + & - pcs%leafc_xfer (np) + & - pcs%livecrootc (np) + & - pcs%livecrootc_storage (np) + & - pcs%livecrootc_xfer (np) + & - pcs%livestemc (np) + & - pcs%livestemc_storage (np) + & - pcs%livestemc_xfer (np) - - ! Make it a cold start if there is no information from the restart file (derived from CLM4 restart) - ! fzeng, 1 Aug 2017 - if (isnan(pcs%leafc_xfer(np))) pcs%leafc_xfer(np) = 0. - - endif - - end do ! defined veg loop - end do ! PFT index loop - - end do ! CN zone loop - end do ! catchment tile loop - - endif - - return - - end subroutine CN_init - - subroutine CN_exit(nch,nveg,nzone,ityp,fveg,cncol,var_col,cnpft,var_pft) - - integer, intent(in) :: nch ! number of tiles - integer, intent(in) :: nveg ! number of vegetation types per zone - integer, intent(in) :: nzone ! number of stress zones per tile - integer, dimension(nch,nveg,nzone), intent(in) :: ityp ! PFT index - real, dimension(nch,nveg,nzone), intent(in) :: fveg ! PFT fraction - - integer, intent(in) :: var_col ! number of CN column restart variables - real*4, dimension(nch,nzone,var_col), intent(out) :: cncol ! gkw: column CN restart - - integer, intent(in) :: var_pft ! number of CN PFT restart variables - real*4, dimension(nch,nzone,nveg,var_pft), intent(out) :: cnpft ! gkw: PFT CN restart - - integer :: n, p, nv, nc, nz, np - - -! copy CN_restart vars to catch_internal_rst -! ------------------------------------------ - n = 0 - np = 0 - do nc = 1,nch ! catchment tile loop - do nz = 1,nzone ! CN zone loop - n = n + 1 - cncol(nc,nz, 1) = ccs%col_ctrunc_vr (n,1) - cncol(nc,nz, 2) = ccs%decomp_cpools_vr(n,1,4) ! cwdc - cncol(nc,nz, 3) = ccs%decomp_cpools_vr(n,1,1) ! litr1c - cncol(nc,nz, 4) = ccs%decomp_cpools_vr(n,1,2) ! litr2c - cncol(nc,nz, 5) = ccs%decomp_cpools_vr(n,1,3) ! litr3c - cncol(nc,nz, 6) = ccs%totvegc_col (n) - cncol(nc,nz, 7) = ccs%prod100c (n) - cncol(nc,nz, 8) = ccs%prod10c (n) - cncol(nc,nz, 9) = ccs%seedc (n) - cncol(nc,nz,10) = ccs%decomp_cpools_vr(n,1,5) ! soil1c - cncol(nc,nz,11) = ccs%decomp_cpools_vr(n,1,6) ! soil2c - cncol(nc,nz,12) = ccs%decomp_cpools_vr(n,1,7) ! soil3c - cncol(nc,nz,13) = ccs%decomp_cpools_vr(n,1,8) ! soil4c - cncol(nc,nz,14) = ccs%totcolc (n) - cncol(nc,nz,15) = ccs%totlitc (n) - cncol(nc,nz,16) = cns%col_ntrunc_vr (n,1) - cncol(nc,nz,17) = cns%decomp_npools_vr(n,1,4) ! cwdn - cncol(nc,nz,18) = cns%decomp_npools_vr(n,1,1) ! litr1n - cncol(nc,nz,19) = cns%decomp_npools_vr(n,1,2) ! litr2n - cncol(nc,nz,20) = cns%decomp_npools_vr(n,1,3) ! litr3n - cncol(nc,nz,21) = cns%prod100n (n) - cncol(nc,nz,22) = cns%prod10n (n) - cncol(nc,nz,23) = cns%seedn (n) - cncol(nc,nz,24) = cns%sminn_vr (n,1) - cncol(nc,nz,25) = cns%decomp_npools_vr(n,1,5) ! soil1n - cncol(nc,nz,26) = cns%decomp_npools_vr(n,1,6) ! soil2n - cncol(nc,nz,27) = cns%decomp_npools_vr(n,1,7) ! soil3n - cncol(nc,nz,28) = cns%decomp_npools_vr(n,1,8) ! soil4n - cncol(nc,nz,29) = cns%totcoln (n) - cncol(nc,nz,30) = cps%fpg (n) - cncol(nc,nz,31) = cps%annsum_counter (n) - cncol(nc,nz,32) = cps%cannavg_t2m (n) - cncol(nc,nz,33) = cps%cannsum_npp (n) - cncol(nc,nz,34) = cps%farea_burned (n) - cncol(nc,nz,35) = cps%fpi_vr (n,1) - - do p = 0,numpft ! PFT index loop - np = np + 1 - do nv = 1,nveg ! defined veg loop - - if(ityp(nc,nv,nz)==p .and. fveg(nc,nv,nz)>1.e-4) then - cnpft(nc,nz,nv, 1) = pcs%cpool (np) - cnpft(nc,nz,nv, 2) = pcs%deadcrootc (np) - cnpft(nc,nz,nv, 3) = pcs%deadcrootc_storage (np) - cnpft(nc,nz,nv, 4) = pcs%deadcrootc_xfer (np) - cnpft(nc,nz,nv, 5) = pcs%deadstemc (np) - cnpft(nc,nz,nv, 6) = pcs%deadstemc_storage (np) - cnpft(nc,nz,nv, 7) = pcs%deadstemc_xfer (np) - cnpft(nc,nz,nv, 8) = pcs%frootc (np) - cnpft(nc,nz,nv, 9) = pcs%frootc_storage (np) - cnpft(nc,nz,nv, 10) = pcs%frootc_xfer (np) - cnpft(nc,nz,nv, 11) = pcs%gresp_storage (np) - cnpft(nc,nz,nv, 12) = pcs%gresp_xfer (np) - cnpft(nc,nz,nv, 13) = pcs%leafc (np) - cnpft(nc,nz,nv, 14) = pcs%leafc_storage (np) - cnpft(nc,nz,nv, 15) = pcs%leafc_xfer (np) - cnpft(nc,nz,nv, 16) = pcs%livecrootc (np) - cnpft(nc,nz,nv, 17) = pcs%livecrootc_storage (np) - cnpft(nc,nz,nv, 18) = pcs%livecrootc_xfer (np) - cnpft(nc,nz,nv, 19) = pcs%livestemc (np) - cnpft(nc,nz,nv, 20) = pcs%livestemc_storage (np) - cnpft(nc,nz,nv, 21) = pcs%livestemc_xfer (np) - cnpft(nc,nz,nv, 22) = pcs%pft_ctrunc (np) - cnpft(nc,nz,nv, 23) = pcs%xsmrpool (np) - cnpft(nc,nz,nv, 24) = pepv%annavg_t2m (np) - cnpft(nc,nz,nv, 25) = pepv%annmax_retransn (np) - cnpft(nc,nz,nv, 26) = pepv%annsum_npp (np) - cnpft(nc,nz,nv, 27) = pepv%annsum_potential_gpp (np) - cnpft(nc,nz,nv, 28) = pepv%dayl (np) - cnpft(nc,nz,nv, 29) = pepv%days_active (np) - cnpft(nc,nz,nv, 30) = pepv%dormant_flag (np) - cnpft(nc,nz,nv, 31) = pepv%offset_counter (np) - cnpft(nc,nz,nv, 32) = pepv%offset_fdd (np) - cnpft(nc,nz,nv, 33) = pepv%offset_flag (np) - cnpft(nc,nz,nv, 34) = pepv%offset_swi (np) - cnpft(nc,nz,nv, 35) = pepv%onset_counter (np) - cnpft(nc,nz,nv, 36) = pepv%onset_fdd (np) - cnpft(nc,nz,nv, 37) = pepv%onset_flag (np) - cnpft(nc,nz,nv, 38) = pepv%onset_gdd (np) - cnpft(nc,nz,nv, 39) = pepv%onset_gddflag (np) - cnpft(nc,nz,nv, 40) = pepv%onset_swi (np) - cnpft(nc,nz,nv, 41) = pepv%prev_frootc_to_litter(np) - cnpft(nc,nz,nv, 42) = pepv%prev_leafc_to_litter (np) - cnpft(nc,nz,nv, 43) = pepv%tempavg_t2m (np) - cnpft(nc,nz,nv, 44) = pepv%tempmax_retransn (np) - cnpft(nc,nz,nv, 45) = pepv%tempsum_npp (np) - cnpft(nc,nz,nv, 46) = pepv%tempsum_potential_gpp(np) - cnpft(nc,nz,nv, 47) = pepv%xsmrpool_recover (np) - cnpft(nc,nz,nv, 48) = pns%deadcrootn (np) - cnpft(nc,nz,nv, 49) = pns%deadcrootn_storage (np) - cnpft(nc,nz,nv, 50) = pns%deadcrootn_xfer (np) - cnpft(nc,nz,nv, 51) = pns%deadstemn (np) - cnpft(nc,nz,nv, 52) = pns%deadstemn_storage (np) - cnpft(nc,nz,nv, 53) = pns%deadstemn_xfer (np) - cnpft(nc,nz,nv, 54) = pns%frootn (np) - cnpft(nc,nz,nv, 55) = pns%frootn_storage (np) - cnpft(nc,nz,nv, 56) = pns%frootn_xfer (np) - cnpft(nc,nz,nv, 57) = pns%leafn (np) - cnpft(nc,nz,nv, 58) = pns%leafn_storage (np) - cnpft(nc,nz,nv, 59) = pns%leafn_xfer (np) - cnpft(nc,nz,nv, 60) = pns%livecrootn (np) - cnpft(nc,nz,nv, 61) = pns%livecrootn_storage (np) - cnpft(nc,nz,nv, 62) = pns%livecrootn_xfer (np) - cnpft(nc,nz,nv, 63) = pns%livestemn (np) - cnpft(nc,nz,nv, 64) = pns%livestemn_storage (np) - cnpft(nc,nz,nv, 65) = pns%livestemn_xfer (np) - cnpft(nc,nz,nv, 66) = pns%npool (np) - cnpft(nc,nz,nv, 67) = pns%pft_ntrunc (np) - cnpft(nc,nz,nv, 68) = pns%retransn (np) - cnpft(nc,nz,nv, 69) = pps%elai (np) - cnpft(nc,nz,nv, 70) = pps%esai (np) - cnpft(nc,nz,nv, 71) = pps%hbot (np) - cnpft(nc,nz,nv, 72) = pps%htop (np) - cnpft(nc,nz,nv, 73) = pps%tlai (np) - cnpft(nc,nz,nv, 74) = pps%tsai (np) - cnpft(nc,nz,nv, 75) = pepv%plant_ndemand (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,nveg,nzone,ityp,fveg,elai,esai,tlai,tsai) - - integer, intent(in) :: nch ! number of tiles - integer, intent(in) :: nveg ! number of vegetation types per zone - integer, intent(in) :: nzone ! number of stress zones per tile - integer, dimension(nch,nveg,nzone), intent(in) :: ityp ! PFT index - real, dimension(nch,nveg,nzone), intent(in) :: fveg ! PFT fraction - real, dimension(nch,nveg,nzone), intent(out) :: elai ! exposed leaf-area index - real, dimension(nch,nveg,nzone), intent(out), optional :: esai ! exposed stem-area index - real, dimension(nch,nveg,nzone), intent(out), optional :: tlai ! total leaf-area index - real, dimension(nch,nveg,nzone), intent(out), optional :: tsai ! total stem-area index - - integer :: n, p, nv, nc, nz, np - - 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,nzone ! CN zone loop - n = n + 1 - do p = 0,numpft ! PFT index loop - np = np + 1 - do nv = 1,nveg ! 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) = pps%elai(np) - if(present(esai)) esai(nc,nv,nz) = pps%esai(np) - if(present(tlai)) tlai(nc,nv,nz) = pps%tlai(np) - if(present(tsai)) tsai(nc,nv,nz) = pps%tsai(np) - endif - - end do ! defined veg loop - end do ! PFT index loop - end do ! CN zone loop - end do ! catchment tile loop - - if ( .not. LAND_FIX ) then ! jkolassa Oct 2020: the if-wrapper here is to toggle between the LDASsa version used by Fanwei Zeng and Eunjee Lee and current GEOSldas Catchment-CN; there is likely a better way to control this - where (elai > 20.) elai = 20. - where (esai > 20.) esai = 20. - end if - - end subroutine get_CN_LAI - -end module CN_DriverMod 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 deleted file mode 100644 index 9b9b7dfbe..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/CNiniTimeVar.F90 +++ /dev/null @@ -1,1163 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: CNiniTimeVar -! -! !INTERFACE: -subroutine CNiniTimeVar(begg, endg, begl, endl, begc, endc, begp, endp) - -!#ifdef CN -! -! !DESCRIPTION: -! Initializes time varying variables used only in -! coupled carbon-nitrogen mode (CN): -! -! !USES: - use clmtype - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clm_varcon , only: istsoil, zsoi - use clm_varpar , only: nlevgrnd, nlevsoi, nlevdecomp, ndecomp_pools, nlevdecomp_full - use clm_varcon , only: istcrop, c13ratio, c14ratio - use clm_varctl , only: use_c13, use_c14, crop_prog - use pftvarcon , only: noveg - use pftvarcon , only: npcropmin -! use decompMod , only: get_proc_bounds -! -! !ARGUMENTS: - implicit none -! -! !CALLED FROM: -! subroutine iniTimeVar in file iniTimeVar.F90 -! -! !REVISION HISTORY: -! 10/21/03: Created by Peter Thornton -! F. Li and S. Levis (11/06/12) -! -! local pointers to implicit in arguments -! - real(r8), pointer :: evergreen(:) ! binary flag for evergreen leaf habit (0 or 1) - real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN) - real(r8), pointer :: deadwdcn(:) ! dead wood (xylem and heartwood) C:N (gC/gN) - integer , pointer :: ivt(:) ! pft vegetation type - integer , pointer :: plandunit(:) ! landunit index associated with each pft - integer , pointer :: clandunit(:) ! landunit index associated with each column - integer , pointer :: itypelun(:) ! landunit type -! -! local pointers to implicit out arguments -! - real(r8), pointer :: forc_hgt_u_pft(:) !observational height of wind at pft-level [m] - real(r8), pointer :: annsum_counter(:) ! seconds since last annual accumulator turnover - real(r8), pointer :: cannsum_npp(:) ! annual sum of NPP, averaged from pft-level (gC/m2/yr) - real(r8), pointer :: cannavg_t2m(:) !annual average of 2m air temperature, averaged from pft-level (K) - real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N - real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C - real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N - real(r8), pointer :: decomp_cpools(:,:) ! (gC/m2) decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_cpools_1m(:,:) ! (gC/m2) Diagnostic: decomposing (litter, cwd, soil) c pools to 1 meter - real(r8), pointer :: decomp_npools(:,:) ! (gC/m2) decomposing (litter, cwd, soil) N pools - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: decomp_npools_1m(:,:) ! (gN/m2) diagnostic: decomposing (litter, cwd, soil) N pools to 1 meter - real(r8), pointer :: sminn_vr(:,:) ! (gN/m3) soil mineral N - real(r8), pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation (diagnostic) - real(r8), pointer :: col_ctrunc_vr(:,:) ! (gC/m3) column-level sink for C truncation (prognostic) - real(r8), pointer :: col_ntrunc_vr(:,:) ! (gN/m3) column-level sink for N truncation - real(r8), pointer :: nfixation_prof(:,:) ! (1/m) profile for N fixation additions - real(r8), pointer :: ndep_prof(:,:) ! (1/m) profile for N fixation additions - - real(r8), pointer :: fpi_vr(:,:) - real(r8), pointer :: alt(:) - real(r8), pointer :: altmax(:) - real(r8), pointer :: altmax_lastyear(:) - integer, pointer :: alt_indx(:) - integer, pointer :: altmax_indx(:) - integer, pointer :: altmax_lastyear_indx(:) - real(r8), pointer :: som_adv_coef(:,:) - real(r8), pointer :: som_diffus_coef(:,:) -#ifdef NITRIF_DENITRIF - real(r8), pointer :: smin_nh4_vr(:,:) ! (gN/m3) soil mineral NH4 pool - real(r8), pointer :: smin_no3_vr(:,:) ! (gN/m3) soil mineral NO3 pool - real(r8), pointer :: smin_nh4(:) ! (gN/m2) soil mineral NH4 pool - real(r8), pointer :: smin_no3(:) ! (gN/m2) soil mineral NO3 pool -#endif - - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: grainc(:) ! (gC/m2) grain C - real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage - real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: xsmrpool(:) ! (gC/m2) abstract C pool to meet excess MR demand - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: grainn(:) ! (gN/m2) grain N - real(r8), pointer :: grainn_storage(:) ! (gN/m2) grain N storage - real(r8), pointer :: grainn_xfer(:) ! (gN/m2) grain N transfer - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N - real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool - real(r8), pointer :: psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: c13_psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: c13_psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: c14_psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: c14_psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: laisun(:) ! sunlit projected leaf area index - real(r8), pointer :: laisha(:) ! shaded projected leaf area index - real(r8), pointer :: dormant_flag(:) ! dormancy flag - real(r8), pointer :: days_active(:) ! number of days since last dormancy - real(r8), pointer :: onset_flag(:) ! onset flag - real(r8), pointer :: onset_counter(:) ! onset days counter - real(r8), pointer :: onset_gddflag(:) ! onset flag for growing degree day sum - real(r8), pointer :: onset_fdd(:) ! onset freezing degree days counter - real(r8), pointer :: onset_gdd(:) ! onset growing degree days - real(r8), pointer :: onset_swi(:) ! onset soil water index - real(r8), pointer :: offset_flag(:) ! offset flag - real(r8), pointer :: offset_counter(:) ! offset days counter - real(r8), pointer :: offset_fdd(:) ! offset freezing degree days counter - real(r8), pointer :: offset_swi(:) ! offset soil water index - real(r8), pointer :: lgsf(:) ! long growing season factor [0-1] - real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s) - real(r8), pointer :: bgtr(:) ! background transfer rate (1/s) - real(r8), pointer :: dayl(:) ! daylength (seconds) - real(r8), pointer :: prev_dayl(:) ! daylength from previous timestep (seconds) - real(r8), pointer :: annavg_t2m(:) ! annual average 2m air temperature (K) - real(r8), pointer :: tempavg_t2m(:) ! temporary average 2m air temperature (K) - real(r8), pointer :: gpp(:) ! GPP flux before downregulation (gC/m2/s) - real(r8), pointer :: availc(:) ! C flux available for allocation (gC/m2/s) - real(r8), pointer :: xsmrpool_recover(:) ! C flux assigned to recovery of negative cpool (gC/m2/s) - real(r8), pointer :: xsmrpool_c13ratio(:) ! C flux assigned to recovery of negative cpool (gC/m2/s) - real(r8), pointer :: alloc_pnow(:) ! fraction of current allocation to display as new growth (DIM) - real(r8), pointer :: c_allometry(:) ! C allocation index (DIM) - real(r8), pointer :: n_allometry(:) ! N allocation index (DIM) - real(r8), pointer :: plant_ndemand(:) ! N flux required to support initial GPP (gN/m2/s) - real(r8), pointer :: tempsum_potential_gpp(:) ! temporary annual sum of plant_ndemand - real(r8), pointer :: annsum_potential_gpp(:) ! annual sum of plant_ndemand - real(r8), pointer :: tempmax_retransn(:) ! temporary max of retranslocated N pool (gN/m2) - real(r8), pointer :: annmax_retransn(:) ! annual max of retranslocated N pool (gN/m2) - real(r8), pointer :: avail_retransn(:) ! N flux available from retranslocation pool (gN/m2/s) - real(r8), pointer :: plant_nalloc(:) ! total allocated N flux (gN/m2/s) - real(r8), pointer :: plant_calloc(:) ! total allocated C flux (gC/m2/s) - real(r8), pointer :: excess_cflux(:) ! C flux not allocated due to downregulation (gC/m2/s) - real(r8), pointer :: downreg(:) ! fractional reduction in GPP due to N limitation (DIM) - real(r8), pointer :: tempsum_npp(:) ! temporary annual sum of NPP - real(r8), pointer :: annsum_npp(:) ! annual sum of NPP -#if (defined CNDV) - real(r8), pointer :: tempsum_litfall(:) ! temporary annual sum of litfall - real(r8), pointer :: annsum_litfall(:) ! annual sum of litfall -#endif - real(r8), pointer :: rc13_canair(:) !C13O2/C12O2 in canopy air - real(r8), pointer :: rc13_psnsun(:) !C13O2/C12O2 in sunlit canopy psn flux - real(r8), pointer :: rc13_psnsha(:) !C13O2/C12O2 in shaded canopy psn flux - real(r8), pointer :: alphapsnsun(:) !sunlit 13c fractionation ([]) - real(r8), pointer :: alphapsnsha(:) !shaded 13c fractionation ([]) - real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s) - real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s) - real(r8), pointer :: qflx_irrig(:) !irrigation flux (mm H2O/s) - - ! fire-related variables changed by F. Li and S. Levis - real(r8), pointer :: wf(:) ! soil moisture in top 0.05 m - real(r8), pointer :: wf2(:) - real(r8), pointer :: nfire(:) ! fire counts/km2/timestep - real(r8), pointer :: baf_crop(:) ! burned area fraction in crop - real(r8), pointer :: baf_peatf(:) ! burned area fraction in peatland - real(r8), pointer :: fbac(:) - real(r8), pointer :: fbac1(:) - real(r8), pointer :: farea_burned(:) ! timestep fractional area burned (proportion) - - real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool - real(r8), pointer :: totecosysc(:) ! (gC/m2) total ecosystem carbon, incl veg but excl cpool - real(r8), pointer :: totlitc(:) ! (gC/m2) total litter carbon - real(r8), pointer :: totsomc(:) ! (gC/m2) total soil organic matter carbon - real(r8), pointer :: totlitc_1m(:) ! (gC/m2) total litter carbon to 1 meter - real(r8), pointer :: totsomc_1m(:) ! (gC/m2) total soil organic matter carbon to 1 meter - - real(r8), pointer :: woodc(:) ! (gC/m2) pft-level wood C - real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg - real(r8), pointer :: totecosysn(:) ! (gN/m2) total ecosystem nitrogen, incl veg - real(r8), pointer :: totlitn(:) ! (gN/m2) total litter nitrogen - real(r8), pointer :: totsomn(:) ! (gN/m2) total soil organic matter nitrogen - real(r8), pointer :: totlitn_1m(:) ! (gN/m2) total litter nitrogen to 1 meter - real(r8), pointer :: totsomn_1m(:) ! (gN/m2) total soil organic matter nitrogen to 1 meter - real(r8), pointer :: dispvegc(:) ! (gC/m2) displayed veg carbon, excluding storage and cpool - real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation - real(r8), pointer :: storvegc(:) ! (gC/m2) stored vegetation carbon, excluding cpool - real(r8), pointer :: totpftc(:) ! (gC/m2) total pft-level carbon, including cpool - real(r8), pointer :: totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool - real(r8), pointer :: prev_frootc_to_litter(:)!previous timestep froot C litterfall flux (gC/m2/s) - real(r8), pointer :: prev_leafc_to_litter(:) !previous timestep leaf C litterfall flux (gC/m2/s) - real(r8), pointer :: dispvegn(:) ! (gN/m2) displayed veg nitrogen, excluding storage - real(r8), pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation - real(r8), pointer :: storvegn(:) ! (gN/m2) stored vegetation nitrogen - real(r8), pointer :: totpftn(:) ! (gN/m2) total pft-level nitrogen - real(r8), pointer :: totvegn(:) ! (gN/m2) total vegetation nitrogen - !!! C13 - real(r8), pointer :: cwdc13(:) ! (gC/m2) coarse woody debris C - real(r8), pointer :: decomp_c13pools(:,:) ! (gC/m2) decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_c13pools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_c13pools_1m(:,:) ! (gC/m2) Diagnostic: decomposing (litter, cwd, soil) c pools to 1 meter - real(r8), pointer :: c13_col_ctrunc_vr(:,:) ! (gC/m3) C truncation term - real(r8), pointer :: leafc13(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc13_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc13_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: frootc13(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc13_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc13_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livestemc13(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc13_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc13_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: deadstemc13(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc13_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc13_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: livecrootc13(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc13_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc13_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: deadcrootc13(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc13_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc13_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: c13_gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: c13_gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: c13pool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: c13xsmrpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: c13_pft_ctrunc(:) ! (gC/m2) C truncation term - real(r8), pointer :: totvegc13(:) ! (gC/m2) total vegetation carbon, excluding cpool - - !!! C14 - real(r8), pointer :: cwdc14(:) ! (gC/m2) coarse woody debris C - real(r8), pointer :: decomp_c14pools(:,:) ! (gC/m2) decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_c14pools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_c14pools_1m(:,:) ! (gC/m2) Diagnostic: decomposing (litter, cwd, soil) c pools to 1 meter - real(r8), pointer :: c14_col_ctrunc_vr(:,:) ! (gC/m3) C truncation term - real(r8), pointer :: leafc14(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc14_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc14_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: frootc14(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc14_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc14_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livestemc14(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc14_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc14_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: deadstemc14(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc14_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc14_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: livecrootc14(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc14_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc14_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: deadcrootc14(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc14_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc14_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: c14_gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: c14_gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: c14pool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: c14xsmrpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: c14_pft_ctrunc(:) ! (gC/m2) C truncation term - real(r8), pointer :: totvegc14(:) ! (gC/m2) total vegetation carbon, excluding cpool - real(r8), pointer :: rc14_atm(:) !C14O2/C12O2 in atmosphere - - ! dynamic landuse variables - real(r8), pointer :: seedc(:) ! (gC/m2) column-level pool for seeding new PFTs - real(r8), pointer :: prod10c(:) ! (gC/m2) wood product C pool, 10-year lifespan - real(r8), pointer :: prod100c(:) ! (gC/m2) wood product C pool, 100-year lifespan - real(r8), pointer :: totprodc(:) ! (gC/m2) total wood product C - - !!! C13 - real(r8), pointer :: seedc13(:) ! (gC/m2) column-level pool for seeding new PFTs - real(r8), pointer :: prod10c13(:) ! (gC/m2) wood product C13 pool, 10-year lifespan - real(r8), pointer :: prod100c13(:) ! (gC/m2) wood product C13 pool, 100-year lifespan - real(r8), pointer :: totprodc13(:) ! (gC/m2) total wood product C13 - !!! C14 - real(r8), pointer :: seedc14(:) ! (gC/m2) column-level pool for seeding new PFTs - real(r8), pointer :: prod10c14(:) ! (gC/m2) wood product C14 pool, 10-year lifespan - real(r8), pointer :: prod100c14(:) ! (gC/m2) wood product C14 pool, 100-year lifespan - real(r8), pointer :: totprodc14(:) ! (gC/m2) total wood product C14 - - real(r8), pointer :: seedn(:) ! (gN/m2) column-level pool for seeding new PFTs - real(r8), pointer :: prod10n(:) ! (gN/m2) wood product N pool, 10-year lifespan - real(r8), pointer :: prod100n(:) ! (gN/m2) wood product N pool, 100-year lifespan - real(r8), pointer :: totprodn(:) ! (gN/m2) total wood product N - real(r8), pointer :: initial_cn_ratio(:) ! c:n ratio for initialization of pools - real(r8), pointer :: initial_stock(:) ! initial concentration for seeding at spinup - - ! crop - real(r8), pointer :: fert_counter(:) - real(r8), pointer :: fert(:) - real(r8), pointer :: soyfixn(:) - real(r8), pointer :: grain_flag(:) -! -! !LOCAL VARIABLES: - integer :: g,l,c,p,j,k ! indices - integer :: begp, endp ! per-clump/proc beginning and ending pft indices - integer :: begc, endc ! per-clump/proc beginning and ending column indices - integer :: begl, endl ! per-clump/proc beginning and ending landunit indices - integer :: begg, endg ! per-clump/proc gridcell ending gridcell indices - -!EOP -!----------------------------------------------------------------------- - - ! assign local pointers at the gridcell level - - ! assign local pointers at the landunit level - itypelun => lun%itype - - ! assign local pointers at the column level - clandunit =>col%landunit - annsum_counter => cps%annsum_counter - cannsum_npp => cps%cannsum_npp - cannavg_t2m => cps%cannavg_t2m - - !fire related variables changed by F. Li and S. Levis - wf => cps%wf - wf2 => cps%wf2 - nfire => cps%nfire - baf_crop => cps%baf_crop - baf_peatf => cps%baf_peatf - fbac => cps%fbac - fbac1 => cps%fbac1 - farea_burned => cps%farea_burned - - qflx_drain => cwf%qflx_drain - qflx_surf => cwf%qflx_surf - decomp_cpools => ccs%decomp_cpools - decomp_cpools_1m => ccs%decomp_cpools_1m - decomp_cpools_vr => ccs%decomp_cpools_vr - decomp_npools => cns%decomp_npools - decomp_npools_vr => cns%decomp_npools_vr - decomp_npools_1m => cns%decomp_npools_1m - nfixation_prof => cps%nfixation_prof - ndep_prof => cps%ndep_prof - qflx_irrig => cwf%qflx_irrig - - ! dynamic landuse variables - seedc => ccs%seedc - prod10c => ccs%prod10c - prod100c => ccs%prod100c - totprodc => ccs%totprodc - seedn => cns%seedn - prod10n => cns%prod10n - prod100n => cns%prod100n - totprodn => cns%totprodn - sminn => cns%sminn - col_ctrunc => ccs%col_ctrunc - sminn_vr => cns%sminn_vr - col_ctrunc_vr => ccs%col_ctrunc_vr - col_ntrunc_vr => cns%col_ntrunc_vr - - fpi_vr => cps%fpi_vr - alt => cps%alt - altmax => cps%altmax - altmax_lastyear => cps%altmax_lastyear - som_adv_coef => cps%som_adv_coef - som_diffus_coef => cps%som_diffus_coef - alt_indx => cps%alt_indx - altmax_indx => cps%altmax_indx - altmax_lastyear_indx => cps%altmax_lastyear_indx -#ifdef NITRIF_DENITRIF - smin_nh4_vr => cns%smin_nh4_vr - smin_no3_vr => cns%smin_no3_vr - smin_nh4 => cns%smin_nh4 - smin_no3 => cns%smin_no3 -#endif - - totcolc => ccs%totcolc - cwdc => ccs%cwdc - totecosysc => ccs%totecosysc - totlitc => ccs%totlitc - totsomc => ccs%totsomc - totlitc_1m => ccs%totlitc_1m - totsomc_1m => ccs%totsomc_1m - - totcoln => cns%totcoln - cwdn => cns%cwdn - totecosysn => cns%totecosysn - totlitn => cns%totlitn - totsomn => cns%totsomn - totlitn_1m => cns%totlitn_1m - totsomn_1m => cns%totsomn_1m -! if ( use_c13 ) then -! seedc13 => cc13s%seedc -! prod10c13 => cc13s%prod10c -! prod100c13 => cc13s%prod100c -! totprodc13 => cc13s%totprodc -! cwdc13 => cc13s%cwdc -! decomp_c13pools => cc13s%decomp_cpools -! decomp_c13pools_vr => cc13s%decomp_cpools_vr -! c13_col_ctrunc_vr => cc13s%col_ctrunc_vr -! decomp_c13pools_1m => cc13s%decomp_cpools_1m -! c13_psnsun => pc13f%psnsun -! c13_psnsha => pc13f%psnsha -! xsmrpool_c13ratio => pepv%xsmrpool_c13ratio -! alphapsnsun => pps%alphapsnsun -! alphapsnsha => pps%alphapsnsha -! leafc13 => pc13s%leafc -! leafc13_storage => pc13s%leafc_storage -! leafc13_xfer => pc13s%leafc_xfer -! frootc13 => pc13s%frootc -! frootc13_storage => pc13s%frootc_storage -! frootc13_xfer => pc13s%frootc_xfer -! livestemc13 => pc13s%livestemc -! livestemc13_storage => pc13s%livestemc_storage -! livestemc13_xfer => pc13s%livestemc_xfer -! deadstemc13 => pc13s%deadstemc -! deadstemc13_storage => pc13s%deadstemc_storage -! deadstemc13_xfer => pc13s%deadstemc_xfer -! livecrootc13 => pc13s%livecrootc -! livecrootc13_storage => pc13s%livecrootc_storage -! livecrootc13_xfer => pc13s%livecrootc_xfer -! deadcrootc13 => pc13s%deadcrootc -! deadcrootc13_storage => pc13s%deadcrootc_storage -! deadcrootc13_xfer => pc13s%deadcrootc_xfer -! c13_gresp_storage => pc13s%gresp_storage -! c13_gresp_xfer => pc13s%gresp_xfer -! c13pool => pc13s%cpool -! c13xsmrpool => pc13s%xsmrpool -! c13_pft_ctrunc => pc13s%pft_ctrunc -! totvegc13 => pc13s%totvegc -! rc13_canair => pepv%rc13_canair -! rc13_psnsun => pepv%rc13_psnsun -! rc13_psnsha => pepv%rc13_psnsha -! endif -! if ( use_c14 ) then -! seedc14 => cc14s%seedc -! prod10c14 => cc14s%prod10c -! prod100c14 => cc14s%prod100c -! totprodc14 => cc14s%totprodc -! cwdc14 => cc14s%cwdc -! decomp_c14pools => cc14s%decomp_cpools -! decomp_c14pools_vr => cc14s%decomp_cpools_vr -! c14_col_ctrunc_vr => cc14s%col_ctrunc_vr -! decomp_c14pools_1m => cc14s%decomp_cpools_1m -! c14_psnsun => pc14f%psnsun -! c14_psnsha => pc14f%psnsha -! leafc14 => pc14s%leafc -! leafc14_storage => pc14s%leafc_storage -! leafc14_xfer => pc14s%leafc_xfer -! frootc14 => pc14s%frootc -! frootc14_storage => pc14s%frootc_storage -! frootc14_xfer => pc14s%frootc_xfer -! livestemc14 => pc14s%livestemc -! livestemc14_storage => pc14s%livestemc_storage -! livestemc14_xfer => pc14s%livestemc_xfer -! deadstemc14 => pc14s%deadstemc -! deadstemc14_storage => pc14s%deadstemc_storage -! deadstemc14_xfer => pc14s%deadstemc_xfer -! livecrootc14 => pc14s%livecrootc -! livecrootc14_storage => pc14s%livecrootc_storage -! livecrootc14_xfer => pc14s%livecrootc_xfer -! deadcrootc14 => pc14s%deadcrootc -! deadcrootc14_storage => pc14s%deadcrootc_storage -! deadcrootc14_xfer => pc14s%deadcrootc_xfer -! c14_gresp_storage => pc14s%gresp_storage -! c14_gresp_xfer => pc14s%gresp_xfer -! c14pool => pc14s%cpool -! c14xsmrpool => pc14s%xsmrpool -! c14_pft_ctrunc => pc14s%pft_ctrunc -! totvegc14 => pc14s%totvegc -! rc14_atm => pepv%rc14_atm -! endif - ! crop - soyfixn => pnf%soyfixn - fert => pnf%fert - fert_counter => pepv%fert_counter - grain_flag => pepv%grain_flag - ! assign local pointers at the pft level - ivt =>pft%itype - plandunit =>pft%landunit - leafc => pcs%leafc - leafc_storage => pcs%leafc_storage - leafc_xfer => pcs%leafc_xfer - grainc => pcs%grainc - grainc_storage => pcs%grainc_storage - grainc_xfer => pcs%grainc_xfer - frootc => pcs%frootc - frootc_storage => pcs%frootc_storage - frootc_xfer => pcs%frootc_xfer - livestemc => pcs%livestemc - livestemc_storage => pcs%livestemc_storage - livestemc_xfer => pcs%livestemc_xfer - deadstemc => pcs%deadstemc - deadstemc_storage => pcs%deadstemc_storage - deadstemc_xfer => pcs%deadstemc_xfer - livecrootc => pcs%livecrootc - livecrootc_storage => pcs%livecrootc_storage - livecrootc_xfer => pcs%livecrootc_xfer - deadcrootc => pcs%deadcrootc - deadcrootc_storage => pcs%deadcrootc_storage - deadcrootc_xfer => pcs%deadcrootc_xfer - gresp_storage => pcs%gresp_storage - gresp_xfer => pcs%gresp_xfer - cpool => pcs%cpool - xsmrpool => pcs%xsmrpool - forc_hgt_u_pft => pps%forc_hgt_u_pft - woodc => pcs%woodc - leafn => pns%leafn - leafn_storage => pns%leafn_storage - leafn_xfer => pns%leafn_xfer - grainn => pns%grainn - grainn_storage => pns%grainn_storage - grainn_xfer => pns%grainn_xfer - frootn => pns%frootn - frootn_storage => pns%frootn_storage - frootn_xfer => pns%frootn_xfer - livestemn => pns%livestemn - livestemn_storage => pns%livestemn_storage - livestemn_xfer => pns%livestemn_xfer - deadstemn => pns%deadstemn - deadstemn_storage => pns%deadstemn_storage - deadstemn_xfer => pns%deadstemn_xfer - livecrootn => pns%livecrootn - livecrootn_storage => pns%livecrootn_storage - livecrootn_xfer => pns%livecrootn_xfer - deadcrootn => pns%deadcrootn - deadcrootn_storage => pns%deadcrootn_storage - deadcrootn_xfer => pns%deadcrootn_xfer - retransn => pns%retransn - npool => pns%npool - psnsun => pcf%psnsun - psnsha => pcf%psnsha - laisun => pps%laisun - laisha => pps%laisha - dormant_flag => pepv%dormant_flag - days_active => pepv%days_active - onset_flag => pepv%onset_flag - onset_counter => pepv%onset_counter - onset_gddflag => pepv%onset_gddflag - onset_fdd => pepv%onset_fdd - onset_gdd => pepv%onset_gdd - onset_swi => pepv%onset_swi - offset_flag => pepv%offset_flag - offset_counter => pepv%offset_counter - offset_fdd => pepv%offset_fdd - offset_swi => pepv%offset_swi - lgsf => pepv%lgsf - bglfr => pepv%bglfr - bgtr => pepv%bgtr - dayl => pepv%dayl - prev_dayl => pepv%prev_dayl - annavg_t2m => pepv%annavg_t2m - tempavg_t2m => pepv%tempavg_t2m - gpp => pepv%gpp - availc => pepv%availc - xsmrpool_recover => pepv%xsmrpool_recover - alloc_pnow => pepv%alloc_pnow - c_allometry => pepv%c_allometry - n_allometry => pepv%n_allometry - plant_ndemand => pepv%plant_ndemand - tempsum_potential_gpp => pepv%tempsum_potential_gpp - annsum_potential_gpp => pepv%annsum_potential_gpp - tempmax_retransn => pepv%tempmax_retransn - annmax_retransn => pepv%annmax_retransn - avail_retransn => pepv%avail_retransn - plant_nalloc => pepv%plant_nalloc - plant_calloc => pepv%plant_calloc - excess_cflux => pepv%excess_cflux - downreg => pepv%downreg - tempsum_npp => pepv%tempsum_npp - annsum_npp => pepv%annsum_npp -#if (defined CNDV) - tempsum_litfall => pepv%tempsum_litfall - annsum_litfall => pepv%annsum_litfall -#endif - dispvegc => pcs%dispvegc - pft_ctrunc => pcs%pft_ctrunc - storvegc => pcs%storvegc - totpftc => pcs%totpftc - totvegc => pcs%totvegc - prev_frootc_to_litter => pepv%prev_frootc_to_litter - prev_leafc_to_litter => pepv%prev_leafc_to_litter - dispvegn => pns%dispvegn - pft_ntrunc => pns%pft_ntrunc - storvegn => pns%storvegn - totpftn => pns%totpftn - totvegn => pns%totvegn - - ! assign local pointers for ecophysiological constants - evergreen => pftcon%evergreen - woody => pftcon%woody - leafcn => pftcon%leafcn - deadwdcn => pftcon%deadwdcn - ! decomposoition parameters - initial_cn_ratio => decomp_cascade_con%initial_cn_ratio - initial_stock => decomp_cascade_con%initial_stock - - ! Determine subgrid bounds on this processor -! call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) ! fzeng, followed what gkw did before - - ! Added 5/4/04, PET: initialize forc_hgt_u (gridcell-level), - ! since this is not initialized before first call to CNVegStructUpdate, - ! and it is required to set the upper bound for canopy top height. - ! Changed 3/21/08, KO: still needed but don't have sufficient information - ! to set this properly (e.g., pft-level displacement height and roughness - ! length). So leave at 30m. - do p = begp, endp - forc_hgt_u_pft(p) = 30._r8 - end do - - ! initialize column-level variables - do c = begc, endc - l = clandunit(c) - if (itypelun(l) == istsoil .or. itypelun(l) == istcrop) then - - ! column physical state variables - annsum_counter(c) = 0._r8 - cannsum_npp(c) = 0._r8 - cannavg_t2m(c) = 280._r8 - ! fire related variables changed by F. Li and S. Levis - wf(c) = 1.0_r8 ! it needs to be non zero so the first time step has no fires - wf2(c) = 1.0_r8 - nfire(c) = 0._r8 - baf_crop(c) = 0._r8 - baf_peatf(c) = 0._r8 - fbac(c) = 0._r8 - fbac1(c) = 0._r8 - farea_burned(c) = 0._r8 - - - ! needed for CNNLeaching - qflx_drain(c) = 0._r8 - qflx_surf(c) = 0._r8 - qflx_irrig(c) = 0._r8 - - ! column carbon state variable initialization - do j = 1, nlevdecomp - do k = 1, ndecomp_pools - if (zsoi(j) .lt. 0.3 ) then !! only initialize upper soil column - decomp_cpools_vr(c,j,k) = initial_stock(k) - else - decomp_cpools_vr(c,j,k) = 0._r8 - endif - end do - col_ctrunc_vr(c,j) = 0._r8 - end do - if ( nlevdecomp .gt. 1 ) then - do j = nlevdecomp+1, nlevdecomp_full - do k = 1, ndecomp_pools - decomp_cpools_vr(c,j,k) = 0._r8 - end do - col_ctrunc_vr(c,j) = 0._r8 - end do - end if - do k = 1, ndecomp_pools - decomp_cpools(c,k) = initial_stock(k) - decomp_cpools_1m(c,k) = initial_stock(k) - end do - - do j = 1, nlevdecomp_full - ! initialize fpi_vr so that levels below nlevsoi are not nans - fpi_vr(c,j) = 0._r8 - som_adv_coef(c,j) = 0._r8 - som_diffus_coef(c,j) = 0._r8 - ! here initialize the profiles for converting to vertically resolved carbon pools - nfixation_prof(c,j) = 0._r8 - ndep_prof(c,j) = 0._r8 - end do - - ! and define alt variables to be zero - alt(c) = 0._r8 - altmax(c) = 0._r8 - altmax_lastyear(c) = 0._r8 - alt_indx(c) = 0 - altmax_indx(c) = 0 - altmax_lastyear_indx(c) = 0 - - cwdc(c) = 0._r8 - col_ctrunc(c) = 0._r8 - totlitc(c) = 0._r8 - totsomc(c) = 0._r8 - totlitc_1m(c) = 0._r8 - totsomc_1m(c) = 0._r8 - totecosysc(c) = 0._r8 - totcolc(c) = 0._r8 - -! if ( use_c13 ) then -! do j = 1, nlevdecomp -! do k = 1, ndecomp_pools -! decomp_c13pools_vr(c,j,k) = decomp_cpools_vr(c,j,k) * c13ratio -! end do -! c13_col_ctrunc_vr(c,j) = col_ctrunc_vr(c,j) * c13ratio -! end do -! if ( nlevdecomp .gt. 1 ) then -! do j = nlevdecomp+1, nlevdecomp_full -! do k = 1, ndecomp_pools -! decomp_c13pools_vr(c,j,k) = 0._r8 -! end do -! c13_col_ctrunc_vr(c,j) = 0._r8 -! end do -! end if -! cwdc13(c) = cwdc(c) * c13ratio -! do k = 1, ndecomp_pools -! decomp_c13pools(c,k) = decomp_cpools(c,k) * c13ratio -! decomp_c13pools_1m(c,k) = decomp_cpools_1m(c,k) * c13ratio -! end do -! endif - -! if ( use_c14 ) then -! do j = 1, nlevdecomp -! do k = 1, ndecomp_pools -! decomp_c14pools_vr(c,j,k) = decomp_cpools_vr(c,j,k) * c14ratio -! end do -! c14_col_ctrunc_vr(c,j) = col_ctrunc_vr(c,j) * c14ratio -! end do -! if ( nlevdecomp .gt. 1 ) then -! do j = nlevdecomp+1, nlevdecomp_full -! do k = 1, ndecomp_pools -! decomp_c14pools_vr(c,j,k) = 0._r8 -! end do -! c14_col_ctrunc_vr(c,j) = 0._r8 -! end do -! end if -! cwdc14(c) = cwdc(c) * c14ratio -! do k = 1, ndecomp_pools -! decomp_c14pools(c,k) = decomp_cpools(c,k) * c14ratio -! decomp_c14pools_1m(c,k) = decomp_cpools_1m(c,k) * c14ratio -! end do -! endif - - ! column nitrogen state variables - sminn(c) = 0._r8 - do j = 1, nlevdecomp - do k = 1, ndecomp_pools - decomp_npools_vr(c,j,k) = decomp_cpools_vr(c,j,k) / initial_cn_ratio(k) - end do - sminn_vr(c,j) = 0._r8 - col_ntrunc_vr(c,j) = 0._r8 - end do - if ( nlevdecomp .gt. 1 ) then - do j = nlevdecomp+1, nlevdecomp_full - do k = 1, ndecomp_pools - decomp_npools_vr(c,j,k) = 0._r8 - end do - sminn_vr(c,j) = 0._r8 - col_ntrunc_vr(c,j) = 0._r8 - end do - end if - do k = 1, ndecomp_pools - decomp_npools(c,k) = decomp_cpools(c,k) / initial_cn_ratio(k) - decomp_npools_1m(c,k) = decomp_cpools_1m(c,k) / initial_cn_ratio(k) - end do - -#ifdef NITRIF_DENITRIF - do j = 1, nlevdecomp_full - smin_nh4_vr(c,j) = 0._r8 - smin_no3_vr(c,j) = 0._r8 - end do - smin_nh4(c) = 0._r8 - smin_no3(c) = 0._r8 -#endif - totlitn(c) = 0._r8 - totsomn(c) = 0._r8 - totlitn_1m(c) = 0._r8 - totsomn_1m(c) = 0._r8 - totecosysn(c) = 0._r8 - totcoln(c) = 0._r8 - cwdn(c) = 0._r8 - - ! dynamic landcover state variables - seedc(c) = 0._r8 - prod10c(c) = 0._r8 - prod100c(c) = 0._r8 - totprodc(c) = 0._r8 - -! if ( use_c13 ) then -! seedc13(c) = 0._r8 -! prod10c13(c) = 0._r8 -! prod100c13(c) = 0._r8 -! totprodc13(c) = 0._r8 -! endif - -! if ( use_c14 ) then -! seedc14(c) = 0._r8 -! prod10c14(c) = 0._r8 -! prod100c14(c) = 0._r8 -! totprodc14(c) = 0._r8 -! endif - - seedn(c) = 0._r8 - prod10n(c) = 0._r8 - prod100n(c) = 0._r8 - totprodn(c) = 0._r8 - - ! also initialize dynamic landcover fluxes so that they have - ! real values on first timestep, prior to calling pftdyn_cnbal - ccf%dwt_seedc_to_leaf(c) = 0._r8 - ccf%dwt_seedc_to_deadstem(c) = 0._r8 - ccf%dwt_conv_cflux(c) = 0._r8 - ccf%lf_conv_cflux(c) = 0._r8 - ccf%dwt_prod10c_gain(c) = 0._r8 - ccf%prod10c_loss(c) = 0._r8 - ccf%dwt_prod100c_gain(c) = 0._r8 - ccf%prod100c_loss(c) = 0._r8 - do j = 1, nlevdecomp_full - ccf%dwt_frootc_to_litr_met_c(c,j) = 0._r8 - ccf%dwt_frootc_to_litr_cel_c(c,j) = 0._r8 - ccf%dwt_frootc_to_litr_lig_c(c,j) = 0._r8 - ccf%dwt_livecrootc_to_cwdc(c,j) = 0._r8 - ccf%dwt_deadcrootc_to_cwdc(c,j) = 0._r8 - end do - ccf%dwt_closs(c) = 0._r8 - -! if ( use_c13 ) then -! cc13f%dwt_seedc_to_leaf(c) = 0._r8 -! cc13f%dwt_seedc_to_deadstem(c) = 0._r8 -! cc13f%dwt_conv_cflux(c) = 0._r8 -! cc13f%dwt_prod10c_gain(c) = 0._r8 -! cc13f%prod10c_loss(c) = 0._r8 -! cc13f%dwt_prod100c_gain(c) = 0._r8 -! cc13f%prod100c_loss(c) = 0._r8 -! do j = 1, nlevdecomp_full -! cc13f%dwt_frootc_to_litr_met_c(c,j) = 0._r8 -! cc13f%dwt_frootc_to_litr_cel_c(c,j) = 0._r8 -! cc13f%dwt_frootc_to_litr_lig_c(c,j) = 0._r8 -! cc13f%dwt_livecrootc_to_cwdc(c,j) = 0._r8 -! cc13f%dwt_deadcrootc_to_cwdc(c,j) = 0._r8 -! end do -! cc13f%dwt_closs(c) = 0._r8 -! endif -! -! if ( use_c14 ) then -! cc14f%dwt_seedc_to_leaf(c) = 0._r8 -! cc14f%dwt_seedc_to_deadstem(c) = 0._r8 -! cc14f%dwt_conv_cflux(c) = 0._r8 -! cc14f%dwt_prod10c_gain(c) = 0._r8 -! cc14f%prod10c_loss(c) = 0._r8 -! cc14f%dwt_prod100c_gain(c) = 0._r8 -! cc14f%prod100c_loss(c) = 0._r8 -! do j = 1, nlevdecomp_full -! cc14f%dwt_frootc_to_litr_met_c(c,j) = 0._r8 -! cc14f%dwt_frootc_to_litr_cel_c(c,j) = 0._r8 -! cc14f%dwt_frootc_to_litr_lig_c(c,j) = 0._r8 -! cc14f%dwt_livecrootc_to_cwdc(c,j) = 0._r8 -! cc14f%dwt_deadcrootc_to_cwdc(c,j) = 0._r8 -! end do -! cc14f%dwt_closs(c) = 0._r8 -! endif - - cnf%dwt_seedn_to_leaf(c) = 0._r8 - cnf%dwt_seedn_to_deadstem(c) = 0._r8 - cnf%dwt_conv_nflux(c) = 0._r8 - cnf%dwt_prod10n_gain(c) = 0._r8 - cnf%prod10n_loss(c) = 0._r8 - cnf%dwt_prod100n_gain(c) = 0._r8 - cnf%prod100n_loss(c) = 0._r8 - do j = 1, nlevdecomp_full - cnf%dwt_frootn_to_litr_met_n(c,j) = 0._r8 - cnf%dwt_frootn_to_litr_cel_n(c,j) = 0._r8 - cnf%dwt_frootn_to_litr_lig_n(c,j) = 0._r8 - cnf%dwt_livecrootn_to_cwdn(c,j) = 0._r8 - cnf%dwt_deadcrootn_to_cwdn(c,j) = 0._r8 - end do - cnf%dwt_nloss(c) = 0._r8 - end if - end do - - ! initialize pft-level variables - do p = begp, endp - l = plandunit(p) - if (itypelun(l) == istsoil .or. itypelun(l) == istcrop) then - - ! carbon state variables - if (ivt(p) == noveg) then - leafc(p) = 0._r8 - leafc_storage(p) = 0._r8 - else - if (evergreen(ivt(p)) == 1._r8) then - leafc(p) = 1._r8 - leafc_storage(p) = 0._r8 - else if (ivt(p) >= npcropmin) then ! prognostic crop types - leafc(p) = 0._r8 - leafc_storage(p) = 0._r8 - else - leafc(p) = 0._r8 - leafc_storage(p) = 1._r8 - end if - end if - leafc_xfer(p) = 0._r8 - if ( crop_prog )then - grainc(p) = 0._r8 - grainc_storage(p) = 0._r8 - grainc_xfer(p) = 0._r8 - fert(p) = 0._r8 - soyfixn(p) = 0._r8 - end if - frootc(p) = 0._r8 - frootc_storage(p) = 0._r8 - frootc_xfer(p) = 0._r8 - livestemc(p) = 0._r8 - livestemc_storage(p) = 0._r8 - livestemc_xfer(p) = 0._r8 - - ! tree types need to be initialized with some stem mass so that - ! roughness length is not zero in canopy flux calculation - - if (woody(ivt(p)) == 1._r8) then - deadstemc(p) = 0.1_r8 - else - deadstemc(p) = 0._r8 - end if - - deadstemc_storage(p) = 0._r8 - deadstemc_xfer(p) = 0._r8 - livecrootc(p) = 0._r8 - livecrootc_storage(p) = 0._r8 - livecrootc_xfer(p) = 0._r8 - deadcrootc(p) = 0._r8 - deadcrootc_storage(p) = 0._r8 - deadcrootc_xfer(p) = 0._r8 - gresp_storage(p) = 0._r8 - gresp_xfer(p) = 0._r8 - cpool(p) = 0._r8 - xsmrpool(p) = 0._r8 - pft_ctrunc(p) = 0._r8 - dispvegc(p) = 0._r8 - storvegc(p) = 0._r8 - totpftc(p) = 0._r8 - ! calculate totvegc explicitly so that it is available for the isotope - ! code on the first time step. - totvegc(p) = leafc(p) + leafc_storage(p) + leafc_xfer(p) + frootc(p) + & - frootc_storage(p) + frootc_xfer(p) + livestemc(p) + livestemc_storage(p) + & - livestemc_xfer(p) + deadstemc(p) + deadstemc_storage(p) + deadstemc_xfer(p) + & - livecrootc(p) + livecrootc_storage(p) + livecrootc_xfer(p) + deadcrootc(p) + & - deadcrootc_storage(p) + deadcrootc_xfer(p) + gresp_storage(p) + & - gresp_xfer(p) + cpool(p) - - if ( crop_prog )then - totvegc(p) = totvegc(p) + grainc(p) + grainc_storage(p) + grainc_xfer(p) - end if - - woodc(p) = 0._r8 - - -! if ( use_c13 ) then -! leafc13(p) = leafc(p) * c13ratio -! leafc13_storage(p) = leafc_storage(p) * c13ratio -! leafc13_xfer(p) = leafc_xfer(p) * c13ratio -! frootc13(p) = frootc(p) * c13ratio -! frootc13_storage(p) = frootc_storage(p) * c13ratio -! frootc13_xfer(p) = frootc_xfer(p) * c13ratio -! livestemc13(p) = livestemc(p) * c13ratio -! livestemc13_storage(p) = livestemc_storage(p) * c13ratio -! livestemc13_xfer(p) = livestemc_xfer(p) * c13ratio -! deadstemc13(p) = deadstemc(p) * c13ratio -! deadstemc13_storage(p) = deadstemc_storage(p) * c13ratio -! deadstemc13_xfer(p) = deadstemc_xfer(p) * c13ratio -! livecrootc13(p) = livecrootc(p) * c13ratio -! livecrootc13_storage(p) = livecrootc_storage(p) * c13ratio -! livecrootc13_xfer(p) = livecrootc_xfer(p) * c13ratio -! deadcrootc13(p) = deadcrootc(p) * c13ratio -! deadcrootc13_storage(p) = deadcrootc_storage(p) * c13ratio -! deadcrootc13_xfer(p) = deadcrootc_xfer(p) * c13ratio -! c13_gresp_storage(p) = gresp_storage(p) * c13ratio -! c13_gresp_xfer(p) = gresp_xfer(p) * c13ratio -! c13pool(p) = cpool(p) * c13ratio -! c13xsmrpool(p) = xsmrpool(p) * c13ratio -! c13_pft_ctrunc(p) = pft_ctrunc(p) * c13ratio -! -! ! calculate totvegc explicitly so that it is available for the isotope -! ! code on the first time step. -! totvegc13(p) = leafc13(p) + leafc13_storage(p) + leafc13_xfer(p) + frootc13(p) + & -! frootc13_storage(p) + frootc13_xfer(p) + livestemc13(p) + livestemc13_storage(p) + & -! livestemc13_xfer(p) + deadstemc13(p) + deadstemc13_storage(p) + deadstemc13_xfer(p) + & -! livecrootc13(p) + livecrootc13_storage(p) + livecrootc13_xfer(p) + deadcrootc13(p) + & -! deadcrootc13_storage(p) + deadcrootc13_xfer(p) + c13_gresp_storage(p) + & -! c13_gresp_xfer(p) + c13pool(p) -! endif -! -! if ( use_c14 ) then -! leafc14(p) = leafc(p) * c14ratio -! leafc14_storage(p) = leafc_storage(p) * c14ratio -! leafc14_xfer(p) = leafc_xfer(p) * c14ratio -! frootc14(p) = frootc(p) * c14ratio -! frootc14_storage(p) = frootc_storage(p) * c14ratio -! frootc14_xfer(p) = frootc_xfer(p) * c14ratio -! livestemc14(p) = livestemc(p) * c14ratio -! livestemc14_storage(p) = livestemc_storage(p) * c14ratio -! livestemc14_xfer(p) = livestemc_xfer(p) * c14ratio -! deadstemc14(p) = deadstemc(p) * c14ratio -! deadstemc14_storage(p) = deadstemc_storage(p) * c14ratio -! deadstemc14_xfer(p) = deadstemc_xfer(p) * c14ratio -! livecrootc14(p) = livecrootc(p) * c14ratio -! livecrootc14_storage(p) = livecrootc_storage(p) * c14ratio -! livecrootc14_xfer(p) = livecrootc_xfer(p) * c14ratio -! deadcrootc14(p) = deadcrootc(p) * c14ratio -! deadcrootc14_storage(p) = deadcrootc_storage(p) * c14ratio -! deadcrootc14_xfer(p) = deadcrootc_xfer(p) * c14ratio -! c14_gresp_storage(p) = gresp_storage(p) * c14ratio -! c14_gresp_xfer(p) = gresp_xfer(p) * c14ratio -! c14pool(p) = cpool(p) * c14ratio -! c14xsmrpool(p) = xsmrpool(p) * c14ratio -! c14_pft_ctrunc(p) = pft_ctrunc(p) * c14ratio -! -! ! calculate totvegc explicitly so that it is available for the isotope -! ! code on the first time step. -! totvegc14(p) = leafc14(p) + leafc14_storage(p) + leafc14_xfer(p) + frootc14(p) + & -! frootc14_storage(p) + frootc14_xfer(p) + livestemc14(p) + livestemc14_storage(p) + & -! livestemc14_xfer(p) + deadstemc14(p) + deadstemc14_storage(p) + deadstemc14_xfer(p) + & -! livecrootc14(p) + livecrootc14_storage(p) + livecrootc14_xfer(p) + deadcrootc14(p) + & -! deadcrootc14_storage(p) + deadcrootc14_xfer(p) + c14_gresp_storage(p) + & -! c14_gresp_xfer(p) + c14pool(p) -! -! rc14_atm(p) = c14ratio -! endif - - ! nitrogen state variables - if (ivt(p) == noveg) then - leafn(p) = 0._r8 - leafn_storage(p) = 0._r8 - else - leafn(p) = leafc(p) / leafcn(ivt(p)) - leafn_storage(p) = leafc_storage(p) / leafcn(ivt(p)) - end if - - leafn_xfer(p) = 0._r8 - if ( crop_prog )then - grainn(p) = 0._r8 - grainn_storage(p) = 0._r8 - grainn_xfer(p) = 0._r8 - end if - frootn(p) = 0._r8 - frootn_storage(p) = 0._r8 - frootn_xfer(p) = 0._r8 - livestemn(p) = 0._r8 - livestemn_storage(p) = 0._r8 - livestemn_xfer(p) = 0._r8 - - ! tree types need to be initialized with some stem mass so that - ! roughness length is not zero in canopy flux calculation - - if (woody(ivt(p)) == 1._r8) then - deadstemn(p) = deadstemc(p) / deadwdcn(ivt(p)) - else - deadstemn(p) = 0._r8 - end if - - deadstemn_storage(p) = 0._r8 - deadstemn_xfer(p) = 0._r8 - livecrootn(p) = 0._r8 - livecrootn_storage(p) = 0._r8 - livecrootn_xfer(p) = 0._r8 - deadcrootn(p) = 0._r8 - deadcrootn_storage(p) = 0._r8 - deadcrootn_xfer(p) = 0._r8 - retransn(p) = 0._r8 - npool(p) = 0._r8 - pft_ntrunc(p) = 0._r8 - dispvegn(p) = 0._r8 - storvegn(p) = 0._r8 - totvegn(p) = 0._r8 - totpftn(p) = 0._r8 - - ! initialization for psnsun and psnsha required for - ! proper arbitrary initialization of allocation routine - ! in initial ecosysdyn call - - psnsun(p) = 0._r8 - psnsha(p) = 0._r8 - -! if ( use_c13 ) then -! c13_psnsun(p) = 0._r8 -! c13_psnsha(p) = 0._r8 -! endif -! -! if ( use_c14 ) then -! c14_psnsun(p) = 0._r8 -! c14_psnsha(p) = 0._r8 -! endif - - laisun(p) = 0._r8 - laisha(p) = 0._r8 - - ! ecophysiological variables - ! phenology variables - dormant_flag(p) = 1._r8 - days_active(p) = 0._r8 - onset_flag(p) = 0._r8 - onset_counter(p) = 0._r8 - onset_gddflag(p) = 0._r8 - onset_fdd(p) = 0._r8 - onset_gdd(p) = 0._r8 - onset_swi(p) = 0.0_r8 - offset_flag(p) = 0._r8 - offset_counter(p) = 0._r8 - offset_fdd(p) = 0._r8 - offset_swi(p) = 0._r8 - lgsf(p) = 0._r8 - bglfr(p) = 0._r8 - bgtr(p) = 0._r8 - annavg_t2m(p) = 280._r8 - tempavg_t2m(p) = 0._r8 - fert_counter(p) = 0._r8 - grain_flag(p) = 0._r8 - - ! non-phenology variables - gpp(p) = 0._r8 - availc(p) = 0._r8 - xsmrpool_recover(p) = 0._r8 - alloc_pnow(p) = 1._r8 - c_allometry(p) = 0._r8 - n_allometry(p) = 0._r8 - plant_ndemand(p) = 0._r8 - tempsum_potential_gpp(p) = 0._r8 - annsum_potential_gpp(p) = 0._r8 - tempmax_retransn(p) = 0._r8 - annmax_retransn(p) = 0._r8 - avail_retransn(p) = 0._r8 - plant_nalloc(p) = 0._r8 - plant_calloc(p) = 0._r8 - excess_cflux(p) = 0._r8 - downreg(p) = 0._r8 - prev_leafc_to_litter(p) = 0._r8 - prev_frootc_to_litter(p) = 0._r8 - tempsum_npp(p) = 0._r8 - annsum_npp(p) = 0._r8 -#if (defined CNDV) - tempsum_litfall(p) = 0._r8 - annsum_litfall(p) = 0._r8 -#endif - -! if ( use_c13 ) then -! xsmrpool_c13ratio(p) = c13ratio -! rc13_canair(p) = 0._r8 -! rc13_psnsun(p) = 0._r8 -! rc13_psnsha(p) = 0._r8 -! alphapsnsun(p) = 0._r8 -! alphapsnsha(p) = 0._r8 -! endif - - end if ! end of if-istsoil block - end do ! end of loop over pfts -!#endif - -end subroutine CNiniTimeVar 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 deleted file mode 100644 index 7d01bcbbf..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/TridiagonalMod.F90 +++ /dev/null @@ -1,140 +0,0 @@ -module TridiagonalMod - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: TridiagonalMod -! -! !DESCRIPTION: -! Tridiagonal matrix solution -! -! !PUBLIC TYPES: - implicit none - save -! -! !PUBLIC MEMBER FUNCTIONS: - public :: Tridiagonal -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: Tridiagonal -! -! !INTERFACE: - subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, & - a, b, c, r, u) -! -! !DESCRIPTION: -! Tridiagonal matrix solution -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clmtype - use clm_varpar , only : nlevurb - use clm_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use clm_varctl , only : iulog -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: lbc, ubc ! lbinning and ubing column indices - integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices - integer , intent(in) :: jtop(lbc:ubc) ! top level for each column - integer , intent(in) :: numf ! filter dimension - integer , intent(in) :: filter(1:numf) ! filter - real(r8), intent(in) :: a(lbc:ubc, lbj:ubj) ! "a" left off diagonal of tridiagonal matrix - real(r8), intent(in) :: b(lbc:ubc, lbj:ubj) ! "b" diagonal column for tridiagonal matrix - real(r8), intent(in) :: c(lbc:ubc, lbj:ubj) ! "c" right off diagonal tridiagonal matrix - real(r8), intent(in) :: r(lbc:ubc, lbj:ubj) ! "r" forcing term of tridiagonal matrix - real(r8), intent(inout) :: u(lbc:ubc, lbj:ubj) ! solution -! local pointers to original implicit in arguments -! - integer , pointer :: ctype(:) ! column type - -! -! !CALLED FROM: -! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod -! subroutine SoilTemperature in module SoilTemperatureMod -! subroutine SoilWater in module HydrologyMod -! -! !REVISION HISTORY: -! 15 September 1999: Yongjiu Dai; Initial code -! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision -! 1 July 2003: Mariana Vertenstein; modified for vectorization -! -! -! !OTHER LOCAL VARIABLES: -!EOP -! - integer :: j,ci,fc !indices - real(r8) :: gam(lbc:ubc,lbj:ubj) !temporary - real(r8) :: bet(lbc:ubc) !temporary -!----------------------------------------------------------------------- - - ! Assign local pointers to derived subtypes components (column-level) - - ctype => col%itype - - ! 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 ((ctype(ci) == icol_sunwall .or. ctype(ci) == icol_shadewall & - .or. ctype(ci) == icol_roof) .and. j <= nlevurb) then - 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 - else if (ctype(ci) /= icol_sunwall .and. ctype(ci) /= icol_shadewall & - .and. ctype(ci) /= icol_roof) then - 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 if - end do - end do - - do j = ubj-1,lbj,-1 - do fc = 1,numf - ci = filter(fc) - if ((ctype(ci) == icol_sunwall .or. ctype(ci) == icol_shadewall & - .or. ctype(ci) == icol_roof) .and. j <= nlevurb-1) then - if (j >= jtop(ci)) then - u(ci,j) = u(ci,j) - gam(ci,j+1) * u(ci,j+1) - end if - else if (ctype(ci) /= icol_sunwall .and. ctype(ci) /= icol_shadewall & - .and. ctype(ci) /= icol_roof) then - if (j >= jtop(ci)) then - u(ci,j) = u(ci,j) - gam(ci,j+1) * u(ci,j+1) - end if - 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/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 deleted file mode 100644 index f321c8625..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_time_manager.F90 +++ /dev/null @@ -1,229 +0,0 @@ -module clm_time_manager - - use update_model_para4cn, only: curr_year,curr_month,curr_day,curr_dofyr,curr_hour,curr_min,curr_sec - use clm_varctl , only: iulog - - implicit none - private - -! Public methods - -! gkw: this is just to get code to compile - - public ::& - get_step_size, &! return step size in seconds - 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_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 - - is_end_curr_day, &! return true on last timestep in current day - is_restart ! return true if this is a restart run - -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 - -!========================================================================================= - -integer function get_nstep(istep) - - ! Return the timestep number. - - integer*8, optional, intent(in) :: istep - - integer, 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 - -!========================================================================================= - -integer function get_rad_step_size() - - ! Return the step size in seconds. - - get_rad_step_size = -999999999 ! gkw: to make sure this is not used - -end function get_rad_step_size - -!========================================================================================= - -subroutine get_curr_date(yr, mon, day, tod) - - ! 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) - - yr = curr_year - mon = curr_month - day = curr_day - tod = 3600*curr_hour + 60*curr_min + curr_sec - -end subroutine get_curr_date - -!========================================================================================= - -function get_curr_calday() - - ! Return calendar day at end of current timestep with optional offset. - ! Calendar day 1.0 = 0Z on Jan 1. - - 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_restart( ) - - ! Determine if it's a restart run - - is_restart = .false. - -end function is_restart - -end module clm_time_manager 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 deleted file mode 100644 index 695a957df..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varcon.F90 +++ /dev/null @@ -1,199 +0,0 @@ -module clm_varcon - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: clm_varcon -! -! !DESCRIPTION: -! Module containing various model constants -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - 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 - use clm_varpar , only: 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 :: spval = 1.e36_r8 ! special value for real data - integer , public, parameter :: ispval = -9999 ! special value for int data - - !!! C13 - real(r8), parameter :: preind_atm_del13c = -6.0 ! preindustrial value for atmospheric del13C - real(r8), parameter :: preind_atm_ratio = SHR_CONST_PDB + (preind_atm_del13c * SHR_CONST_PDB)/1000.0 ! 13C/12C - real(r8) :: c13ratio = preind_atm_ratio/(1.0+preind_atm_ratio) ! 13C/(12+13)C preind atmosphere - - !!! C14 - real(r8) :: c14ratio = 1.e-12_r8 - ! real(r8) :: c14ratio = 1._r8 ! debug lets set to 1 to try to avoid numerical errors - - integer, private :: i ! loop index - - -#ifdef NITRIF_DENITRIF - ! real(r8), parameter :: nitrif_n2o_loss_frac = 0.02_r8 !fraction of N lost as N2O in nitrification (Parton et al., 2001) - real(r8), parameter :: nitrif_n2o_loss_frac = 6.e-4_r8 !fraction of N lost as N2O in nitrification (Li et al., 2000) - real(r8), parameter :: frac_minrlztn_to_no3 = 0.2_r8 !fraction of N mineralized that is dieverted to the nitrification stream (Parton et al., 2001) -#endif - - - !------------------------------------------------------------------ - ! Initialize water type constants - !------------------------------------------------------------------ - - ! "land unit " types - ! 1 soil (includes vegetated landunits) - ! 2 land ice (glacier) - ! 3 deep lake - ! (DEPRECATED: New lake model has variable depth) 4 shallow lake - ! 5 wetland (swamp, marsh, etc.) - ! 6 urban - ! 7 land ice (glacier) with multiple elevation classes - ! 8 crop - - integer, parameter :: istsoil = 1 !soil landunit type - integer, parameter :: istice = 2 !land ice landunit type - integer, parameter :: istdlak = 3 !deep lake landunit type - ! Not used; now 3 is used for all lakes, which have variable depth. - integer, parameter :: istslak = 4 !shallow lake landunit type - integer, parameter :: istwet = 5 !wetland landunit type - integer, parameter :: isturb = 6 !urban landunit type - integer, parameter :: istice_mec = 7 !land ice (multiple elevation classes) landunit type - integer, parameter :: istcrop = 8 !crop landunit type - integer, parameter :: max_lunit = 8 !maximum value that lun%itype can have - !(i.e., largest value in the above list) - - ! urban column types - - integer, parameter :: icol_roof = 61 - integer, parameter :: icol_sunwall = 62 - integer, parameter :: icol_shadewall = 63 - integer, parameter :: icol_road_imperv = 64 - integer, parameter :: icol_road_perv = 65 - - !------------------------------------------------------------------ - ! Initialize miscellaneous radiation constants - !------------------------------------------------------------------ - - ! Lake Model Constants will be defined in SLakeCon. - - !------------------------------------------------------------------ - ! Soil depths are constants for now; lake depths can vary by gridcell - ! zlak and dzlak correspond to the default 50 m lake depth. - ! The values for the following arrays are set in routine iniTimeConst - !------------------------------------------------------------------ - - 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) - - !------------------------------------------------------------------ - ! (Non-tunable) Constants for the CH4 submodel (Tuneable constants in ch4varcon) - !------------------------------------------------------------------ - ! Note some of these constants are also used in CNNitrifDenitrifMod - - real(r8), parameter :: catomw = 12.011_r8 ! molar mass of C atoms (g/mol) - - real(r8) :: s_con(ngases,4) ! Schmidt # calculation constants (spp, #) - data (s_con(1,i),i=1,4) /1898_r8, -110.1_r8, 2.834_r8, -0.02791_r8/ ! CH4 - data (s_con(2,i),i=1,4) /1801_r8, -120.1_r8, 3.7818_r8, -0.047608_r8/ ! O2 - data (s_con(3,i),i=1,4) /1911_r8, -113.7_r8, 2.967_r8, -0.02943_r8/ ! CO2 - - real(r8) :: 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) :: 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 - - real(r8) :: c_h_inv(ngases) ! constant (K) for Henry's law (4.12, Wania) - data c_h_inv(1:3) /1600._r8, 1500._r8, 2400._r8/ ! CH4, O2, CO2 - real(r8) :: kh_theta(ngases) ! Henry's constant (L.atm/mol) at standard temperature (298K) - data kh_theta(1:3) /714.29_r8, 769.23_r8, 29.4_r8/ ! CH4, O2, CO2 - real(r8) :: kh_tbase = 298._r8 ! base temperature for calculation of Henry's constant (K) - -! !PUBLIC MEMBER FUNCTIONS: - public clm_varcon_init ! Initialze constants that need to be initialized - -! !REVISION HISTORY: -! Created by Mariana Vertenstein - -!EOP -!----------------------------------------------------------------------- -contains - -!------------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: clm_varcon_init -! -! !INTERFACE: - subroutine clm_varcon_init() -! -! !DESCRIPTION: -! This subroutine initializes constants in clm_varcon. MUST be called -! after the clm_varpar_init. -! -! !USES: -! -! !ARGUMENTS: - implicit none -! -! !REVISION HISTORY: -! Created by E. Kluzek -! -! -! !LOCAL VARIABLES: -! -!EOP -!------------------------------------------------------------------------------ - allocate( zsoi(1:nlevgrnd) ) - allocate( dzsoi(1:nlevgrnd) ) - allocate( zisoi(0:nlevgrnd) ) - allocate( dzsoi_decomp(1:nlevdecomp_full) ) - - !! Use this setting temporarily. Need to improve if VERTSOILC is turned on!! fzeng, 13 Mar 2017 - 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/GEOScatchCNCLM45_GridComp/CLM45/clm_varctl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varctl.F90 deleted file mode 100644 index 1bff24ede..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varctl.F90 +++ /dev/null @@ -1,316 +0,0 @@ -module clm_varctl - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: clm_varctl -! -! !DESCRIPTION: -! Module containing run control variables -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 -! -! !PUBLIC MEMBER FUNCTIONS: - implicit none - public :: set_clmvarctl ! Set variables - public :: clmvarctl_init ! Initialize and check values after namelist input - - private - save -! -! !PUBLIC TYPES: -! - integer, parameter, private :: iundef = -9999999 - integer, parameter, private :: rundef = -9999999._r8 -! -! Run control variables -! - character(len=256), public :: caseid = ' ' ! case id - character(len=256), public :: ctitle = ' ' ! case title - integer, public :: nsrest = iundef ! Type of run - integer, public, parameter :: nsrStartup = 0 ! Startup from initial conditions - integer, public, parameter :: nsrContinue = 1 ! Continue from restart files - integer, public, parameter :: nsrBranch = 2 ! Branch from restart files - logical, public :: brnch_retain_casename = .false. ! true => allow case name to remain the same for branch run - ! by default this is not allowed - logical, public :: noland = .false. ! true => no valid land points -- do NOT run - character(len=256), public :: hostname = ' ' ! Hostname of machine running on - character(len=256), public :: username = ' ' ! username of user running program - character(len=256), public :: source = "Community Land Model CLM4.0" ! description of this source - character(len=256), public :: version = " " ! version of program - character(len=256), public :: conventions = "CF-1.0" ! dataset conventions -! -! Unit Numbers -! - integer, public :: iulog = 6 ! "stdout" log file unit number, default is 6 -! -! Output NetCDF files -! - logical, public :: outnc_large_files = .true. ! large file support for output NetCDF files -! -! Run input files -! - character(len=256), public :: finidat = ' ' ! initial conditions file name - character(len=256), public :: fsurdat = ' ' ! surface data file name - character(len=256), public :: fatmgrid = ' ' ! atm grid file name - character(len=256), public :: fatmlndfrc = ' ' ! lnd frac file on atm grid - character(len=256), public :: fatmtopo = ' ' ! topography on atm grid - character(len=256), public :: flndtopo = ' ' ! topography on lnd grid - character(len=256), public :: fpftdyn = ' ' ! dynamic landuse dataset - character(len=256), public :: fpftcon = ' ' ! ASCII data file with PFT physiological constants - character(len=256), public :: nrevsn = ' ' ! restart data file name for branch run - character(len=256), public :: fsnowoptics = ' ' ! snow optical properties file name - character(len=256), public :: fsnowaging = ' ' ! snow aging parameters file name - -! -! Irrigate logic -! - logical, public :: irrigate = .false. ! do not irrigate by default - -! crop logic (moved from CLM4.5 surfrdMod.F90, fzeng, 17 Mar 2017) - logical, public :: crop_prog = .false. ! default is .false. in CLM4.5 - -! Landunit logic -! - logical, public :: create_crop_landunit = .false. ! true => separate crop landunit is not created by default - logical, public :: allocate_all_vegpfts = .false. ! true => allocate memory for all possible vegetated pfts on - ! vegetated landunit if at least one pft has nonzero weight -! -! BGC logic and datasets -! - character(len=16), public :: co2_type = 'constant' ! values of 'prognostic','diagnostic','constant' - integer, public :: spinup_state = 0 ! State of the model for the accelerated decomposition (AD) spinup. 0 (default) = normal model; 1 = AD SPINUP - logical, public :: override_bgc_restart_mismatch_dump = .false. ! used to override an error check on reading in restart files - -! -! Physics -! - integer, public :: subgridflag = 1 !use subgrid fluxes - logical, public :: wrtdia = .false. ! true => write global average diagnostics to std out - real(r8), public :: co2_ppmv = 355._r8 ! atmospheric CO2 molar ratio (by volume) (umol/mol) -#if (defined LCH4 && defined VERTSOILC) - logical, public :: anoxia = .true. ! true => anoxia is applied to heterotrophic respiration - ! also considered in CH4 model -#else - logical, public :: anoxia = .false. -#endif - - ! C isotopes - logical, public :: use_c13 = .false. ! true => use C-13 model - logical, public :: use_c14 = .false. ! true => use C-14 model - - ! fire - logical, public :: use_nofire = .false. ! see clm4_6_00, fzeng, 7 May 2019 - -! glacier_mec control variables: default values (may be overwritten by namelist) -! NOTE: glc_smb must have the same values for CLM and GLC - - logical , public :: create_glacier_mec_landunit = .false. ! glacier_mec landunit is not created (set in controlMod) - logical , public :: glc_smb = .true. ! if true, pass surface mass balance info to GLC - ! if false, pass positive-degree-day info to GLC - logical , public :: glc_dyntopo = .false. ! true => CLM glacier topography changes dynamically - real(r8), public, allocatable :: glc_topomax(:) ! upper limit of each class (m) (set in surfrd) - character(len=256), public :: glc_grid = ' ' ! glc_grid used to determine fglcmask - character(len=256), public :: fglcmask = ' ' ! glacier mask file name (based on glc_grid) -! -! single column control variables -! - logical, public :: single_column = .false. ! true => single column mode - real(r8), public :: scmlat = rundef ! single column lat - real(r8), public :: scmlon = rundef ! single column lon -! -! instance control -! - integer, public :: inst_index - character(len=16), public :: inst_name - character(len=16), public :: inst_suffix -! -! Decomp control variables -! - integer, public :: nsegspc = 20 ! number of segments per clump for decomp -! -! Derived variables (run, history and restart file) -! - character(len=256), public :: rpntdir = '.' ! directory name for local restart pointer file - character(len=256), public :: rpntfil = 'rpointer.lnd' ! file name for local restart pointer file -! -! Error growth perturbation limit -! - real(r8), public :: pertlim = 0.0_r8 ! perturbation limit when doing error growth test -! -! To retrieve namelist - character(len=256), public :: NLFilename_in ! Namelist filename -! -! -! !PRIVATE DATA MEMBERS: -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein and Gordon Bonan -! 1 June 2004, Peter Thornton: added fnedpdat for nitrogen deposition data -! -!EOP -!----------------------------------------------------------------------- - logical, private :: clmvarctl_isset = .false. - -!=============================================================== -contains -!=============================================================== - -!--------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: set_clmvarctl -! -! !INTERFACE: - subroutine set_clmvarctl( caseid_in, ctitle_in, brnch_retain_casename_in, & - single_column_in, scmlat_in, scmlon_in, nsrest_in, & - version_in, hostname_in, username_in) -! -! !DESCRIPTION: -! Set input control variables. -! -! !USES: -! use shr_sys_mod, only : shr_sys_abort -! -! !ARGUMENTS: - character(len=256), optional, intent(IN) :: caseid_in ! case id - character(len=256), optional, intent(IN) :: ctitle_in ! case title - logical, optional, intent(IN) :: brnch_retain_casename_in ! true => allow case name to remain the same for branch run - logical, optional, intent(IN) :: single_column_in ! true => single column mode - real(r8), optional, intent(IN) :: scmlat_in ! single column lat - real(r8), optional, intent(IN) :: scmlon_in ! single column lon - integer, optional, intent(IN) :: nsrest_in ! 0: initial run. 1: restart: 3: branch - character(len=256), optional, intent(IN) :: version_in ! model version - character(len=256), optional, intent(IN) :: hostname_in ! hostname running on - character(len=256), optional, intent(IN) :: username_in ! username running job - -! -! !LOCAL VARIABLES: - character(len=32) :: subname = 'set_clmvarctl' ! subroutine name -! -! !REVISION HISTORY: -! Author: Erik Kluzek -! -!EOP -!----------------------------------------------------------------------- - if ( clmvarctl_isset )then -! call shr_sys_abort( subname//' ERROR:: control variables already set -- can not call this subroutine' ) - stop 'set_clmvarctl ERROR:: control variables already set -- can not call this subroutine' - end if - if ( present(caseid_in ) ) caseid = caseid_in - if ( present(ctitle_in ) ) ctitle = ctitle_in - if ( present(single_column_in) ) single_column = single_column_in - if ( present(scmlat_in ) ) scmlat = scmlat_in - if ( present(scmlon_in ) ) scmlon = scmlon_in - if ( present(nsrest_in ) ) nsrest = nsrest_in - if ( present(brnch_retain_casename_in) ) brnch_retain_casename = brnch_retain_casename_in - if ( present(version_in ) ) version = version_in - if ( present(username_in ) ) username = username_in - if ( present(hostname_in ) ) hostname = hostname_in - - end subroutine set_clmvarctl - -!--------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: clmvarctl_init -! -! !INTERFACE: - subroutine clmvarctl_init( masterproc, dtime ) -! -! !DESCRIPTION: -! Check that values are correct, and finish setting variables based on other variables. -! -! !USES: -! use shr_sys_mod , only : shr_sys_abort - use clm_varpar , only : maxpatch_pft, numpft -! -! !ARGUMENTS: - logical, intent(IN) :: masterproc ! proc 0 logical for printing msgs - integer, intent(IN) :: dtime ! timestep in seconds -! -! !LOCAL VARIABLES: - character(len=32) :: subname = 'clmvarctl_init' ! subroutine name -! -! !REVISION HISTORY: -! Author: Erik Kluzek -! -!EOP -!----------------------------------------------------------------------- - - ! landunit generation - - if (maxpatch_pft == numpft+1) then - allocate_all_vegpfts = .true. - else - allocate_all_vegpfts = .false. -#ifdef CROP - write(iulog,*)'maxpatch_pft = ',maxpatch_pft,& - ' does NOT equal numpft+1 = ',numpft+1 -! call shr_sys_abort( subname//' ERROR:: Can NOT turn CROP on without all PFTs' ) - stop 'clmvarctl_init ERROR:: Can NOT turn CROP on without all PFTs' -#endif - end if - - if (masterproc) then - - ! Consistency settings for co2 type - - if (co2_type /= 'constant' .and. co2_type /= 'prognostic' .and. co2_type /= 'diagnostic') then - write(iulog,*)'co2_type = ',co2_type,' is not supported' -! call shr_sys_abort( subname//' ERROR:: choices are constant, prognostic or diagnostic' ) - stop 'clmvarctl_init ERROR:: choices are constant, prognostic or diagnostic' - end if - - ! Consistency settings for dynamic land use, etc. - - if (fpftdyn /= ' ' .and. create_crop_landunit) & -! call shr_sys_abort( subname//' ERROR:: dynamic landuse is currently not supported with create_crop_landunit option' ) - stop 'clmvarctl_init ERROR:: dynamic landuse is currently not supported with create_crop_landunit option' - if (create_crop_landunit .and. .not.allocate_all_vegpfts) & -! call shr_sys_abort( subname//' ERROR:: maxpft 3000.0_r8) ) & -! call shr_sys_abort( subname//' ERROR: co2_ppmv is out of a reasonable range' ) - stop 'clmvarctl_init ERROR: co2_ppmv is out of a reasonable range' - - if (nsrest == nsrStartup ) nrevsn = ' ' - if (nsrest == nsrContinue) nrevsn = 'set by restart pointer file file' - if (nsrest /= nsrStartup .and. nsrest /= nsrContinue .and. nsrest /= nsrBranch ) & -! call shr_sys_abort( subname//' ERROR: nsrest NOT set to a valid value' ) - stop 'clmvarctl_init ERROR: nsrest NOT set to a valid value' - - if ( single_column .and. (scmlat == rundef .or. scmlon == rundef ) ) & -! call shr_sys_abort( subname//' ERROR:: single column mode on -- but scmlat and scmlon are NOT set' ) - stop 'clmvarctl_init ERROR:: single column mode on -- but scmlat and scmlon are NOT set' - -#ifndef LCH4 - if ( anoxia ) then -! call shr_sys_abort( subname//'ERROR:: anoxia is turned on, but this currently requires turning on the CH4 submodel') - stop 'clmvarctl_init ERROR:: anoxia is turned on, but this currently requires turning on the CH4 submodel' - end if -#endif - - endif ! end of if-masterproc if-block - - clmvarctl_isset = .true. - - end subroutine clmvarctl_init - -end module clm_varctl 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 deleted file mode 100644 index 151eccc3a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clm_varpar.F90 +++ /dev/null @@ -1,162 +0,0 @@ -module clm_varpar - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: clm_varpar -! -! !DESCRIPTION: -! Module containing CLM parameters -! -! !USES: -! - use clm_varpar_shared, only : VAR_COL =>VAR_COL_45, VAR_PFT => VAR_PFT_45, & - numpft => numpft_CN, NUM_ZON => NUM_ZON_CN, & - NUM_VEG => NUM_VEG_CN -! !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, parameter :: nlevcan = 1 ! number of canopy layers - integer :: nlevurb ! number of urban layers - logical, public :: more_vertlayers = .false. ! true => run with more vertical soil layers. ".false." is the default setting in CLM4.5 - -! Define indices used in surface file read -! maxpatch_pft = max number of plant functional types in naturally vegetated landunit - - integer :: maxpatch_pft - -! clm_varpar_init seems to do something similar; less prone to error to move -! these three lines there? (slevis) - integer, parameter :: max_pft_per_col = numpft+1 - - integer :: nlevdecomp ! number of biogeochemically active soil layers - integer :: nlevdecomp_full ! number of biogeochemical layers (includes lower layers that are biogeochemically inactive) - -! For CH4 code - integer, parameter :: ngases = 3 ! CH4, O2, & CO2 - -! !PUBLIC MEMBER FUNCTIONS: - public clm_varpar_init ! set parameters - -! !REVISION HISTORY: -! Created by Mariana Vertenstein - - ! CatchCN parameters - ! ------------------ - -! CN types: -! https://svn-ccsm-inputdata.cgd.ucar.edu/trunk/inputdata/lnd/clm2/pftdata/pft-physiology.c130503.nc -! -! PFT Description -! 0 0 Bare -! 1 1 Needleleaf evergreen temperate tree -! 2 2 Needleleaf evergreen boreal tree -! 3 3 Needleleaf deciduous boreal tree -! 4 4 Broadleaf evergreen tropical tree -! 5 5 Broadleaf evergreen temperate tree -! 6 6 Broadleaf deciduous tropical tree -! 7 7 Broadleaf deciduous temperate tree -! 8 8 Broadleaf deciduous boreal tree -! 9 9 Broadleaf evergreen temperate shrub -! 10 10 Broadleaf deciduous temperate shrub [moisture + deciduous] -! 11 - Broadleaf deciduous temperate shrub [moisture stress only] -! 12 11 Broadleaf deciduous boreal shrub -! 13 12 Arctic c3 grass -! 14 13 Cool c3 grass [moisture + deciduous] -! 15 - Cool c3 grass [moisture stress only] -! 16 14 Warm c4 grass [moisture + deciduous] -! 17 - Warm c4 grass [moisture stress only] -! 18 15 C3 crop [moisture + deciduous] -! 19 16 C3 crop [moisture stress only] - -! Catchment types and potential PFT mapping: -! -! 1: BROADLEAF EVERGREEN TREES => 4,5 -! 2: BROADLEAF DECIDUOUS TREES => 6,7,8 -! 3: NEEDLELEAF TREES => 1,2,3 -! 4: GROUND COVER => 0,13-19 -! 5: BROADLEAF SHRUBS => 9,10,11 -! 6: DWARF TREES (TUNDRA) => 12 -! 7: BARE SOIL => 0 -! 8: DESERT => 0 -! 9: ICE => n/a - - 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,5,6,4,4,4,4,4,4,4/) - -! ------------------------------------------------------- -! Module Varaibles (initialized in clm_varpar_init) -! ------------------------------------------------------- - -#ifndef CENTURY_DECOMP - ! parameters for decomposition cascade - integer, parameter :: ndecomp_pools = 8 - integer, parameter :: ndecomp_cascade_transitions = 9 - integer, parameter :: i_met_lit = 1 - integer, parameter :: i_cel_lit = 2 - integer, parameter :: i_lig_lit = 3 - integer, parameter :: i_cwd = 4 - integer, parameter :: nsompools = 4 -#else - ! parameters for decomposition cascade - integer, parameter :: ndecomp_pools = 7 - integer, parameter :: ndecomp_cascade_transitions = 10 - integer, parameter :: i_met_lit = 1 - integer, parameter :: i_cel_lit = 2 - integer, parameter :: i_lig_lit = 3 - integer, parameter :: i_cwd = 4 - integer, parameter :: nsompools = 3 -#endif - -!EOP -!----------------------------------------------------------------------- -contains - -!------------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: clm_varpar_init -! -! !INTERFACE: - subroutine clm_varpar_init() -! -! !DESCRIPTION: -! This subroutine initializes parameters in clm_varpar -! -! !USES: -! -! !ARGUMENTS: - implicit none -! -! !REVISION HISTORY: -! Created by T Craig -! -! -! !LOCAL VARIABLES: -! -!EOP -!------------------------------------------------------------------------------ - - maxpatch_pft = numpft + 1 ! MAXPATCH_PFT ! gkw: this was set via compiler directive - nlevurb = 5 ! use the value from CLM4.5 for now, change later if needed, fzeng, 28 Mar 2017 - - ! 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 -#ifdef VERTSOILC - nlevdecomp = nlevsoi - nlevdecomp_full = nlevgrnd -#else - nlevdecomp = 1 - nlevdecomp_full = 1 -#endif - - end subroutine clm_varpar_init - -!------------------------------------------------------------------------------ -end module clm_varpar 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 deleted file mode 100644 index 368fe3b59..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clmtype.F90 +++ /dev/null @@ -1,2418 +0,0 @@ -module clmtype - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: clmtype -! -! !DESCRIPTION: -! Define derived type hierarchy. Includes declaration of -! the clm derived type and 1d mapping arrays. -! -! -------------------------------------------------------- -! gridcell types can have values of -! -------------------------------------------------------- -! 1 => default -! -------------------------------------------------------- -! landunits types can have values of (see clm_varcon.F90) -! -------------------------------------------------------- -! 1 => (istsoil) soil (vegetated or bare soil landunit) -! 2 => (istice) land ice -! 3 => (istdlak) deep lake -! 4 => (istslak) shall lake (not currently implemented; SLake implementation has variable depth) -! 5 => (istwet) wetland -! 6 => (isturb) urban -! 7 => (istice_mec) land ice (multiple elevation classes) -! 8 => (istcrop) crop (only for crop configuration) -! -------------------------------------------------------- -! column types can have values of -! -------------------------------------------------------- -! 1 => (istsoil) soil (vegetated or bare soil) -! 2 => (istice) land ice -! 3 => (istdlak) deep lake -! 4 => (istslak) shallow lake -! 5 => (istwet) wetland -! 7 => (istice_mec) land ice (multiple elevation classes) -! 61 => (icol_roof) urban roof -! 62 => (icol_sunwall) urban sunwall -! 63 => (icol_shadewall) urban shadewall -! 64 => (icol_road_imperv) urban impervious road -! 65 => (icol_road_perv) urban pervious road -! -------------------------------------------------------- -! pft types can have values of -! -------------------------------------------------------- -! 0 => not vegetated -! 1 => needleleaf evergreen temperate tree -! 2 => needleleaf evergreen boreal tree -! 3 => needleleaf deciduous boreal tree -! 4 => broadleaf evergreen tropical tree -! 5 => broadleaf evergreen temperate tree -! 6 => broadleaf deciduous tropical tree -! 7 => broadleaf deciduous temperate tree -! 8 => broadleaf deciduous boreal tree -! 9 => broadleaf evergreen shrub -! 10 => broadleaf deciduous temperate shrub -! 11 => broadleaf deciduous boreal shrub -! 12 => c3 arctic grass -! 13 => c3 non-arctic grass -! 14 => c4 grass -! 15 => c3_crop -! 16 => c3_irrigated -! 17 => corn -! 18 => irrigated corn -! 19 => spring temperate cereal -! 20 => irrigated spring temperate cereal -! 21 => winter temperate cereal -! 22 => irrigated winter temperate cereal -! 23 => soybean -! 24 => irrigated soybean -! -------------------------------------------------------- -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - -! -! !PUBLIC TYPES: - implicit none -! -! !REVISION HISTORY: -! Created by Peter Thornton and Mariana Vertenstein -! F. Li and S. Levis (11/06/12) -!******************************************************************************* -!---------------------------------------------------- -! Begin definition of conservation check structures -!---------------------------------------------------- -! energy balance structure -!---------------------------------------------------- -type, public :: energy_balance_type - real(r8), pointer :: errsoi(:) !soil/lake energy conservation error (W/m**2) - real(r8), pointer :: errseb(:) !surface energy conservation error (W/m**2) - real(r8), pointer :: errsol(:) !solar radiation conservation error (W/m**2) - real(r8), pointer :: errlon(:) !longwave radiation conservation error (W/m**2) -end type energy_balance_type - -type(energy_balance_type) :: pebal !energy balance structure -type(energy_balance_type) :: cebal !energy balance structure - -!---------------------------------------------------- -! water balance structure -!---------------------------------------------------- -type, public :: water_balance_type - real(r8), pointer :: begwb(:) !water mass begining of the time step - real(r8), pointer :: endwb(:) !water mass end of the time step - real(r8), pointer :: errh2o(:) !water conservation error (mm H2O) -end type water_balance_type - -type(water_balance_type) :: pwbal !water balance structure -type(water_balance_type) :: cwbal !water balance structure - -!---------------------------------------------------- -! carbon balance structure -!---------------------------------------------------- -type, public :: carbon_balance_type - real(r8), pointer :: begcb(:) !carbon mass, beginning of time step (gC/m**2) - real(r8), pointer :: endcb(:) !carbon mass, end of time step (gC/m**2) - real(r8), pointer :: errcb(:) !carbon balance error for the timestep (gC/m**2) -end type carbon_balance_type - -type(carbon_balance_type) :: pcbal !carbon balance structure -type(carbon_balance_type) :: ccbal !carbon balance structure - -!---------------------------------------------------- -! nitrogen balance structure -!---------------------------------------------------- -type, public :: nitrogen_balance_type - real(r8), pointer :: begnb(:) !nitrogen mass, beginning of time step (gN/m**2) - real(r8), pointer :: endnb(:) !nitrogen mass, end of time step (gN/m**2) - real(r8), pointer :: errnb(:) !nitrogen balance error for the timestep (gN/m**2) -end type nitrogen_balance_type - -type(nitrogen_balance_type) :: pnbal !nitrogen balance structure -type(nitrogen_balance_type) :: cnbal !nitrogen balance structure - -!---------------------------------------------------- -! End definition of conservation check structures -!---------------------------------------------------- -!******************************************************************************* - -!******************************************************************************* -!---------------------------------------------------- -! Begin definition of structures defined at the pft_type level -!---------------------------------------------------- -! pft physical state variables structure -!---------------------------------------------------- -type, public :: pft_pstate_type - real(r8), pointer :: prec60(:) !60-day running mean of tot. precipitation (mm/s) added by F. Li and S. Levis - real(r8), pointer :: prec10(:) !10-day running mean of tot. precipitation (mm/s) added by F. Li and S. Levis - integer , pointer :: frac_veg_nosno(:) !fraction of vegetation not covered by snow (0 OR 1) [-] - integer , pointer :: frac_veg_nosno_alb(:) !fraction of vegetation not covered by snow (0 OR 1) [-] - real(r8), pointer :: emv(:) !vegetation emissivity - real(r8), pointer :: z0mv(:) !roughness length over vegetation, momentum [m] - real(r8), pointer :: z0hv(:) !roughness length over vegetation, sensible heat [m] - real(r8), pointer :: z0qv(:) !roughness length over vegetation, latent heat [m] - real(r8), pointer :: rootfr(:,:) !fraction of roots in each soil layer (nlevgrnd) - real(r8), pointer :: rootr(:,:) !effective fraction of roots in each soil layer (nlevgrnd) - real(r8), pointer :: rresis(:,:) !root resistance by layer (0-1) (nlevgrnd) - real(r8), pointer :: dewmx(:) !Maximum allowed dew [mm] - real(r8), pointer :: rssun(:) !sunlit stomatal resistance (s/m) - real(r8), pointer :: rhal(:) !relative humidity of the canopy air vs leaf - real(r8), pointer :: vpdal(:) !vpd of the canopy air vs leaf - real(r8), pointer :: rssha(:) !shaded stomatal resistance (s/m) - real(r8), pointer :: rssun_z(:,:) !canopy layer: sunlit leaf stomatal resistance (s/m) - real(r8), pointer :: rssha_z(:,:) !canopy layer: shaded leaf stomatal resistance (s/m) - real(r8), pointer :: laisun(:) !sunlit projected leaf area index - real(r8), pointer :: laisha(:) !shaded projected leaf area index - real(r8), pointer :: laisun_z(:,:) !sunlit leaf area for canopy layer - real(r8), pointer :: laisha_z(:,:) !shaded leaf area for canopy layer - real(r8), pointer :: btran(:) !transpiration wetness factor (0 to 1) - real(r8), pointer :: btran2(:) ! root zone soil wetness factor (0 to 1) added by F. Li and S. Levis - real(r8), pointer :: fsun(:) !sunlit fraction of canopy - real(r8), pointer :: tlai(:) !one-sided leaf area index, no burying by snow - real(r8), pointer :: tsai(:) !one-sided stem area index, no burying by snow - real(r8), pointer :: elai(:) !one-sided leaf area index with burying by snow - real(r8), pointer :: esai(:) !one-sided stem area index with burying by snow - real(r8), pointer :: fwet(:) !fraction of canopy that is wet (0 to 1) - real(r8), pointer :: fdry(:) !fraction of foliage that is green and dry [-] (new) - real(r8), pointer :: dt_veg(:) !change in t_veg, last iteration (Kelvin) - real(r8), pointer :: htop(:) !canopy top (m) - real(r8), pointer :: hbot(:) !canopy bottom (m) - real(r8), pointer :: z0m(:) !momentum roughness length (m) - real(r8), pointer :: displa(:) !displacement height (m) - real(r8), pointer :: albd(:,:) !surface albedo (direct) (numrad) - real(r8), pointer :: albi(:,:) !surface albedo (diffuse) (numrad) - real(r8), pointer :: fabd(:,:) !flux absorbed by canopy per unit direct flux (numrad) - real(r8), pointer :: fabd_sun(:,:) !flux absorbed by sunlit canopy per unit direct flux (numrad) - real(r8), pointer :: fabd_sha(:,:) !flux absorbed by shaded canopy per unit direct flux (numrad) - real(r8), pointer :: fabi(:,:) !flux absorbed by canopy per unit diffuse flux (numrad) - real(r8), pointer :: fabi_sun(:,:) !flux absorbed by sunlit canopy per unit diffuse flux (numrad) - real(r8), pointer :: fabi_sha(:,:) !flux absorbed by shaded canopy per unit diffuse flux (numrad) - real(r8), pointer :: ftdd(:,:) !down direct flux below canopy per unit direct flx (numrad) - real(r8), pointer :: ftid(:,:) !down diffuse flux below canopy per unit direct flx (numrad) - real(r8), pointer :: ftii(:,:) !down diffuse flux below canopy per unit diffuse flx (numrad) - real(r8), pointer :: vcmaxcintsun(:) ! leaf to canopy scaling coefficient, sunlit leaf vcmax - real(r8), pointer :: vcmaxcintsha(:) ! leaf to canopy scaling coefficient, shaded leaf vcmax - integer , pointer :: ncan(:) !number of canopy layers - integer , pointer :: nrad(:) !number of canopy layers, above snow for radiative transfer - real(r8), pointer :: fabd_sun_z(:,:) !absorbed sunlit leaf direct PAR (per unit lai+sai) for each canopy layer - real(r8), pointer :: fabd_sha_z(:,:) !absorbed shaded leaf direct PAR (per unit lai+sai) for each canopy layer - real(r8), pointer :: fabi_sun_z(:,:) !absorbed sunlit leaf diffuse PAR (per unit lai+sai) for each canopy layer - real(r8), pointer :: fabi_sha_z(:,:) !absorbed shaded leaf diffuse PAR (per unit lai+sai) for each canopy layer - real(r8), pointer :: fsun_z(:,:) !sunlit fraction of canopy layer - real(r8), pointer :: tlai_z(:,:) !tlai increment for canopy layer - real(r8), pointer :: tsai_z(:,:) !tsai increment for canopy layer - real(r8), pointer :: u10(:) !10-m wind (m/s) (for dust model) - real(r8), pointer :: u10_clm(:) !10-m wind (m/s) - real(r8), pointer :: va(:) !atmospheric wind speed plus convective velocity (m/s) - real(r8), pointer :: ram1(:) !aerodynamical resistance (s/m) - real(r8), pointer :: ram1_lake(:) !aerodynamical resistance (s/m) - integer , pointer :: burndate(:) ! crop burn date - real(r8), pointer :: rh_leaf(:) !fractional humidity at leaf surface (dimensionless) - real(r8), pointer :: rhaf(:) !fractional humidity of canopy air (dimensionless) - real(r8), pointer :: fv(:) !friction velocity (m/s) (for dust model) - real(r8), pointer :: forc_hgt_u_pft(:) !wind forcing height (10m+z0m+d) (m) - real(r8), pointer :: forc_hgt_t_pft(:) !temperature forcing height (10m+z0m+d) (m) - real(r8), pointer :: forc_hgt_q_pft(:) !specific humidity forcing height (10m+z0m+d) (m) - real(r8), pointer :: lfpftd(:) ! decrease of pft weight (0-1) on the column for the timestep added by F. Li and S. Levis - ! Variables for prognostic crop model - real(r8), pointer :: hdidx(:) ! cold hardening index? - real(r8), pointer :: cumvd(:) ! cumulative vernalization d?ependence? - real(r8), pointer :: htmx(:) ! max hgt attained by a crop during yr (m) - real(r8), pointer :: vf(:) ! vernalization factor for cereal - real(r8), pointer :: gddmaturity(:) ! growing degree days (gdd) needed to harvest (ddays) - real(r8), pointer :: gdd0(:) ! growing degree-days base 0C from planting (ddays) - real(r8), pointer :: gdd8(:) ! growing degree-days base 8C from planting (ddays) - real(r8), pointer :: gdd10(:) ! growing degree-days base 10C from planting (ddays) - real(r8), pointer :: gdd020(:) ! 20-year average of gdd0 (ddays) - real(r8), pointer :: gdd820(:) ! 20-year average of gdd8 (ddays) - real(r8), pointer :: gdd1020(:) ! 20-year average of gdd10 (ddays) - real(r8), pointer :: gddplant(:) ! accum gdd past planting date for crop (ddays) - real(r8), pointer :: gddtsoi(:) ! growing degree-days from planting (top two soil layers) (ddays) - real(r8), pointer :: huileaf(:) ! heat unit index needed from planting to leaf emergence - real(r8), pointer :: huigrain(:) ! heat unit index needed to reach vegetative maturity - real(r8), pointer :: aleafi(:) ! saved leaf allocation coefficient from phase 2 - real(r8), pointer :: astemi(:) ! saved stem allocation coefficient from phase 2 - real(r8), pointer :: aleaf(:) ! leaf allocation coefficient - real(r8), pointer :: astem(:) ! stem allocation coefficient - logical , pointer :: croplive(:) ! Flag, true if planted, not harvested - logical , pointer :: cropplant(:) ! Flag, true if planted - integer , pointer :: harvdate(:) ! harvest date - ! cropplant and harvdate could be 2D to facilitate rotation - integer , pointer :: idop(:) ! date of planting - integer , pointer :: peaklai(:) ! 1: max allowed lai; 0: not at max - real(r8), pointer :: vds(:) !deposition velocity term (m/s) (for dry dep SO4, NH4NO3) - real(r8), pointer :: alphapsnsun(:) !sunlit 13c fractionation ([]) - real(r8), pointer :: alphapsnsha(:) !shaded 13c fractionation ([]) - real(r8), pointer :: sandfrac(:) ! sand fraction - real(r8), pointer :: clayfrac(:) ! clay fraction - ! for dry deposition of chemical tracers - real(r8), pointer :: mlaidiff(:) ! difference between lai month one and month two - real(r8), pointer :: rb1(:) ! aerodynamical resistance (s/m) - real(r8), pointer :: annlai(:,:) ! 12 months of monthly lai from input data set - - ! New variable for methane code - real(r8), pointer :: grnd_ch4_cond(:) !tracer conductance for boundary layer [m/s] - real(r8), pointer :: canopy_cond(:) !tracer conductance for canopy [m/s] - - ! and vertical profiles for calculating fluxes - real(r8), pointer :: leaf_prof(:,:) ! (1/m) profile of leaves - real(r8), pointer :: froot_prof(:,:) ! (1/m) profile of fine roots - real(r8), pointer :: croot_prof(:,:) ! (1/m) profile of coarse roots - real(r8), pointer :: stem_prof(:,:) ! (1/m) profile of stems -end type pft_pstate_type - -type(pft_pstate_type) :: pps !physical state variables -type(pft_pstate_type) :: pps_a !pft-level pstate variables averaged to the column - -!---------------------------------------------------- -! pft photosynthesis structure -!---------------------------------------------------- - -type, public :: pft_psynstate_type - logical, pointer :: c3flag(:) ! true if C3 and false if C4 - real(r8), pointer :: ac(:,:) ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8), pointer :: aj(:,:) ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8), pointer :: ap(:,:) ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8), pointer :: ag(:,:) ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8), pointer :: an(:,:) ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8), pointer :: vcmax_z(:,:) ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), pointer :: cp(:) ! CO2 compensation point (Pa) - real(r8), pointer :: kc(:) ! Michaelis-Menten constant for CO2 (Pa) - real(r8), pointer :: ko(:) ! Michaelis-Menten constant for O2 (Pa) - real(r8), pointer :: qe(:) ! quantum efficiency, used only for C4 (mol CO2 / mol photons) - real(r8), pointer :: tpu_z(:,:) ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8), pointer :: kp_z(:,:) ! initial slope of CO2 response curve (C4 plants) - real(r8), pointer :: theta_cj(:) ! empirical curvature parameter for ac, aj photosynthesis co-limitation - real(r8), pointer :: bbb(:) ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8), pointer :: mbb(:) ! Ball-Berry slope of conductance-photosynthesis relationship - real(r8), pointer :: gs_mol(:,:) ! leaf stomatal conductance (umol H2O/m**2/s) - real(r8), pointer :: gb_mol(:) ! leaf boundary layer conductance (umol H2O/m**2/s) -end type pft_psynstate_type - -type(pft_psynstate_type)::ppsyns !photosynthesis relevant variables - -!---------------------------------------------------- -! pft ecophysiological constants structure -!---------------------------------------------------- -type, public :: pft_epc_type - integer , pointer :: noveg(:) !value for not vegetated - integer , pointer :: tree(:) !tree or not? - real(r8), pointer :: smpso(:) !soil water potential at full stomatal opening (mm) - real(r8), pointer :: smpsc(:) !soil water potential at full stomatal closure (mm) - real(r8), pointer :: fnitr(:) !foliage nitrogen limitation factor (-) - real(r8), pointer :: foln(:) !foliage nitrogen (%) - real(r8), pointer :: dleaf(:) !characteristic leaf dimension (m) - real(r8), pointer :: c3psn(:) !photosynthetic pathway: 0. = c4, 1. = c3 - real(r8), pointer :: xl(:) !leaf/stem orientation index - real(r8), pointer :: rhol(:) !leaf reflectance: 1=vis, 2=nir (numrad). fzeng: only vis - real(r8), pointer :: rhos(:) !stem reflectance: 1=vis, 2=nir (numrad). fzeng: only vis - real(r8), pointer :: taul(:) !leaf transmittance: 1=vis, 2=nir (numrad). fzeng: only vis - real(r8), pointer :: taus(:) !stem transmittance: 1=vis, 2=nir (numrad). fzeng: only vis - real(r8), pointer :: z0mr(:) !ratio of momentum roughness length to canopy top height (-) - real(r8), pointer :: displar(:) !ratio of displacement height to canopy top height (-) - real(r8), pointer :: roota_par(:) !CLM rooting distribution parameter [1/m] - real(r8), pointer :: rootb_par(:) !CLM rooting distribution parameter [1/m] - ! new variables for CN code - real(r8), pointer :: dwood(:) !wood density (gC/m3) - real(r8), pointer :: slatop(:) !specific leaf area at top of canopy, projected area basis [m^2/gC] - real(r8), pointer :: dsladlai(:) !dSLA/dLAI, projected area basis [m^2/gC] - real(r8), pointer :: leafcn(:) !leaf C:N (gC/gN) - real(r8), pointer :: flnr(:) !fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) - real(r8), pointer :: woody(:) !binary flag for woody lifeform (1=woody, 0=not woody) - real(r8), pointer :: lflitcn(:) !leaf litter C:N (gC/gN) - real(r8), pointer :: frootcn(:) !fine root C:N (gC/gN) - real(r8), pointer :: livewdcn(:) !live wood (phloem and ray parenchyma) C:N (gC/gN) - real(r8), pointer :: deadwdcn(:) !dead wood (xylem and heartwood) C:N (gC/gN) - real(r8), pointer :: graincn(:) !grain C:N (gC/gN) for prognostic crop model - real(r8), pointer :: froot_leaf(:) !allocation parameter: new fine root C per new leaf C (gC/gC) - real(r8), pointer :: stem_leaf(:) !allocation parameter: new stem c per new leaf C (gC/gC) - real(r8), pointer :: croot_stem(:) !allocation parameter: new coarse root C per new stem C (gC/gC) - real(r8), pointer :: flivewd(:) !allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units) - real(r8), pointer :: fcur(:) !allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage - real(r8), pointer :: lf_flab(:) !leaf litter labile fraction - real(r8), pointer :: lf_fcel(:) !leaf litter cellulose fraction - real(r8), pointer :: lf_flig(:) !leaf litter lignin fraction - real(r8), pointer :: fr_flab(:) !fine root litter labile fraction - real(r8), pointer :: fr_fcel(:) !fine root litter cellulose fraction - real(r8), pointer :: fr_flig(:) !fine root litter lignin fraction - real(r8), pointer :: leaf_long(:) !leaf longevity (yrs) - real(r8), pointer :: evergreen(:) !binary flag for evergreen leaf habit (0 or 1) - real(r8), pointer :: stress_decid(:) !binary flag for stress-deciduous leaf habit (0 or 1) - real(r8), pointer :: season_decid(:) !binary flag for seasonal-deciduous leaf habit (0 or 1) - -! fire variables added by F. Li and S. Levis - - ! combustion completeness factors (0 to 1) - real(r8), pointer :: cc_leaf(:) !combustion completeness factor for leaf - real(r8), pointer :: cc_lstem(:) !combustion completeness factor for live stem - real(r8), pointer :: cc_dstem(:) !combustion completeness factor for dead stem - real(r8), pointer :: cc_other(:) !combustion completeness factor for other plant tissues - ! mortality factors (0 to 1) - real(r8), pointer :: fm_leaf(:) !fire-related mortality factor for leaf - real(r8), pointer :: fm_lstem(:) !fire-related mortality factor for live stem - real(r8), pointer :: fm_dstem(:) !fire-related mortality factor for dead stem - real(r8), pointer :: fm_other(:) !fire-related mortality factor for other plant tissues - real(r8), pointer :: fm_root(:) !fire-related mortality factor for fine roots - real(r8), pointer :: fm_lroot(:) !fire-related mortality factor for live roots - real(r8), pointer :: fm_droot(:) !fire-related mortality factor for dead roots - ! fzeng: - real(r8), pointer :: fsr_pft(:) !Fire spread rate (m/s) - real(r8), pointer :: fd_pft(:) !Fire duration (hr) - - real(r8), pointer :: rootprof_beta(:) !CLM rooting distribution parameter for C and N inputs [unitless] - - ! new variables for crop code - real(r8), pointer :: fertnitro(:) ! fertilizer applied - real(r8), pointer :: fleafcn(:) ! C:N during grain fill; leaf - real(r8), pointer :: ffrootcn(:) ! C:N during grain fill; froot - real(r8), pointer :: fstemcn(:) ! C:N during grain fill; stem - ! fzeng: - integer, pointer :: mnNHplantdate(:) ! Minimum planting date for the Northern Hemipsphere (MMDD) - integer, pointer :: mxNHplantdate(:) ! Maximum planting date for the Northern Hemipsphere (MMDD) - integer, pointer :: mnSHplantdate(:) ! Minimum planting date for the Southern Hemipsphere (MMDD) - integer, pointer :: mxSHplantdate(:) ! Maximum planting date for the Southern Hemipsphere (MMDD) - real(r8), pointer :: gddmin(:) ! Minimim growing degree days used in CNPhenology - real(r8), pointer :: hybgdd(:) ! Growing Degree Days for maturity used in CNPhenology (unitless) - real(r8), pointer :: lfemerg(:) ! Leaf emergence parameter used in CNPhenology (unitless) - real(r8), pointer :: grnfill(:) ! Grain fill parameter used in CNPhenology (unitless) - real(r8), pointer :: mxmat(:) ! Maximum number of days to maturity parameter in CNPhenology (days) - real(r8), pointer :: minplanttemp(:) ! Average 5 day daily minimum temperature needed for planting (K) - real(r8), pointer :: planttemp(:) ! Average 10 day temperature needed for planting (K) - - ! new variables for subroutine CNVegStructUpdate - real(r8), pointer :: laimx(:) ! Maximum Leaf Area Index used in CNVegStructUpdate - real(r8), pointer :: ztopmx(:) ! Canopy top coefficient used in CNVegStructUpdate (m) - - ! fzeng: for CNAllocation - real(r8), pointer :: declfact(:) ! Decline factor for gddmaturity used in CNAllocation - real(r8), pointer :: bfact(:) ! Exponential factor used in CNAllocation for fraction allocated to leaf - real(r8), pointer :: aleaff(:) ! Leaf Allocation coefficient parameter used in CNAllocation - real(r8), pointer :: arootf(:) ! Root Allocation coefficient parameter used in CNAllocation - real(r8), pointer :: astemf(:) ! Stem Allocation coefficient parameter used in CNAllocation - real(r8), pointer :: arooti(:) ! Root Allocation coefficient parameter used in CNAllocation - real(r8), pointer :: fleafi(:) ! Leaf Allocation coefficient parameter fraction used in CNAllocation - real(r8), pointer :: allconsl(:) ! Leaf Allocation coefficient parameter power used in CNAllocation - real(r8), pointer :: allconss(:) ! Stem Allocation coefficient parameter power used in CNAllocation - - ! fzeng: - real(r8), pointer :: grperc(:) ! Growth respiration factor (unitless) - real(r8), pointer :: grpnow(:) ! Growth respiration factor (unitless) - real(r8), pointer :: mxtmp(:) ! Max Temperature, parameter used in CN_Driver (degree C) - real(r8), pointer :: baset(:) ! Base Temperature, parameter used in CN_Driver (degree C) - real(r8), pointer :: qe25(:) ! quantum efficiency at 25C (umol CO2 / umol photon) - -end type pft_epc_type - -type(pft_epc_type), public, target, save :: pftcon - -!---------------------------------------------------- -! decomp cascade structure -!---------------------------------------------------- - -type, public :: decomp_cascade_type - !-- properties of each pathway along decomposition cascade - 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 - 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 -end type decomp_cascade_type - -type(decomp_cascade_type), public, target, save :: decomp_cascade_con - -!---------------------------------------------------- -! pft DGVM-specific ecophysiological constants structure -!---------------------------------------------------- -type, public :: pft_dgvepc_type - real(r8), pointer :: crownarea_max(:) !tree maximum crown area [m2] - real(r8), pointer :: tcmin(:) !minimum coldest monthly mean temperature [units?] - real(r8), pointer :: tcmax(:) !maximum coldest monthly mean temperature [units?] - real(r8), pointer :: gddmin(:) !minimum growing degree days (at or above 5 C) - real(r8), pointer :: twmax(:) !upper limit of temperature of the warmest month [units?] - real(r8), pointer :: reinickerp(:) !parameter in allometric equation - real(r8), pointer :: allom1(:) !parameter in allometric - real(r8), pointer :: allom2(:) !parameter in allometric - real(r8), pointer :: allom3(:) !parameter in allometric -end type pft_dgvepc_type - -type(pft_dgvepc_type), public, target, save :: dgv_pftcon - -!---------------------------------------------------- -! pft ecophysiological variables structure -!---------------------------------------------------- -type, public :: pft_epv_type - real(r8), pointer :: dormant_flag(:) !dormancy flag - real(r8), pointer :: days_active(:) !number of days since last dormancy - real(r8), pointer :: onset_flag(:) !onset flag - real(r8), pointer :: onset_counter(:) !onset days counter - real(r8), pointer :: onset_gddflag(:) !onset flag for growing degree day sum - real(r8), pointer :: onset_fdd(:) !onset freezing degree days counter - real(r8), pointer :: onset_gdd(:) !onset growing degree days - real(r8), pointer :: onset_swi(:) !onset soil water index - real(r8), pointer :: offset_flag(:) !offset flag - real(r8), pointer :: offset_counter(:) !offset days counter - real(r8), pointer :: offset_fdd(:) !offset freezing degree days counter - real(r8), pointer :: offset_swi(:) !offset soil water index - real(r8), pointer :: fert_counter(:) !>0 fertilize; <=0 not - real(r8), pointer :: grain_flag(:) !1: grain fill stage; 0: not - real(r8), pointer :: lgsf(:) !long growing season factor [0-1] - real(r8), pointer :: bglfr(:) !background litterfall rate (1/s) - real(r8), pointer :: bgtr(:) !background transfer growth rate (1/s) - real(r8), pointer :: dayl(:) !daylength (seconds) - real(r8), pointer :: prev_dayl(:) !daylength from previous timestep (seconds) - real(r8), pointer :: annavg_t2m(:) !annual average 2m air temperature (K) - real(r8), pointer :: tempavg_t2m(:) !temporary average 2m air temperature (K) - real(r8), pointer :: gpp(:) !GPP flux before downregulation (gC/m2/s) - real(r8), pointer :: availc(:) !C flux available for allocation (gC/m2/s) - real(r8), pointer :: xsmrpool_recover(:) !C flux assigned to recovery of negative cpool (gC/m2/s) - real(r8), pointer :: xsmrpool_c13ratio(:) !C13/C(12+13) ratio for xsmrpool (proportion) - real(r8), pointer :: alloc_pnow(:) !fraction of current allocation to display as new growth (DIM) - real(r8), pointer :: c_allometry(:) !C allocation index (DIM) - real(r8), pointer :: n_allometry(:) !N allocation index (DIM) - real(r8), pointer :: plant_ndemand(:) !N flux required to support initial GPP (gN/m2/s) - real(r8), pointer :: tempsum_potential_gpp(:)!temporary annual sum of potential GPP - real(r8), pointer :: annsum_potential_gpp(:) !annual sum of potential GPP - real(r8), pointer :: tempmax_retransn(:) !temporary annual max of retranslocated N pool (gN/m2) - real(r8), pointer :: annmax_retransn(:) !annual max of retranslocated N pool (gN/m2) - real(r8), pointer :: avail_retransn(:) !N flux available from retranslocation pool (gN/m2/s) - real(r8), pointer :: plant_nalloc(:) !total allocated N flux (gN/m2/s) - real(r8), pointer :: plant_calloc(:) !total allocated C flux (gC/m2/s) - real(r8), pointer :: excess_cflux(:) !C flux not allocated due to downregulation (gC/m2/s) - real(r8), pointer :: downreg(:) !fractional reduction in GPP due to N limitation (DIM) - real(r8), pointer :: prev_leafc_to_litter(:) !previous timestep leaf C litterfall flux (gC/m2/s) - real(r8), pointer :: prev_frootc_to_litter(:)!previous timestep froot C litterfall flux (gC/m2/s) - real(r8), pointer :: tempsum_npp(:) !temporary annual sum of NPP (gC/m2/yr) - real(r8), pointer :: annsum_npp(:) !annual sum of NPP (gC/m2/yr) - !CNDV - real(r8), pointer :: tempsum_litfall(:) !temporary annual sum of litfall (gC/m2/yr) - real(r8), pointer :: annsum_litfall(:) !annual sum of litfall (gC/m2/yr) - ! - real(r8), pointer :: rc13_canair(:) !C13O2/C12O2 in canopy air - real(r8), pointer :: rc13_psnsun(:) !C13O2/C12O2 in sunlit canopy psn flux - real(r8), pointer :: rc13_psnsha(:) !C13O2/C12O2 in shaded canopy psn flux - real(r8), pointer :: rc14_atm(:) !C14O2/C12O2 in atmosphere -end type pft_epv_type - -type(pft_epv_type) :: pepv !pft ecophysiological variables - -!---------------------------------------------------- -! pft energy state variables structure -!---------------------------------------------------- -type, public :: pft_estate_type - real(r8), pointer :: t_ref2m(:) !2 m height surface air temperature (Kelvin) - real(r8), pointer :: t_ref2m_min(:) !daily minimum of average 2 m height surface air temperature (K) - real(r8), pointer :: t_ref2m_max(:) !daily maximum of average 2 m height surface air temperature (K) - real(r8), pointer :: t_ref2m_min_inst(:) !instantaneous daily min of average 2 m height surface air temp (K) - real(r8), pointer :: t_ref2m_max_inst(:) !instantaneous daily max of average 2 m height surface air temp (K) - real(r8), pointer :: q_ref2m(:) !2 m height surface specific humidity (kg/kg) - real(r8), pointer :: t_ref2m_u(:) !Urban 2 m height surface air temperature (Kelvin) - real(r8), pointer :: t_ref2m_r(:) !Rural 2 m height surface air temperature (Kelvin) - real(r8), pointer :: t_ref2m_min_u(:) !Urban daily minimum of average 2 m height surface air temperature (K) - real(r8), pointer :: t_ref2m_min_r(:) !Rural daily minimum of average 2 m height surface air temperature (K) - real(r8), pointer :: t_ref2m_max_u(:) !Urban daily maximum of average 2 m height surface air temperature (K) - real(r8), pointer :: t_ref2m_max_r(:) !Rural daily maximum of average 2 m height surface air temperature (K) - real(r8), pointer :: t_ref2m_min_inst_u(:) !Urban instantaneous daily min of average 2 m height surface air temp (K) - real(r8), pointer :: t_ref2m_min_inst_r(:) !Rural instantaneous daily min of average 2 m height surface air temp (K) - real(r8), pointer :: t_ref2m_max_inst_u(:) !Urban instantaneous daily max of average 2 m height surface air temp (K) - real(r8), pointer :: t_ref2m_max_inst_r(:) !Rural instantaneous daily max of average 2 m height surface air temp (K) - real(r8), pointer :: a10tmin(:) !10-day running mean of min 2-m temperature - real(r8), pointer :: a5tmin(:) !5-day running mean of min 2-m temperature - real(r8), pointer :: t10(:) !10-day running mean of the 2 m temperature (K) - real(r8), pointer :: rh_ref2m(:) !2 m height surface relative humidity (%) - real(r8), pointer :: rh_ref2m_u(:) !Urban 2 m height surface relative humidity (%) - real(r8), pointer :: rh_ref2m_r(:) !Rural 2 m height surface relative humidity (%) - real(r8), pointer :: t_veg(:) !vegetation temperature (Kelvin) - real(r8), pointer :: thm(:) !intermediate variable (forc_t+0.0098*forc_hgt_t_pft) -end type pft_estate_type - -type(pft_estate_type) :: pes !pft energy state - -!---------------------------------------------------- -! pft water state variables structure -!---------------------------------------------------- -type, public :: pft_wstate_type - real(r8), pointer :: h2ocan(:) !canopy water (mm H2O) -end type pft_wstate_type - -type(pft_wstate_type) :: pws !pft water state - -!---------------------------------------------------- -! pft carbon state variables structure -!---------------------------------------------------- -type, public :: pft_cstate_type - real(r8), pointer :: leafcmax(:) ! (gC/m2) ann max leaf C - ! variables for prognostic crop model - real(r8), pointer :: grainc(:) ! (gC/m2) grain C - real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage - real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer - ! - real(r8), pointer :: leafc(:) ! (gC/m2) leaf C - real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage - real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer - real(r8), pointer :: frootc(:) ! (gC/m2) fine root C - real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage - real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer - real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C - real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage - real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer - real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C - real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage - real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer - real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C - real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage - real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer - real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C - real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage - real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer - real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage - real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer - real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool - real(r8), pointer :: xsmrpool(:) ! (gC/m2) abstract C pool to meet excess MR demand - real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation - ! summary (diagnostic) state variables, not involved in mass balance - real(r8), pointer :: dispvegc(:) ! (gC/m2) displayed veg carbon, excluding storage and cpool - real(r8), pointer :: storvegc(:) ! (gC/m2) stored vegetation carbon, excluding cpool - real(r8), pointer :: totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool - real(r8), pointer :: totpftc(:) ! (gC/m2) total pft-level carbon, including cpool - ! CN - real(r8), pointer :: woodc(:) ! (gC/m2) wood C - ! -end type pft_cstate_type - -type(pft_cstate_type), target :: pcs !pft carbon state -type(pft_cstate_type), target :: pcs_a !pft-level carbon state averaged to the column -type(pft_cstate_type), target :: pc13s !pft carbon-13 state -type(pft_cstate_type), target :: pc13s_a !pft carbon-13 state averaged to the column -type(pft_cstate_type), target :: pc14s !pft carbon-14 state -type(pft_cstate_type), target :: pc14s_a !pft carbon-14 state averaged to the column - -!---------------------------------------------------- -! pft nitrogen state variables structure -!---------------------------------------------------- -type, public :: pft_nstate_type - ! variables for prognostic crop model - real(r8), pointer :: grainn(:) ! (gN/m2) grain N - real(r8), pointer :: grainn_storage(:) ! (gN/m2) grain N storage - real(r8), pointer :: grainn_xfer(:) ! (gN/m2) grain N transfer - ! - real(r8), pointer :: leafn(:) ! (gN/m2) leaf N - real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage - real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer - real(r8), pointer :: frootn(:) ! (gN/m2) fine root N - real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage - real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer - real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N - real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage - real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer - real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N - real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage - real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer - real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N - real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage - real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer - real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N - real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage - real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer - real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N - real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool - real(r8), pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation - ! summary (diagnostic) state variables, not involved in mass balance - real(r8), pointer :: dispvegn(:) ! (gN/m2) displayed veg nitrogen, excluding storage - real(r8), pointer :: storvegn(:) ! (gN/m2) stored vegetation nitrogen - real(r8), pointer :: totvegn(:) ! (gN/m2) total vegetation nitrogen - real(r8), pointer :: totpftn(:) ! (gN/m2) total pft-level nitrogen -end type pft_nstate_type - -type(pft_nstate_type) :: pns !pft nitrogen state -type(pft_nstate_type) :: pns_a !pft-level nitrogen state variables averaged to the column - -!---------------------------------------------------- -! pft VOC state variables structure -!---------------------------------------------------- -type, public :: pft_vstate_type - real(r8), pointer :: t_veg24(:) ! 24hr average vegetation temperature (K) - real(r8), pointer :: t_veg240(:) ! 240hr average vegetation temperature (Kelvin) - real(r8), pointer :: fsd24(:) ! 24hr average of direct beam radiation - real(r8), pointer :: fsd240(:) ! 240hr average of direct beam radiation - real(r8), pointer :: fsi24(:) ! 24hr average of diffuse beam radiation - real(r8), pointer :: fsi240(:) ! 240hr average of diffuse beam radiation - real(r8), pointer :: fsun24(:) ! 24hr average of sunlit fraction of canopy - real(r8), pointer :: fsun240(:) ! 240hr average of sunlit fraction of canopy - real(r8), pointer :: elai_p(:) ! leaf area index average over timestep -end type pft_vstate_type - -type(pft_vstate_type) :: pvs !pft VOC state - -!---------------------------------------------------- -! pft DGVM state variables structure -!---------------------------------------------------- -type, public :: pft_dgvstate_type - real(r8), pointer :: agddtw(:) !accumulated growing degree days above twmax - real(r8), pointer :: agdd(:) !accumulated growing degree days above 5 - real(r8), pointer :: t_mo(:) !30-day average temperature (Kelvin) - real(r8), pointer :: t_mo_min(:) !annual min of t_mo (Kelvin) - real(r8), pointer :: prec365(:) !365-day running mean of tot. precipitation - logical , pointer :: present(:) !whether PFT present in patch - logical , pointer :: pftmayexist(:) !if .false. then exclude seasonal decid pfts from tropics - real(r8), pointer :: nind(:) !number of individuals (#/m**2) - real(r8), pointer :: lm_ind(:) !individual leaf mass - real(r8), pointer :: lai_ind(:) !LAI per individual - real(r8), pointer :: fpcinc(:) !foliar projective cover increment (fraction) - real(r8), pointer :: fpcgrid(:) !foliar projective cover on gridcell (fraction) - real(r8), pointer :: fpcgridold(:) !last yr's fpcgrid - real(r8), pointer :: crownarea(:) !area that each individual tree takes up (m^2) - real(r8), pointer :: greffic(:) - real(r8), pointer :: heatstress(:) -end type pft_dgvstate_type - -type(pft_dgvstate_type) :: pdgvs !pft DGVM state variables - -!---------------------------------------------------- -! pft energy flux variables structure -!---------------------------------------------------- -type, public :: pft_eflux_type - real(r8), pointer :: sabg_soil(:) !solar radiation absorbed by soil (W/m**2) - real(r8), pointer :: sabg_snow(:) !solar radiation absorbed by snow (W/m**2) - real(r8), pointer :: sabg_chk(:) !fsno weighted sum (needed by balancecheck, because fsno changes midway) - real(r8), pointer :: sabg(:) !solar radiation absorbed by ground (W/m**2) - real(r8), pointer :: sabv(:) !solar radiation absorbed by vegetation (W/m**2) - real(r8), pointer :: fsa(:) !solar radiation absorbed (total) (W/m**2) - real(r8), pointer :: fsa_u(:) !urban solar radiation absorbed (total) (W/m**2) - real(r8), pointer :: fsa_r(:) !rural solar radiation absorbed (total) (W/m**2) - real(r8), pointer :: fsr(:) !solar radiation reflected (W/m**2) - real(r8), pointer :: parsun_z(:,:) !absorbed PAR for sunlit leaves in canopy layer (W/m**2) - real(r8), pointer :: parsha_z(:,:) !absorbed PAR for shaded leaves in canopy layer (W/m**2) - real(r8), pointer :: dlrad(:) !downward longwave radiation below the canopy [W/m2] - real(r8), pointer :: ulrad(:) !upward longwave radiation above the canopy [W/m2] - real(r8), pointer :: eflx_lh_tot(:) !total latent heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_lh_tot_u(:) !urban total latent heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_lh_tot_r(:) !rural total latent heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_lh_grnd(:) !ground evaporation heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_soil_grnd(:) !soil heat flux (W/m**2) [+ = into soil] - real(r8), pointer :: eflx_soil_grnd_u(:) !urban soil heat flux (W/m**2) [+ = into soil] - real(r8), pointer :: eflx_soil_grnd_r(:) !rural soil heat flux (W/m**2) [+ = into soil] - real(r8), pointer :: eflx_sh_tot(:) !total sensible heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_sh_tot_u(:) !urban total sensible heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_sh_tot_r(:) !rural total sensible heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_sh_grnd(:) !sensible heat flux from ground (W/m**2) [+ to atm] - real(r8), pointer :: eflx_sh_snow(:) !sensible heat flux from snow (W/m**2) [+ to atm] - real(r8), pointer :: eflx_sh_soil(:) !sensible heat flux from soil (W/m**2) [+ to atm] - real(r8), pointer :: eflx_sh_h2osfc(:) !sensible heat flux from surface water (W/m**2) [+ to atm] - real(r8), pointer :: eflx_sh_veg(:) !sensible heat flux from leaves (W/m**2) [+ to atm] - real(r8), pointer :: eflx_lh_vege(:) !veg evaporation heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_lh_vegt(:) !veg transpiration heat flux (W/m**2) [+ to atm] - real(r8), pointer :: eflx_wasteheat_pft(:) !sensible heat flux from domestic heating/cooling sources of waste heat (W/m**2) - real(r8), pointer :: eflx_heat_from_ac_pft(:) !sensible heat flux put back into canyon due to removal by AC (W/m**2) - real(r8), pointer :: eflx_traffic_pft(:) !traffic sensible heat flux (W/m**2) - real(r8), pointer :: eflx_anthro(:) !total anthropogenic heat flux (W/m**2) - real(r8), pointer :: cgrnd(:) !deriv. of soil energy flux wrt to soil temp [w/m2/k] - real(r8), pointer :: cgrndl(:) !deriv. of soil latent heat flux wrt soil temp [w/m**2/k] - real(r8), pointer :: cgrnds(:) !deriv. of soil sensible heat flux wrt soil temp [w/m2/k] - real(r8), pointer :: eflx_gnet(:) !net heat flux into ground (W/m**2) -! New lake field - real(r8), pointer :: eflx_grnd_lake(:) !net heat flux into lake / snow surface, excluding light transmission (W/m**2) - real(r8), pointer :: dgnetdT(:) !derivative of net ground heat flux wrt soil temp (W/m**2 K) - real(r8), pointer :: eflx_lwrad_out(:) !emitted infrared (longwave) radiation (W/m**2) - real(r8), pointer :: eflx_lwrad_net(:) !net infrared (longwave) rad (W/m**2) [+ = to atm] - real(r8), pointer :: eflx_lwrad_net_u(:) !urban net infrared (longwave) rad (W/m**2) [+ = to atm] - real(r8), pointer :: eflx_lwrad_net_r(:) !rural net infrared (longwave) rad (W/m**2) [+ = to atm] - real(r8), pointer :: netrad(:) !net radiation (W/m**2) [+ = to sfc] - real(r8), pointer :: fsds_vis_d(:) !incident direct beam vis solar radiation (W/m**2) - real(r8), pointer :: fsds_nir_d(:) !incident direct beam nir solar radiation (W/m**2) - real(r8), pointer :: fsds_vis_i(:) !incident diffuse vis solar radiation (W/m**2) - real(r8), pointer :: fsds_nir_i(:) !incident diffuse nir solar radiation (W/m**2) - real(r8), pointer :: fsr_vis_d(:) !reflected direct beam vis solar radiation (W/m**2) - real(r8), pointer :: fsr_nir_d(:) !reflected direct beam nir solar radiation (W/m**2) - real(r8), pointer :: fsr_vis_i(:) !reflected diffuse vis solar radiation (W/m**2) - real(r8), pointer :: fsr_nir_i(:) !reflected diffuse nir solar radiation (W/m**2) - real(r8), pointer :: fsds_vis_d_ln(:) !incident direct beam vis solar radiation at local noon (W/m**2) - real(r8), pointer :: fsds_vis_i_ln(:) !incident diffuse beam vis solar radiation at local noon (W/m**2) - real(r8), pointer :: parveg_ln(:) !absorbed par by vegetation at local noon (W/m**2) - real(r8), pointer :: fsds_nir_d_ln(:) !incident direct beam nir solar radiation at local noon (W/m**2) - real(r8), pointer :: fsr_vis_d_ln(:) !reflected direct beam vis solar radiation at local noon (W/m**2) - real(r8), pointer :: fsr_nir_d_ln(:) !reflected direct beam nir solar radiation at local noon (W/m**2) - real(r8), pointer :: sabg_lyr(:,:) ! absorbed radiation in each snow layer and top soil layer (pft,lyr) [W/m2] - real(r8), pointer :: sabg_pen(:) ! (rural) shortwave radiation penetrating top soisno layer [W/m2] - real(r8), pointer :: sfc_frc_aer(:) ! surface forcing of snow with all aerosols (pft) [W/m2] - real(r8), pointer :: sfc_frc_bc(:) ! surface forcing of snow with BC (pft) [W/m2] - real(r8), pointer :: sfc_frc_oc(:) ! surface forcing of snow with OC (pft) [W/m2] - real(r8), pointer :: sfc_frc_dst(:) ! surface forcing of snow with dust (pft) [W/m2] - real(r8), pointer :: sfc_frc_aer_sno(:)! surface forcing of snow with all aerosols, averaged only when snow is present (pft) [W/m2] - real(r8), pointer :: sfc_frc_bc_sno(:) ! surface forcing of snow with BC, averaged only when snow is present (pft) [W/m2] - real(r8), pointer :: sfc_frc_oc_sno(:) ! surface forcing of snow with OC, averaged only when snow is present (pft) [W/m2] - real(r8), pointer :: sfc_frc_dst_sno(:)! surface forcing of snow with dust, averaged only when snow is present (pft) [W/m2] - real(r8), pointer :: fsr_sno_vd(:) ! reflected direct beam vis solar radiation from snow (W/m**2) - real(r8), pointer :: fsr_sno_nd(:) ! reflected direct beam NIR solar radiation from snow (W/m**2) - real(r8), pointer :: fsr_sno_vi(:) ! reflected diffuse vis solar radiation from snow (W/m**2) - real(r8), pointer :: fsr_sno_ni(:) ! reflected diffuse NIR solar radiation from snow (W/m**2) - real(r8), pointer :: fsds_sno_vd(:) ! incident visible, direct radiation on snow (for history files) [W/m2] - real(r8), pointer :: fsds_sno_nd(:) ! incident near-IR, direct radiation on snow (for history files) [W/m2] - real(r8), pointer :: fsds_sno_vi(:) ! incident visible, diffuse radiation on snow (for history files) [W/m2] - real(r8), pointer :: fsds_sno_ni(:) ! incident near-IR, diffuse radiation on snow (for history files) [W/m2] -end type pft_eflux_type - -type(pft_eflux_type) :: pef !pft energy flux - -!---------------------------------------------------- -! pft momentum flux variables structure -!---------------------------------------------------- -type, public :: pft_mflux_type - real(r8),pointer :: taux(:) !wind (shear) stress: e-w (kg/m/s**2) - real(r8),pointer :: tauy(:) !wind (shear) stress: n-s (kg/m/s**2) -end type pft_mflux_type - -type(pft_mflux_type) :: pmf !pft momentum flux - -!---------------------------------------------------- -! pft water flux variables structure -!---------------------------------------------------- -type, public :: pft_wflux_type - real(r8), pointer :: qflx_prec_intr(:) !interception of precipitation [mm/s] - real(r8), pointer :: qflx_prec_grnd(:) !water onto ground including canopy runoff [kg/(m2 s)] - real(r8), pointer :: qflx_rain_grnd(:) !rain on ground after interception (mm H2O/s) [+] - real(r8), pointer :: qflx_snow_grnd(:) !snow on ground after interception (mm H2O/s) [+] - real(r8), pointer :: qflx_snwcp_ice(:) !excess snowfall due to snow capping (mm H2O /s) [+] - real(r8), pointer :: qflx_snwcp_liq(:) !excess rainfall due to snow capping (mm H2O /s) [+] - real(r8), pointer :: qflx_evap_veg(:) !vegetation evaporation (mm H2O/s) (+ = to atm) - real(r8), pointer :: qflx_tran_veg(:) !vegetation transpiration (mm H2O/s) (+ = to atm) - real(r8), pointer :: qflx_evap_can(:) !evaporation from leaves and stems - real(r8), pointer :: qflx_evap_soi(:) !soil evaporation (mm H2O/s) (+ = to atm) - real(r8), pointer :: qflx_evap_tot(:) !qflx_evap_soi + qflx_evap_can + qflx_tran_veg - real(r8), pointer :: qflx_evap_grnd(:) !ground surface evaporation rate (mm H2O/s) [+] - real(r8), pointer :: qflx_dew_grnd(:) !ground surface dew formation (mm H2O /s) [+] - real(r8), pointer :: qflx_sub_snow(:) !sublimation rate from snow pack (mm H2O /s) [+] - real(r8), pointer :: qflx_dew_snow(:) !surface dew added to snow pack (mm H2O /s) [+] - real(r8), pointer :: qflx_ev_snow(:) !snow evaporation (mm H2O/s) (+ = to atm) - real(r8), pointer :: qflx_ev_soil(:) !soil evaporation (mm H2O/s) (+ = to atm) - real(r8), pointer :: qflx_ev_h2osfc(:) !h2osfc evaporation (mm H2O/s) (+ = to atm) -end type pft_wflux_type - -type(pft_wflux_type) :: pwf !pft water flux - -!---------------------------------------------------- -! pft carbon flux variables structure -!---------------------------------------------------- -type, public :: pft_cflux_type - real(r8), pointer :: psnsun(:) !sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: psnsha(:) !shaded leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: psnsun_z(:,:) !canopy layer: sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: psnsha_z(:,:) !canopy layer: shaded leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: cisun_z(:,:) !intracellular sunlit leaf CO2 (Pa) - real(r8), pointer :: cisha_z(:,:) !intracellular shaded leaf CO2 (Pa) - real(r8), pointer :: lmrsun(:) !sunlit leaf maintenance respiration rate (umol CO2/m**2/s) - real(r8), pointer :: lmrsha(:) !shaded leaf maintenance respiration rate (umol CO2/m**2/s) - real(r8), pointer :: lmrsun_z(:,:) !canopy layer: sunlit leaf maintenance respiration rate (umol CO2/m**2/s) - real(r8), pointer :: lmrsha_z(:,:) !canopy layer: shaded leaf maintenance respiration rate (umol CO2/m**2/s) - real(r8), pointer :: fpsn(:) !photosynthesis (umol CO2 /m**2 /s) - real(r8), pointer :: fco2(:) !net CO2 flux (umol CO2 /m**2 /s) [+ = to atm] - real(r8), pointer :: psnsun_wc(:) !Rubsico-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: psnsha_wc(:) !Rubsico-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: fpsn_wc(:) !Rubisco-limited photosynthesis (umol CO2 /m**2 /s) - real(r8), pointer :: psnsun_wj(:) !RuBP-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: psnsha_wj(:) !RuBP-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: fpsn_wj(:) !RuBP-limited photosynthesis (umol CO2 /m**2 /s) - real(r8), pointer :: psnsun_wp(:) !product-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: psnsha_wp(:) !product-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), pointer :: fpsn_wp(:) !product-limited photosynthesis (umol CO2 /m**2 /s) - ! new variables for CN code - ! gap mortality fluxes - real(r8), pointer :: m_leafc_to_litter(:) ! leaf C mortality (gC/m2/s) - real(r8), pointer :: m_leafc_storage_to_litter(:) ! leaf C storage mortality (gC/m2/s) - real(r8), pointer :: m_leafc_xfer_to_litter(:) ! leaf C transfer mortality (gC/m2/s) - real(r8), pointer :: m_frootc_to_litter(:) ! fine root C mortality (gC/m2/s) - real(r8), pointer :: m_frootc_storage_to_litter(:) ! fine root C storage mortality (gC/m2/s) - real(r8), pointer :: m_frootc_xfer_to_litter(:) ! fine root C transfer mortality (gC/m2/s) - real(r8), pointer :: m_livestemc_to_litter(:) ! live stem C mortality (gC/m2/s) - real(r8), pointer :: m_livestemc_storage_to_litter(:) ! live stem C storage mortality (gC/m2/s) - real(r8), pointer :: m_livestemc_xfer_to_litter(:) ! live stem C transfer mortality (gC/m2/s) - real(r8), pointer :: m_deadstemc_to_litter(:) ! dead stem C mortality (gC/m2/s) - real(r8), pointer :: m_deadstemc_storage_to_litter(:) ! dead stem C storage mortality (gC/m2/s) - real(r8), pointer :: m_deadstemc_xfer_to_litter(:) ! dead stem C transfer mortality (gC/m2/s) - real(r8), pointer :: m_livecrootc_to_litter(:) ! live coarse root C mortality (gC/m2/s) - real(r8), pointer :: m_livecrootc_storage_to_litter(:) ! live coarse root C storage mortality (gC/m2/s) - real(r8), pointer :: m_livecrootc_xfer_to_litter(:) ! live coarse root C transfer mortality (gC/m2/s) - real(r8), pointer :: m_deadcrootc_to_litter(:) ! dead coarse root C mortality (gC/m2/s) - real(r8), pointer :: m_deadcrootc_storage_to_litter(:) ! dead coarse root C storage mortality (gC/m2/s) - real(r8), pointer :: m_deadcrootc_xfer_to_litter(:) ! dead coarse root C transfer mortality (gC/m2/s) - real(r8), pointer :: m_gresp_storage_to_litter(:) ! growth respiration storage mortality (gC/m2/s) - real(r8), pointer :: m_gresp_xfer_to_litter(:) ! growth respiration transfer mortality (gC/m2/s) - ! harvest mortality fluxes - real(r8), pointer :: hrv_leafc_to_litter(:) ! leaf C harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_leafc_storage_to_litter(:) ! leaf C storage harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_leafc_xfer_to_litter(:) ! leaf C transfer harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_frootc_to_litter(:) ! fine root C harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_frootc_storage_to_litter(:) ! fine root C storage harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_frootc_xfer_to_litter(:) ! fine root C transfer harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_livestemc_to_litter(:) ! live stem C harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_livestemc_storage_to_litter(:) ! live stem C storage harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_livestemc_xfer_to_litter(:) ! live stem C transfer harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_deadstemc_to_prod10c(:) ! dead stem C harvest to 10-year product pool (gC/m2/s) - real(r8), pointer :: hrv_deadstemc_to_prod100c(:) ! dead stem C harvest to 100-year product pool (gC/m2/s) - real(r8), pointer :: hrv_deadstemc_storage_to_litter(:) ! dead stem C storage harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_deadstemc_xfer_to_litter(:) ! dead stem C transfer harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_livecrootc_to_litter(:) ! live coarse root C harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_livecrootc_storage_to_litter(:) ! live coarse root C storage harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_livecrootc_xfer_to_litter(:) ! live coarse root C transfer harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_deadcrootc_to_litter(:) ! dead coarse root C harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_deadcrootc_storage_to_litter(:) ! dead coarse root C storage harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_deadcrootc_xfer_to_litter(:) ! dead coarse root C transfer harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_gresp_storage_to_litter(:) ! growth respiration storage harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_gresp_xfer_to_litter(:) ! growth respiration transfer harvest mortality (gC/m2/s) - real(r8), pointer :: hrv_xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s) - - ! PFT-level fire C fluxes added by F. Li and S. Levis - real(r8), pointer :: m_leafc_to_fire(:) ! (gC/m2/s) fire C emissions from leafc - real(r8), pointer :: m_leafc_storage_to_fire(:) ! (gC/m2/s) fire C emissions from leafc_storage - real(r8), pointer :: m_leafc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from leafc_xfer - real(r8), pointer :: m_livestemc_to_fire(:) ! (gC/m2/s) fire C emissions from livestemc - real(r8), pointer :: m_livestemc_storage_to_fire(:) ! (gC/m2/s) fire C emissions from livestemc_storage - real(r8), pointer :: m_livestemc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from livestemc_xfer - real(r8), pointer :: m_deadstemc_to_fire(:) ! (gC/m2/s) fire C emissions from deadstemc_xfer - real(r8), pointer :: m_deadstemc_storage_to_fire(:) ! (gC/m2/s) fire C emissions from deadstemc_storage - real(r8), pointer :: m_deadstemc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from deadstemc_xfer - real(r8), pointer :: m_frootc_to_fire(:) ! (gC/m2/s) fire C emissions from frootc - real(r8), pointer :: m_frootc_storage_to_fire(:) ! (gC/m2/s) fire C emissions from frootc_storage - real(r8), pointer :: m_frootc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from frootc_xfer - real(r8), pointer :: m_livecrootc_to_fire(:) ! (gC/m2/s) fire C emissions from livecrootc - real(r8), pointer :: m_livecrootc_storage_to_fire(:)! (gC/m2/s) fire C emissions from livecrootc_storage - real(r8), pointer :: m_livecrootc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from livecrootc_xfer - real(r8), pointer :: m_deadcrootc_to_fire(:) ! (gC/m2/s) fire C emissions from deadcrootc - real(r8), pointer :: m_deadcrootc_storage_to_fire(:)! (gC/m2/s) fire C emissions from deadcrootc_storage - real(r8), pointer :: m_deadcrootc_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from deadcrootc_xfer - real(r8), pointer :: m_gresp_storage_to_fire(:) ! (gC/m2/s) fire C emissions from gresp_storage - real(r8), pointer :: m_gresp_xfer_to_fire(:) ! (gC/m2/s) fire C emissions from gresp_xfer - real(r8), pointer :: m_leafc_to_litter_fire(:) ! (gC/m2/s) from leafc to litter c due to fire - real(r8), pointer :: m_leafc_storage_to_litter_fire(:) ! (gC/m2/s) from leafc_storage to litter C due to fire - real(r8), pointer :: m_leafc_xfer_to_litter_fire(:) ! (gC/m2/s) from leafc_xfer to litter C due to fire - real(r8), pointer :: m_livestemc_to_litter_fire(:) ! (gC/m2/s) from livestemc to litter C due to fire - real(r8), pointer :: m_livestemc_storage_to_litter_fire(:) ! (gC/m2/s) from livestemc_storage to litter C due to fire - real(r8), pointer :: m_livestemc_xfer_to_litter_fire(:) !(gC/m2/s) from livestemc_xfer to litter C due to fire - real(r8), pointer :: m_livestemc_to_deadstemc_fire(:) !(gC/m2/s) from livestemc to deadstemc due to fire - real(r8), pointer :: m_deadstemc_to_litter_fire(:) !(gC/m2/s) from deadstemc to litter C due to fire - real(r8), pointer :: m_deadstemc_storage_to_litter_fire(:) !(gC/m2/s) from deadstemc_storage to litter C due to fire - real(r8), pointer :: m_deadstemc_xfer_to_litter_fire(:) !(gC/m2/s) from deadstemc_xfer to litter C due to fire - real(r8), pointer :: m_frootc_to_litter_fire(:) !(gC/m2/s) from frootc to litter C due to fire - real(r8), pointer :: m_frootc_storage_to_litter_fire(:) !(gC/m2/s) from frootc_storage to litter C due to fire - real(r8), pointer :: m_frootc_xfer_to_litter_fire(:) !(gC/m2/s) from frootc_xfer to litter C due to fire - real(r8), pointer :: m_livecrootc_to_litter_fire(:) !(gC/m2/s) from livecrootc to litter C due to fire - real(r8), pointer :: m_livecrootc_storage_to_litter_fire(:) !(gC/m2/s) from livecrootc_storage to litter C due to fire - real(r8), pointer :: m_livecrootc_xfer_to_litter_fire(:) !(gC/m2/s) from livecrootc_xfer to litter C due to fire - real(r8), pointer :: m_livecrootc_to_deadcrootc_fire(:) !(gC/m2/s) from livecrootc to deadstemc due to fire - real(r8), pointer :: m_deadcrootc_to_litter_fire(:) !(gC/m2/s) from deadcrootc to litter C due to fire - real(r8), pointer :: m_deadcrootc_storage_to_litter_fire(:) !(gC/m2/s) from deadcrootc_storage to litter C due to fire - real(r8), pointer :: m_deadcrootc_xfer_to_litter_fire(:) !(gC/m2/s) from deadcrootc_xfer to litter C due to fire - real(r8), pointer :: m_gresp_storage_to_litter_fire(:) !(gC/m2/s) from gresp_storage to litter C due to fire - real(r8), pointer :: m_gresp_xfer_to_litter_fire(:) !(gC/m2/s) from gresp_xfer to litter C due to fire - - ! phenology fluxes from transfer pools - real(r8), pointer :: grainc_xfer_to_grainc(:) ! grain C growth from storage for prognostic crop(gC/m2/s) - real(r8), pointer :: leafc_xfer_to_leafc(:) ! leaf C growth from storage (gC/m2/s) - real(r8), pointer :: frootc_xfer_to_frootc(:) ! fine root C growth from storage (gC/m2/s) - real(r8), pointer :: livestemc_xfer_to_livestemc(:) ! live stem C growth from storage (gC/m2/s) - real(r8), pointer :: deadstemc_xfer_to_deadstemc(:) ! dead stem C growth from storage (gC/m2/s) - real(r8), pointer :: livecrootc_xfer_to_livecrootc(:) ! live coarse root C growth from storage (gC/m2/s) - real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:) ! dead coarse root C growth from storage (gC/m2/s) - ! leaf and fine root litterfall - real(r8), pointer :: leafc_to_litter(:) ! leaf C litterfall (gC/m2/s) - real(r8), pointer :: frootc_to_litter(:) ! fine root C litterfall (gC/m2/s) - real(r8), pointer :: livestemc_to_litter(:) ! live stem C litterfall (gC/m2/s) - real(r8), pointer :: grainc_to_food(:) ! grain C to food for prognostic crop(gC/m2/s) - ! maintenance respiration fluxes - real(r8), pointer :: leaf_mr(:) ! leaf maintenance respiration (gC/m2/s) - real(r8), pointer :: froot_mr(:) ! fine root maintenance respiration (gC/m2/s) - real(r8), pointer :: livestem_mr(:) ! live stem maintenance respiration (gC/m2/s) - real(r8), pointer :: livecroot_mr(:) ! live coarse root maintenance respiration (gC/m2/s) - real(r8), pointer :: grain_mr(:) ! crop grain or organs maint. respiration (gC/m2/s) - real(r8), pointer :: leaf_curmr(:) ! leaf maintenance respiration from current GPP (gC/m2/s) - real(r8), pointer :: froot_curmr(:) ! fine root maintenance respiration from current GPP (gC/m2/s) - real(r8), pointer :: livestem_curmr(:) ! live stem maintenance respiration from current GPP (gC/m2/s) - real(r8), pointer :: livecroot_curmr(:) ! live coarse root maintenance respiration from current GPP (gC/m2/s) - real(r8), pointer :: grain_curmr(:) ! crop grain or organs maint. respiration from current GPP (gC/m2/s) - real(r8), pointer :: leaf_xsmr(:) ! leaf maintenance respiration from storage (gC/m2/s) - real(r8), pointer :: froot_xsmr(:) ! fine root maintenance respiration from storage (gC/m2/s) - real(r8), pointer :: livestem_xsmr(:) ! live stem maintenance respiration from storage (gC/m2/s) - real(r8), pointer :: livecroot_xsmr(:) ! live coarse root maintenance respiration from storage (gC/m2/s) - real(r8), pointer :: grain_xsmr(:) ! crop grain or organs maint. respiration from storage (gC/m2/s) - ! photosynthesis fluxes - real(r8), pointer :: psnsun_to_cpool(:) ! C fixation from sunlit canopy (gC/m2/s) - real(r8), pointer :: psnshade_to_cpool(:) ! C fixation from shaded canopy (gC/m2/s) - ! allocation fluxes, from current GPP - real(r8), pointer :: cpool_to_xsmrpool(:) ! allocation to maintenance respiration storage pool (gC/m2/s) - real(r8), pointer :: cpool_to_grainc(:) ! allocation to grain C for prognostic crop(gC/m2/s) - real(r8), pointer :: cpool_to_grainc_storage(:) ! allocation to grain C storage for prognostic crop(gC/m2/s) - real(r8), pointer :: cpool_to_leafc(:) ! allocation to leaf C (gC/m2/s) - real(r8), pointer :: cpool_to_leafc_storage(:) ! allocation to leaf C storage (gC/m2/s) - real(r8), pointer :: cpool_to_frootc(:) ! allocation to fine root C (gC/m2/s) - real(r8), pointer :: cpool_to_frootc_storage(:) ! allocation to fine root C storage (gC/m2/s) - real(r8), pointer :: cpool_to_livestemc(:) ! allocation to live stem C (gC/m2/s) - real(r8), pointer :: cpool_to_livestemc_storage(:) ! allocation to live stem C storage (gC/m2/s) - real(r8), pointer :: cpool_to_deadstemc(:) ! allocation to dead stem C (gC/m2/s) - real(r8), pointer :: cpool_to_deadstemc_storage(:) ! allocation to dead stem C storage (gC/m2/s) - real(r8), pointer :: cpool_to_livecrootc(:) ! allocation to live coarse root C (gC/m2/s) - real(r8), pointer :: cpool_to_livecrootc_storage(:) ! allocation to live coarse root C storage (gC/m2/s) - real(r8), pointer :: cpool_to_deadcrootc(:) ! allocation to dead coarse root C (gC/m2/s) - real(r8), pointer :: cpool_to_deadcrootc_storage(:) ! allocation to dead coarse root C storage (gC/m2/s) - real(r8), pointer :: cpool_to_gresp_storage(:) ! allocation to growth respiration storage (gC/m2/s) - ! growth respiration fluxes - real(r8), pointer :: xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s) - real(r8), pointer :: cpool_leaf_gr(:) ! leaf growth respiration (gC/m2/s) - real(r8), pointer :: cpool_leaf_storage_gr(:) ! leaf growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_leaf_gr(:) ! leaf growth respiration from storage (gC/m2/s) - real(r8), pointer :: cpool_froot_gr(:) ! fine root growth respiration (gC/m2/s) - real(r8), pointer :: cpool_froot_storage_gr(:) ! fine root growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_froot_gr(:) ! fine root growth respiration from storage (gC/m2/s) - real(r8), pointer :: cpool_livestem_gr(:) ! live stem growth respiration (gC/m2/s) - real(r8), pointer :: cpool_livestem_storage_gr(:) ! live stem growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_livestem_gr(:) ! live stem growth respiration from storage (gC/m2/s) - real(r8), pointer :: cpool_deadstem_gr(:) ! dead stem growth respiration (gC/m2/s) - real(r8), pointer :: cpool_deadstem_storage_gr(:) ! dead stem growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_deadstem_gr(:) ! dead stem growth respiration from storage (gC/m2/s) - real(r8), pointer :: cpool_livecroot_gr(:) ! live coarse root growth respiration (gC/m2/s) - real(r8), pointer :: cpool_livecroot_storage_gr(:) ! live coarse root growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_livecroot_gr(:) ! live coarse root growth respiration from storage (gC/m2/s) - real(r8), pointer :: cpool_deadcroot_gr(:) ! dead coarse root growth respiration (gC/m2/s) - real(r8), pointer :: cpool_deadcroot_storage_gr(:) ! dead coarse root growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_deadcroot_gr(:) ! dead coarse root growth respiration from storage (gC/m2/s) - ! growth respiration for prognostic crop model - real(r8), pointer :: cpool_grain_gr(:) ! grain growth respiration (gC/m2/s) - real(r8), pointer :: cpool_grain_storage_gr(:) ! grain growth respiration to storage (gC/m2/s) - real(r8), pointer :: transfer_grain_gr(:) ! grain growth respiration from storage (gC/m2/s) - ! annual turnover of storage to transfer pools - real(r8), pointer :: grainc_storage_to_xfer(:) ! grain C shift storage to transfer for prognostic crop model (gC/m2/s) - real(r8), pointer :: leafc_storage_to_xfer(:) ! leaf C shift storage to transfer (gC/m2/s) - real(r8), pointer :: frootc_storage_to_xfer(:) ! fine root C shift storage to transfer (gC/m2/s) - real(r8), pointer :: livestemc_storage_to_xfer(:) ! live stem C shift storage to transfer (gC/m2/s) - real(r8), pointer :: deadstemc_storage_to_xfer(:) ! dead stem C shift storage to transfer (gC/m2/s) - real(r8), pointer :: livecrootc_storage_to_xfer(:) ! live coarse root C shift storage to transfer (gC/m2/s) - real(r8), pointer :: deadcrootc_storage_to_xfer(:) ! dead coarse root C shift storage to transfer (gC/m2/s) - real(r8), pointer :: gresp_storage_to_xfer(:) ! growth respiration shift storage to transfer (gC/m2/s) - ! turnover of livewood to deadwood - real(r8), pointer :: livestemc_to_deadstemc(:) ! live stem C turnover (gC/m2/s) - real(r8), pointer :: livecrootc_to_deadcrootc(:) ! live coarse root C turnover (gC/m2/s) - ! summary (diagnostic) flux variables, not involved in mass balance - real(r8), pointer :: gpp(:) ! (gC/m2/s) gross primary production - real(r8), pointer :: mr(:) ! (gC/m2/s) maintenance respiration - real(r8), pointer :: current_gr(:) ! (gC/m2/s) growth resp for new growth displayed in this timestep - real(r8), pointer :: transfer_gr(:) ! (gC/m2/s) growth resp for transfer growth displayed in this timestep - real(r8), pointer :: storage_gr(:) ! (gC/m2/s) growth resp for growth sent to storage for later display - real(r8), pointer :: gr(:) ! (gC/m2/s) total growth respiration - real(r8), pointer :: ar(:) ! (gC/m2/s) autotrophic respiration (MR + GR) - real(r8), pointer :: rr(:) ! (gC/m2/s) root respiration (fine root MR + total root GR) - real(r8), pointer :: npp(:) ! (gC/m2/s) net primary production - real(r8), pointer :: agnpp(:) ! (gC/m2/s) aboveground NPP - real(r8), pointer :: bgnpp(:) ! (gC/m2/s) belowground NPP - real(r8), pointer :: litfall(:) ! (gC/m2/s) litterfall (leaves and fine roots) - real(r8), pointer :: vegfire(:) ! (gC/m2/s) pft-level fire loss (obsolete, mark for removal) - real(r8), pointer :: wood_harvestc(:) ! (gC/m2/s) pft-level wood harvest (to product pools) - real(r8), pointer :: pft_cinputs(:) ! (gC/m2/s) pft-level carbon inputs (for balance checking) - real(r8), pointer :: pft_coutputs(:) ! (gC/m2/s) pft-level carbon outputs (for balance checking) - ! CN: CLAMP summary (diagnostic) variables, not involved in mass balance - real(r8), pointer :: frootc_alloc(:) ! (gC/m2/s) pft-level fine root C alloc - real(r8), pointer :: frootc_loss(:) ! (gC/m2/s) pft-level fine root C loss - real(r8), pointer :: leafc_alloc(:) ! (gC/m2/s) pft-level leaf C alloc - real(r8), pointer :: leafc_loss(:) ! (gC/m2/s) pft-level leaf C loss - real(r8), pointer :: woodc_alloc(:) ! (gC/m2/s) pft-level wood C alloc - real(r8), pointer :: woodc_loss(:) ! (gC/m2/s) pft-level wood C loss - ! new variables for fire code - real(r8), pointer :: pft_fire_closs(:) ! (gC/m2/s) total pft-level fire C loss - ! For aerenchyma calculations in CH4 code - real(r8), pointer :: annavg_agnpp(:) ! (gC/m2/s) annual average aboveground NPP - real(r8), pointer :: annavg_bgnpp(:) ! (gC/m2/s) annual average belowground NPP - real(r8), pointer :: tempavg_agnpp(:) ! (gC/m2/s) temp. average aboveground NPP - real(r8), pointer :: tempavg_bgnpp(:) ! (gC/m2/s) temp. average belowground NPP - ! -end type pft_cflux_type - -type(pft_cflux_type), target :: pcf !pft carbon flux -type(pft_cflux_type), target :: pcf_a !pft carbon flux averaged to the column -type(pft_cflux_type), target :: pc13f !pft carbon-13 flux -type(pft_cflux_type), target :: pc13f_a !pft carbon-13 flux averaged to the column -type(pft_cflux_type), target :: pc14f !pft carbon-14 flux -type(pft_cflux_type), target :: pc14f_a !pft carbon-14 flux averaged to the column - -!---------------------------------------------------- -! pft nitrogen flux variables structure -!---------------------------------------------------- -type, public :: pft_nflux_type - ! new variables for CN code - ! gap mortality fluxes - real(r8), pointer :: m_leafn_to_litter(:) ! leaf N mortality (gN/m2/s) - real(r8), pointer :: m_frootn_to_litter(:) ! fine root N mortality (gN/m2/s) - real(r8), pointer :: m_leafn_storage_to_litter(:) ! leaf N storage mortality (gN/m2/s) - real(r8), pointer :: m_frootn_storage_to_litter(:) ! fine root N storage mortality (gN/m2/s) - real(r8), pointer :: m_livestemn_storage_to_litter(:) ! live stem N storage mortality (gN/m2/s) - real(r8), pointer :: m_deadstemn_storage_to_litter(:) ! dead stem N storage mortality (gN/m2/s) - real(r8), pointer :: m_livecrootn_storage_to_litter(:) ! live coarse root N storage mortality (gN/m2/s) - real(r8), pointer :: m_deadcrootn_storage_to_litter(:) ! dead coarse root N storage mortality (gN/m2/s) - real(r8), pointer :: m_leafn_xfer_to_litter(:) ! leaf N transfer mortality (gN/m2/s) - real(r8), pointer :: m_frootn_xfer_to_litter(:) ! fine root N transfer mortality (gN/m2/s) - real(r8), pointer :: m_livestemn_xfer_to_litter(:) ! live stem N transfer mortality (gN/m2/s) - real(r8), pointer :: m_deadstemn_xfer_to_litter(:) ! dead stem N transfer mortality (gN/m2/s) - real(r8), pointer :: m_livecrootn_xfer_to_litter(:) ! live coarse root N transfer mortality (gN/m2/s) - real(r8), pointer :: m_deadcrootn_xfer_to_litter(:) ! dead coarse root N transfer mortality (gN/m2/s) - real(r8), pointer :: m_livestemn_to_litter(:) ! live stem N mortality (gN/m2/s) - real(r8), pointer :: m_deadstemn_to_litter(:) ! dead stem N mortality (gN/m2/s) - real(r8), pointer :: m_livecrootn_to_litter(:) ! live coarse root N mortality (gN/m2/s) - real(r8), pointer :: m_deadcrootn_to_litter(:) ! dead coarse root N mortality (gN/m2/s) - real(r8), pointer :: m_retransn_to_litter(:) ! retranslocated N pool mortality (gN/m2/s) - ! harvest mortality fluxes - real(r8), pointer :: hrv_leafn_to_litter(:) ! leaf N harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_frootn_to_litter(:) ! fine root N harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_leafn_storage_to_litter(:) ! leaf N storage harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_frootn_storage_to_litter(:) ! fine root N storage harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_livestemn_storage_to_litter(:) ! live stem N storage harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_deadstemn_storage_to_litter(:) ! dead stem N storage harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_livecrootn_storage_to_litter(:) ! live coarse root N storage harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_deadcrootn_storage_to_litter(:) ! dead coarse root N storage harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_leafn_xfer_to_litter(:) ! leaf N transfer harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_frootn_xfer_to_litter(:) ! fine root N transfer harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_livestemn_xfer_to_litter(:) ! live stem N transfer harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_deadstemn_xfer_to_litter(:) ! dead stem N transfer harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_livecrootn_xfer_to_litter(:) ! live coarse root N transfer harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_deadcrootn_xfer_to_litter(:) ! dead coarse root N transfer harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_livestemn_to_litter(:) ! live stem N harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_deadstemn_to_prod10n(:) ! dead stem N harvest to 10-year product pool (gN/m2/s) - real(r8), pointer :: hrv_deadstemn_to_prod100n(:) ! dead stem N harvest to 100-year product pool (gN/m2/s) - real(r8), pointer :: hrv_livecrootn_to_litter(:) ! live coarse root N harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_deadcrootn_to_litter(:) ! dead coarse root N harvest mortality (gN/m2/s) - real(r8), pointer :: hrv_retransn_to_litter(:) ! retranslocated N pool harvest mortality (gN/m2/s) - - ! PFT-level fire N fluxes added by F. Li and S. Levis - real(r8), pointer :: m_leafn_to_fire(:) ! (gN/m2/s) fire N emissions from leafn - real(r8), pointer :: m_leafn_storage_to_fire(:) ! (gN/m2/s) fire N emissions from leafn_storage - real(r8), pointer :: m_leafn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from leafn_xfer - real(r8), pointer :: m_livestemn_to_fire(:) ! (gN/m2/s) fire N emissions from livestemn - real(r8), pointer :: m_livestemn_storage_to_fire(:) ! (gN/m2/s) fire N emissions from livestemn_storage - real(r8), pointer :: m_livestemn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from livestemn_xfer - real(r8), pointer :: m_deadstemn_to_fire(:) ! (gN/m2/s) fire N emissions from deadstemn - real(r8), pointer :: m_deadstemn_storage_to_fire(:) ! (gN/m2/s) fire N emissions from deadstemn_storage - real(r8), pointer :: m_deadstemn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from deadstemn_xfer - real(r8), pointer :: m_frootn_to_fire(:) ! (gN/m2/s) fire N emissions from frootn - real(r8), pointer :: m_frootn_storage_to_fire(:) ! (gN/m2/s) fire N emissions from frootn_storage - real(r8), pointer :: m_frootn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from frootn_xfer - real(r8), pointer :: m_livecrootn_to_fire(:) ! (gN/m2/s) fire N emissions from m_livecrootn_to_fire - real(r8), pointer :: m_livecrootn_storage_to_fire(:)! (gN/m2/s) fire N emissions from livecrootn_storage - real(r8), pointer :: m_livecrootn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from livecrootn_xfer - real(r8), pointer :: m_deadcrootn_to_fire(:) ! (gN/m2/s) fire N emissions from deadcrootn - real(r8), pointer :: m_deadcrootn_storage_to_fire(:)! (gN/m2/s) fire N emissions from deadcrootn_storage - real(r8), pointer :: m_deadcrootn_xfer_to_fire(:) ! (gN/m2/s) fire N emissions from deadcrootn_xfer - real(r8), pointer :: m_retransn_to_fire(:) ! (gN/m2/s) fire N emissions from retransn - real(r8), pointer :: m_leafn_to_litter_fire(:) ! (gN/m2/s) from leafn to litter N due to fire - real(r8), pointer :: m_leafn_storage_to_litter_fire(:) ! (gN/m2/s) from leafn_storage to litter N due to fire - real(r8), pointer :: m_leafn_xfer_to_litter_fire(:) ! (gN/m2/s) from leafn_xfer to litter N due to fire - real(r8), pointer :: m_livestemn_to_litter_fire(:) ! (gN/m2/s) from livestemn to litter N due to fire - real(r8), pointer :: m_livestemn_storage_to_litter_fire(:) ! (gN/m2/s) from livestemn_storage to litter N due to fire - real(r8), pointer :: m_livestemn_xfer_to_litter_fire(:) ! (gN/m2/s) from livestemn_xfer to litter N due to fire - real(r8), pointer :: m_livestemn_to_deadstemn_fire(:) ! (gN/m2/s) from livestemn to deadstemn N due to fire - real(r8), pointer :: m_deadstemn_to_litter_fire(:) ! (gN/m2/s) from deadstemn to litter N due to fire - real(r8), pointer :: m_deadstemn_storage_to_litter_fire(:) ! (gN/m2/s) from deadstemn_storage to litter N due to fire - real(r8), pointer :: m_deadstemn_xfer_to_litter_fire(:) ! (gN/m2/s) from deadstemn_xfer to litter N due to fire - real(r8), pointer :: m_frootn_to_litter_fire(:) ! (gN/m2/s) from frootn to litter N due to fire - real(r8), pointer :: m_frootn_storage_to_litter_fire(:) ! (gN/m2/s) from frootn_storage to litter N due to fire - real(r8), pointer :: m_frootn_xfer_to_litter_fire(:) ! (gN/m2/s) from frootn_xfer to litter N due to fire - real(r8), pointer :: m_livecrootn_to_litter_fire(:) ! (gN/m2/s) from livecrootn to litter N due to fire - real(r8), pointer :: m_livecrootn_storage_to_litter_fire(:)! (gN/m2/s) from livecrootn_storage to litter N due to fire - real(r8), pointer :: m_livecrootn_xfer_to_litter_fire(:) ! (gN/m2/s) from livecrootn_xfer to litter N due to fire - real(r8), pointer :: m_livecrootn_to_deadcrootn_fire(:) ! (gN/m2/s) from livecrootn_xfer to deadcrootn due to fire - real(r8), pointer :: m_deadcrootn_to_litter_fire(:) ! (gN/m2/s) from deadcrootn to deadcrootn due to fire - real(r8), pointer :: m_deadcrootn_storage_to_litter_fire(:)! (gN/m2/s) from deadcrootn_storage to deadcrootn due to fire - real(r8), pointer :: m_deadcrootn_xfer_to_litter_fire(:) ! (gN/m2/s) from deadcrootn_xfer to deadcrootn due to fire - real(r8), pointer :: m_retransn_to_litter_fire(:) ! (gN/m2/s) from retransn to deadcrootn due to fire - - - ! phenology fluxes from transfer pool - real(r8), pointer :: grainn_xfer_to_grainn(:) ! grain N growth from storage for prognostic crop model (gN/m2/s) - real(r8), pointer :: leafn_xfer_to_leafn(:) ! leaf N growth from storage (gN/m2/s) - real(r8), pointer :: frootn_xfer_to_frootn(:) ! fine root N growth from storage (gN/m2/s) - real(r8), pointer :: livestemn_xfer_to_livestemn(:) ! live stem N growth from storage (gN/m2/s) - real(r8), pointer :: deadstemn_xfer_to_deadstemn(:) ! dead stem N growth from storage (gN/m2/s) - real(r8), pointer :: livecrootn_xfer_to_livecrootn(:) ! live coarse root N growth from storage (gN/m2/s) - real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:) ! dead coarse root N growth from storage (gN/m2/s) - ! litterfall fluxes - real(r8), pointer :: livestemn_to_litter(:) ! livestem N to litter (gN/m2/s) - real(r8), pointer :: grainn_to_food(:) ! grain N to food for prognostic crop (gN/m2/s) - real(r8), pointer :: leafn_to_litter(:) ! leaf N litterfall (gN/m2/s) - real(r8), pointer :: leafn_to_retransn(:) ! leaf N to retranslocated N pool (gN/m2/s) - real(r8), pointer :: frootn_to_retransn(:) ! fine root N to retranslocated N pool (gN/m2/s) - real(r8), pointer :: frootn_to_litter(:) ! fine root N litterfall (gN/m2/s) - ! allocation fluxes - real(r8), pointer :: retransn_to_npool(:) ! deployment of retranslocated N (gN/m2/s) - real(r8), pointer :: sminn_to_npool(:) ! deployment of soil mineral N uptake (gN/m2/s) - real(r8), pointer :: npool_to_grainn(:) ! allocation to grain N for prognostic crop (gN/m2/s) - real(r8), pointer :: npool_to_grainn_storage(:) ! allocation to grain N storage for prognostic crop (gN/m2/s) - real(r8), pointer :: npool_to_leafn(:) ! allocation to leaf N (gN/m2/s) - real(r8), pointer :: npool_to_leafn_storage(:) ! allocation to leaf N storage (gN/m2/s) - real(r8), pointer :: npool_to_frootn(:) ! allocation to fine root N (gN/m2/s) - real(r8), pointer :: npool_to_frootn_storage(:) ! allocation to fine root N storage (gN/m2/s) - real(r8), pointer :: npool_to_livestemn(:) ! allocation to live stem N (gN/m2/s) - real(r8), pointer :: npool_to_livestemn_storage(:) ! allocation to live stem N storage (gN/m2/s) - real(r8), pointer :: npool_to_deadstemn(:) ! allocation to dead stem N (gN/m2/s) - real(r8), pointer :: npool_to_deadstemn_storage(:) ! allocation to dead stem N storage (gN/m2/s) - real(r8), pointer :: npool_to_livecrootn(:) ! allocation to live coarse root N (gN/m2/s) - real(r8), pointer :: npool_to_livecrootn_storage(:) ! allocation to live coarse root N storage (gN/m2/s) - real(r8), pointer :: npool_to_deadcrootn(:) ! allocation to dead coarse root N (gN/m2/s) - real(r8), pointer :: npool_to_deadcrootn_storage(:) ! allocation to dead coarse root N storage (gN/m2/s) - ! annual turnover of storage to transfer pools - real(r8), pointer :: grainn_storage_to_xfer(:) ! grain N shift storage to transfer for prognostic crop (gN/m2/s) - real(r8), pointer :: leafn_storage_to_xfer(:) ! leaf N shift storage to transfer (gN/m2/s) - real(r8), pointer :: frootn_storage_to_xfer(:) ! fine root N shift storage to transfer (gN/m2/s) - real(r8), pointer :: livestemn_storage_to_xfer(:) ! live stem N shift storage to transfer (gN/m2/s) - real(r8), pointer :: deadstemn_storage_to_xfer(:) ! dead stem N shift storage to transfer (gN/m2/s) - real(r8), pointer :: livecrootn_storage_to_xfer(:) ! live coarse root N shift storage to transfer (gN/m2/s) - real(r8), pointer :: deadcrootn_storage_to_xfer(:) ! dead coarse root N shift storage to transfer (gN/m2/s) - real(r8), pointer :: fert(:) ! applied fertilizer (gN/m2/s) - real(r8), pointer :: soyfixn(:) ! soybean fixed N (gN/m2/s) - ! turnover of livewood to deadwood, with retranslocation - real(r8), pointer :: livestemn_to_deadstemn(:) ! live stem N turnover (gN/m2/s) - real(r8), pointer :: livestemn_to_retransn(:) ! live stem N to retranslocated N pool (gN/m2/s) - real(r8), pointer :: livecrootn_to_deadcrootn(:) ! live coarse root N turnover (gN/m2/s) - real(r8), pointer :: livecrootn_to_retransn(:) ! live coarse root N to retranslocated N pool (gN/m2/s) - ! summary (diagnostic) flux variables, not involved in mass balance - real(r8), pointer :: ndeploy(:) ! total N deployed to growth and storage (gN/m2/s) - real(r8), pointer :: pft_ninputs(:) ! total N inputs to pft-level (gN/m2/s) - real(r8), pointer :: pft_noutputs(:) ! total N outputs from pft-level (gN/m2/s) - real(r8), pointer :: wood_harvestn(:) ! total N losses to wood product pools (gN/m2/s) - ! new variables for fire code - real(r8), pointer :: pft_fire_nloss(:) ! total pft-level fire N loss (gN/m2/s) -end type pft_nflux_type - -type(pft_nflux_type) :: pnf !pft nitrogen flux -type(pft_nflux_type) :: pnf_a !pft-level nitrogen flux variables averaged to the column - -!---------------------------------------------------- -! pft VOC fluxes structure for history output -!---------------------------------------------------- -type, public :: megan_out_type - real(r8), pointer :: flux_out(:) !(n_megan_comps) MEGAN flux [ug C m-2 h-1] -endtype megan_out_type - -!---------------------------------------------------- -! pft VOC flux variables structure -!---------------------------------------------------- -type, public :: pft_vflux_type - real(r8), pointer :: vocflx_tot(:) !total VOC flux into atmosphere [moles/m2/sec] - real(r8), pointer :: vocflx(:,:) !(num_mech_comps) MEGAN flux [moles/m2/sec] - real(r8), pointer :: Eopt_out(:) !Eopt coefficient - real(r8), pointer :: topt_out(:) !topt coefficient - real(r8), pointer :: alpha_out(:) !alpha coefficient - real(r8), pointer :: cp_out(:) !cp coefficient - real(r8), pointer :: paru_out(:) - real(r8), pointer :: par24u_out(:) - real(r8), pointer :: par240u_out(:) - real(r8), pointer :: para_out(:) - real(r8), pointer :: par24a_out(:) - real(r8), pointer :: par240a_out(:) - real(r8), pointer :: gamma_out(:) - real(r8), pointer :: gammaL_out(:) - real(r8), pointer :: gammaT_out(:) - real(r8), pointer :: gammaP_out(:) - real(r8), pointer :: gammaA_out(:) - real(r8), pointer :: gammaS_out(:) - real(r8), pointer :: gammaC_out(:) - type(megan_out_type), pointer :: meg(:) ! points to output fluxes -end type pft_vflux_type - -type(pft_vflux_type) :: pvf !pft VOC flux - -!---------------------------------------------------- -! pft dry dep velocity variables structure -!---------------------------------------------------- -type, public :: pft_depvd_type - real(r8), pointer :: drydepvel(:,:) -end type pft_depvd_type - -type(pft_depvd_type) :: pdd !dry dep velocity - -!---------------------------------------------------- -! pft dust flux variables structure -!---------------------------------------------------- -type, public :: pft_dflux_type - real(r8), pointer :: flx_mss_vrt_dst(:,:) !(ndst) !surface dust emission (kg/m**2/s) [ + = to atm] - real(r8), pointer :: flx_mss_vrt_dst_tot(:) !total dust flux into atmosphere - real(r8), pointer :: vlc_trb(:,:) !(ndst) turbulent deposition velocity (m/s) - real(r8), pointer :: vlc_trb_1(:) !turbulent deposition velocity 1(m/s) - real(r8), pointer :: vlc_trb_2(:) !turbulent deposition velocity 2(m/s) - real(r8), pointer :: vlc_trb_3(:) !turbulent deposition velocity 3(m/s) - real(r8), pointer :: vlc_trb_4(:) !turbulent deposition velocity 4(m/s) -end type pft_dflux_type - -type(pft_dflux_type) :: pdf !pft dust flux - -!---------------------------------------------------- -! End definition of structures defined at the pft_type level -!---------------------------------------------------- -!******************************************************************************* - - -!******************************************************************************* -!---------------------------------------------------- -! Begin definition of structures defined at the column_type level -!---------------------------------------------------- -! column physical state variables structure -!---------------------------------------------------- -type, public :: column_pstate_type - integer , pointer :: snl(:) !number of snow layers - integer , pointer :: isoicol(:) !soil color class - - !F. Li and S. Levis - real(r8), pointer :: gdp_lf(:) ! global real gdp data (k US$/capita) - real(r8), pointer :: peatf_lf(:) ! global peatland fraction data (0-1) - integer , pointer :: abm_lf(:) ! global peak month of crop fire emissions - real(r8), pointer :: lgdp_col(:) !gdp limitation factor for fire occurrence (0-1) - real(r8), pointer :: lgdp1_col(:) !gdp limitation factor for fire spreading (0-1) - real(r8), pointer :: lpop_col(:) !pop limitation factor for fire spreading (0-1) - - real(r8), pointer :: bsw(:,:) !Clapp and Hornberger "b" (nlevgrnd) - real(r8), pointer :: watsat(:,:) !volumetric soil water at saturation (porosity) (nlevgrnd) - real(r8), pointer :: watdry(:,:) !btran parameter for btran=0 - real(r8), pointer :: watopt(:,:) !btran parameter for btran = 1 - real(r8), pointer :: hksat(:,:) !hydraulic conductivity at saturation (mm H2O /s) (nlevgrnd) - real(r8), pointer :: hksat_min(:,:) !mineral hksat - real(r8), pointer :: tk_hist(:,:) !thermal conductivity - real(r8), pointer :: cv_hist(:,:) !heat capacity - real(r8), pointer :: sucsat(:,:) !minimum soil suction (mm) (nlevgrnd) - real(r8), pointer :: hkdepth(:) !decay factor (m) - real(r8), pointer :: wtfact(:) !maximum saturated fraction for a gridcell - real(r8), pointer :: fracice(:,:) !fractional impermeability (-) - real(r8), pointer :: csol(:,:) !heat capacity, soil solids (J/m**3/Kelvin) (nlevgrnd) - real(r8), pointer :: tkmg(:,:) !thermal conductivity, soil minerals [W/m-K] (new) (nlevgrnd) - real(r8), pointer :: tkdry(:,:) !thermal conductivity, dry soil (W/m/Kelvin) (nlevgrnd) - real(r8), pointer :: tksatu(:,:) !thermal conductivity, saturated soil [W/m-K] (new) (nlevgrnd) - real(r8), pointer :: smpmin(:) !restriction for min of soil potential (mm) (new) - real(r8), pointer :: gwc_thr(:) !threshold soil moisture based on clay content - real(r8), pointer :: mss_frc_cly_vld(:) ![frc] Mass fraction clay limited to 0.20 - real(r8), pointer :: mbl_bsn_fct(:) !basin factor - logical , pointer :: do_capsnow(:) !true => do snow capping - real(r8), pointer :: snow_depth(:) !snow height of snow covered area (m) - real(r8), pointer :: snowdp(:) ! gridcell averaged snow height (m) - real(r8), pointer :: frac_sno(:) !fraction of ground covered by snow (0 to 1) - real(r8), pointer :: frac_sno_eff(:) !fraction of ground covered by snow (0 to 1) - real(r8), pointer :: frac_h2osfc(:) !fractional area with surface water greater than zero - real(r8), pointer :: topo_std(:) !gridcell topographic standard deviation (m) - real(r8), pointer :: topo_ndx(:) !gridcell topographic index - real(r8), pointer :: topo_slope(:) !gridcell topographic slope - real(r8), pointer :: micro_sigma(:) ! microtopography pdf sigma (m) - real(r8), pointer :: h2osfc_thresh(:) ! level at which h2osfc "percolates" - real(r8), pointer :: n_melt(:) ! SCA shape parameter - real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) (-nlevsno+0:nlevgrnd) - real(r8), pointer :: dz(:,:) !layer thickness (m) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: z(:,:) !layer depth (m) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: frac_iceold(:,:) !fraction of ice relative to the tot water (new) (-nlevsno+1:nlevgrnd) - integer , pointer :: imelt(:,:) !flag for melting (=1), freezing (=2), Not=0 (new) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: eff_porosity(:,:) !effective porosity = porosity - vol_ice (nlevgrnd) - real(r8), pointer :: emg(:) !ground emissivity - real(r8), pointer :: z0mg(:) !roughness length over ground, momentum [m] - real(r8), pointer :: z0hg(:) !roughness length over ground, sensible heat [m] - real(r8), pointer :: z0qg(:) !roughness length over ground, latent heat [m] - real(r8), pointer :: htvp(:) !latent heat of vapor of water (or sublimation) [j/kg] - real(r8), pointer :: beta(:) !coefficient of convective velocity [-] - real(r8), pointer :: zii(:) !convective boundary height [m] - real(r8), pointer :: albgrd(:,:) !ground albedo (direct) (numrad) - real(r8), pointer :: albgri(:,:) !ground albedo (diffuse) (numrad) - real(r8), pointer :: rootr_column(:,:) !effective fraction of roots in each soil layer (nlevgrnd) - real(r8), pointer :: rootfr_road_perv(:,:) !fraction of roots in each soil layer for urban pervious road - real(r8), pointer :: rootr_road_perv(:,:) !effective fraction of roots in each soil layer of urban pervious road - - real(r8), pointer :: wf(:) !soil water as frac. of whc for top 0.05 m (0-1) (only comment changed by F. Li and S. Levis) - real(r8), pointer :: wf2(:) !soil water as frac. of whc for top 0.17 m (0-1) added by F. Li and S. Levis - - real(r8), pointer :: psisat(:,:) !soil water potential at saturation for CN code (MPa), added by fzeng - real(r8), pointer :: psiwilt(:) !root-zone soil water potential at wilting point (MPa), added by fzeng - -! real(r8), pointer :: xirrig(:) !irrigation rate - real(r8), pointer :: max_dayl(:) !maximum daylength for this column (s) - ! VICHYRDRO - real(r8), pointer :: b_infil(:) !b infiltration parameter - real(r8), pointer :: ds(:) !fracton of Dsmax where non-linear baseflow begins - real(r8), pointer :: dsmax(:) !max. velocity of baseflow (mm/day) - real(r8), pointer :: Wsvic(:) !fraction of maximum soil moisutre where non-liear base flow occurs - real(r8), pointer :: c_param(:) !baseflow exponent (Qb) - real(r8), pointer :: expt(:,:) !pore-size distribution related paramter(Q12) - real(r8), pointer :: ksat(:,:) !Saturated hydrologic conductivity - real(r8), pointer :: phi_s(:,:) !soil moisture dissusion parameter - real(r8), pointer :: depth(:,:) !layer depth of upper layer - real(r8), pointer :: porosity(:,:) !soil porisity (1-bulk_density/soil_density) - real(r8), pointer :: max_moist(:,:) !max layer moist + ice (mm) - real(r8), pointer :: vic_clm_fract(:,:,:)!fraction of VIC layers in CLM layers - ! new variables for CN code - real(r8), pointer :: decl(:) ! solar declination angle (radians) - real(r8), pointer :: coszen(:) ! cosine of solar zenith angle - real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) - real(r8), pointer :: bd(:,:) ! bulk density of dry soil material [kg/m^3] - real(r8), pointer :: fpi_vr(:,:) ! fraction of potential immobilization (no units) - real(r8), pointer :: fpi(:) ! fraction of potential immobilization (no units) - real(r8), pointer :: rf_decomp_cascade(:,:,:) ! respired fraction in decomposition step (frac) - real(r8), pointer :: pathfrac_decomp_cascade(:,:,:) ! what fraction of C leaving a given pool passes through a given transition (frac) - real(r8), pointer :: nfixation_prof(:,:) ! (1/m) profile for N fixation additions - real(r8), pointer :: ndep_prof(:,:) ! (1/m) profile for N fixation additions - real(r8), pointer :: alt(:) ! current depth of thaw - real(r8), pointer :: altmax(:) ! maximum annual depth of thaw - real(r8), pointer :: altmax_lastyear(:) ! prior year maximum annual depth of thaw - integer, pointer :: alt_indx(:) ! current depth of thaw - integer, pointer :: altmax_indx(:) ! maximum annual depth of thaw - integer, pointer :: altmax_lastyear_indx(:) ! prior year maximum annual depth of thaw - real(r8), pointer :: som_adv_coef(:,:) ! SOM advective flux (m/s) - real(r8), pointer :: som_diffus_coef(:,:) ! SOM diffusivity due to bio/cryo-turbation (m2/s) - - ! NITRIF_DENITRIF - real(r8), pointer :: tmean_monthly_max_vr(:,:) ! maximumn monthly-mean soil temperature - real(r8), pointer :: tmean_monthly_vr(:,:) ! monthly-mean soil temperature - ! - real(r8), pointer :: fpg(:) !fraction of potential gpp (no units) - real(r8), pointer :: annsum_counter(:) !seconds since last annual accumulator turnover - real(r8), pointer :: cannsum_npp(:) !annual sum of NPP, averaged from pft-level (gC/m2/yr) - real(r8), pointer :: col_lag_npp(:) ! (gC/m2/s) lagged net primary production - real(r8), pointer :: cannavg_t2m(:) !annual average of 2m air temperature, averaged from pft-level (K) - real(r8), pointer :: watfc(:,:) !volumetric soil water at field capacity (nlevsoi) - - ! F. Li and S. Levis - real(r8), pointer :: nfire(:) ! fire counts (count/km2/timestep), valid only in Reg. C - real(r8), pointer :: fsr_pft(:) ! fire spread rate in pft level (m/s) - real(r8), pointer :: fsr_col(:) ! fire spread rate at column level (m/s) - real(r8), pointer :: fd_col(:) ! fire duration at column level (hr) - real(r8), pointer :: fd_pft(:) ! fire duration in pft level (hr) - real(r8), pointer :: prec60_col(:) !60-day running mean of tot. precipitation (mm/s) - real(r8), pointer :: prec10_col(:) !10-day running mean of tot. precipitation (mm/s) - real(r8), pointer :: lfc(:) ! conversion area fraction of BET and BDT that haven't burned before (0-1) - real(r8), pointer :: lfc2(:) ! conversion area fraction of BET and BDT that burned in this timestep ((timestep)-1) - real(r8), pointer :: dtrotr_col(:) ! annual decreased fraction coverage of BET on the gridcell (0-1) - real(r8), pointer :: trotr1_col(:) ! pft weight of BET and BDT on the gridcell(0-1) - real(r8), pointer :: trotr2_col(:) ! pft weight of BDT on the gridcell (0-1) - real(r8), pointer :: cropf_col(:) ! crop fraction in veg column (0-1) - real(r8), pointer :: baf_crop(:) ! baf for cropland per time step(0-1) - real(r8), pointer :: baf_peatf(:) ! baf for peatland per time step (0-1) - real(r8), pointer :: fbac(:) ! total burned area out of conversion (0-1) - real(r8), pointer :: fbac1(:) ! burned area out of conversion region due to land use fire (0-1) - real(r8), pointer :: btran_col(:) ! btran2 at column level (0-1) - real(r8), pointer :: wtlf(:) ! fractional coverage of non-crop PFTs (0-1) - real(r8), pointer :: lfwt(:) ! fractional coverage of non-crop and non-bare-soil PFTs (0-1) - real(r8), pointer :: farea_burned(:) !timestep fractional area burned (0-1) - - - real(r8), pointer :: albsnd_hst(:,:) ! snow albedo, direct, for history files (col,bnd) [frc] - real(r8), pointer :: albsni_hst(:,:) ! snow albedo, diffuse, for history files (col,bnd) [frc] - real(r8), pointer :: albsod(:,:) ! soil albedo: direct (col,bnd) [frc] - real(r8), pointer :: albsoi(:,:) ! soil albedo: diffuse (col,bnd) [frc] - real(r8), pointer :: flx_absdv(:,:) ! absorbed flux per unit incident direct flux: VIS (col,lyr) [frc] - real(r8), pointer :: flx_absdn(:,:) ! absorbed flux per unit incident direct flux: NIR (col,lyr) [frc] - real(r8), pointer :: flx_absiv(:,:) ! absorbed flux per unit incident diffuse flux: VIS (col,lyr) [frc] - real(r8), pointer :: flx_absin(:,:) ! absorbed flux per unit incident diffuse flux: NIR (col,lyr) [frc] - real(r8), pointer :: snw_rds(:,:) ! snow grain radius (col,lyr) [m^-6, microns] - real(r8), pointer :: snw_rds_top(:) ! snow grain radius, top layer (col) [m^-6, microns] - real(r8), pointer :: sno_liq_top(:) ! snow liquid water fraction (mass), top layer (col) [fraction] - real(r8), pointer :: mss_bcpho(:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg] - real(r8), pointer :: mss_bcphi(:,:) ! mass of hydrophillic BC in snow (col,lyr) [kg] - real(r8), pointer :: mss_bctot(:,:) ! total mass of BC in snow (pho+phi) (col,lyr) [kg] - real(r8), pointer :: mss_bc_col(:) ! column-integrated mass of total BC (col) [kg] - real(r8), pointer :: mss_bc_top(:) ! top-layer mass of total BC (col) [kg] - real(r8), pointer :: mss_ocpho(:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg] - real(r8), pointer :: mss_ocphi(:,:) ! mass of hydrophillic OC in snow (col,lyr) [kg] - real(r8), pointer :: mss_octot(:,:) ! total mass of OC in snow (pho+phi) (col,lyr) [kg] - real(r8), pointer :: mss_oc_col(:) ! column-integrated mass of total OC (col) [kg] - real(r8), pointer :: mss_oc_top(:) ! top-layer mass of total OC (col) [kg] - real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg] - real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg] - real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg] - real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg] - real(r8), pointer :: mss_dsttot(:,:) ! total mass of dust in snow (col,lyr) [kg] - real(r8), pointer :: mss_dst_col(:) ! column-integrated mass of dust in snow (col) [kg] - real(r8), pointer :: mss_dst_top(:) ! top-layer mass of dust in snow (col) [kg] - real(r8), pointer :: h2osno_top(:) ! top-layer mass of snow (col) [kg] - real(r8), pointer :: mss_cnc_bcphi(:,:) ! mass concentration of hydrophilic BC in snow (col,lyr) [kg/kg] - real(r8), pointer :: mss_cnc_bcpho(:,:) ! mass concentration of hydrophilic BC in snow (col,lyr) [kg/kg] - real(r8), pointer :: mss_cnc_ocphi(:,:) ! mass concentration of hydrophilic OC in snow (col,lyr) [kg/kg] - real(r8), pointer :: mss_cnc_ocpho(:,:) ! mass concentration of hydrophilic OC in snow (col,lyr) [kg/kg] - real(r8), pointer :: mss_cnc_dst1(:,:) ! mass concentration of dust species 1 in snow (col,lyr) [kg/kg] - real(r8), pointer :: mss_cnc_dst2(:,:) ! mass concentration of dust species 2 in snow (col,lyr) [kg/kg] - real(r8), pointer :: mss_cnc_dst3(:,:) ! mass concentration of dust species 3 in snow (col,lyr) [kg/kg] - real(r8), pointer :: mss_cnc_dst4(:,:) ! mass concentration of dust species 4 in snow (col,lyr) [kg/kg] - real(r8), pointer :: albgrd_pur(:,:) ! pure snow ground direct albedo (numrad) - real(r8), pointer :: albgri_pur(:,:) ! pure snow ground diffuse albedo (numrad) - real(r8), pointer :: albgrd_bc(:,:) ! ground direct albedo without BC (numrad) - real(r8), pointer :: albgri_bc(:,:) ! ground diffuse albedo without BC (numrad) - real(r8), pointer :: albgrd_oc(:,:) ! ground direct albedo without OC (numrad) - real(r8), pointer :: albgri_oc(:,:) ! ground diffuse albedo without OC (numrad) - real(r8), pointer :: albgrd_dst(:,:) ! ground direct albedo without dust (numrad) - real(r8), pointer :: albgri_dst(:,:) ! ground diffuse albedo without dust (numrad) - real(r8), pointer :: dTdz_top(:) ! temperature gradient in top layer [K m-1] - real(r8), pointer :: snot_top(:) ! temperature of top snow layer [K] - ! new variables for S Lake code - real(r8), pointer :: ws(:) ! surface friction velocity (m/s) - real(r8), pointer :: ks(:) ! coefficient for calculation of decay of eddy diffusivity with depth - real(r8), pointer :: dz_lake(:,:) ! lake layer thickness (m) (1:nlevlak) - real(r8), pointer :: z_lake(:,:) ! layer depth for lake (m) - real(r8), pointer :: savedtke1(:) ! top level eddy conductivity from previous timestep (W/mK) - real(r8), pointer :: cellsand(:,:) ! sand value for gridcell containing column (1:nlevsoi) - real(r8), pointer :: cellclay(:,:) ! clay value for gridcell containing column (1:nlevsoi) - real(r8), pointer :: cellorg(:,:) ! organic matter for gridcell containing column (1:nlevsoi) - real(r8), pointer :: lakedepth(:) ! variable lake depth (m) - real(r8), pointer :: etal(:) ! lake extinction coefficient from surface data (1/m) - real(r8), pointer :: lakefetch(:) ! lake fetch from surface data (m) - real(r8), pointer :: ust_lake(:) ! friction velocity (m/s) - ! end new variables for S Lake code - ! New variables for finundated in methane code - real(r8), pointer :: zwt0(:) ! coefficient for determining finundated (m) - real(r8), pointer :: f0(:) ! maximum inundated fraction for a gridcell (for methane code) - real(r8), pointer :: p3(:) ! coefficient for determining finundated (m) - ! added by Lei Meng for pH effects of methane production - real(r8), pointer :: pH(:) ! pH values - ! End New variables for methane code - real(r8), pointer :: irrig_rate(:) ! current irrigation rate [mm/s] - integer, pointer :: n_irrig_steps_left(:) ! number of time steps for which we still need to irrigate today (if 0, ignore irrig_rate) - real(r8), pointer :: forc_pbot(:) ! surface atm pressure, downscaled to column (Pa) - real(r8), pointer :: forc_rho(:) ! surface air density, downscaled to column (kg/m^3) - real(r8), pointer :: glc_frac(:) ! ice fractional area - real(r8), pointer :: glc_topo(:) ! surface elevation (m) -end type column_pstate_type - -type(column_pstate_type) :: cps !column physical state variables - -!---------------------------------------------------- -! column energy state variables structure -!---------------------------------------------------- -type, public :: column_estate_type - real(r8), pointer :: t_grnd(:) !ground temperature (Kelvin) - real(r8), pointer :: t_grnd_u(:) !Urban ground temperature (Kelvin) - real(r8), pointer :: t_grnd_r(:) !Rural ground temperature (Kelvin) - real(r8), pointer :: dt_grnd(:) !change in t_grnd, last iteration (Kelvin) - real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: t_soi_10cm(:) !soil temperature in top 10cm of soil (Kelvin) - real(r8), pointer :: tsoi17(:) !soil temperature in top 17cm of soil (Kelvin) by F. Li and S. Levis - real(r8), pointer :: t_lake(:,:) !lake temperature (Kelvin) (1:nlevlak) - real(r8), pointer :: tssbef(:,:) !soil/snow temperature before update (-nlevsno+1:nlevgrnd) - real(r8), pointer :: thv(:) !virtual potential temperature (kelvin) - real(r8), pointer :: hc_soi(:) !soil heat content (MJ/m2) - real(r8), pointer :: hc_soisno(:) !soil plus snow heat content (MJ/m2) - real(r8), pointer :: forc_t(:) !atm temperature, downscaled to column (Kelvin) - real(r8), pointer :: forc_th(:) !atm potl temperature, downscaled to column (Kelvin) - real(r8), pointer :: t_h2osfc(:) !surface water temperature - real(r8), pointer :: t_h2osfc_bef(:) !surface water temperature from time-step before -end type column_estate_type - -type(column_estate_type) :: ces !column energy state - -!---------------------------------------------------- -! column water state variables structure -!---------------------------------------------------- -type, public :: column_wstate_type - real(r8), pointer :: h2osfc(:) !surface water (mm H2O) - real(r8), pointer :: qg_snow(:) !ground specific humidity [kg/kg] - real(r8), pointer :: qg_soil(:) !ground specific humidity [kg/kg] - real(r8), pointer :: qg_h2osfc(:) !ground specific humidity [kg/kg] - real(r8), pointer :: swe_old(:,:) !initial snow water - real(r8), pointer :: h2osno(:) !snow water (mm H2O) - real(r8), pointer :: errh2osno(:) !imbalance in snow water (mm H2O) - real(r8), pointer :: snow_sources(:) !snow sources (mm H2O/s) - real(r8), pointer :: snow_sinks(:) !snow sinks (mm H2O/s) - real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) (new) (-nlevsno+1:nlevgrnd) - real(r8), pointer :: h2osoi_liqice_10cm(:) !liquid water + ice lens in top 10cm of soil (kg/m2) - real(r8), pointer :: h2osoi_vol(:,:) !volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (nlevgrnd) - real(r8), pointer :: h2osno_old(:) !snow mass for previous time step (kg/m2) (new) - real(r8), pointer :: qg(:) !ground specific humidity [kg/kg] - real(r8), pointer :: dqgdT(:) !d(qg)/dT - real(r8), pointer :: snowice(:) !average snow ice lens - real(r8), pointer :: snowliq(:) !average snow liquid water - real(r8) ,pointer :: soilalpha(:) !factor that reduces ground saturated specific humidity (-) - real(r8), pointer :: soilbeta(:) !factor that reduces ground evaporation L&P1992(-) - real(r8) ,pointer :: soilalpha_u(:) !urban factor that reduces ground saturated specific humidity (-) - real(r8), pointer :: zwt(:) !water table depth - real(r8), pointer :: frost_table(:) !frost table depth - real(r8), pointer :: zwt_perched(:) !perched water table depth - real(r8), pointer :: int_snow(:) !integrated snowfall (mm H2O) - real(r8), pointer :: fcov(:) !fractional impermeable area - real(r8), pointer :: wa(:) !water in the unconfined aquifer (mm) - real(r8), pointer :: qcharge(:) !aquifer recharge rate (mm/s) - real(r8), pointer :: smp_l(:,:) !soil matric potential (mm) - real(r8), pointer :: hk_l(:,:) !hydraulic conductivity (mm/s) - real(r8), pointer :: fsat(:) !fractional area with water table at surface - real(r8), pointer :: forc_q(:) !atm specific humidity, downscaled to column (kg/kg) - ! VICHYDRO - real(r8), pointer :: moist(:,:) !soil moisture (kg/m2) for VIC soil layers - real(r8), pointer :: ice(:,:) !soil ice (kg/m2) for VIC soil layers - real(r8), pointer :: moist_vol(:,:) !volumetric soil moisture for VIC soil layers - real(r8), pointer :: max_infil(:) !maximum infiltration rate calculated by VIC - real(r8), pointer :: i_0(:) !average saturation in top soil layers in VIC - ! CH4 - real(r8), pointer :: finundated(:) !fractional inundated area (excluding dedicated wetland columns) - ! new variables for S Lake code - real(r8), pointer :: lake_icefrac(:,:) ! mass fraction of lake layer that is frozen - real(r8), pointer :: lake_icethick(:) ! ice thickness (m) (integrated if lakepuddling) - ! end new variables for S Lake code -end type column_wstate_type - -type(column_wstate_type) :: cws !column water state -type(pft_wstate_type) :: pws_a !pft-level water state variables averaged to the column - -!---------------------------------------------------- -! column carbon state variables structure -!---------------------------------------------------- -type, public :: column_cstate_type - ! NOTE: the soilc variable is used by the original CLM C-cycle code, - ! and is not used by the CN code - real(r8), pointer :: soilc(:) !soil carbon (kg C /m**2) - ! all c pools involved in decomposition - real(r8), pointer :: decomp_cpools_vr(:,:,:) ! (gC/m3) vertically-resolved decomposing (litter, cwd, soil) c pools - real(r8), pointer :: col_ctrunc_vr(:,:) ! (gC/m3) vertically-resolved column-level sink for C truncation - - !fire-related variables added by F. Li and S. Levis - real(r8), pointer :: rootc_col(:) !root carbon at column level (gC/m2) - real(r8), pointer :: totvegc_col(:) !column-level totvegc (gC/m2) - real(r8), pointer :: leafc_col(:) !column-level leafc (gC/m2) - real(r8), pointer :: fuelc(:) ! fuel avalability factor for Reg.C (0-1) - real(r8), pointer :: fuelc_crop(:) ! fuel avalability factor for Reg.A (0-1) - real(r8), pointer :: cpool_col(:) !column-level temporary photosynthate C pool (gC/m2) - - ! pools for dynamic landcover - real(r8), pointer :: seedc(:) ! (gC/m2) column-level pool for seeding new PFTs - real(r8), pointer :: prod10c(:) ! (gC/m2) wood product C pool, 10-year lifespan - real(r8), pointer :: prod100c(:) ! (gC/m2) wood product C pool, 100-year lifespan - real(r8), pointer :: totprodc(:) ! (gC/m2) total wood product C - ! summary (diagnostic) state variables, not involved in mass balance - real(r8), pointer :: decomp_cpools(:,:) ! (gC/m2) decomposing (litter, cwd, soil) c pools - real(r8), pointer :: decomp_cpools_1m(:,:) ! (gC/m2) Diagnostic: decomposing (litter, cwd, soil) c pools to 1 meter - real(r8), pointer :: cwdc(:) ! (gC/m2) Diagnostic: coarse woody debris C - real(r8), pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation - real(r8), pointer :: totlitc(:) ! (gC/m2) total litter carbon - real(r8), pointer :: totsomc(:) ! (gC/m2) total soil organic matter carbon - real(r8), pointer :: totlitc_1m(:) ! (gC/m2) total litter carbon to 1 meter - real(r8), pointer :: totsomc_1m(:) ! (gC/m2) total soil organic matter carbon to 1 meter - real(r8), pointer :: totecosysc(:) ! (gC/m2) total ecosystem carbon, incl veg but excl cpool - real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool -end type column_cstate_type - -type(column_cstate_type), target :: ccs !column carbon state -type(column_cstate_type), target :: cc13s !column carbon-13 state -type(column_cstate_type), target :: cc14s !column carbon-14 state - -!---------------------------------------------------- -! column methane variables structure -!---------------------------------------------------- -type, public :: column_ch4_type - ! new variables for CH4 code - ! column-level methane fluxes - real(r8), pointer :: ch4_prod_depth_sat(:,:) ! CH4 production rate from methanotrophs (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_prod_depth_unsat(:,:) ! CH4 production rate from methanotrophs (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_prod_depth_lake(:,:)! CH4 production rate from methanotrophs (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_oxid_depth_sat(:,:) ! CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_oxid_depth_unsat(:,:) !CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_oxid_depth_lake(:,:) ! CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_aere_depth_sat(:,:) ! CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_aere_depth_unsat(:,:) ! CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_tran_depth_sat(:,:) ! CH4 loss rate via transpiration in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_tran_depth_unsat(:,:) ! CH4 loss rate via transpiration in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_ebul_depth_sat(:,:) ! CH4 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_ebul_depth_unsat(:,:) ! CH4 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: ch4_ebul_total_sat(:) ! Total column CH4 ebullition (mol/m2/s) - real(r8), pointer :: ch4_ebul_total_unsat(:) ! Total column CH4 ebullition (mol/m2/s) - real(r8), pointer :: ch4_surf_aere_sat(:) ! CH4 aerenchyma flux to atmosphere (after oxidation) (mol/m2/s) - real(r8), pointer :: ch4_surf_aere_unsat(:) ! CH4 aerenchyma flux to atmosphere (after oxidation) (mol/m2/s) - real(r8), pointer :: ch4_surf_ebul_sat(:) ! CH4 ebullition flux to atmosphere (after oxidation) (mol/m2/s) - real(r8), pointer :: ch4_surf_ebul_unsat(:) ! CH4 ebullition flux to atmosphere (after oxidation) (mol/m2/s) - real(r8), pointer :: ch4_surf_ebul_lake(:) ! CH4 ebullition flux to atmosphere (after oxidation) (mol/m2/s) - real(r8), pointer :: co2_aere_depth_sat(:,:) ! CO2 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: co2_aere_depth_unsat(:,:) ! CO2 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: o2_oxid_depth_sat(:,:) ! O2 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: o2_oxid_depth_unsat(:,:) ! O2 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: o2_aere_depth_sat(:,:) ! O2 gain rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: o2_aere_depth_unsat(:,:) ! O2 gain rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: o2_decomp_depth_sat(:,:) !O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) - real(r8), pointer :: o2_decomp_depth_unsat(:,:)!O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) - real(r8), pointer :: co2_decomp_depth_sat(:,:) ! CO2 production during decomposition in each soil layer (nlevsoi) (mol/m3/s) - real(r8), pointer :: co2_decomp_depth_unsat(:,:) ! CO2 production during decomposition in each soil layer (nlevsoi) (mol/m3/s) - real(r8), pointer :: co2_oxid_depth_sat(:,:) ! CO2 production rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: co2_oxid_depth_unsat(:,:) ! CO2 production rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) - real(r8), pointer :: conc_o2_sat(:,:) ! O2 conc in each soil layer (mol/m3) (nlevsoi) - real(r8), pointer :: conc_o2_unsat(:,:) ! O2 conc in each soil layer (mol/m3) (nlevsoi) - real(r8), pointer :: conc_o2_lake(:,:) ! O2 conc in each soil layer (mol/m3) (nlevsoi) - real(r8), pointer :: conc_ch4_sat(:,:) ! CH4 conc in each soil layer (mol/m3) (nlevsoi) - real(r8), pointer :: conc_ch4_unsat(:,:) ! CH4 conc in each soil layer (mol/m3) (nlevsoi) - real(r8), pointer :: conc_ch4_lake(:,:) ! CH4 conc in each soil layer (mol/m3) (nlevsoi) - real(r8), pointer :: ch4_surf_diff_sat(:) ! CH4 surface flux (mol/m2/s) - real(r8), pointer :: ch4_surf_diff_unsat(:) ! CH4 surface flux (mol/m2/s) - real(r8), pointer :: ch4_surf_diff_lake(:) ! CH4 surface flux (mol/m2/s) - real(r8), pointer :: ch4_dfsat_flux(:) ! CH4 flux to atm due to decreasing fsat (kg C/m^2/s) [+] - ! Other variables - real(r8), pointer :: zwt_ch4_unsat(:) ! depth of water table for unsaturated fraction (m) - real(r8), pointer :: fsat_bef(:) !fsat from previous timestep - real(r8), pointer :: lake_soilc(:,:) ! total soil organic matter found in level (g C / m^3) (nlevsoi) - real(r8), pointer :: lake_raw(:) !aerodynamic resistance for moisture (s/m) - real(r8), pointer :: totcolch4(:) ! total methane found in soil column (g C / m^2) - real(r8), pointer :: fphr(:,:) ! fraction of potential heterotrophic respiration - real(r8), pointer :: annsum_counter(:) ! seconds since last annual accumulator turnover - real(r8), pointer :: tempavg_somhr(:) ! temporary average SOM heterotrophic resp. (gC/m2/s) - real(r8), pointer :: annavg_somhr(:) ! annual average SOM heterotrophic resp. (gC/m2/s) - real(r8), pointer :: tempavg_finrw(:) ! respiration-weighted annual average of finundated - real(r8), pointer :: annavg_finrw(:) ! respiration-weighted annual average of finundated - real(r8), pointer :: sif(:) ! (unitless) ratio applied to sat. prod. to account for seasonal inundation - real(r8), pointer :: o2stress_unsat(:,:) ! Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) - real(r8), pointer :: o2stress_sat(:,:) ! Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) - real(r8), pointer :: ch4stress_unsat(:,:) ! Ratio of methane available to the total per-timestep methane sinks (nlevsoi) - real(r8), pointer :: ch4stress_sat(:,:) ! Ratio of methane available to the total per-timestep methane sinks (nlevsoi) - real(r8), pointer :: qflx_surf_lag(:) ! time-lagged surface runoff (mm H2O /s) - real(r8), pointer :: finundated_lag(:) ! time-lagged fractional inundated area - real(r8), pointer :: layer_sat_lag(:,:) ! Lagged saturation status of soil layer in the unsaturated zone (1 = sat) -end type column_ch4_type - -type(column_ch4_type) :: cch4 !column CH4 variables - -!---------------------------------------------------- -! column nitrogen state variables structure -!---------------------------------------------------- -type, public :: column_nstate_type - ! all n pools involved in decomposition - real(r8), pointer :: decomp_npools_vr(:,:,:) ! (gN/m3) vertically-resolved decomposing (litter, cwd, soil) N pools - real(r8), pointer :: sminn_vr(:,:) ! (gN/m3) vertically-resolved soil mineral N - real(r8), pointer :: col_ntrunc_vr(:,:) ! (gN/m3) vertically-resolved column-level sink for N truncation - ! NITRIF_DENITRIF - real(r8), pointer :: smin_no3_vr(:,:) ! (gN/m3) vertically-resolved soil mineral NO3 - real(r8), pointer :: smin_no3(:) ! (gN/m2) soil mineral NO3 pool - real(r8), pointer :: smin_nh4_vr(:,:) ! (gN/m3) vertically-resolved soil mineral NH4 - real(r8), pointer :: smin_nh4(:) ! (gN/m2) soil mineral NH4 pool - ! wood product pools, for dynamic landcover - real(r8), pointer :: seedn(:) ! (gN/m2) column-level pool for seeding new PFTs - real(r8), pointer :: prod10n(:) ! (gN/m2) wood product N pool, 10-year lifespan - real(r8), pointer :: prod100n(:) ! (gN/m2) wood product N pool, 100-year lifespan - real(r8), pointer :: totprodn(:) ! (gN/m2) total wood product N - ! summary (diagnostic) state variables, not involved in mass balance - real(r8), pointer :: decomp_npools(:,:) ! (gN/m2) decomposing (litter, cwd, soil) N pools - real(r8), pointer :: decomp_npools_1m(:,:) ! (gN/m2) diagnostic: decomposing (litter, cwd, soil) N pools to 1 meter - real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N - real(r8), pointer :: col_ntrunc(:) ! (gN/m2) column-level sink for N truncation - real(r8), pointer :: cwdn(:) ! (gN/m2) Diagnostic: coarse woody debris N - real(r8), pointer :: totlitn(:) ! (gN/m2) total litter nitrogen - real(r8), pointer :: totsomn(:) ! (gN/m2) total soil organic matter nitrogen - real(r8), pointer :: totlitn_1m(:) ! (gN/m2) total litter nitrogen to 1 meter - real(r8), pointer :: totsomn_1m(:) ! (gN/m2) total soil organic matter nitrogen to 1 meter - real(r8), pointer :: totecosysn(:) ! (gN/m2) total ecosystem nitrogen, incl veg - real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg -end type column_nstate_type - -type(column_nstate_type) :: cns !column nitrogen state -type(column_nstate_type) :: cns_a !column-level nitrogen state variables averaged to gridcell - -!---------------------------------------------------- -! column VOC state variables structure -!---------------------------------------------------- -type, public :: column_vstate_type - real(r8), pointer :: dummy_entry(:) -end type column_vstate_type - -!---------------------------------------------------- -! column DGVM state variables structure -!---------------------------------------------------- -type, public :: column_dgvstate_type - real(r8), pointer :: dummy_entry(:) -end type column_dgvstate_type - -!---------------------------------------------------- -! column dust state variables structure -!---------------------------------------------------- -type, public :: column_dstate_type - real(r8), pointer :: dummy_entry(:) -end type column_dstate_type - -!---------------------------------------------------- -! column energy flux variables structure -!---------------------------------------------------- -type, public :: column_eflux_type - real(r8), pointer :: eflx_snomelt(:) ! snow melt heat flux (W/m**2) - real(r8), pointer :: eflx_snomelt_u(:) ! urban snow melt heat flux (W/m**2) - real(r8), pointer :: eflx_snomelt_r(:) ! rural snow melt heat flux (W/m**2) - real(r8), pointer :: eflx_impsoil(:) ! implicit evaporation for soil temperature equation - real(r8), pointer :: eflx_fgr12(:) ! ground heat flux between soil layers 1 and 2 (W/m2) - real(r8), pointer :: eflx_fgr(:,:) ! (rural) soil downward heat flux (W/m2) (1:nlevgrnd) - ! Urban variable - real(r8), pointer :: eflx_building_heat(:) ! heat flux from urban building interior to urban walls, roof (W/m**2) - real(r8), pointer :: eflx_urban_ac(:) ! urban air conditioning flux (W/m**2) - real(r8), pointer :: eflx_urban_heat(:) ! urban heating flux (W/m**2) - real(r8), pointer :: eflx_bot(:) ! heat flux from beneath the soil or ice column (W/m**2) - ! positive upward; usually eflx_bot >= 0 -end type column_eflux_type - -type(column_eflux_type) :: cef ! column energy flux -type(pft_eflux_type) :: pef_a ! pft-level energy flux variables averaged to the column - -!---------------------------------------------------- -! column momentum flux variables structure -!---------------------------------------------------- -type, public :: column_mflux_type - real(r8), pointer :: dummy_entry(:) -end type column_mflux_type - -!---------------------------------------------------- -! column water flux variables structure -!---------------------------------------------------- -type, public :: column_wflux_type - real(r8), pointer :: qflx_infl(:) ! infiltration (mm H2O /s) - real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s) - real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s) - real(r8), pointer :: qflx_top_soil(:)! net water input into soil from top (mm/s) - real(r8), pointer :: qflx_h2osfc_to_ice(:) ! conversion of h2osfc to ice - real(r8), pointer :: qflx_h2osfc_surf(:) !surface water runoff - real(r8), pointer :: qflx_snow_h2osfc(:) !snow falling on surface water - real(r8), pointer :: qflx_drain_perched(:) ! sub-surface runoff from perched wt (mm H2O /s) - real(r8), pointer :: qflx_floodc(:) ! flood water flux at column level - real(r8), pointer :: qflx_sl_top_soil(:) ! liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) - real(r8), pointer :: qflx_snomelt(:) ! snow melt (mm H2O /s) - real(r8), pointer :: qflx_snow_melt(:) ! snow melt (net) - real(r8), pointer :: qflx_qrgwl(:) ! qflx_surf at glaciers, wetlands, lakes - real(r8), pointer :: qflx_runoff(:) ! total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s) - real(r8), pointer :: qflx_runoff_u(:) ! Urban total runoff (qflx_drain+qflx_surf) (mm H2O /s) - real(r8), pointer :: qflx_runoff_r(:) ! Rural total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s) - real(r8), pointer :: qmelt(:) ! snow melt [mm/s] - real(r8), pointer :: h2ocan_loss(:) ! mass balance correction term for dynamic weights - real(r8), pointer :: qflx_rsub_sat(:) ! soil saturation excess [mm/s] - real(r8), pointer :: flx_bc_dep_dry(:) ! dry (BCPHO+BCPHI) BC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_bc_dep_wet(:) ! wet (BCPHI) BC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_bc_dep_pho(:) ! hydrophobic BC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_bc_dep_phi(:) ! hydrophillic BC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_bc_dep(:) ! total (dry+wet) BC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_oc_dep_dry(:) ! dry (OCPHO+OCPHI) OC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_oc_dep_wet(:) ! wet (OCPHI) OC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_oc_dep_pho(:) ! hydrophobic OC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_oc_dep_phi(:) ! hydrophillic OC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_oc_dep(:) ! total (dry+wet) OC deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep_dry1(:) ! dust species 1 dry deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep_wet1(:) ! dust species 1 wet deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep_dry2(:) ! dust species 2 dry deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep_wet2(:) ! dust species 2 wet deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep_dry3(:) ! dust species 3 dry deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep_wet3(:) ! dust species 3 wet deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep_dry4(:) ! dust species 4 dry deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep_wet4(:) ! dust species 4 wet deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: flx_dst_dep(:) ! total (dry+wet) dust deposition on ground (positive definite) (col) [kg/s] - real(r8), pointer :: qflx_snofrz_lyr(:,:)! snow freezing rate (positive definite) (col,lyr) [kg m-2 s-1] - real(r8), pointer :: qflx_snofrz_col(:) ! column-integrated snow freezing rate (positive definite) (col) [kg m-2 s-1] - real(r8), pointer :: qflx_irrig(:) !irrigation flux (mm H2O/s) - real(r8), pointer :: qflx_glcice(:) ! net flux of new glacial ice (growth - melt) (mm H2O/s), passed to GLC - real(r8), pointer :: qflx_glcice_frz(:) ! ice growth (positive definite) (mm H2O/s) - real(r8), pointer :: qflx_glcice_melt(:) ! ice melt (positive definite) (mm H2O/s) - real(r8), pointer :: glc_rofi(:) ! ice runoff passed from GLC to CLM (mm H2O /s) - real(r8), pointer :: glc_rofl(:) ! liquid runoff passed from GLC to CLM (mm H2O /s) -end type column_wflux_type - -type(column_wflux_type) :: cwf ! column water flux -type(pft_wflux_type) :: pwf_a ! pft-level water flux variables averaged to the column - -!---------------------------------------------------- -! column carbon flux variables structure -!---------------------------------------------------- -type, public :: column_cflux_type - ! phenology: litterfall and crop fluxes - real(r8), pointer :: phenology_c_to_litr_met_c(:,:) ! C fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gC/m3/s) - real(r8), pointer :: phenology_c_to_litr_cel_c(:,:) ! C fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gC/m3/s) - real(r8), pointer :: phenology_c_to_litr_lig_c(:,:) ! 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(:,:) ! C fluxes associated with gap mortality to litter metabolic pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_litr_cel_c(:,:) ! C fluxes associated with gap mortality to litter cellulose pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_litr_lig_c(:,:) ! C fluxes associated with gap mortality to litter lignin pool (gC/m3/s) - real(r8), pointer :: gap_mortality_c_to_cwdc(:,:) ! C fluxes associated with gap mortality to CWD pool (gC/m3/s) - ! fire - real(r8), pointer :: fire_mortality_c_to_cwdc(:,:) ! C fluxes associated with fire mortality to CWD pool (gC/m3/s) - ! harvest - real(r8), pointer :: harvest_c_to_litr_met_c(:,:) ! C fluxes associated with harvest to litter metabolic pool (gC/m3/s) - real(r8), pointer :: harvest_c_to_litr_cel_c(:,:) ! C fluxes associated with harvest to litter cellulose pool (gC/m3/s) - real(r8), pointer :: harvest_c_to_litr_lig_c(:,:) ! C fluxes associated with harvest to litter lignin pool (gC/m3/s) - real(r8), pointer :: harvest_c_to_cwdc(:,:) ! C fluxes associated with harvest to CWD pool (gC/m3/s) - ! new variables for CN code - real(r8), pointer :: hrv_deadstemc_to_prod10c(:) ! dead stem C harvest mortality to 10-year product pool (gC/m2/s) - real(r8), pointer :: hrv_deadstemc_to_prod100c(:) ! dead stem C harvest mortality to 100-year product pool (gC/m2/s) - ! column-level fire fluxes - real(r8), pointer :: m_decomp_cpools_to_fire_vr(:,:,:) ! vertically-resolved decomposing C fire loss (gC/m3/s) - real(r8), pointer :: m_decomp_cpools_to_fire(:,:) ! vertically-integrated (diagnostic) decomposing C fire loss (gC/m2/s) - real(r8), pointer :: m_c_to_litr_met_fire(:,:) ! 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(:,:) ! 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(:,:) ! C from leaf, froot, xfer and storage C to litter lignin C by fire (gC/m3/s) - real(r8), pointer :: lf_conv_cflux(:) ! (gC/m2/s) conversion C flux due to BET and BDT area decreasing (immediate loss to atm) - real(r8), pointer :: somc_fire(:) ! (gC/m2/s) carbon emissions due to peat burning - - ! decomposition fluxes - real(r8), pointer :: decomp_cascade_hr_vr(:,:,:) ! vertically-resolved het. resp. from decomposing C pools (gC/m3/s) - real(r8), pointer :: decomp_cascade_hr(:,:) ! vertically-integrated (diagnostic) het. resp. from decomposing C pools (gC/m2/s) - real(r8), pointer :: decomp_cascade_ctransfer_vr(:,:,:) ! vertically-resolved C transferred along deomposition cascade (gC/m3/s) - real(r8), pointer :: decomp_cascade_ctransfer(:,:) ! vertically-integrated (diagnostic) C transferred along deomposition cascade (gC/m2/s) - real(r8), pointer :: decomp_cpools_sourcesink(:,:,:) ! (gC/m3/timestep) change in decomposing c pools. Used to update concentrations concurrently with vertical transport - real(r8), pointer :: decomp_k(:,:,:) ! rate constant for decomposition (1./sec) - real(r8), pointer :: hr_vr(:,:) ! total vertically-resolved het. resp. from decomposing C pools (gC/m3/s) - real(r8), pointer :: o_scalar(:,:) ! fraction by which decomposition is limited by anoxia - real(r8), pointer :: w_scalar(:,:) ! fraction by which decomposition is limited by moisture availability - real(r8), pointer :: t_scalar(:,:) ! fraction by which decomposition is limited by temperature - real(r8), pointer :: som_c_leached(:) ! total SOM C loss from vertical transport (gC/m^2/s) - real(r8), pointer :: decomp_cpools_leached(:,:) ! C loss from vertical transport from each decomposing C pool (gC/m^2/s) - real(r8), pointer :: decomp_cpools_transport_tendency(:,:,:) ! C tendency due to vertical transport in decomposing C pools (gC/m^3/s) - ! NITRIF_DENITRIF - real(r8), pointer :: phr_vr(:,:) ! potential hr (not N-limited) (gC/m3/s) - ! CN dynamic landcover fluxes - real(r8), pointer :: dwt_seedc_to_leaf(:) ! (gC/m2/s) seed source to PFT-level - real(r8), pointer :: dwt_seedc_to_deadstem(:) ! (gC/m2/s) seed source to PFT-level - real(r8), pointer :: dwt_conv_cflux(:) ! (gC/m2/s) conversion C flux (immediate loss to atm) - real(r8), pointer :: dwt_prod10c_gain(:) ! (gC/m2/s) addition to 10-yr wood product pool - real(r8), pointer :: dwt_prod100c_gain(:) ! (gC/m2/s) addition to 100-yr wood product pool - real(r8), pointer :: dwt_frootc_to_litr_met_c(:,:) ! (gC/m3/s) fine root to litter due to landcover change - real(r8), pointer :: dwt_frootc_to_litr_cel_c(:,:) ! (gC/m3/s) fine root to litter due to landcover change - real(r8), pointer :: dwt_frootc_to_litr_lig_c(:,:) ! (gC/m3/s) fine root to litter due to landcover change - real(r8), pointer :: dwt_livecrootc_to_cwdc(:,:) ! (gC/m3/s) live coarse root to CWD due to landcover change - real(r8), pointer :: dwt_deadcrootc_to_cwdc(:,:) ! (gC/m3/s) dead coarse root to CWD due to landcover change - real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from product pools and conversion - real(r8), pointer :: landuseflux(:) ! (gC/m2/s) dwt_closs+product_closs - real(r8), pointer :: landuptake(:) ! (gC/m2/s) nee-landuseflux - ! CN wood product pool loss fluxes - real(r8), pointer :: prod10c_loss(:) ! (gC/m2/s) decomposition loss from 10-yr wood product pool - real(r8), pointer :: prod100c_loss(:) ! (gC/m2/s) decomposition loss from 100-yr wood product pool - real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss - ! summary (diagnostic) flux variables, not involved in mass balance - real(r8), pointer :: lithr(:) ! (gC/m2/s) litter heterotrophic respiration - real(r8), pointer :: somhr(:) ! (gC/m2/s) soil organic matter heterotrophic respiration - real(r8), pointer :: hr(:) ! (gC/m2/s) total heterotrophic respiration - real(r8), pointer :: sr(:) ! (gC/m2/s) total soil respiration (HR + root resp) - real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic - real(r8), pointer :: litfire(:) ! (gC/m2/s) litter fire losses - real(r8), pointer :: somfire(:) ! (gC/m2/s) soil organic matter fire losses - real(r8), pointer :: totfire(:) ! (gC/m2/s) total ecosystem fire losses - real(r8), pointer :: nep(:) ! (gC/m2/s) net ecosystem production, excludes fire, landuse, and harvest flux, positive for sink - real(r8), pointer :: nbp(:) ! (gC/m2/s) net biome production, includes fire, landuse, and harvest flux, positive for sink - real(r8), pointer :: nee(:) ! (gC/m2/s) net ecosystem exchange of carbon, includes fire, landuse, harvest, and hrv_xsmrpool flux, positive for source - real(r8), pointer :: col_cinputs(:) ! (gC/m2/s) total column-level carbon inputs (for balance check) - real(r8), pointer :: col_coutputs(:) ! (gC/m2/s) total column-level carbon outputs (for balance check) - ! CN CLAMP summary (diagnostic) flux variables, not involved in mass balance - real(r8), pointer :: cwdc_hr(:) ! (gC/m2/s) col-level coarse woody debris C heterotrophic respiration - real(r8), pointer :: cwdc_loss(:) ! (gC/m2/s) col-level coarse woody debris C loss - real(r8), pointer :: litterc_loss(:) ! (gC/m2/s) col-level litter C loss - ! new variables for fire - real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss -end type column_cflux_type - -type(column_cflux_type), target :: ccf ! column carbon flux -type(column_cflux_type), target :: cc13f ! column carbon-13 flux -type(column_cflux_type), target :: cc14f ! column carbon-14 flux - -!---------------------------------------------------- -! column nitrogen flux variables structure -!---------------------------------------------------- -type, public :: column_nflux_type - ! new variables for CN code - ! deposition fluxes - real(r8), pointer :: ndep_to_sminn(:) ! atmospheric N deposition to soil mineral N (gN/m2/s) - real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) - real(r8), pointer :: fert_to_sminn(:) ! fertilizer N to soil mineral N (gN/m2/s) - real(r8), pointer :: soyfixn_to_sminn(:) ! soybean fixation to soil mineral N (gN/m2/s) - ! phenology: litterfall and crop fluxes - real(r8), pointer :: phenology_n_to_litr_met_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter metabolic pool (gN/m3/s) - real(r8), pointer :: phenology_n_to_litr_cel_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter cellulose pool (gN/m3/s) - real(r8), pointer :: phenology_n_to_litr_lig_n(:,:) ! N fluxes associated with phenology (litterfall and crop) to litter lignin pool (gN/m3/s) - ! gap mortality - real(r8), pointer :: gap_mortality_n_to_litr_met_n(:,:) ! N fluxes associated with gap mortality to litter metabolic pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_litr_cel_n(:,:) ! N fluxes associated with gap mortality to litter cellulose pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_litr_lig_n(:,:) ! N fluxes associated with gap mortality to litter lignin pool (gN/m3/s) - real(r8), pointer :: gap_mortality_n_to_cwdn(:,:) ! N fluxes associated with gap mortality to CWD pool (gN/m3/s) - ! fire - real(r8), pointer :: fire_mortality_n_to_cwdn(:,:) ! N fluxes associated with fire mortality to CWD pool (gN/m3/s) - ! harvest - real(r8), pointer :: harvest_n_to_litr_met_n(:,:) ! N fluxes associated with harvest to litter metabolic pool (gN/m3/s) - real(r8), pointer :: harvest_n_to_litr_cel_n(:,:) ! N fluxes associated with harvest to litter cellulose pool (gN/m3/s) - real(r8), pointer :: harvest_n_to_litr_lig_n(:,:) ! N fluxes associated with harvest to litter lignin pool (gN/m3/s) - real(r8), pointer :: harvest_n_to_cwdn(:,:) ! N fluxes associated with harvest to CWD pool (gN/m3/s) - ! - real(r8), pointer :: hrv_deadstemn_to_prod10n(:) ! dead stem N harvest mortality to 10-year product pool (gN/m2/s) - real(r8), pointer :: hrv_deadstemn_to_prod100n(:) ! dead stem N harvest mortality to 100-year product pool (gN/m2/s) - real(r8), pointer :: m_decomp_npools_to_fire_vr(:,:,:) ! vertically-resolved decomposing N fire loss (gN/m3/s) - real(r8), pointer :: m_decomp_npools_to_fire(:,:) ! vertically-integrated (diagnostic) decomposing N fire loss (gN/m2/s) - ! column-level fire N fluxes added by F. Li and S. Levis - real(r8), pointer :: m_n_to_litr_met_fire(:,:) ! 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(:,:) ! 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(:,:) ! N from leaf, froot, xfer and storage N to litter lignin N by fire (gN/m3/s) - - ! decomposition fluxes - real(r8), pointer :: decomp_cascade_ntransfer_vr(:,:,:) ! vert-res transfer of N from donor to receiver pool along decomp. cascade (gN/m3/s) - real(r8), pointer :: decomp_cascade_ntransfer(:,:) ! 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(:,:,:) ! vert-res mineral N flux for transition along decomposition cascade (gN/m3/s) - real(r8), pointer :: decomp_cascade_sminn_flux(:,:) ! vert-int (diagnostic) mineral N flux for transition along decomposition cascade (gN/m2/s) - real(r8), pointer :: decomp_npools_sourcesink(:,:,:) ! (gN/m3) change in decomposing n pools (sum of all additions and subtractions from stateupdate1). Used to update concentrations concurrently with vertical transport - ! vertically-resolved immobilization fluxes - real(r8), pointer :: potential_immob_vr(:,:) ! vertically-resolved potential N immobilization (gN/m3/s) at each level - real(r8), pointer :: potential_immob(:) ! vert-int (diagnostic) potential N immobilization (gN/m2/s) - real(r8), pointer :: actual_immob_vr(:,:) ! vertically-resolved actual N immobilization (gN/m3/s) at each level - real(r8), pointer :: actual_immob(:) ! vert-int (diagnostic) actual N immobilization (gN/m2/s) - real(r8), pointer :: sminn_to_plant_vr(:,:) ! vertically-resolved plant uptake of soil mineral N (gN/m3/s) - real(r8), pointer :: sminn_to_plant(:) ! vert-int (diagnostic) plant uptake of soil mineral N (gN/m2/s) - real(r8), pointer :: supplement_to_sminn_vr(:,:) ! vertically-resolved supplemental N supply (gN/m3/s) - real(r8), pointer :: supplement_to_sminn(:) ! vert-int (diagnostic) supplemental N supply (gN/m2/s) - real(r8), pointer :: gross_nmin_vr(:,:) ! vertically-resolved gross rate of N mineralization (gN/m3/s) - real(r8), pointer :: gross_nmin(:) ! vert-int (diagnostic) gross rate of N mineralization (gN/m2/s) - real(r8), pointer :: net_nmin_vr(:,:) ! vertically-resolved net rate of N mineralization (gN/m3/s) - real(r8), pointer :: net_nmin(:) ! vert-int (diagnostic) net rate of N mineralization (gN/m2/s) - ! NITRIF_DENITRIF - ! nitrification / denitrification fluxes - real(r8), pointer :: f_nit_vr(:,:) ! (gN/m3/s) soil nitrification flux - real(r8), pointer :: f_denit_vr(:,:) ! (gN/m3/s) soil denitrification flux - real(r8), pointer :: f_nit(:) ! (gN/m2/s) soil nitrification flux - real(r8), pointer :: f_denit(:) ! (gN/m2/s) soil denitrification flux - - real(r8), pointer :: pot_f_nit_vr(:,:) ! (gN/m3/s) potential soil nitrification flux - real(r8), pointer :: pot_f_denit_vr(:,:) ! (gN/m3/s) potential soil denitrification flux - real(r8), pointer :: pot_f_nit(:) ! (gN/m2/s) potential soil nitrification flux - real(r8), pointer :: pot_f_denit(:) ! (gN/m2/s) potential soil denitrification flux - real(r8), pointer :: n2_n2o_ratio_denit_vr(:,:) ! ratio of N2 to N2O production by denitrification [gN/gN] - real(r8), pointer :: f_n2o_denit_vr(:,:) ! flux of N2o from denitrification [gN/m^3/s] - real(r8), pointer :: f_n2o_denit(:) ! flux of N2o from denitrification [gN/m^2/s] - real(r8), pointer :: f_n2o_nit_vr(:,:) ! flux of N2o from nitrification [gN/m^3/s] - real(r8), pointer :: f_n2o_nit(:) ! flux of N2o from nitrification [gN/m^2/s] - - ! immobilization / uptake fluxes - real(r8), pointer :: actual_immob_no3_vr(:,:) ! vertically-resolved actual immobilization of NO3 (gN/m3/s) - real(r8), pointer :: actual_immob_nh4_vr(:,:) ! vertically-resolved actual immobilization of NH4 (gN/m3/s) - real(r8), pointer :: smin_no3_to_plant_vr(:,:) ! vertically-resolved plant uptake of soil NO3 (gN/m3/s) - real(r8), pointer :: smin_nh4_to_plant_vr(:,:) ! vertically-resolved plant uptake of soil NH4 (gN/m3/s) - real(r8), pointer :: actual_immob_no3(:) ! actual immobilization of NO3 (gN/m2/s) - real(r8), pointer :: actual_immob_nh4(:) ! actual immobilization of NH4 (gN/m2/s) - real(r8), pointer :: smin_no3_to_plant(:) ! plant uptake of soil NO3 (gN/m2/s) - real(r8), pointer :: smin_nh4_to_plant(:) ! plant uptake of soil Nh4 (gN/m2/s) - ! leaching fluxes - real(r8), pointer :: smin_no3_leached_vr(:,:) ! vertically-resolved soil mineral NO3 loss to leaching (gN/m3/s) - real(r8), pointer :: smin_no3_leached(:) ! soil mineral NO3 pool loss to leaching (gN/m2/s) - real(r8), pointer :: smin_no3_runoff_vr(:,:) ! vertically-resolved rate of mineral NO3 loss with runoff (gN/m3/s) - real(r8), pointer :: smin_no3_runoff(:) ! soil mineral NO3 pool loss to runoff (gN/m2/s) - - ! NITRIF_DENITRIF diagnostic quantities - real(r8), pointer :: smin_no3_massdens_vr(:,:) ! (ugN / g soil) soil nitrate concentration - real(r8), pointer :: soil_bulkdensity(:,:) ! (kg soil / m3) bulk density of soil - real(r8), pointer :: k_nitr_t_vr(:,:) - real(r8), pointer :: k_nitr_ph_vr(:,:) - real(r8), pointer :: k_nitr_h2o_vr(:,:) - real(r8), pointer :: k_nitr_vr(:,:) - real(r8), pointer :: wfps_vr(:,:) - real(r8), pointer :: fmax_denit_carbonsubstrate_vr(:,:) - real(r8), pointer :: fmax_denit_nitrate_vr(:,:) - real(r8), pointer :: f_denit_base_vr(:,:) ! nitrification and denitrification fluxes - real(r8), pointer :: diffus(:,:) !diffusivity (m2/s) - real(r8), pointer :: ratio_k1(:,:) - real(r8), pointer :: ratio_no3_co2(:,:) - real(r8), pointer :: soil_co2_prod(:,:) - real(r8), pointer :: fr_WFPS(:,:) - - real(r8), pointer :: r_psi(:,:) - real(r8), pointer :: anaerobic_frac(:,:) - ! no NITRIF_DENITRIF - ! denitrification fluxes - real(r8), pointer :: sminn_to_denit_decomp_cascade_vr(:,:,:) ! vertically-resolved denitrification along decomp cascade (gN/m3/s) - real(r8), pointer :: sminn_to_denit_decomp_cascade(:,:) ! vertically-integrated (diagnostic) denitrification along decomp cascade (gN/m2/s) - real(r8), pointer :: sminn_to_denit_excess_vr(:,:) ! vertically-resolved denitrification from excess mineral N pool (gN/m3/s) - real(r8), pointer :: sminn_to_denit_excess(:) ! vertically-integrated (diagnostic) denitrification from excess mineral N pool (gN/m2/s) - ! leaching fluxes - real(r8), pointer :: sminn_leached_vr(:,:) ! vertically-resolved soil mineral N pool loss to leaching (gN/m3/s) - real(r8), pointer :: sminn_leached(:) ! soil mineral N pool loss to leaching (gN/m2/s) - ! - ! dynamic landcover fluxes - real(r8), pointer :: dwt_seedn_to_leaf(:) ! (gN/m2/s) seed source to PFT-level - real(r8), pointer :: dwt_seedn_to_deadstem(:) ! (gN/m2/s) seed source to PFT-level - real(r8), pointer :: dwt_conv_nflux(:) ! (gN/m2/s) conversion N flux (immediate loss to atm) - real(r8), pointer :: dwt_prod10n_gain(:) ! (gN/m2/s) addition to 10-yr wood product pool - real(r8), pointer :: dwt_prod100n_gain(:) ! (gN/m2/s) addition to 100-yr wood product pool - real(r8), pointer :: dwt_frootn_to_litr_met_n(:,:) ! (gN/m3/s) fine root to litter due to landcover change - real(r8), pointer :: dwt_frootn_to_litr_cel_n(:,:) ! (gN/m3/s) fine root to litter due to landcover change - real(r8), pointer :: dwt_frootn_to_litr_lig_n(:,:) ! (gN/m3/s) fine root to litter due to landcover change - real(r8), pointer :: dwt_livecrootn_to_cwdn(:,:) ! (gN/m3/s) live coarse root to CWD due to landcover change - real(r8), pointer :: dwt_deadcrootn_to_cwdn(:,:) ! (gN/m3/s) dead coarse root to CWD due to landcover change - real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion - ! wood product pool loss fluxes - real(r8), pointer :: prod10n_loss(:) ! (gN/m2/s) decomposition loss from 10-yr wood product pool - real(r8), pointer :: prod100n_loss(:) ! (gN/m2/s) decomposition loss from 100-yr wood product pool - real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss - ! summary (diagnostic) flux variables, not involved in mass balance - real(r8), pointer :: denit(:) ! total rate of denitrification (gN/m2/s) - real(r8), pointer :: col_ninputs(:) ! column-level N inputs (gN/m2/s) - real(r8), pointer :: col_noutputs(:) ! column-level N outputs (gN/m2/s) - ! new variables for fire - real(r8), pointer :: col_fire_nloss(:) ! total column-level fire N loss (gN/m2/s) - - real(r8), pointer :: som_n_leached(:) ! total SOM N loss from vertical transport (gN/m^2/s) - real(r8), pointer :: decomp_npools_leached(:,:) ! N loss from vertical transport from each decomposing N pool (gN/m^2/s) - real(r8), pointer :: decomp_npools_transport_tendency(:,:,:) ! N tendency due to vertical transport in decomposing N pools (gN/m^3/s) -end type column_nflux_type - -type(column_nflux_type) :: cnf !column nitrogen flux - -!---------------------------------------------------- -! column dust flux variables structure -!---------------------------------------------------- -type, public :: column_dflux_type - real(r8), pointer :: dummy_entry(:) -end type column_dflux_type - -!---------------------------------------------------- -! End definition of structures defined at the column_type level -!---------------------------------------------------- -!******************************************************************************* - - -!******************************************************************************* -!---------------------------------------------------- -! Begin definition of structures defined at the landunit_type level -!---------------------------------------------------- -! landunit physical state variables structure -! note - landunit type can be vegetated (includes bare soil), deep lake, -! shallow lake, wetland, glacier or urban -!---------------------------------------------------- -type, public :: landunit_pstate_type - ! Urban variables - real(r8), pointer :: t_building(:) ! internal building temperature (K) - real(r8), pointer :: t_building_max(:) ! maximum internal building temperature (K) - real(r8), pointer :: t_building_min(:) ! minimum internal building temperature (K) - real(r8), pointer :: tk_wall(:,:) ! thermal conductivity of urban wall (W/m/K) - real(r8), pointer :: tk_roof(:,:) ! thermal conductivity of urban roof (W/m/K) - real(r8), pointer :: tk_improad(:,:) ! thermal conductivity of urban impervious road (W/m/K) - real(r8), pointer :: cv_wall(:,:) ! heat capacity of urban wall (J/m^3/K) - real(r8), pointer :: cv_roof(:,:) ! heat capacity of urban roof (J/m^3/K) - real(r8), pointer :: cv_improad(:,:) ! heat capacity of urban impervious road (J/m^3/K) - real(r8), pointer :: thick_wall(:) ! total thickness of urban wall (m) - real(r8), pointer :: thick_roof(:) ! total thickness of urban roof (m) - integer, pointer :: nlev_improad(:) ! number of impervious road layers (-) - real(r8), pointer :: vf_sr(:) ! view factor of sky for road - real(r8), pointer :: vf_wr(:) ! view factor of one wall for road - real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall - real(r8), pointer :: vf_rw(:) ! view factor of road for one wall - real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall - real(r8), pointer :: taf(:) ! urban canopy air temperature (K) - real(r8), pointer :: qaf(:) ! urban canopy air specific humidity (kg/kg) - real(r8), pointer :: sabs_roof_dir(:,:) ! direct solar absorbed by roof per unit ground area per unit incident flux - real(r8), pointer :: sabs_roof_dif(:,:) ! diffuse solar absorbed by roof per unit ground area per unit incident flux - real(r8), pointer :: sabs_sunwall_dir(:,:) ! direct solar absorbed by sunwall per unit wall area per unit incident flux - real(r8), pointer :: sabs_sunwall_dif(:,:) ! diffuse solar absorbed by sunwall per unit wall area per unit incident flux - real(r8), pointer :: sabs_shadewall_dir(:,:) ! direct solar absorbed by shadewall per unit wall area per unit incident flux - real(r8), pointer :: sabs_shadewall_dif(:,:) ! diffuse solar absorbed by shadewall per unit wall area per unit incident flux - real(r8), pointer :: sabs_improad_dir(:,:) ! direct solar absorbed by impervious road per unit ground area per unit incident flux - real(r8), pointer :: sabs_improad_dif(:,:) ! diffuse solar absorbed by impervious road per unit ground area per unit incident flux - real(r8), pointer :: sabs_perroad_dir(:,:) ! direct solar absorbed by pervious road per unit ground area per unit incident flux - real(r8), pointer :: sabs_perroad_dif(:,:) ! diffuse solar absorbed by pervious road per unit ground area per unit incident flux -end type landunit_pstate_type - -type(landunit_pstate_type) :: lps !land unit physical state variables -type(column_pstate_type) :: cps_a !column-level physical state variables averaged to landunit - -!---------------------------------------------------- -! landunit energy flux variables structure -!---------------------------------------------------- -type, public :: landunit_eflux_type - ! Urban variables - real(r8), pointer :: eflx_traffic_factor(:) ! multiplicative traffic factor for sensible heat flux from urban traffic (-) - real(r8), pointer :: eflx_traffic(:) ! traffic sensible heat flux (W/m**2) - real(r8), pointer :: eflx_wasteheat(:) ! sensible heat flux from domestic heating/cooling sources of waste heat (W/m**2) - real(r8), pointer :: eflx_heat_from_ac(:) ! sensible heat flux to be put back into canyon due to removal by AC (W/m**2) -end type landunit_eflux_type - -type(landunit_eflux_type) :: lef ! average of energy fluxes all columns -type(column_eflux_type) :: cef_a ! column-level energy flux variables averaged to landunit - -!---------------------------------------------------- -! End definition of structures defined at the landunit_type level -!---------------------------------------------------- -!******************************************************************************* - -!******************************************************************************* -!---------------------------------------------------- -! Begin definition of structures defined at the gridcell_type level -!---------------------------------------------------- -! gridcell physical state variables structure -!---------------------------------------------------- -type, public :: gridcell_pstate_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_pstate_type - -!---------------------------------------------------- -! gridcell energy state variables structure -!---------------------------------------------------- -type, public :: gridcell_estate_type - real(r8), pointer :: gc_heat1(:) ! initial gridcell total heat content - real(r8), pointer :: gc_heat2(:) ! post land cover change total heat content -end type gridcell_estate_type - -type(gridcell_estate_type) :: ges !average of energy states all landunits - -!---------------------------------------------------- -! gridcell water state variables structure -!---------------------------------------------------- -type, public :: gridcell_wstate_type - real(r8), pointer :: gc_liq1(:) ! initial gridcell total h2o liq content - real(r8), pointer :: gc_liq2(:) ! post land cover change total liq content - real(r8), pointer :: gc_ice1(:) ! initial gridcell total h2o liq content - real(r8), pointer :: gc_ice2(:) ! post land cover change total ice content -end type gridcell_wstate_type - -type(gridcell_wstate_type) :: gws !average of water states all landunits - -!---------------------------------------------------- -! gridcell carbon state variables structure -!---------------------------------------------------- -type, public :: gridcell_cstate_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_cstate_type - -!---------------------------------------------------- -! gridcell CH4 flux variables structure -!---------------------------------------------------- -type, public :: gridcell_ch4_type - real(r8), pointer :: c_atm(:,:) !atmospheric conc of CH4, O2, CO2 (mol/m3) - real(r8), pointer :: ch4co2f(:) !gridcell CO2 production from CH4 oxidation (g C/m**2/s) - real(r8), pointer :: ch4prodg(:) !gridcell average CH4 production (g C/m^2/s) - real(r8), pointer :: nem(:) !gridcell average net methane correction to CO2 flux (g C/m^2/s) -end type gridcell_ch4_type - -type(gridcell_ch4_type) :: gch4 !average of CH4 fluxes all landunits - -!---------------------------------------------------- -! gridcell nitrogen state variables structure -!---------------------------------------------------- -type, public :: gridcell_nstate_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_nstate_type - - -!---------------------------------------------------- -! gridcell VOC state variables structure -!---------------------------------------------------- -type, public :: gridcell_vstate_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_vstate_type - -type(column_vstate_type):: cvs_a !column-level VOC state variables averaged to gridcell - -!---------------------------------------------------- -! gridcell VOC emission factor variables structure (heald) -!---------------------------------------------------- -type, public :: gridcell_efstate_type - real(r8), pointer :: efisop(:,:) ! isoprene emission factors -end type gridcell_efstate_type - -type(gridcell_efstate_type):: gve !gridcell VOC emission factors - -!---------------------------------------------------- -! gridcell dust state variables structure -!---------------------------------------------------- -type, public :: gridcell_dstate_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_dstate_type - -!---------------------------------------------------- -! gridcell DGVM state variables structure -!---------------------------------------------------- -type, public :: gridcell_dgvstate_type - real(r8), pointer :: agdd20(:) !20-yr running mean of agdd - real(r8), pointer :: tmomin20(:) !20-yr running mean of tmomin - real(r8), pointer :: t10min(:) !ann minimum of 10-day running mean (K) -end type gridcell_dgvstate_type - -type(gridcell_dgvstate_type):: gdgvs !gridcell DGVM structure - -!---------------------------------------------------- -! gridcell energy flux variables structure -!---------------------------------------------------- -type, public :: gridcell_eflux_type - real(r8), pointer :: eflx_sh_totg(:) ! total grid-level sensible heat flux - real(r8), pointer :: eflx_dynbal(:) ! dynamic land cover change conversion energy flux -end type gridcell_eflux_type - -type(gridcell_eflux_type) :: gef !average of energy fluxes all landunits - -!---------------------------------------------------- -! gridcell momentum flux variables structure -!-- ------------------------------------------------- -type, public :: gridcell_mflux_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_mflux_type - -!---------------------------------------------------- -! gridcell water flux variables structure -!---------------------------------------------------- -type, public :: gridcell_wflux_type - real(r8), pointer :: qflx_runoffg(:) ! total grid-level liq runoff - real(r8), pointer :: qflx_snwcp_iceg(:) ! total grid-level ice runoff - real(r8), pointer :: qflx_liq_dynbal(:) ! liq dynamic land cover change conversion runoff flux - real(r8), pointer :: qflx_ice_dynbal(:) ! ice dynamic land cover change conversion runoff flux - real(r8), pointer :: qflx_floodg(:) ! total grid-level flood water flux -end type gridcell_wflux_type - -type(gridcell_wflux_type) :: gwf !average of water fluxes all landunits - -!---------------------------------------------------- -! gridcell carbon flux variables structure -!---------------------------------------------------- -type, public :: gridcell_cflux_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_cflux_type - -!---------------------------------------------------- -! gridcell nitrogen flux variables structure -!---------------------------------------------------- -type, public :: gridcell_nflux_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_nflux_type - -!---------------------------------------------------- -! gridcell dust flux variables structure -!---------------------------------------------------- -type, public :: gridcell_dflux_type - real(r8), pointer :: dummy_entry(:) -end type gridcell_dflux_type - -!---------------------------------------------------- -! End definition of structures defined at the gridcell_type level -!---------------------------------------------------- -!******************************************************************************* - - -!******************************************************************************* -!---------------------------------------------------- -! Begin definition of spatial scaling hierarchy -!---------------------------------------------------- - -!---------------------------------------------------- -! define the pft structure -!---------------------------------------------------- - -type, public :: pft_type - ! g/l/c/p hierarchy, local g/l/c/p cells only - integer , pointer :: column(:) !index into column level quantities - real(r8), pointer :: wtcol(:) !weight (relative to column) - integer , pointer :: landunit(:) !index into landunit level quantities - real(r8), pointer :: wtlunit(:) !weight (relative to landunit) - integer , pointer :: gridcell(:) !index into gridcell level quantities - real(r8), pointer :: wtgcell(:) !weight (relative to gridcell) - ! topological mapping functionality - integer , pointer :: itype(:) !pft vegetation - integer , pointer :: mxy(:) !m index for laixy(i,j,m),etc. - logical , pointer :: active(:) !true=>do computations on this pft (see reweightMod for details) -end type pft_type - -type(pft_type), target :: pft !plant functional type (pft) data structure - -!---------------------------------------------------- -! define the column structure -!---------------------------------------------------- - -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 :: pfti(:) !beginning pft index for each column - integer , pointer :: pftf(:) !ending pft index for each column - integer , pointer :: npfts(:) !number of pfts for each column - ! topological mapping functionality - integer , pointer :: itype(:) !column type - logical , pointer :: active(:) !true=>do computations on this column (see reweightMod for details) -end type column_type - -type(column_type), target :: col !column data structure (soil/snow/canopy columns) - -!---------------------------------------------------- -! define the geomorphological land unit structure -!---------------------------------------------------- - -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 :: pfti(:) !beginning pft index for each landunit - integer , pointer :: pftf(:) !ending pft index for each landunit - integer , pointer :: npfts(:) !number of pfts for each landunit - - ! Urban canyon related properties - real(r8), pointer :: canyon_hwr(:) ! urban landunit canyon height to width ratio (-) - real(r8), pointer :: wtroad_perv(:) ! urban landunit weight of pervious road column to total road (-) - real(r8), pointer :: wtlunit_roof(:) ! weight of roof with respect to urban landunit (-) - - ! Urban related info MV - this should be moved to land physical state - MV - real(r8), pointer :: ht_roof(:) ! height of urban roof (m) - real(r8), pointer :: wind_hgt_canyon(:)! height above road at which wind in canyon is to be computed (m) - real(r8), pointer :: z_0_town(:) ! urban landunit momentum roughness length (m) - real(r8), pointer :: z_d_town(:) ! urban landunit displacement height (m) - - ! topological mapping functionality - integer , pointer :: itype(:) !landunit type - logical , pointer :: ifspecial(:) !true=>landunit is not vegetated - logical , pointer :: lakpoi(:) !true=>lake point - logical , pointer :: urbpoi(:) !true=>urban point - logical , pointer :: glcmecpoi(:) !true=>glacier_mec point - integer , pointer :: udenstype(:) !urban density type - logical , pointer :: active(:) !true=>do computations on this landunit (see reweightMod for details) -end type landunit_type - -type(landunit_type), target :: lun !geomorphological landunits - -!---------------------------------------------------- -! define the gridcell structure -!---------------------------------------------------- - -type, public :: gridcell_type - ! g/l/c/p hierarchy, local g/l/c/p cells only - integer, pointer :: luni(:) !beginning landunit index - integer, pointer :: lunf(:) !ending landunit index - integer, pointer :: nlandunits(:) !number of landunit for each gridcell - integer, pointer :: coli(:) !beginning column index - integer, pointer :: colf(:) !ending column index - integer, pointer :: ncolumns(:) !number of columns for each gridcell - integer, pointer :: pfti(:) !beginning pft index - integer, pointer :: pftf(:) !ending pft index - integer, pointer :: npfts(:) !number of pfts for each gridcell - - ! topological mapping functionality, local 1d gdc arrays - integer , pointer :: gindex(:) !global index - real(r8), pointer :: area(:) !total land area, gridcell (km^2) - real(r8), pointer :: lat(:) !latitude (radians) - real(r8), pointer :: lon(:) !longitude (radians) - real(r8), pointer :: latdeg(:) !latitude (degrees) - real(r8), pointer :: londeg(:) !longitude (degrees) - integer , pointer :: gindex_a(:) !"atm" global index - real(r8), pointer :: lat_a(:) !"atm" latitude (radians) for albedo - real(r8), pointer :: lon_a(:) !"atm" longitude (radians) for albedo - real(r8), pointer :: latdeg_a(:) !"atm" latitude (degrees) for albedo - real(r8), pointer :: londeg_a(:) !"atm" longitude (degrees) for albedo - - real(r8), pointer :: gris_mask(:) !Greenland ice sheet mask - real(r8), pointer :: gris_area(:) !Greenland ice-covered area per gridcell (km^2) - real(r8), pointer :: aais_mask(:) !Antarctic ice sheet mask - real(r8), pointer :: aais_area(:) !Antarctic ice-covered area per gridcell (km^2) - real(r8), pointer :: tws(:) !total water storage (mm H2O) - - ! fzeng added, Mar 2017 - real(r8), pointer :: forc_ndep(:) ! nitrogen deposition rate (gN/m2/s) - real(r8), pointer :: forc_rh(:) ! relative humidity (%) - real(r8), pointer :: forc_wind(:) ! wind speed (m/s) - real(r8), pointer :: forc_t(:) ! air temperature (K) - real(r8), pointer :: forc_rain(:) ! rainfall (convective + largescale) (mm/s) - real(r8), pointer :: forc_snow(:) ! snowfall (mm/s) - real(r8), pointer :: forc_hdm(:) ! Human population density - real(r8), pointer :: forc_lnfm(:) ! Lightning frequency - -end type gridcell_type - -type(gridcell_type), target :: grc !gridcell data structure - -character(len=16), parameter, public :: grlnd = 'lndgrid' ! name of lndgrid -character(len=16), parameter, public :: namea = 'gridcellatm' ! name of atmgrid -character(len=16), parameter, public :: nameg = 'gridcell' ! name of gridcells -character(len=16), parameter, public :: namel = 'landunit' ! name of landunits -character(len=16), parameter, public :: namec = 'column' ! name of columns -character(len=16), parameter, public :: namep = 'pft' ! name of pfts - -! -!EOP -!----------------------------------------------------------------------- -end module clmtype 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 deleted file mode 100644 index a9cff5af2..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/clmtypeInitMod.F90 +++ /dev/null @@ -1,3306 +0,0 @@ -module clmtypeInitMod - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: clmtypeInitMod -! -! !DESCRIPTION: -! Allocate clmtype components and initialize them to signaling NaN. -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 -! use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) - use nanMod , only : nan, bigint - use clmtype - use clm_varpar , only : maxpatch_pft, nlevsno, nlevgrnd, & - numpft, nlevsoi, nlevdecomp, nlevdecomp_full, & - ndecomp_cascade_transitions, ndecomp_pools, nlevcan - use clm_varctl , only : use_c13, use_c14 - -! -! !PUBLIC TYPES: - implicit none - save -! -! !PUBLIC MEMBER FUNCTIONS: - public :: initClmtype -! -! !REVISION HISTORY: -! Created by Peter Thornton and Mariana Vertenstein -! Modified by Colette L. Heald (05/06) for VOC emission factors -! 3/17/08 David Lawrence, changed nlevsoi to nlevgrnd where appropriate -!!F. Li and S. Levis (11/06/12) -! !PRIVATE MEMBER FUNCTIONS: - private :: init_pft_type - private :: init_column_type - private :: init_landunit_type - private :: init_gridcell_type - private :: init_pft_ecophys_constants - private :: init_decomp_cascade_constants -#if (defined CNDV) - private :: init_pft_DGVMecophys_constants -#endif - private :: init_pft_pstate_type - private :: init_pft_epv_type -#if (defined CNDV) - private :: init_pft_pdgvstate_type -#endif - private :: init_pft_estate_type - private :: init_pft_cstate_type - private :: init_pft_nstate_type - private :: init_pft_cflux_type - private :: init_pft_nflux_type - private :: init_column_pstate_type - private :: init_column_estate_type - private :: init_column_wstate_type - private :: init_column_cstate_type - private :: init_column_nstate_type - private :: init_column_wflux_type - private :: init_column_cflux_type -#ifdef LCH4 - private :: init_column_ch4_type -#endif - private :: init_column_nflux_type -#ifdef LCH4 - private :: init_gridcell_ch4_type -#endif -!EOP -!---------------------------------------------------- - -contains - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: initClmtype -! -! !INTERFACE: - subroutine initClmtype(begg,endg,begl,endl,begc,endc,begp,endp) -! -! !DESCRIPTION: -! Initialize clmtype components to signaling nan -! The following clmtype components should NOT be initialized here -! since they are set in routine clm_map which is called before this -! routine is invoked -! *%area, *%wtlnd, *%wtxy, *%ixy, *%jxy, *%mxy, %snindex -! *%ifspecial, *%ityplun, *%itype -! *%pfti, *%pftf, *%pftn -! *%coli, *%colf, *%coln -! *%luni, *%lunf, *%lunn -! -! !USES: -! use decompMod , only : get_proc_bounds, get_proc_global -! -! !ARGUMENTS: - implicit none -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -! -! LOCAL VARAIBLES: - integer :: begp, endp ! per-proc beginning and ending pft indices - integer :: begc, endc ! per-proc beginning and ending column indices - integer :: begl, endl ! per-proc beginning and ending landunit indices - integer :: begg, endg ! per-proc gridcell ending gridcell indices - integer :: numg ! total number of gridcells across all processors - integer :: numl ! total number of landunits across all processors - integer :: numc ! total number of columns across all processors - integer :: nump ! total number of pfts across all processors - character(len=32), parameter :: subname = "initClmtype" -!------------------------------------------------------------------------ - - ! Determine necessary indices - -! call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) -! call get_proc_global(numg, numl, numc, nump) - - call init_pft_type (begp, endp, pft) - call init_column_type (begc, endc, col) - call init_landunit_type(begl, endl, lun) - call init_gridcell_type(begg, endg, grc) - - ! pft ecophysiological constants - - call init_pft_ecophys_constants() - - call init_decomp_cascade_constants() - -#if (defined CNDV) - ! pft DGVM-specific ecophysiological constants - - call init_pft_DGVMecophys_constants() -#endif - - ! carbon balance structures (pft and column levels) - - call init_carbon_balance_type(begp, endp, pcbal) - call init_carbon_balance_type(begc, endc, ccbal) - - ! nitrogen balance structures (pft and column levels) - - call init_nitrogen_balance_type(begp, endp, pnbal) - call init_nitrogen_balance_type(begc, endc, cnbal) - - ! pft physical state variables at pft level - - call init_pft_pstate_type(begp, endp, pps) - - ! pft ecophysiological variables (only at the pft level for now) - call init_pft_epv_type(begp, endp, pepv) - - !pft photosynthesis relevant variables - call init_pft_psynstate_type(begp, endp, ppsyns) -#if (defined CNDV) - ! pft DGVM state variables at pft level and averaged to column - - call init_pft_pdgvstate_type(begp, endp, pdgvs) -#endif - - ! pft energy state variables at the pft level and averaged to the column - - call init_pft_estate_type(begp, endp, pes) - - ! pft carbon state variables at the pft level and averaged to the column - - call init_pft_cstate_type(begp, endp, pcs) - call init_pft_cstate_type(begc, endc, pcs_a) - -! if ( use_c13 ) then -! call init_pft_cstate_type(begp, endp, pc13s) -! call init_pft_cstate_type(begc, endc, pc13s_a) -!#ifdef CROP -! stop 'initClmtype ERROR:: CROP and C13 can NOT be on at the same time' -!#endif -! endif - -! if ( use_c14 ) then -! call init_pft_cstate_type(begp, endp, pc14s) -! call init_pft_cstate_type(begc, endc, pc14s_a) -!#ifdef CROP -! stop 'initClmtype ERROR:: CROP and C14 can NOT be on at the same time' -!#endif -! endif - - ! pft nitrogen state variables at the pft level and averaged to the column - - call init_pft_nstate_type(begp, endp, pns) - call init_pft_nstate_type(begc, endc, pns_a) - - ! pft carbon flux variables at pft level and averaged to column - - call init_pft_cflux_type(begp, endp, pcf) - call init_pft_cflux_type(begc, endc, pcf_a) - -! if ( use_c13 ) then -! call init_pft_cflux_type(begp, endp, pc13f) -! call init_pft_cflux_type(begc, endc, pc13f_a) -! endif - -! if ( use_c14 ) then -! call init_pft_cflux_type(begp, endp, pc14f) -! call init_pft_cflux_type(begc, endc, pc14f_a) -! endif - - ! pft nitrogen flux variables at pft level and averaged to column - - call init_pft_nflux_type(begp, endp, pnf) - call init_pft_nflux_type(begc, endc, pnf_a) - - ! column physical state variables at column level - - call init_column_pstate_type(begc, endc, cps) - - ! column energy state variables at column level - - call init_column_estate_type(begc, endc, ces) - - ! column water state variables at column level - - call init_column_wstate_type(begc, endc, cws) - - ! column carbon state variables at column level - - call init_column_cstate_type(begc, endc, ccs) - -! if ( use_c13 ) then -! call init_column_cstate_type(begc, endc, cc13s) -! endif - -! if ( use_c14 ) then -! call init_column_cstate_type(begc, endc, cc14s) -! endif - - ! column nitrogen state variables at column level - - call init_column_nstate_type(begc, endc, cns) - - ! column water flux variables at column level - - call init_column_wflux_type(begc, endc, cwf) - - ! column carbon flux variables at column level - - call init_column_cflux_type(begc, endc, ccf) - -! if ( use_c13 ) then -! call init_column_cflux_type(begc, endc, cc13f) -! endif - -! if ( use_c14 ) then -! call init_column_cflux_type(begc, endc, cc14f) -! endif - -#if (defined LCH4) - ! column CH4 flux variables at column level - call init_column_ch4_type(begc, endc, cch4) -#endif - - ! column nitrogen flux variables at column level - - call init_column_nflux_type(begc, endc, cnf) - -#if (defined CNDV) - ! gridcell DGVM variables - - call init_gridcell_dgvstate_type(begg, endg, gdgvs) -#endif - -#if (defined LCH4) - ! gridcell: ch4 variables - - call init_gridcell_ch4_type(begg, endg, gch4) -#endif - - end subroutine initClmtype - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_type -! -! !INTERFACE: - subroutine init_pft_type (beg, end, pft) -! -! !DESCRIPTION: -! Initialize components of pft_type structure -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type(pft_type), intent(inout):: pft -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(pft%gridcell(beg:end),pft%wtgcell(beg:end)) - allocate(pft%landunit(beg:end)) - allocate(pft%column (beg:end),pft%wtcol (beg:end)) - - allocate(pft%itype(beg:end)) - allocate(pft%active(beg:end)) - - end subroutine init_pft_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_type -! -! !INTERFACE: - subroutine init_column_type (beg, end, c) -! -! !DESCRIPTION: -! Initialize components of column_type structure -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type(column_type), intent(inout):: c -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(col%gridcell(beg:end),col%wtgcell(beg:end)) - allocate(col%landunit(beg:end),col%wtlunit(beg:end)) - - allocate(col%pfti(beg:end),col%pftf(beg:end),col%npfts(beg:end)) - - allocate(col%itype(beg:end)) - allocate(col%active(beg:end)) - - end subroutine init_column_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_landunit_type -! -! !INTERFACE: - subroutine init_landunit_type (beg, end,l) -! -! !DESCRIPTION: -! Initialize components of landunit_type structure -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type(landunit_type), intent(inout):: l -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(lun%itype(beg:end)) - allocate(lun%ifspecial(beg:end)) - - end subroutine init_landunit_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_gridcell_type -! -! !INTERFACE: - subroutine init_gridcell_type (beg, end,grc) -! -! !DESCRIPTION: -! Initialize components of gridcell_type structure -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type(gridcell_type), intent(inout):: grc -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - ! Modified by fzeng, 2017 - allocate(grc%gindex(beg:end)) - allocate(grc%forc_ndep(beg:end)) - allocate(grc%forc_rh (beg:end)) - allocate(grc%forc_wind(beg:end)) - allocate(grc%forc_t (beg:end)) - allocate(grc%forc_rain(beg:end)) - allocate(grc%forc_snow(beg:end)) - allocate(grc%latdeg(beg:end)) - allocate(grc%londeg(beg:end)) - allocate(grc%forc_hdm(beg:end)) - allocate(grc%forc_lnfm(beg:end)) - - end subroutine init_gridcell_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_carbon_balance_type -! -! !INTERFACE: - subroutine init_carbon_balance_type(beg, end, cbal) -! -! !DESCRIPTION: -! Initialize carbon balance variables -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type(carbon_balance_type), intent(inout):: cbal -! -! !REVISION HISTORY: -! Created by Peter Thornton, 12/11/2003 -! -!EOP -!------------------------------------------------------------------------ - - allocate(cbal%begcb(beg:end)) - allocate(cbal%endcb(beg:end)) - allocate(cbal%errcb(beg:end)) - - cbal%begcb(beg:end) = nan - cbal%endcb(beg:end) = nan - cbal%errcb(beg:end) = nan - - end subroutine init_carbon_balance_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_nitrogen_balance_type -! -! !INTERFACE: - subroutine init_nitrogen_balance_type(beg, end, nbal) -! -! !DESCRIPTION: -! Initialize nitrogen balance variables -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type(nitrogen_balance_type), intent(inout):: nbal -! -! !REVISION HISTORY: -! Created by Peter Thornton, 12/11/2003 -! -!EOP -!------------------------------------------------------------------------ - - allocate(nbal%begnb(beg:end)) - allocate(nbal%endnb(beg:end)) - allocate(nbal%errnb(beg:end)) - - nbal%begnb(beg:end) = nan - nbal%endnb(beg:end) = nan - nbal%errnb(beg:end) = nan - end subroutine init_nitrogen_balance_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_ecophys_constants -! -! !INTERFACE: - subroutine init_pft_ecophys_constants() -! -! !DESCRIPTION: -! Initialize pft physical state -! -! !ARGUMENTS: - implicit none -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(pftcon%noveg(0:numpft)) - allocate(pftcon%tree(0:numpft)) - allocate(pftcon%fnitr(0:numpft)) - allocate(pftcon%c3psn(0:numpft)) - allocate(pftcon%xl(0:numpft)) - allocate(pftcon%rhol(0:numpft)) - allocate(pftcon%rhos(0:numpft)) - allocate(pftcon%taul(0:numpft)) - allocate(pftcon%taus(0:numpft)) - allocate(pftcon%z0mr(0:numpft)) - allocate(pftcon%displar(0:numpft)) - allocate(pftcon%roota_par(0:numpft)) - allocate(pftcon%rootb_par(0:numpft)) - allocate(pftcon%slatop(0:numpft)) - allocate(pftcon%dsladlai(0:numpft)) - allocate(pftcon%leafcn(0:numpft)) - allocate(pftcon%flnr(0:numpft)) - allocate(pftcon%woody(0:numpft)) - allocate(pftcon%lflitcn(0:numpft)) - allocate(pftcon%frootcn(0:numpft)) - allocate(pftcon%livewdcn(0:numpft)) - allocate(pftcon%deadwdcn(0:numpft)) - allocate(pftcon%graincn(0:numpft)) - allocate(pftcon%froot_leaf(0:numpft)) - allocate(pftcon%stem_leaf(0:numpft)) - allocate(pftcon%croot_stem(0:numpft)) - allocate(pftcon%flivewd(0:numpft)) - allocate(pftcon%fcur(0:numpft)) - allocate(pftcon%lf_flab(0:numpft)) - allocate(pftcon%lf_fcel(0:numpft)) - allocate(pftcon%lf_flig(0:numpft)) - allocate(pftcon%fr_flab(0:numpft)) - allocate(pftcon%fr_fcel(0:numpft)) - allocate(pftcon%fr_flig(0:numpft)) - allocate(pftcon%leaf_long(0:numpft)) - allocate(pftcon%evergreen(0:numpft)) - allocate(pftcon%stress_decid(0:numpft)) - allocate(pftcon%season_decid(0:numpft)) - allocate(pftcon%dwood(0:numpft)) - allocate(pftcon%cc_dstem(0:numpft)) - allocate(pftcon%cc_leaf(0:numpft)) - allocate(pftcon%cc_lstem(0:numpft)) - allocate(pftcon%cc_other(0:numpft)) - allocate(pftcon%fm_dstem(0:numpft)) - allocate(pftcon%fm_leaf(0:numpft)) - allocate(pftcon%fm_lstem(0:numpft)) - allocate(pftcon%fm_other(0:numpft)) - allocate(pftcon%fm_root(0:numpft)) - allocate(pftcon%fm_lroot(0:numpft)) - allocate(pftcon%fm_droot(0:numpft)) - allocate(pftcon%rootprof_beta(0:numpft)) - allocate(pftcon%fertnitro(0:numpft)) - allocate(pftcon%fleafcn(0:numpft)) - allocate(pftcon%ffrootcn(0:numpft)) - allocate(pftcon%fstemcn(0:numpft)) - allocate(pftcon%laimx(0:numpft)) - allocate(pftcon%ztopmx(0:numpft)) - - ! fzeng: - allocate(pftcon%declfact(0:numpft)) - allocate(pftcon%bfact(0:numpft)) - allocate(pftcon%aleaff(0:numpft)) - allocate(pftcon%arootf(0:numpft)) - allocate(pftcon%astemf(0:numpft)) - allocate(pftcon%arooti(0:numpft)) - allocate(pftcon%fleafi(0:numpft)) - allocate(pftcon%allconsl(0:numpft)) - allocate(pftcon%allconss(0:numpft)) - allocate(pftcon%grperc(0:numpft)) - allocate(pftcon%grpnow(0:numpft)) - allocate(pftcon%fsr_pft(0:numpft)) - allocate(pftcon%fd_pft(0:numpft)) - allocate(pftcon%mnNHplantdate(0:numpft)) - allocate(pftcon%mxNHplantdate(0:numpft)) - allocate(pftcon%mnSHplantdate(0:numpft)) - allocate(pftcon%mxSHplantdate(0:numpft)) - allocate(pftcon%gddmin(0:numpft)) - allocate(pftcon%hybgdd(0:numpft)) - allocate(pftcon%lfemerg(0:numpft)) - allocate(pftcon%grnfill(0:numpft)) - allocate(pftcon%mxmat(0:numpft)) - allocate(pftcon%minplanttemp(0:numpft)) - allocate(pftcon%planttemp(0:numpft)) - allocate(pftcon%mxtmp(0:numpft)) - allocate(pftcon%baset(0:numpft)) - allocate(pftcon%qe25(0:numpft)) - - pftcon%noveg(:) = huge(1) - pftcon%tree(:) = huge(1) - pftcon%fnitr(:) = nan - pftcon%c3psn(:) = nan - pftcon%xl(:) = nan - pftcon%rhol(:) = nan - pftcon%rhos(:) = nan - pftcon%taul(:) = nan - pftcon%taus(:) = nan - pftcon%z0mr(:) = nan - pftcon%displar(:) = nan - pftcon%roota_par(:) = nan - pftcon%rootb_par(:) = nan - pftcon%slatop(:) = nan - pftcon%dsladlai(:) = nan - pftcon%leafcn(:) = nan - pftcon%flnr(:) = nan - pftcon%woody(:) = nan - pftcon%lflitcn(:) = nan - pftcon%frootcn(:) = nan - pftcon%livewdcn(:) = nan - pftcon%deadwdcn(:) = nan - pftcon%graincn(:) = nan - pftcon%froot_leaf(:) = nan - pftcon%stem_leaf(:) = nan - pftcon%croot_stem(:) = nan - pftcon%flivewd(:) = nan - pftcon%fcur(:) = nan - pftcon%lf_flab(:) = nan - pftcon%lf_fcel(:) = nan - pftcon%lf_flig(:) = nan - pftcon%fr_flab(:) = nan - pftcon%fr_fcel(:) = nan - pftcon%fr_flig(:) = nan - pftcon%leaf_long(:) = nan - pftcon%evergreen(:) = nan - pftcon%stress_decid(:) = nan - pftcon%season_decid(:) = nan - pftcon%dwood(:) = nan - pftcon%cc_dstem(:) = nan - pftcon%cc_leaf(:) = nan - pftcon%cc_lstem(:) = nan - pftcon%cc_other(:) = nan - pftcon%fm_dstem(:) = nan - pftcon%fm_leaf(:) = nan - pftcon%fm_lstem(:) = nan - pftcon%fm_other(:) = nan - pftcon%fm_root(:) = nan - pftcon%fm_lroot(:) = nan - pftcon%fm_droot(:) = nan - pftcon%rootprof_beta(:) = nan - pftcon%fertnitro(:) = nan - pftcon%fleafcn(:) = nan - pftcon%ffrootcn(:) = nan - pftcon%fstemcn(:) = nan - pftcon%laimx(:) = nan - pftcon%ztopmx(:) = nan - - ! fzeng: - pftcon%declfact(:) = nan - pftcon%bfact(:) = nan - pftcon%aleaff(:) = nan - pftcon%arootf(:) = nan - pftcon%astemf(:) = nan - pftcon%arooti(:) = nan - pftcon%fleafi(:) = nan - pftcon%allconsl(:) = nan - pftcon%allconss(:) = nan - pftcon%grperc(:) = nan - pftcon%grpnow(:) = nan - pftcon%fsr_pft(:) = nan - pftcon%fd_pft(:) = nan - pftcon%mnNHplantdate(:) = huge(1) - pftcon%mxNHplantdate(:) = huge(1) - pftcon%mnSHplantdate(:) = huge(1) - pftcon%mxSHplantdate(:) = huge(1) - pftcon%gddmin(:) = nan - pftcon%hybgdd(:) = nan - pftcon%lfemerg(:) = nan - pftcon%grnfill(:) = nan - pftcon%mxmat(:) = nan - pftcon%minplanttemp(:) = nan - pftcon%planttemp(:)= nan - pftcon%mxtmp(:) = nan - pftcon%baset(:) = nan - pftcon%qe25(:) = nan - - end subroutine init_pft_ecophys_constants - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_decomp_cascade_constants -! -! !INTERFACE: - subroutine init_decomp_cascade_constants() -! -! !DESCRIPTION: -! Initialize decomposition cascade state -! -! !ARGUMENTS: - implicit none -! -! !REVISION HISTORY: -! Created by Charlie Koven -! -!EOP -!------------------------------------------------------------------------ - - !-- 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(0:ndecomp_pools)) - allocate(decomp_cascade_con%decomp_pool_name_restart(0:ndecomp_pools)) - allocate(decomp_cascade_con%decomp_pool_name_history(0:ndecomp_pools)) - allocate(decomp_cascade_con%decomp_pool_name_long(0:ndecomp_pools)) - allocate(decomp_cascade_con%decomp_pool_name_short(0:ndecomp_pools)) - allocate(decomp_cascade_con%is_litter(0:ndecomp_pools)) - allocate(decomp_cascade_con%is_soil(0:ndecomp_pools)) - allocate(decomp_cascade_con%is_cwd(0:ndecomp_pools)) - allocate(decomp_cascade_con%initial_cn_ratio(0:ndecomp_pools)) - allocate(decomp_cascade_con%initial_stock(0:ndecomp_pools)) - allocate(decomp_cascade_con%is_metabolic(0:ndecomp_pools)) - allocate(decomp_cascade_con%is_cellulose(0:ndecomp_pools)) - allocate(decomp_cascade_con%is_lignin(0:ndecomp_pools)) - allocate(decomp_cascade_con%spinup_factor(0:ndecomp_pools)) - !-- 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 - !-- properties of each decomposing pool - decomp_cascade_con%floating_cn_ratio_decomp_pools(0:ndecomp_pools) = .false. - decomp_cascade_con%decomp_pool_name_history(0:ndecomp_pools) = '' - decomp_cascade_con%decomp_pool_name_restart(0:ndecomp_pools) = '' - decomp_cascade_con%decomp_pool_name_long(0:ndecomp_pools) = '' - decomp_cascade_con%decomp_pool_name_short(0:ndecomp_pools) = '' - decomp_cascade_con%is_litter(0:ndecomp_pools) = .false. - decomp_cascade_con%is_soil(0:ndecomp_pools) = .false. - decomp_cascade_con%is_cwd(0:ndecomp_pools) = .false. - decomp_cascade_con%initial_cn_ratio(0:ndecomp_pools) = nan - decomp_cascade_con%initial_stock(0:ndecomp_pools) = nan - decomp_cascade_con%is_metabolic(0:ndecomp_pools) = .false. - decomp_cascade_con%is_cellulose(0:ndecomp_pools) = .false. - decomp_cascade_con%is_lignin(0:ndecomp_pools) = .false. - decomp_cascade_con%spinup_factor(0:ndecomp_pools) = nan - - end subroutine init_decomp_cascade_constants - - -#if (defined CNDV) -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_DGVMecophys_constants -! -! !INTERFACE: - subroutine init_pft_DGVMecophys_constants() -! -! !DESCRIPTION: -! Initialize pft physical state -! -! !ARGUMENTS: - implicit none -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(dgv_pftcon%crownarea_max(0:numpft)) - allocate(dgv_pftcon%tcmin(0:numpft)) - allocate(dgv_pftcon%tcmax(0:numpft)) - allocate(dgv_pftcon%gddmin(0:numpft)) - allocate(dgv_pftcon%twmax(0:numpft)) - allocate(dgv_pftcon%reinickerp(0:numpft)) - allocate(dgv_pftcon%allom1(0:numpft)) - allocate(dgv_pftcon%allom2(0:numpft)) - allocate(dgv_pftcon%allom3(0:numpft)) - - dgv_pftcon%crownarea_max(:) = nan - dgv_pftcon%tcmin(:) = nan - dgv_pftcon%tcmax(:) = nan - dgv_pftcon%gddmin(:) = nan - dgv_pftcon%twmax(:) = nan - dgv_pftcon%reinickerp(:) = nan - dgv_pftcon%allom1(:) = nan - dgv_pftcon%allom2(:) = nan - dgv_pftcon%allom3(:) = nan - - end subroutine init_pft_DGVMecophys_constants -#endif - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_pstate_type -! -! !INTERFACE: - subroutine init_pft_pstate_type(beg, end, pps) -! -! !DESCRIPTION: -! Initialize pft physical state -! -! !USES: - use clm_varcon, only : spval,ispval - use clm_varctl , only : crop_prog -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_pstate_type), intent(inout):: pps -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - allocate(pps%prec10(beg:end)) !F. Li and S. Levis - allocate(pps%prec60(beg:end)) !F. Li and S. Levis - allocate(pps%frac_veg_nosno(beg:end)) - allocate(pps%frac_veg_nosno_alb(beg:end)) - allocate(pps%rootfr(beg:end,1:nlevgrnd)) - allocate(pps%rootr(beg:end,1:nlevgrnd)) - allocate(pps%laisun(beg:end)) - allocate(pps%laisha(beg:end)) - allocate(pps%btran2(beg:end)) ! F. Li and S. Levis - allocate(pps%tlai(beg:end)) - allocate(pps%tsai(beg:end)) - allocate(pps%elai(beg:end)) - allocate(pps%esai(beg:end)) - allocate(pps%htop(beg:end)) - allocate(pps%hbot(beg:end)) - allocate(pps%burndate(beg:end)) ! F. Li and S. Levis - if ( crop_prog )then - allocate(pps%hdidx(beg:end)) - allocate(pps%cumvd(beg:end)) - allocate(pps%htmx(beg:end)) - allocate(pps%vf(beg:end)) - allocate(pps%gddmaturity(beg:end)) - allocate(pps%gdd0(beg:end)) - allocate(pps%gdd8(beg:end)) - allocate(pps%gdd10(beg:end)) - allocate(pps%gdd020(beg:end)) - allocate(pps%gdd820(beg:end)) - allocate(pps%gdd1020(beg:end)) - allocate(pps%gddplant(beg:end)) - allocate(pps%gddtsoi(beg:end)) - allocate(pps%huileaf(beg:end)) - allocate(pps%huigrain(beg:end)) - allocate(pps%aleafi(beg:end)) - allocate(pps%astemi(beg:end)) - allocate(pps%aleaf(beg:end)) - allocate(pps%astem(beg:end)) - allocate(pps%croplive(beg:end)) - allocate(pps%cropplant(beg:end)) !,numpft)) ! make 2-D if using - allocate(pps%harvdate(beg:end)) !,numpft)) ! crop rotation - allocate(pps%idop(beg:end)) - allocate(pps%peaklai(beg:end)) - end if - allocate(pps%forc_hgt_u_pft(beg:end)) - allocate(pps%lfpftd(beg:end)) !F. Li and S. Levis - - ! 4/14/05: PET - ! Adding isotope code - -! if ( use_c13 ) then -! allocate(pps%alphapsnsun(beg:end)) -! allocate(pps%alphapsnsha(beg:end)) -! endif - -#if (defined LCH4) - ! CH4 code - allocate(pps%grnd_ch4_cond(beg:end)) - allocate(pps%canopy_cond(beg:end)) -#endif - ! and vertical profiles for calculating fluxes - allocate(pps%leaf_prof(beg:end,1:nlevdecomp_full)) - allocate(pps%froot_prof(beg:end,1:nlevdecomp_full)) - allocate(pps%croot_prof(beg:end,1:nlevdecomp_full)) - allocate(pps%stem_prof(beg:end,1:nlevdecomp_full)) - pps%prec10(beg:end) = nan ! F. Li and S. Levis - pps%prec60(beg:end) = nan ! F. Li and S. Levis - pps%frac_veg_nosno(beg:end) = huge(1) - pps%frac_veg_nosno_alb(beg:end) = 0 - pps%rootfr(beg:end,:nlevgrnd) = spval - pps%rootr (beg:end,:nlevgrnd) = spval - pps%laisun(beg:end) = nan - pps%laisha(beg:end) = nan - pps%btran2(beg:end) = spval !F. Li and S. Levis - pps%tlai(beg:end) = 0._r8 - pps%tsai(beg:end) = 0._r8 - pps%elai(beg:end) = 0._r8 - pps%esai(beg:end) = 0._r8 - pps%htop(beg:end) = 0._r8 - pps%hbot(beg:end) = 0._r8 - pps%burndate(beg:end) = ispval ! F. Li and S. Levis - if ( crop_prog )then - pps%hdidx(beg:end) = nan - pps%cumvd(beg:end) = nan - pps%htmx(beg:end) = 0.0_r8 - pps%vf(beg:end) = 0.0_r8 - pps%gddmaturity(beg:end) = spval - pps%gdd0(beg:end) = spval - pps%gdd8(beg:end) = spval - pps%gdd10(beg:end) = spval - pps%gdd020(beg:end) = spval - pps%gdd820(beg:end) = spval - pps%gdd1020(beg:end) = spval - pps%gddplant(beg:end) = spval - pps%gddtsoi(beg:end) = spval - pps%huileaf(beg:end) = nan - pps%huigrain(beg:end) = nan - pps%aleafi(beg:end) = nan - pps%astemi(beg:end) = nan - pps%aleaf(beg:end) = nan - pps%astem(beg:end) = nan - pps%croplive(beg:end) = .false. - pps%cropplant(beg:end) = .false. - pps%harvdate(beg:end) = huge(1) - pps%idop(beg:end) = huge(1) - pps%peaklai(beg:end) = 0 - end if - pps%forc_hgt_u_pft(beg:end) = nan - - ! 4/14/05: PET - ! Adding isotope code ! EBK Check this! - !!!pps%cisun(beg:end) = spval - !!!pps%cisha(beg:end) = spval - -! if ( use_c13 ) then -! pps%alphapsnsun(beg:end) = spval -! pps%alphapsnsha(beg:end) = spval -! endif - -#if defined (LCH4) - ! CH4 code - pps%grnd_ch4_cond(beg:end) = nan - pps%canopy_cond(beg:end) = nan -#endif - ! and vertical profiles for calculating fluxes - pps%leaf_prof(beg:end,1:nlevdecomp_full) = spval - pps%froot_prof(beg:end,1:nlevdecomp_full) = spval - pps%croot_prof(beg:end,1:nlevdecomp_full) = spval - pps%stem_prof(beg:end,1:nlevdecomp_full) = spval - - end subroutine init_pft_pstate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_epv_type -! -! !INTERFACE: - subroutine init_pft_epv_type(beg, end, pepv) -! -! !DESCRIPTION: -! Initialize pft ecophysiological variables -! -! !USES: - use clm_varcon, only : spval -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_epv_type), intent(inout):: pepv -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -!EOP -!------------------------------------------------------------------------ - - allocate(pepv%dormant_flag(beg:end)) - allocate(pepv%days_active(beg:end)) - allocate(pepv%onset_flag(beg:end)) - allocate(pepv%onset_counter(beg:end)) - allocate(pepv%onset_gddflag(beg:end)) - allocate(pepv%onset_fdd(beg:end)) - allocate(pepv%onset_gdd(beg:end)) - allocate(pepv%onset_swi(beg:end)) - allocate(pepv%offset_flag(beg:end)) - allocate(pepv%offset_counter(beg:end)) - allocate(pepv%offset_fdd(beg:end)) - allocate(pepv%offset_swi(beg:end)) - allocate(pepv%fert_counter(beg:end)) - allocate(pepv%grain_flag(beg:end)) - allocate(pepv%lgsf(beg:end)) - allocate(pepv%bglfr(beg:end)) - allocate(pepv%bgtr(beg:end)) - allocate(pepv%dayl(beg:end)) - allocate(pepv%prev_dayl(beg:end)) - allocate(pepv%annavg_t2m(beg:end)) - allocate(pepv%tempavg_t2m(beg:end)) - allocate(pepv%gpp(beg:end)) - allocate(pepv%availc(beg:end)) - allocate(pepv%xsmrpool_recover(beg:end)) -! if ( use_c13 ) then -! allocate(pepv%xsmrpool_c13ratio(beg:end)) -! endif - allocate(pepv%alloc_pnow(beg:end)) - allocate(pepv%c_allometry(beg:end)) - allocate(pepv%n_allometry(beg:end)) - allocate(pepv%plant_ndemand(beg:end)) - allocate(pepv%tempsum_potential_gpp(beg:end)) - allocate(pepv%annsum_potential_gpp(beg:end)) - allocate(pepv%tempmax_retransn(beg:end)) - allocate(pepv%annmax_retransn(beg:end)) - allocate(pepv%avail_retransn(beg:end)) - allocate(pepv%plant_nalloc(beg:end)) - allocate(pepv%plant_calloc(beg:end)) - allocate(pepv%excess_cflux(beg:end)) - allocate(pepv%downreg(beg:end)) - allocate(pepv%prev_leafc_to_litter(beg:end)) - allocate(pepv%prev_frootc_to_litter(beg:end)) - allocate(pepv%tempsum_npp(beg:end)) - allocate(pepv%annsum_npp(beg:end)) -#if (defined CNDV) - allocate(pepv%tempsum_litfall(beg:end)) - allocate(pepv%annsum_litfall(beg:end)) -#endif -! if ( use_c13 ) then -! allocate(pepv%rc13_canair(beg:end)) -! allocate(pepv%rc13_psnsun(beg:end)) -! allocate(pepv%rc13_psnsha(beg:end)) -! endif - -! if ( use_c14 ) then -! allocate(pepv%rc14_atm(beg:end)) -! endif - - pepv%dormant_flag(beg:end) = nan - pepv%days_active(beg:end) = nan - pepv%onset_flag(beg:end) = nan - pepv%onset_counter(beg:end) = nan - pepv%onset_gddflag(beg:end) = nan - pepv%onset_fdd(beg:end) = nan - pepv%onset_gdd(beg:end) = nan - pepv%onset_swi(beg:end) = nan - pepv%offset_flag(beg:end) = nan - pepv%offset_counter(beg:end) = nan - pepv%offset_fdd(beg:end) = nan - pepv%offset_swi(beg:end) = nan - pepv%fert_counter(beg:end) = nan - pepv%grain_flag(beg:end) = nan - pepv%lgsf(beg:end) = nan - pepv%bglfr(beg:end) = nan - pepv%bgtr(beg:end) = nan - pepv%dayl(beg:end) = nan - pepv%prev_dayl(beg:end) = nan - pepv%annavg_t2m(beg:end) = nan - pepv%tempavg_t2m(beg:end) = nan - pepv%gpp(beg:end) = nan - pepv%availc(beg:end) = nan - pepv%xsmrpool_recover(beg:end) = nan -! if ( use_c13 ) then -! pepv%xsmrpool_c13ratio(beg:end) = nan -! endif - pepv%alloc_pnow(beg:end) = nan - pepv%c_allometry(beg:end) = nan - pepv%n_allometry(beg:end) = nan - pepv%plant_ndemand(beg:end) = nan - pepv%tempsum_potential_gpp(beg:end) = nan - pepv%annsum_potential_gpp(beg:end) = nan - pepv%tempmax_retransn(beg:end) = nan - pepv%annmax_retransn(beg:end) = nan - pepv%avail_retransn(beg:end) = nan - pepv%plant_nalloc(beg:end) = nan - pepv%plant_calloc(beg:end) = nan - pepv%excess_cflux(beg:end) = nan - pepv%downreg(beg:end) = nan - pepv%prev_leafc_to_litter(beg:end) = nan - pepv%prev_frootc_to_litter(beg:end) = nan - pepv%tempsum_npp(beg:end) = nan - pepv%annsum_npp(beg:end) = nan -#if (defined CNDV) - pepv%tempsum_litfall(beg:end) = nan - pepv%annsum_litfall(beg:end) = nan -#endif -! if ( use_c13 ) then -! pepv%rc13_canair(beg:end) = spval -! pepv%rc13_psnsun(beg:end) = spval -! pepv%rc13_psnsha(beg:end) = spval -! endif - -! if ( use_c14 ) then -! pepv%rc14_atm(beg:end) = nan -! ! pepv%rc14_canair(beg:end) = nan -! ! pepv%rc14_psnsun(beg:end) = nan -! ! pepv%rc14_psnsha(beg:end) = nan -! endif - - end subroutine init_pft_epv_type - -#if (defined CNDV) -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_pdgvstate_type -! -! !INTERFACE: - subroutine init_pft_pdgvstate_type(beg, end, pdgvs) -! -! !DESCRIPTION: -! Initialize pft DGVM state variables -! -! !USES: -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_dgvstate_type), intent(inout):: pdgvs -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(pdgvs%agddtw(beg:end)) - allocate(pdgvs%agdd(beg:end)) - allocate(pdgvs%t_mo(beg:end)) - allocate(pdgvs%t_mo_min(beg:end)) - allocate(pdgvs%prec365(beg:end)) - allocate(pdgvs%present(beg:end)) - allocate(pdgvs%pftmayexist(beg:end)) - allocate(pdgvs%nind(beg:end)) - allocate(pdgvs%lm_ind(beg:end)) - allocate(pdgvs%lai_ind(beg:end)) - allocate(pdgvs%fpcinc(beg:end)) - allocate(pdgvs%fpcgrid(beg:end)) - allocate(pdgvs%fpcgridold(beg:end)) - allocate(pdgvs%crownarea(beg:end)) - allocate(pdgvs%greffic(beg:end)) - allocate(pdgvs%heatstress(beg:end)) - - pdgvs%agddtw(beg:end) = nan - pdgvs%agdd(beg:end) = nan - pdgvs%t_mo(beg:end) = nan - pdgvs%t_mo_min(beg:end) = nan - pdgvs%prec365(beg:end) = nan - pdgvs%present(beg:end) = .false. - pdgvs%pftmayexist(beg:end) = .true. - pdgvs%nind(beg:end) = nan - pdgvs%lm_ind(beg:end) = nan - pdgvs%lai_ind(beg:end) = nan - pdgvs%fpcinc(beg:end) = nan - pdgvs%fpcgrid(beg:end) = nan - pdgvs%fpcgridold(beg:end) = nan - pdgvs%crownarea(beg:end) = nan - pdgvs%greffic(beg:end) = nan - pdgvs%heatstress(beg:end) = nan - - end subroutine init_pft_pdgvstate_type -#endif - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_psynstate_type -! -! !INTERFACE: - subroutine init_pft_psynstate_type(beg, end, ppsyns) -! -! !DESCRIPTION: -! Initialize pft energy state -! -! !USES: - use clm_varcon, only : spval - use clm_varctl, only : crop_prog -! !AGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_psynstate_type), intent(inout):: ppsyns -! -! !REVISION HISTORY: -! Created by Jinyun Tang -! -!EOP -!----------------------------------------------------------------------- - - allocate(ppsyns%c3flag(beg:end)) - allocate(ppsyns%ac(beg:end,1:nlevcan)) - allocate(ppsyns%aj(beg:end,1:nlevcan)) - allocate(ppsyns%ap(beg:end,1:nlevcan)) - allocate(ppsyns%ag(beg:end,1:nlevcan)) - allocate(ppsyns%an(beg:end,1:nlevcan)) - allocate(ppsyns%vcmax_z(beg:end,1:nlevcan)) - allocate(ppsyns%cp(beg:end)) - allocate(ppsyns%kc(beg:end)) - allocate(ppsyns%ko(beg:end)) - allocate(ppsyns%qe(beg:end)) - allocate(ppsyns%tpu_z(beg:end,1:nlevcan)) - allocate(ppsyns%kp_z(beg:end,1:nlevcan)) - allocate(ppsyns%theta_cj(beg:end)) - allocate(ppsyns%bbb(beg:end)) - allocate(ppsyns%mbb(beg:end)) - allocate(ppsyns%gb_mol(beg:end)) - allocate(ppsyns%gs_mol(beg:end,1:nlevcan)) - - ppsyns%c3flag = .false. - ppsyns%ac(beg:end,1:nlevcan) = nan - ppsyns%aj(beg:end,1:nlevcan) = nan - ppsyns%ap(beg:end,1:nlevcan) = nan - ppsyns%ag(beg:end,1:nlevcan) = nan - ppsyns%an(beg:end,1:nlevcan) = nan - ppsyns%vcmax_z(beg:end,1:nlevcan) = nan - ppsyns%cp(beg:end) = nan - ppsyns%kc(beg:end) = nan - ppsyns%ko(beg:end) = nan - ppsyns%qe(beg:end) = nan - ppsyns%tpu_z(beg:end,1:nlevcan) = nan - ppsyns%kp_z(beg:end,1:nlevcan) = nan - ppsyns%theta_cj(beg:end) = nan - ppsyns%bbb(beg:end) = nan - ppsyns%mbb(beg:end) = nan - ppsyns%gb_mol(beg:end) = nan - ppsyns%gs_mol(beg:end,1:nlevcan) = nan - - end subroutine init_pft_psynstate_type - - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_estate_type -! -! !INTERFACE: - subroutine init_pft_estate_type(beg, end, pes) -! -! !DESCRIPTION: -! Initialize pft energy state -! -! !USES: - use clm_varcon, only : spval - use clm_varctl, only : crop_prog -! !AGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_estate_type), intent(inout):: pes -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!----------------------------------------------------------------------- - - allocate(pes%t_ref2m(beg:end)) - allocate(pes%t_ref2m_min(beg:end)) - allocate(pes%t_ref2m_max(beg:end)) - allocate(pes%t10(beg:end)) - if ( crop_prog )then - allocate(pes%a10tmin(beg:end)) - allocate(pes%a5tmin(beg:end)) - end if - - pes%t_ref2m(beg:end) = nan - pes%t_ref2m_min(beg:end) = nan - pes%t_ref2m_max(beg:end) = nan - pes%t10(beg:end) = spval - if ( crop_prog )then - pes%a10tmin(beg:end) = spval - pes%a5tmin(beg:end) = spval - end if - - end subroutine init_pft_estate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_cstate_type -! -! !INTERFACE: - subroutine init_pft_cstate_type(beg, end, pcs) -! -! !DESCRIPTION: -! Initialize pft carbon state -! -! !USES: - use clm_varctl, only : crop_prog -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_cstate_type), intent(inout):: pcs !pft carbon state -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -!EOP -!------------------------------------------------------------------------ - - allocate(pcs%leafc(beg:end)) - allocate(pcs%leafc_storage(beg:end)) - allocate(pcs%leafc_xfer(beg:end)) - allocate(pcs%frootc(beg:end)) - allocate(pcs%frootc_storage(beg:end)) - allocate(pcs%frootc_xfer(beg:end)) - allocate(pcs%livestemc(beg:end)) - allocate(pcs%livestemc_storage(beg:end)) - allocate(pcs%livestemc_xfer(beg:end)) - allocate(pcs%deadstemc(beg:end)) - allocate(pcs%deadstemc_storage(beg:end)) - allocate(pcs%deadstemc_xfer(beg:end)) - allocate(pcs%livecrootc(beg:end)) - allocate(pcs%livecrootc_storage(beg:end)) - allocate(pcs%livecrootc_xfer(beg:end)) - allocate(pcs%deadcrootc(beg:end)) - allocate(pcs%deadcrootc_storage(beg:end)) - allocate(pcs%deadcrootc_xfer(beg:end)) - allocate(pcs%gresp_storage(beg:end)) - allocate(pcs%gresp_xfer(beg:end)) - allocate(pcs%cpool(beg:end)) - allocate(pcs%xsmrpool(beg:end)) - allocate(pcs%pft_ctrunc(beg:end)) - allocate(pcs%dispvegc(beg:end)) - allocate(pcs%storvegc(beg:end)) - allocate(pcs%totvegc(beg:end)) - allocate(pcs%totpftc(beg:end)) - allocate(pcs%leafcmax(beg:end)) - if ( crop_prog )then - allocate(pcs%grainc(beg:end)) - allocate(pcs%grainc_storage(beg:end)) - allocate(pcs%grainc_xfer(beg:end)) - end if -!#ifdef CN - allocate(pcs%woodc(beg:end)) -!#endif - - pcs%leafc(beg:end) = nan - pcs%leafc_storage(beg:end) = nan - pcs%leafc_xfer(beg:end) = nan - pcs%frootc(beg:end) = nan - pcs%frootc_storage(beg:end) = nan - pcs%frootc_xfer(beg:end) = nan - pcs%livestemc(beg:end) = nan - pcs%livestemc_storage(beg:end) = nan - pcs%livestemc_xfer(beg:end) = nan - pcs%deadstemc(beg:end) = nan - pcs%deadstemc_storage(beg:end) = nan - pcs%deadstemc_xfer(beg:end) = nan - pcs%livecrootc(beg:end) = nan - pcs%livecrootc_storage(beg:end) = nan - pcs%livecrootc_xfer(beg:end) = nan - pcs%deadcrootc(beg:end) = nan - pcs%deadcrootc_storage(beg:end) = nan - pcs%deadcrootc_xfer(beg:end) = nan - pcs%gresp_storage(beg:end) = nan - pcs%gresp_xfer(beg:end) = nan - pcs%cpool(beg:end) = nan - pcs%xsmrpool(beg:end) = nan - pcs%pft_ctrunc(beg:end) = nan - pcs%dispvegc(beg:end) = nan - pcs%storvegc(beg:end) = nan - pcs%totvegc(beg:end) = nan - pcs%totpftc(beg:end) = nan - pcs%leafcmax(beg:end) = nan - if ( crop_prog )then - pcs%grainc(beg:end) = nan - pcs%grainc_storage(beg:end) = nan - pcs%grainc_xfer(beg:end) = nan - end if -!#ifdef CN - pcs%woodc(beg:end) = nan -!#endif - - end subroutine init_pft_cstate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_nstate_type -! -! !INTERFACE: - subroutine init_pft_nstate_type(beg, end, pns) -! -! !DESCRIPTION: -! Initialize pft nitrogen state -! -! !USES: - use clm_varctl, only : crop_prog -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_nstate_type), intent(inout):: pns !pft nitrogen state -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -!EOP -!------------------------------------------------------------------------ - - if ( crop_prog )then - allocate(pns%grainn(beg:end)) - allocate(pns%grainn_storage(beg:end)) - allocate(pns%grainn_xfer(beg:end)) - end if - allocate(pns%leafn(beg:end)) - allocate(pns%leafn_storage(beg:end)) - allocate(pns%leafn_xfer(beg:end)) - allocate(pns%frootn(beg:end)) - allocate(pns%frootn_storage(beg:end)) - allocate(pns%frootn_xfer(beg:end)) - allocate(pns%livestemn(beg:end)) - allocate(pns%livestemn_storage(beg:end)) - allocate(pns%livestemn_xfer(beg:end)) - allocate(pns%deadstemn(beg:end)) - allocate(pns%deadstemn_storage(beg:end)) - allocate(pns%deadstemn_xfer(beg:end)) - allocate(pns%livecrootn(beg:end)) - allocate(pns%livecrootn_storage(beg:end)) - allocate(pns%livecrootn_xfer(beg:end)) - allocate(pns%deadcrootn(beg:end)) - allocate(pns%deadcrootn_storage(beg:end)) - allocate(pns%deadcrootn_xfer(beg:end)) - allocate(pns%retransn(beg:end)) - allocate(pns%npool(beg:end)) - allocate(pns%pft_ntrunc(beg:end)) - allocate(pns%dispvegn(beg:end)) - allocate(pns%storvegn(beg:end)) - allocate(pns%totvegn(beg:end)) - allocate(pns%totpftn(beg:end)) - - if ( crop_prog )then - pns%grainn(beg:end) = nan - pns%grainn_storage(beg:end) = nan - pns%grainn_xfer(beg:end) = nan - end if - pns%leafn(beg:end) = nan - pns%leafn_storage(beg:end) = nan - pns%leafn_xfer(beg:end) = nan - pns%frootn(beg:end) = nan - pns%frootn_storage(beg:end) = nan - pns%frootn_xfer(beg:end) = nan - pns%livestemn(beg:end) = nan - pns%livestemn_storage(beg:end) = nan - pns%livestemn_xfer(beg:end) = nan - pns%deadstemn(beg:end) = nan - pns%deadstemn_storage(beg:end) = nan - pns%deadstemn_xfer(beg:end) = nan - pns%livecrootn(beg:end) = nan - pns%livecrootn_storage(beg:end) = nan - pns%livecrootn_xfer(beg:end) = nan - pns%deadcrootn(beg:end) = nan - pns%deadcrootn_storage(beg:end) = nan - pns%deadcrootn_xfer(beg:end) = nan - pns%retransn(beg:end) = nan - pns%npool(beg:end) = nan - pns%pft_ntrunc(beg:end) = nan - pns%dispvegn(beg:end) = nan - pns%storvegn(beg:end) = nan - pns%totvegn(beg:end) = nan - pns%totpftn(beg:end) = nan - - end subroutine init_pft_nstate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_cflux_type -! -! !INTERFACE: - subroutine init_pft_cflux_type(beg, end, pcf) -! -! !DESCRIPTION: -! Initialize pft carbon flux variables -! -! !USES: - use clm_varcon, only : spval - use clm_varctl , only : crop_prog -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_cflux_type), intent(inout) :: pcf -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(pcf%psnsun(beg:end)) - allocate(pcf%psnsha(beg:end)) - allocate(pcf%psnsun_z(beg:end,1:nlevcan)) - allocate(pcf%psnsha_z(beg:end,1:nlevcan)) - allocate(pcf%cisun_z(beg:end,1:nlevcan)) - allocate(pcf%cisha_z(beg:end,1:nlevcan)) - allocate(pcf%lmrsun(beg:end)) - allocate(pcf%lmrsha(beg:end)) - allocate(pcf%lmrsun_z(beg:end,1:nlevcan)) - allocate(pcf%lmrsha_z(beg:end,1:nlevcan)) - allocate(pcf%fpsn(beg:end)) - allocate(pcf%fco2(beg:end)) - allocate(pcf%psnsun_wc(beg:end)) - allocate(pcf%psnsha_wc(beg:end)) - allocate(pcf%fpsn_wc(beg:end)) - allocate(pcf%psnsun_wj(beg:end)) - allocate(pcf%psnsha_wj(beg:end)) - allocate(pcf%fpsn_wj(beg:end)) - allocate(pcf%psnsun_wp(beg:end)) - allocate(pcf%psnsha_wp(beg:end)) - allocate(pcf%fpsn_wp(beg:end)) - - allocate(pcf%m_leafc_to_litter(beg:end)) - allocate(pcf%m_frootc_to_litter(beg:end)) - allocate(pcf%m_leafc_storage_to_litter(beg:end)) - allocate(pcf%m_frootc_storage_to_litter(beg:end)) - allocate(pcf%m_livestemc_storage_to_litter(beg:end)) - allocate(pcf%m_deadstemc_storage_to_litter(beg:end)) - allocate(pcf%m_livecrootc_storage_to_litter(beg:end)) - allocate(pcf%m_deadcrootc_storage_to_litter(beg:end)) - allocate(pcf%m_leafc_xfer_to_litter(beg:end)) - allocate(pcf%m_frootc_xfer_to_litter(beg:end)) - allocate(pcf%m_livestemc_xfer_to_litter(beg:end)) - allocate(pcf%m_deadstemc_xfer_to_litter(beg:end)) - allocate(pcf%m_livecrootc_xfer_to_litter(beg:end)) - allocate(pcf%m_deadcrootc_xfer_to_litter(beg:end)) - allocate(pcf%m_livestemc_to_litter(beg:end)) - allocate(pcf%m_deadstemc_to_litter(beg:end)) - allocate(pcf%m_livecrootc_to_litter(beg:end)) - allocate(pcf%m_deadcrootc_to_litter(beg:end)) - allocate(pcf%m_gresp_storage_to_litter(beg:end)) - allocate(pcf%m_gresp_xfer_to_litter(beg:end)) - allocate(pcf%hrv_leafc_to_litter(beg:end)) - allocate(pcf%hrv_leafc_storage_to_litter(beg:end)) - allocate(pcf%hrv_leafc_xfer_to_litter(beg:end)) - allocate(pcf%hrv_frootc_to_litter(beg:end)) - allocate(pcf%hrv_frootc_storage_to_litter(beg:end)) - allocate(pcf%hrv_frootc_xfer_to_litter(beg:end)) - allocate(pcf%hrv_livestemc_to_litter(beg:end)) - allocate(pcf%hrv_livestemc_storage_to_litter(beg:end)) - allocate(pcf%hrv_livestemc_xfer_to_litter(beg:end)) - allocate(pcf%hrv_deadstemc_to_prod10c(beg:end)) - allocate(pcf%hrv_deadstemc_to_prod100c(beg:end)) - allocate(pcf%hrv_deadstemc_storage_to_litter(beg:end)) - allocate(pcf%hrv_deadstemc_xfer_to_litter(beg:end)) - allocate(pcf%hrv_livecrootc_to_litter(beg:end)) - allocate(pcf%hrv_livecrootc_storage_to_litter(beg:end)) - allocate(pcf%hrv_livecrootc_xfer_to_litter(beg:end)) - allocate(pcf%hrv_deadcrootc_to_litter(beg:end)) - allocate(pcf%hrv_deadcrootc_storage_to_litter(beg:end)) - allocate(pcf%hrv_deadcrootc_xfer_to_litter(beg:end)) - allocate(pcf%hrv_gresp_storage_to_litter(beg:end)) - allocate(pcf%hrv_gresp_xfer_to_litter(beg:end)) - allocate(pcf%hrv_xsmrpool_to_atm(beg:end)) - - ! fire related variables changed by F. Li and S. Levis - allocate(pcf%m_leafc_to_fire(beg:end)) - allocate(pcf%m_leafc_storage_to_fire(beg:end)) - allocate(pcf%m_leafc_xfer_to_fire(beg:end)) - allocate(pcf%m_livestemc_to_fire(beg:end)) - allocate(pcf%m_livestemc_storage_to_fire(beg:end)) - allocate(pcf%m_livestemc_xfer_to_fire(beg:end)) - allocate(pcf%m_deadstemc_to_fire(beg:end)) - allocate(pcf%m_deadstemc_storage_to_fire(beg:end)) - allocate(pcf%m_deadstemc_xfer_to_fire(beg:end)) - allocate(pcf%m_frootc_to_fire(beg:end)) - allocate(pcf%m_frootc_storage_to_fire(beg:end)) - allocate(pcf%m_frootc_xfer_to_fire(beg:end)) - allocate(pcf%m_livecrootc_to_fire(beg:end)) - allocate(pcf%m_livecrootc_storage_to_fire(beg:end)) - allocate(pcf%m_livecrootc_xfer_to_fire(beg:end)) - allocate(pcf%m_deadcrootc_to_fire(beg:end)) - allocate(pcf%m_deadcrootc_storage_to_fire(beg:end)) - allocate(pcf%m_deadcrootc_xfer_to_fire(beg:end)) - allocate(pcf%m_gresp_storage_to_fire(beg:end)) - allocate(pcf%m_gresp_xfer_to_fire(beg:end)) - allocate(pcf%m_leafc_to_litter_fire(beg:end)) - allocate(pcf%m_leafc_storage_to_litter_fire(beg:end)) - allocate(pcf%m_leafc_xfer_to_litter_fire(beg:end)) - allocate(pcf%m_livestemc_to_litter_fire(beg:end)) - allocate(pcf%m_livestemc_storage_to_litter_fire(beg:end)) - allocate(pcf%m_livestemc_xfer_to_litter_fire(beg:end)) - allocate(pcf%m_livestemc_to_deadstemc_fire(beg:end)) - allocate(pcf%m_deadstemc_to_litter_fire(beg:end)) - allocate(pcf%m_deadstemc_storage_to_litter_fire(beg:end)) - allocate(pcf%m_deadstemc_xfer_to_litter_fire(beg:end)) - allocate(pcf%m_frootc_to_litter_fire(beg:end)) - allocate(pcf%m_frootc_storage_to_litter_fire(beg:end)) - allocate(pcf%m_frootc_xfer_to_litter_fire(beg:end)) - allocate(pcf%m_livecrootc_to_litter_fire(beg:end)) - allocate(pcf%m_livecrootc_storage_to_litter_fire(beg:end)) - allocate(pcf%m_livecrootc_xfer_to_litter_fire(beg:end)) - allocate(pcf%m_livecrootc_to_deadcrootc_fire(beg:end)) - allocate(pcf%m_deadcrootc_to_litter_fire(beg:end)) - allocate(pcf%m_deadcrootc_storage_to_litter_fire(beg:end)) - allocate(pcf%m_deadcrootc_xfer_to_litter_fire(beg:end)) - allocate(pcf%m_gresp_storage_to_litter_fire(beg:end)) - allocate(pcf%m_gresp_xfer_to_litter_fire(beg:end)) - - - allocate(pcf%leafc_xfer_to_leafc(beg:end)) - allocate(pcf%frootc_xfer_to_frootc(beg:end)) - allocate(pcf%livestemc_xfer_to_livestemc(beg:end)) - allocate(pcf%deadstemc_xfer_to_deadstemc(beg:end)) - allocate(pcf%livecrootc_xfer_to_livecrootc(beg:end)) - allocate(pcf%deadcrootc_xfer_to_deadcrootc(beg:end)) - allocate(pcf%leafc_to_litter(beg:end)) - allocate(pcf%frootc_to_litter(beg:end)) - allocate(pcf%leaf_mr(beg:end)) - allocate(pcf%froot_mr(beg:end)) - allocate(pcf%livestem_mr(beg:end)) - allocate(pcf%livecroot_mr(beg:end)) - allocate(pcf%grain_mr(beg:end)) - allocate(pcf%leaf_curmr(beg:end)) - allocate(pcf%froot_curmr(beg:end)) - allocate(pcf%livestem_curmr(beg:end)) - allocate(pcf%livecroot_curmr(beg:end)) - allocate(pcf%grain_curmr(beg:end)) - allocate(pcf%leaf_xsmr(beg:end)) - allocate(pcf%froot_xsmr(beg:end)) - allocate(pcf%livestem_xsmr(beg:end)) - allocate(pcf%livecroot_xsmr(beg:end)) - allocate(pcf%grain_xsmr(beg:end)) - allocate(pcf%psnsun_to_cpool(beg:end)) - allocate(pcf%psnshade_to_cpool(beg:end)) - allocate(pcf%cpool_to_xsmrpool(beg:end)) - allocate(pcf%cpool_to_leafc(beg:end)) - allocate(pcf%cpool_to_leafc_storage(beg:end)) - allocate(pcf%cpool_to_frootc(beg:end)) - allocate(pcf%cpool_to_frootc_storage(beg:end)) - allocate(pcf%cpool_to_livestemc(beg:end)) - allocate(pcf%cpool_to_livestemc_storage(beg:end)) - allocate(pcf%cpool_to_deadstemc(beg:end)) - allocate(pcf%cpool_to_deadstemc_storage(beg:end)) - allocate(pcf%cpool_to_livecrootc(beg:end)) - allocate(pcf%cpool_to_livecrootc_storage(beg:end)) - allocate(pcf%cpool_to_deadcrootc(beg:end)) - allocate(pcf%cpool_to_deadcrootc_storage(beg:end)) - allocate(pcf%cpool_to_gresp_storage(beg:end)) - allocate(pcf%cpool_leaf_gr(beg:end)) - allocate(pcf%cpool_leaf_storage_gr(beg:end)) - allocate(pcf%transfer_leaf_gr(beg:end)) - allocate(pcf%cpool_froot_gr(beg:end)) - allocate(pcf%cpool_froot_storage_gr(beg:end)) - allocate(pcf%transfer_froot_gr(beg:end)) - allocate(pcf%cpool_livestem_gr(beg:end)) - allocate(pcf%cpool_livestem_storage_gr(beg:end)) - allocate(pcf%transfer_livestem_gr(beg:end)) - allocate(pcf%cpool_deadstem_gr(beg:end)) - allocate(pcf%cpool_deadstem_storage_gr(beg:end)) - allocate(pcf%transfer_deadstem_gr(beg:end)) - allocate(pcf%cpool_livecroot_gr(beg:end)) - allocate(pcf%cpool_livecroot_storage_gr(beg:end)) - allocate(pcf%transfer_livecroot_gr(beg:end)) - allocate(pcf%cpool_deadcroot_gr(beg:end)) - allocate(pcf%cpool_deadcroot_storage_gr(beg:end)) - allocate(pcf%transfer_deadcroot_gr(beg:end)) - allocate(pcf%leafc_storage_to_xfer(beg:end)) - allocate(pcf%frootc_storage_to_xfer(beg:end)) - allocate(pcf%livestemc_storage_to_xfer(beg:end)) - allocate(pcf%deadstemc_storage_to_xfer(beg:end)) - allocate(pcf%livecrootc_storage_to_xfer(beg:end)) - allocate(pcf%deadcrootc_storage_to_xfer(beg:end)) - allocate(pcf%gresp_storage_to_xfer(beg:end)) - allocate(pcf%livestemc_to_deadstemc(beg:end)) - allocate(pcf%livecrootc_to_deadcrootc(beg:end)) - allocate(pcf%gpp(beg:end)) - allocate(pcf%mr(beg:end)) - allocate(pcf%current_gr(beg:end)) - allocate(pcf%transfer_gr(beg:end)) - allocate(pcf%storage_gr(beg:end)) - allocate(pcf%gr(beg:end)) - allocate(pcf%ar(beg:end)) - allocate(pcf%rr(beg:end)) - allocate(pcf%npp(beg:end)) - allocate(pcf%agnpp(beg:end)) - allocate(pcf%bgnpp(beg:end)) - allocate(pcf%litfall(beg:end)) - allocate(pcf%vegfire(beg:end)) - allocate(pcf%wood_harvestc(beg:end)) - allocate(pcf%pft_cinputs(beg:end)) - allocate(pcf%pft_coutputs(beg:end)) - allocate(pcf%pft_fire_closs(beg:end)) - if ( crop_prog )then - allocate(pcf%xsmrpool_to_atm(beg:end)) - allocate(pcf%grainc_xfer_to_grainc(beg:end)) - allocate(pcf%livestemc_to_litter(beg:end)) - allocate(pcf%grainc_to_food(beg:end)) - allocate(pcf%cpool_to_grainc(beg:end)) - allocate(pcf%cpool_to_grainc_storage(beg:end)) - allocate(pcf%cpool_grain_gr(beg:end)) - allocate(pcf%cpool_grain_storage_gr(beg:end)) - allocate(pcf%transfer_grain_gr(beg:end)) - allocate(pcf%grainc_storage_to_xfer(beg:end)) - end if -!#ifdef CN - allocate(pcf%frootc_alloc(beg:end)) - allocate(pcf%frootc_loss(beg:end)) - allocate(pcf%leafc_alloc(beg:end)) - allocate(pcf%leafc_loss(beg:end)) - allocate(pcf%woodc_alloc(beg:end)) - allocate(pcf%woodc_loss(beg:end)) -!#endif -#ifdef LCH4 - allocate(pcf%tempavg_agnpp(beg:end)) - allocate(pcf%tempavg_bgnpp(beg:end)) - allocate(pcf%annavg_agnpp(beg:end)) - allocate(pcf%annavg_bgnpp(beg:end)) -#endif - - pcf%psnsun(beg:end) = nan - pcf%psnsha(beg:end) = nan - pcf%psnsun_z(beg:end,:nlevcan) = nan - pcf%psnsha_z(beg:end,:nlevcan) = nan - pcf%cisun_z(beg:end,:nlevcan) = nan - pcf%cisha_z(beg:end,:nlevcan) = nan - pcf%lmrsun(beg:end) = nan - pcf%lmrsha(beg:end) = nan - pcf%lmrsun_z(beg:end,:nlevcan) = nan - pcf%lmrsha_z(beg:end,:nlevcan) = nan - pcf%fpsn(beg:end) = spval - pcf%fco2(beg:end) = 0._r8 - pcf%psnsun_wc(beg:end) = nan - pcf%psnsha_wc(beg:end) = nan - pcf%fpsn_wc(beg:end) = nan - pcf%psnsun_wj(beg:end) = nan - pcf%psnsha_wj(beg:end) = nan - pcf%fpsn_wj(beg:end) = nan - pcf%psnsun_wp(beg:end) = nan - pcf%psnsha_wp(beg:end) = nan - pcf%fpsn_wp(beg:end) = nan - - pcf%m_leafc_to_litter(beg:end) = nan - pcf%m_frootc_to_litter(beg:end) = nan - pcf%m_leafc_storage_to_litter(beg:end) = nan - pcf%m_frootc_storage_to_litter(beg:end) = nan - pcf%m_livestemc_storage_to_litter(beg:end) = nan - pcf%m_deadstemc_storage_to_litter(beg:end) = nan - pcf%m_livecrootc_storage_to_litter(beg:end) = nan - pcf%m_deadcrootc_storage_to_litter(beg:end) = nan - pcf%m_leafc_xfer_to_litter(beg:end) = nan - pcf%m_frootc_xfer_to_litter(beg:end) = nan - pcf%m_livestemc_xfer_to_litter(beg:end) = nan - pcf%m_deadstemc_xfer_to_litter(beg:end) = nan - pcf%m_livecrootc_xfer_to_litter(beg:end) = nan - pcf%m_deadcrootc_xfer_to_litter(beg:end) = nan - pcf%m_livestemc_to_litter(beg:end) = nan - pcf%m_deadstemc_to_litter(beg:end) = nan - pcf%m_livecrootc_to_litter(beg:end) = nan - pcf%m_deadcrootc_to_litter(beg:end) = nan - pcf%m_gresp_storage_to_litter(beg:end) = nan - pcf%m_gresp_xfer_to_litter(beg:end) = nan - pcf%hrv_leafc_to_litter(beg:end) = nan - pcf%hrv_leafc_storage_to_litter(beg:end) = nan - pcf%hrv_leafc_xfer_to_litter(beg:end) = nan - pcf%hrv_frootc_to_litter(beg:end) = nan - pcf%hrv_frootc_storage_to_litter(beg:end) = nan - pcf%hrv_frootc_xfer_to_litter(beg:end) = nan - pcf%hrv_livestemc_to_litter(beg:end) = nan - pcf%hrv_livestemc_storage_to_litter(beg:end) = nan - pcf%hrv_livestemc_xfer_to_litter(beg:end) = nan - pcf%hrv_deadstemc_to_prod10c(beg:end) = nan - pcf%hrv_deadstemc_to_prod100c(beg:end) = nan - pcf%hrv_deadstemc_storage_to_litter(beg:end) = nan - pcf%hrv_deadstemc_xfer_to_litter(beg:end) = nan - pcf%hrv_livecrootc_to_litter(beg:end) = nan - pcf%hrv_livecrootc_storage_to_litter(beg:end) = nan - pcf%hrv_livecrootc_xfer_to_litter(beg:end) = nan - pcf%hrv_deadcrootc_to_litter(beg:end) = nan - pcf%hrv_deadcrootc_storage_to_litter(beg:end) = nan - pcf%hrv_deadcrootc_xfer_to_litter(beg:end) = nan - pcf%hrv_gresp_storage_to_litter(beg:end) = nan - pcf%hrv_gresp_xfer_to_litter(beg:end) = nan - pcf%hrv_xsmrpool_to_atm(beg:end) = nan - - ! fire variable changed by F. Li and S. Levis - pcf%m_leafc_to_fire(beg:end) = nan - pcf%m_leafc_storage_to_fire(beg:end) = nan - pcf%m_leafc_xfer_to_fire(beg:end) = nan - pcf%m_livestemc_to_fire(beg:end) = nan - pcf%m_livestemc_storage_to_fire(beg:end) = nan - pcf%m_livestemc_xfer_to_fire(beg:end) = nan - pcf%m_deadstemc_to_fire(beg:end) = nan - pcf%m_deadstemc_storage_to_fire(beg:end) = nan - pcf%m_deadstemc_xfer_to_fire(beg:end) = nan - pcf%m_frootc_to_fire(beg:end) = nan - pcf%m_frootc_storage_to_fire(beg:end) = nan - pcf%m_frootc_xfer_to_fire(beg:end) = nan - pcf%m_livecrootc_to_fire(beg:end) = nan - pcf%m_livecrootc_storage_to_fire(beg:end) = nan - pcf%m_livecrootc_xfer_to_fire(beg:end) = nan - pcf%m_deadcrootc_to_fire(beg:end) = nan - pcf%m_deadcrootc_storage_to_fire(beg:end) = nan - pcf%m_deadcrootc_xfer_to_fire(beg:end) = nan - pcf%m_gresp_storage_to_fire(beg:end) = nan - pcf%m_gresp_xfer_to_fire(beg:end) = nan - - pcf%m_leafc_to_litter_fire(beg:end) = nan - pcf%m_leafc_storage_to_litter_fire(beg:end) = nan - pcf%m_leafc_xfer_to_litter_fire(beg:end) = nan - pcf%m_livestemc_to_litter_fire(beg:end) = nan - pcf%m_livestemc_storage_to_litter_fire(beg:end) = nan - pcf%m_livestemc_xfer_to_litter_fire(beg:end) = nan - pcf%m_livestemc_to_deadstemc_fire(beg:end) = nan - pcf%m_deadstemc_to_litter_fire(beg:end) = nan - pcf%m_deadstemc_storage_to_litter_fire(beg:end) = nan - pcf%m_deadstemc_xfer_to_litter_fire(beg:end) = nan - pcf%m_frootc_to_litter_fire(beg:end) = nan - pcf%m_frootc_storage_to_litter_fire(beg:end) = nan - pcf%m_frootc_xfer_to_litter_fire(beg:end) = nan - pcf%m_livecrootc_to_litter_fire(beg:end) = nan - pcf%m_livecrootc_storage_to_litter_fire(beg:end) = nan - pcf%m_livecrootc_xfer_to_litter_fire(beg:end) = nan - pcf%m_livecrootc_to_deadcrootc_fire(beg:end) = nan - pcf%m_deadcrootc_to_litter_fire(beg:end) = nan - pcf%m_deadcrootc_storage_to_litter_fire(beg:end) = nan - pcf%m_deadcrootc_xfer_to_litter_fire(beg:end) = nan - pcf%m_gresp_storage_to_litter_fire(beg:end) = nan - pcf%m_gresp_xfer_to_litter_fire(beg:end) = nan - - - pcf%leafc_xfer_to_leafc(beg:end) = nan - pcf%frootc_xfer_to_frootc(beg:end) = nan - pcf%livestemc_xfer_to_livestemc(beg:end) = nan - pcf%deadstemc_xfer_to_deadstemc(beg:end) = nan - pcf%livecrootc_xfer_to_livecrootc(beg:end) = nan - pcf%deadcrootc_xfer_to_deadcrootc(beg:end) = nan - pcf%leafc_to_litter(beg:end) = nan - pcf%frootc_to_litter(beg:end) = nan - pcf%leaf_mr(beg:end) = nan - pcf%froot_mr(beg:end) = nan - pcf%livestem_mr(beg:end) = nan - pcf%livecroot_mr(beg:end) = nan - pcf%grain_mr(beg:end) = nan - pcf%leaf_curmr(beg:end) = nan - pcf%froot_curmr(beg:end) = nan - pcf%livestem_curmr(beg:end) = nan - pcf%livecroot_curmr(beg:end) = nan - pcf%grain_curmr(beg:end) = nan - pcf%leaf_xsmr(beg:end) = nan - pcf%froot_xsmr(beg:end) = nan - pcf%livestem_xsmr(beg:end) = nan - pcf%livecroot_xsmr(beg:end) = nan - pcf%grain_xsmr(beg:end) = nan - pcf%psnsun_to_cpool(beg:end) = nan - pcf%psnshade_to_cpool(beg:end) = nan - pcf%cpool_to_xsmrpool(beg:end) = nan - pcf%cpool_to_leafc(beg:end) = nan - pcf%cpool_to_leafc_storage(beg:end) = nan - pcf%cpool_to_frootc(beg:end) = nan - pcf%cpool_to_frootc_storage(beg:end) = nan - pcf%cpool_to_livestemc(beg:end) = nan - pcf%cpool_to_livestemc_storage(beg:end) = nan - pcf%cpool_to_deadstemc(beg:end) = nan - pcf%cpool_to_deadstemc_storage(beg:end) = nan - pcf%cpool_to_livecrootc(beg:end) = nan - pcf%cpool_to_livecrootc_storage(beg:end) = nan - pcf%cpool_to_deadcrootc(beg:end) = nan - pcf%cpool_to_deadcrootc_storage(beg:end) = nan - pcf%cpool_to_gresp_storage(beg:end) = nan - pcf%cpool_leaf_gr(beg:end) = nan - pcf%cpool_leaf_storage_gr(beg:end) = nan - pcf%transfer_leaf_gr(beg:end) = nan - pcf%cpool_froot_gr(beg:end) = nan - pcf%cpool_froot_storage_gr(beg:end) = nan - pcf%transfer_froot_gr(beg:end) = nan - pcf%cpool_livestem_gr(beg:end) = nan - pcf%cpool_livestem_storage_gr(beg:end) = nan - pcf%transfer_livestem_gr(beg:end) = nan - pcf%cpool_deadstem_gr(beg:end) = nan - pcf%cpool_deadstem_storage_gr(beg:end) = nan - pcf%transfer_deadstem_gr(beg:end) = nan - pcf%cpool_livecroot_gr(beg:end) = nan - pcf%cpool_livecroot_storage_gr(beg:end) = nan - pcf%transfer_livecroot_gr(beg:end) = nan - pcf%cpool_deadcroot_gr(beg:end) = nan - pcf%cpool_deadcroot_storage_gr(beg:end) = nan - pcf%transfer_deadcroot_gr(beg:end) = nan - pcf%leafc_storage_to_xfer(beg:end) = nan - pcf%frootc_storage_to_xfer(beg:end) = nan - pcf%livestemc_storage_to_xfer(beg:end) = nan - pcf%deadstemc_storage_to_xfer(beg:end) = nan - pcf%livecrootc_storage_to_xfer(beg:end) = nan - pcf%deadcrootc_storage_to_xfer(beg:end) = nan - pcf%gresp_storage_to_xfer(beg:end) = nan - pcf%livestemc_to_deadstemc(beg:end) = nan - pcf%livecrootc_to_deadcrootc(beg:end) = nan - pcf%gpp(beg:end) = nan - pcf%mr(beg:end) = nan - pcf%current_gr(beg:end) = nan - pcf%transfer_gr(beg:end) = nan - pcf%storage_gr(beg:end) = nan - pcf%gr(beg:end) = nan - pcf%ar(beg:end) = nan - pcf%rr(beg:end) = nan - pcf%npp(beg:end) = nan - pcf%agnpp(beg:end) = nan - pcf%bgnpp(beg:end) = nan - pcf%litfall(beg:end) = nan - pcf%vegfire(beg:end) = nan - pcf%wood_harvestc(beg:end) = nan - pcf%pft_cinputs(beg:end) = nan - pcf%pft_coutputs(beg:end) = nan - pcf%pft_fire_closs(beg:end) = nan - if ( crop_prog )then - pcf%xsmrpool_to_atm(beg:end) = nan - pcf%grainc_xfer_to_grainc(beg:end) = nan - pcf%livestemc_to_litter(beg:end) = nan - pcf%grainc_to_food(beg:end) = nan - pcf%cpool_to_grainc(beg:end) = nan - pcf%cpool_to_grainc_storage(beg:end) = nan - pcf%cpool_grain_gr(beg:end) = nan - pcf%cpool_grain_storage_gr(beg:end) = nan - pcf%transfer_grain_gr(beg:end) = nan - pcf%grainc_storage_to_xfer(beg:end) = nan - end if -!#if (defined CN) - pcf%frootc_alloc(beg:end) = nan - pcf%frootc_loss(beg:end) = nan - pcf%leafc_alloc(beg:end) = nan - pcf%leafc_loss(beg:end) = nan - pcf%woodc_alloc(beg:end) = nan - pcf%woodc_loss(beg:end) = nan -!#endif -#if (defined LCH4) - pcf%tempavg_agnpp(beg:end) = spval ! For back-compatibility - pcf%tempavg_bgnpp(beg:end) = spval ! For back-compatibility - pcf%annavg_agnpp(beg:end) = spval ! To detect first year - pcf%annavg_bgnpp(beg:end) = spval ! To detect first year -#endif - - - end subroutine init_pft_cflux_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_pft_nflux_type -! -! !INTERFACE: - subroutine init_pft_nflux_type(beg, end, pnf) -! -! !DESCRIPTION: -! Initialize pft nitrogen flux variables -! -! !USES: - use clm_varctl , only : crop_prog -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (pft_nflux_type), intent(inout) :: pnf -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(pnf%m_leafn_to_litter(beg:end)) - allocate(pnf%m_frootn_to_litter(beg:end)) - allocate(pnf%m_leafn_storage_to_litter(beg:end)) - allocate(pnf%m_frootn_storage_to_litter(beg:end)) - allocate(pnf%m_livestemn_storage_to_litter(beg:end)) - allocate(pnf%m_deadstemn_storage_to_litter(beg:end)) - allocate(pnf%m_livecrootn_storage_to_litter(beg:end)) - allocate(pnf%m_deadcrootn_storage_to_litter(beg:end)) - allocate(pnf%m_leafn_xfer_to_litter(beg:end)) - allocate(pnf%m_frootn_xfer_to_litter(beg:end)) - allocate(pnf%m_livestemn_xfer_to_litter(beg:end)) - allocate(pnf%m_deadstemn_xfer_to_litter(beg:end)) - allocate(pnf%m_livecrootn_xfer_to_litter(beg:end)) - allocate(pnf%m_deadcrootn_xfer_to_litter(beg:end)) - allocate(pnf%m_livestemn_to_litter(beg:end)) - allocate(pnf%m_deadstemn_to_litter(beg:end)) - allocate(pnf%m_livecrootn_to_litter(beg:end)) - allocate(pnf%m_deadcrootn_to_litter(beg:end)) - allocate(pnf%m_retransn_to_litter(beg:end)) - allocate(pnf%hrv_leafn_to_litter(beg:end)) - allocate(pnf%hrv_frootn_to_litter(beg:end)) - allocate(pnf%hrv_leafn_storage_to_litter(beg:end)) - allocate(pnf%hrv_frootn_storage_to_litter(beg:end)) - allocate(pnf%hrv_livestemn_storage_to_litter(beg:end)) - allocate(pnf%hrv_deadstemn_storage_to_litter(beg:end)) - allocate(pnf%hrv_livecrootn_storage_to_litter(beg:end)) - allocate(pnf%hrv_deadcrootn_storage_to_litter(beg:end)) - allocate(pnf%hrv_leafn_xfer_to_litter(beg:end)) - allocate(pnf%hrv_frootn_xfer_to_litter(beg:end)) - allocate(pnf%hrv_livestemn_xfer_to_litter(beg:end)) - allocate(pnf%hrv_deadstemn_xfer_to_litter(beg:end)) - allocate(pnf%hrv_livecrootn_xfer_to_litter(beg:end)) - allocate(pnf%hrv_deadcrootn_xfer_to_litter(beg:end)) - allocate(pnf%hrv_livestemn_to_litter(beg:end)) - allocate(pnf%hrv_deadstemn_to_prod10n(beg:end)) - allocate(pnf%hrv_deadstemn_to_prod100n(beg:end)) - allocate(pnf%hrv_livecrootn_to_litter(beg:end)) - allocate(pnf%hrv_deadcrootn_to_litter(beg:end)) - allocate(pnf%hrv_retransn_to_litter(beg:end)) - - ! fire variables changed by F. Li and S. Levis - allocate(pnf%m_leafn_to_fire(beg:end)) - allocate(pnf%m_leafn_storage_to_fire(beg:end)) - allocate(pnf%m_leafn_xfer_to_fire(beg:end)) - allocate(pnf%m_livestemn_to_fire(beg:end)) - allocate(pnf%m_livestemn_storage_to_fire(beg:end)) - allocate(pnf%m_livestemn_xfer_to_fire(beg:end)) - allocate(pnf%m_deadstemn_to_fire(beg:end)) - allocate(pnf%m_deadstemn_storage_to_fire(beg:end)) - allocate(pnf%m_deadstemn_xfer_to_fire(beg:end)) - allocate(pnf%m_frootn_to_fire(beg:end)) - allocate(pnf%m_frootn_storage_to_fire(beg:end)) - allocate(pnf%m_frootn_xfer_to_fire(beg:end)) - allocate(pnf%m_livecrootn_to_fire(beg:end)) - allocate(pnf%m_livecrootn_storage_to_fire(beg:end)) - allocate(pnf%m_livecrootn_xfer_to_fire(beg:end)) - allocate(pnf%m_deadcrootn_to_fire(beg:end)) - allocate(pnf%m_deadcrootn_storage_to_fire(beg:end)) - allocate(pnf%m_deadcrootn_xfer_to_fire(beg:end)) - allocate(pnf%m_retransn_to_fire(beg:end)) - - allocate(pnf%m_leafn_to_litter_fire(beg:end)) - allocate(pnf%m_leafn_storage_to_litter_fire(beg:end)) - allocate(pnf%m_leafn_xfer_to_litter_fire(beg:end)) - allocate(pnf%m_livestemn_to_litter_fire(beg:end)) - allocate(pnf%m_livestemn_storage_to_litter_fire(beg:end)) - allocate(pnf%m_livestemn_xfer_to_litter_fire(beg:end)) - allocate(pnf%m_livestemn_to_deadstemn_fire(beg:end)) - allocate(pnf%m_deadstemn_to_litter_fire(beg:end)) - allocate(pnf%m_deadstemn_storage_to_litter_fire(beg:end)) - allocate(pnf%m_deadstemn_xfer_to_litter_fire(beg:end)) - allocate(pnf%m_frootn_to_litter_fire(beg:end)) - allocate(pnf%m_frootn_storage_to_litter_fire(beg:end)) - allocate(pnf%m_frootn_xfer_to_litter_fire(beg:end)) - allocate(pnf%m_livecrootn_to_litter_fire(beg:end)) - allocate(pnf%m_livecrootn_storage_to_litter_fire(beg:end)) - allocate(pnf%m_livecrootn_xfer_to_litter_fire(beg:end)) - allocate(pnf%m_livecrootn_to_deadcrootn_fire(beg:end)) - allocate(pnf%m_deadcrootn_to_litter_fire(beg:end)) - allocate(pnf%m_deadcrootn_storage_to_litter_fire(beg:end)) - allocate(pnf%m_deadcrootn_xfer_to_litter_fire(beg:end)) - allocate(pnf%m_retransn_to_litter_fire(beg:end)) - - - - allocate(pnf%leafn_xfer_to_leafn(beg:end)) - allocate(pnf%frootn_xfer_to_frootn(beg:end)) - allocate(pnf%livestemn_xfer_to_livestemn(beg:end)) - allocate(pnf%deadstemn_xfer_to_deadstemn(beg:end)) - allocate(pnf%livecrootn_xfer_to_livecrootn(beg:end)) - allocate(pnf%deadcrootn_xfer_to_deadcrootn(beg:end)) - allocate(pnf%leafn_to_litter(beg:end)) - allocate(pnf%leafn_to_retransn(beg:end)) - allocate(pnf%frootn_to_retransn(beg:end)) - allocate(pnf%frootn_to_litter(beg:end)) - allocate(pnf%retransn_to_npool(beg:end)) - allocate(pnf%sminn_to_npool(beg:end)) - allocate(pnf%npool_to_leafn(beg:end)) - allocate(pnf%npool_to_leafn_storage(beg:end)) - allocate(pnf%npool_to_frootn(beg:end)) - allocate(pnf%npool_to_frootn_storage(beg:end)) - allocate(pnf%npool_to_livestemn(beg:end)) - allocate(pnf%npool_to_livestemn_storage(beg:end)) - allocate(pnf%npool_to_deadstemn(beg:end)) - allocate(pnf%npool_to_deadstemn_storage(beg:end)) - allocate(pnf%npool_to_livecrootn(beg:end)) - allocate(pnf%npool_to_livecrootn_storage(beg:end)) - allocate(pnf%npool_to_deadcrootn(beg:end)) - allocate(pnf%npool_to_deadcrootn_storage(beg:end)) - allocate(pnf%leafn_storage_to_xfer(beg:end)) - allocate(pnf%frootn_storage_to_xfer(beg:end)) - allocate(pnf%livestemn_storage_to_xfer(beg:end)) - allocate(pnf%deadstemn_storage_to_xfer(beg:end)) - allocate(pnf%livecrootn_storage_to_xfer(beg:end)) - allocate(pnf%deadcrootn_storage_to_xfer(beg:end)) - allocate(pnf%livestemn_to_deadstemn(beg:end)) - allocate(pnf%livestemn_to_retransn(beg:end)) - allocate(pnf%livecrootn_to_deadcrootn(beg:end)) - allocate(pnf%livecrootn_to_retransn(beg:end)) - allocate(pnf%ndeploy(beg:end)) - allocate(pnf%pft_ninputs(beg:end)) - allocate(pnf%pft_noutputs(beg:end)) - allocate(pnf%wood_harvestn(beg:end)) - allocate(pnf%pft_fire_nloss(beg:end)) - if ( crop_prog )then - allocate(pnf%grainn_xfer_to_grainn(beg:end)) - allocate(pnf%livestemn_to_litter(beg:end)) - allocate(pnf%grainn_to_food(beg:end)) - allocate(pnf%npool_to_grainn(beg:end)) - allocate(pnf%npool_to_grainn_storage(beg:end)) - allocate(pnf%grainn_storage_to_xfer(beg:end)) - allocate(pnf%fert(beg:end)) - allocate(pnf%soyfixn(beg:end)) - end if - - pnf%m_leafn_to_litter(beg:end) = nan - pnf%m_frootn_to_litter(beg:end) = nan - pnf%m_leafn_storage_to_litter(beg:end) = nan - pnf%m_frootn_storage_to_litter(beg:end) = nan - pnf%m_livestemn_storage_to_litter(beg:end) = nan - pnf%m_deadstemn_storage_to_litter(beg:end) = nan - pnf%m_livecrootn_storage_to_litter(beg:end) = nan - pnf%m_deadcrootn_storage_to_litter(beg:end) = nan - pnf%m_leafn_xfer_to_litter(beg:end) = nan - pnf%m_frootn_xfer_to_litter(beg:end) = nan - pnf%m_livestemn_xfer_to_litter(beg:end) = nan - pnf%m_deadstemn_xfer_to_litter(beg:end) = nan - pnf%m_livecrootn_xfer_to_litter(beg:end) = nan - pnf%m_deadcrootn_xfer_to_litter(beg:end) = nan - pnf%m_livestemn_to_litter(beg:end) = nan - pnf%m_deadstemn_to_litter(beg:end) = nan - pnf%m_livecrootn_to_litter(beg:end) = nan - pnf%m_deadcrootn_to_litter(beg:end) = nan - pnf%m_retransn_to_litter(beg:end) = nan - pnf%hrv_leafn_to_litter(beg:end) = nan - pnf%hrv_frootn_to_litter(beg:end) = nan - pnf%hrv_leafn_storage_to_litter(beg:end) = nan - pnf%hrv_frootn_storage_to_litter(beg:end) = nan - pnf%hrv_livestemn_storage_to_litter(beg:end) = nan - pnf%hrv_deadstemn_storage_to_litter(beg:end) = nan - pnf%hrv_livecrootn_storage_to_litter(beg:end) = nan - pnf%hrv_deadcrootn_storage_to_litter(beg:end) = nan - pnf%hrv_leafn_xfer_to_litter(beg:end) = nan - pnf%hrv_frootn_xfer_to_litter(beg:end) = nan - pnf%hrv_livestemn_xfer_to_litter(beg:end) = nan - pnf%hrv_deadstemn_xfer_to_litter(beg:end) = nan - pnf%hrv_livecrootn_xfer_to_litter(beg:end) = nan - pnf%hrv_deadcrootn_xfer_to_litter(beg:end) = nan - pnf%hrv_livestemn_to_litter(beg:end) = nan - pnf%hrv_deadstemn_to_prod10n(beg:end) = nan - pnf%hrv_deadstemn_to_prod100n(beg:end) = nan - pnf%hrv_livecrootn_to_litter(beg:end) = nan - pnf%hrv_deadcrootn_to_litter(beg:end) = nan - pnf%hrv_retransn_to_litter(beg:end) = nan - - ! fire varibles changed by F. Li and S. Levis - pnf%m_leafn_to_fire(beg:end) = nan - pnf%m_leafn_storage_to_fire(beg:end) = nan - pnf%m_leafn_xfer_to_fire(beg:end) = nan - pnf%m_livestemn_to_fire(beg:end) = nan - pnf%m_livestemn_storage_to_fire(beg:end) = nan - pnf%m_livestemn_xfer_to_fire(beg:end) = nan - pnf%m_deadstemn_to_fire(beg:end) = nan - pnf%m_deadstemn_storage_to_fire(beg:end) = nan - pnf%m_deadstemn_xfer_to_fire(beg:end) = nan - pnf%m_frootn_to_fire(beg:end) = nan - pnf%m_frootn_storage_to_fire(beg:end) = nan - pnf%m_frootn_xfer_to_fire(beg:end) = nan - pnf%m_livestemn_to_fire(beg:end) = nan - pnf%m_livecrootn_storage_to_fire(beg:end) = nan - pnf%m_livecrootn_xfer_to_fire(beg:end) = nan - pnf%m_deadcrootn_to_fire(beg:end) = nan - pnf%m_deadcrootn_storage_to_fire(beg:end) = nan - pnf%m_deadcrootn_xfer_to_fire(beg:end) = nan - pnf%m_retransn_to_fire(beg:end) = nan - - pnf%m_leafn_to_litter_fire(beg:end) = nan - pnf%m_leafn_storage_to_litter_fire(beg:end) = nan - pnf%m_leafn_xfer_to_litter_fire(beg:end) = nan - pnf%m_livestemn_to_litter_fire(beg:end) = nan - pnf%m_livestemn_storage_to_litter_fire(beg:end) = nan - pnf%m_livestemn_xfer_to_litter_fire(beg:end) = nan - pnf%m_livestemn_to_deadstemn_fire(beg:end) = nan - pnf%m_deadstemn_to_litter_fire(beg:end) = nan - pnf%m_deadstemn_storage_to_litter_fire(beg:end) = nan - pnf%m_deadstemn_xfer_to_litter_fire(beg:end) = nan - pnf%m_frootn_to_litter_fire(beg:end) = nan - pnf%m_frootn_storage_to_litter_fire(beg:end) = nan - pnf%m_frootn_xfer_to_litter_fire(beg:end) = nan - pnf%m_livecrootn_to_litter_fire(beg:end) = nan - pnf%m_livecrootn_storage_to_litter_fire(beg:end) = nan - pnf%m_livecrootn_xfer_to_litter_fire(beg:end) = nan - pnf%m_livecrootn_to_deadcrootn_fire(beg:end) = nan - pnf%m_deadcrootn_to_litter_fire(beg:end) = nan - pnf%m_deadcrootn_storage_to_litter_fire(beg:end) = nan - pnf%m_deadcrootn_xfer_to_litter_fire(beg:end) = nan - pnf%m_retransn_to_litter_fire(beg:end) = nan - - - - pnf%leafn_xfer_to_leafn(beg:end) = nan - pnf%frootn_xfer_to_frootn(beg:end) = nan - pnf%livestemn_xfer_to_livestemn(beg:end) = nan - pnf%deadstemn_xfer_to_deadstemn(beg:end) = nan - pnf%livecrootn_xfer_to_livecrootn(beg:end) = nan - pnf%deadcrootn_xfer_to_deadcrootn(beg:end) = nan - pnf%leafn_to_litter(beg:end) = nan - pnf%leafn_to_retransn(beg:end) = nan - pnf%frootn_to_retransn(beg:end) = nan - pnf%frootn_to_litter(beg:end) = nan - pnf%retransn_to_npool(beg:end) = nan - pnf%sminn_to_npool(beg:end) = nan - pnf%npool_to_leafn(beg:end) = nan - pnf%npool_to_leafn_storage(beg:end) = nan - pnf%npool_to_frootn(beg:end) = nan - pnf%npool_to_frootn_storage(beg:end) = nan - pnf%npool_to_livestemn(beg:end) = nan - pnf%npool_to_livestemn_storage(beg:end) = nan - pnf%npool_to_deadstemn(beg:end) = nan - pnf%npool_to_deadstemn_storage(beg:end) = nan - pnf%npool_to_livecrootn(beg:end) = nan - pnf%npool_to_livecrootn_storage(beg:end) = nan - pnf%npool_to_deadcrootn(beg:end) = nan - pnf%npool_to_deadcrootn_storage(beg:end) = nan - pnf%leafn_storage_to_xfer(beg:end) = nan - pnf%frootn_storage_to_xfer(beg:end) = nan - pnf%livestemn_storage_to_xfer(beg:end) = nan - pnf%deadstemn_storage_to_xfer(beg:end) = nan - pnf%livecrootn_storage_to_xfer(beg:end) = nan - pnf%deadcrootn_storage_to_xfer(beg:end) = nan - pnf%livestemn_to_deadstemn(beg:end) = nan - pnf%livestemn_to_retransn(beg:end) = nan - pnf%livecrootn_to_deadcrootn(beg:end) = nan - pnf%livecrootn_to_retransn(beg:end) = nan - pnf%ndeploy(beg:end) = nan - pnf%pft_ninputs(beg:end) = nan - pnf%pft_noutputs(beg:end) = nan - pnf%wood_harvestn(beg:end) = nan - pnf%pft_fire_nloss(beg:end) = nan - if ( crop_prog )then - pnf%grainn_xfer_to_grainn(beg:end) = nan - pnf%livestemn_to_litter(beg:end) = nan - pnf%grainn_to_food(beg:end) = nan - pnf%npool_to_grainn(beg:end) = nan - pnf%npool_to_grainn_storage(beg:end) = nan - pnf%grainn_storage_to_xfer(beg:end) = nan - pnf%fert(beg:end) = nan - pnf%soyfixn(beg:end) = nan - end if - - end subroutine init_pft_nflux_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_pstate_type -! -! !INTERFACE: - subroutine init_column_pstate_type(beg, end, cps) -! -! !DESCRIPTION: -! Initialize column physical state variables -! -! !USES: - use clm_varcon, only : spval -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_pstate_type), intent(inout):: cps -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(cps%snl(beg:end)) !* cannot be averaged up - - !F. Li and S. Levis - allocate(cps%gdp_lf(beg:end)) - allocate(cps%peatf_lf(beg:end)) - allocate(cps%abm_lf(beg:end)) - allocate(cps%lgdp_col(beg:end)) - allocate(cps%lgdp1_col(beg:end)) - allocate(cps%lpop_col(beg:end)) - - allocate(cps%bsw(beg:end,nlevgrnd)) - allocate(cps%watsat(beg:end,nlevgrnd)) - allocate(cps%watfc(beg:end,nlevgrnd)) - allocate(cps%sucsat(beg:end,nlevgrnd)) - allocate(cps%snow_depth(beg:end)) - allocate(cps%snowdp(beg:end)) - allocate(cps%zi(beg:end,-nlevsno+0:nlevgrnd)) - allocate(cps%dz(beg:end,-nlevsno+1:nlevgrnd)) - allocate(cps%z (beg:end,-nlevsno+1:nlevgrnd)) - allocate(cps%wf(beg:end)) - allocate(cps%wf2(beg:end)) - allocate(cps%psisat(beg:end,-nlevsno+1:nlevgrnd)) ! added by fzeng - allocate(cps%psiwilt(beg:end)) ! added by fzeng - allocate(cws%fsat(beg:end)) ! added by fzeng - allocate(cps%soilpsi(beg:end,nlevgrnd)) - allocate(cps%bd(beg:end,nlevgrnd)) - allocate(cps%fpi(beg:end)) - allocate(cps%fpi_vr(beg:end,1:nlevdecomp_full)) - allocate(cps%fpg(beg:end)) - allocate(cps%annsum_counter(beg:end)) - allocate(cps%cannsum_npp(beg:end)) - allocate(cps%col_lag_npp(beg:end)) - allocate(cps%cannavg_t2m(beg:end)) - - - ! fire-related variables changed by F. Li and S. Levis - allocate(cps%nfire(beg:end)) - allocate(cps%farea_burned(beg:end)) - allocate(cps%fsr_col(beg:end)) - allocate(cps%fd_col(beg:end)) - allocate(cps%cropf_col(beg:end)) - allocate(cps%prec10_col(beg:end)) - allocate(cps%prec60_col(beg:end)) - allocate(cps%lfc(beg:end)) - allocate(cps%lfc2(beg:end)) - allocate(cps%trotr1_col(beg:end)) - allocate(cps%trotr2_col(beg:end)) - allocate(cps%dtrotr_col(beg:end)) - allocate(cps%baf_crop(beg:end)) - allocate(cps%baf_peatf(beg:end)) - allocate(cps%fbac(beg:end)) - allocate(cps%fbac1(beg:end)) - allocate(cps%btran_col(beg:end)) - allocate(cps%wtlf(beg:end)) - allocate(cps%lfwt(beg:end)) -#ifdef LCH4 -! New variable for finundated parameterization - allocate(cps%zwt0(beg:end)) - allocate(cps%f0(beg:end)) - allocate(cps%p3(beg:end)) -! New variable for methane - allocate(cps%pH(beg:end)) -#endif - - allocate(cps%rf_decomp_cascade(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) - allocate(cps%pathfrac_decomp_cascade(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) - allocate(cps%nfixation_prof(beg:end,1:nlevdecomp_full)) - allocate(cps%ndep_prof(beg:end,1:nlevdecomp_full)) - allocate(cps%alt(beg:end)) - allocate(cps%altmax(beg:end)) - allocate(cps%altmax_lastyear(beg:end)) - allocate(cps%alt_indx(beg:end)) - allocate(cps%altmax_indx(beg:end)) - allocate(cps%altmax_lastyear_indx(beg:end)) - allocate(cps%som_adv_coef(beg:end,1:nlevdecomp_full)) - allocate(cps%som_diffus_coef(beg:end,1:nlevdecomp_full)) - - cps%snl(beg:end) = huge(1) - - !F. Li and S. Levis - cps%gdp_lf(beg:end) = nan - cps%peatf_lf(beg:end) = nan - cps%abm_lf(beg:end) = 13 - cps%lgdp_col(beg:end) = nan - cps%lgdp1_col(beg:end) = nan - cps%lpop_col(beg:end) = nan - - cps%bsw(beg:end,1:nlevgrnd) = nan - cps%watsat(beg:end,1:nlevgrnd) = nan - cps%watfc(beg:end,1:nlevgrnd) = nan - cps%sucsat(beg:end,1:nlevgrnd) = nan - cps%snow_depth(beg:end) = nan - cps%snowdp(beg:end) = nan - cps%zi(beg:end,-nlevsno+0:nlevgrnd) = nan - cps%dz(beg:end,-nlevsno+1:nlevgrnd) = nan - cps%z (beg:end,-nlevsno+1:nlevgrnd) = nan - cps%wf(beg:end) = nan - cps%wf2(beg:end) = nan - cps%psisat(beg:end,-nlevsno+1:nlevgrnd) = nan ! added by fzeng - cps%psiwilt(beg:end) = nan ! added by fzeng - cws%fsat(beg:end) = nan ! added by fzeng - cps%soilpsi(beg:end,1:nlevgrnd) = spval - cps%bd(beg:end,1:nlevgrnd) = spval - cps%fpi(beg:end) = nan - cps%fpi_vr(beg:end,1:nlevdecomp_full) = nan - cps%fpg(beg:end) = nan - cps%annsum_counter(beg:end) = nan - cps%cannsum_npp(beg:end) = nan - cps%col_lag_npp(beg:end) = spval - cps%cannavg_t2m(beg:end) = nan - - ! fire-related varibles changed by F. Li and S. Levis - cps%nfire(beg:end) = spval - cps%farea_burned(beg:end) = nan - cps%btran_col(beg:end) = nan - cps%wtlf(beg:end) = nan - cps%lfwt(beg:end) = nan - cps%fsr_col(beg:end) = nan - cps%fd_col(beg:end) = nan - cps%cropf_col(beg:end) = nan - cps%baf_crop(beg:end) = nan - cps%baf_peatf(beg:end) = nan - cps%fbac(beg:end) = nan - cps%fbac1(beg:end) = nan - cps%trotr1_col(beg:end) = 0._r8 - cps%trotr2_col(beg:end) = 0._r8 - cps%dtrotr_col(beg:end) = 0._r8 - cps%prec10_col(beg:end) = nan - cps%prec60_col(beg:end) = nan - cps%lfc(beg:end) = spval - cps%lfc2(beg:end) = 0._r8 -#ifdef LCH4 - cps%zwt0(beg:end) = nan - cps%f0(beg:end) = nan - cps%p3(beg:end) = nan -! New variable for methane - cps%pH(beg:end) = nan -#endif - - cps%rf_decomp_cascade(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions) = nan - cps%pathfrac_decomp_cascade(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions) = nan - cps%nfixation_prof(beg:end,1:nlevdecomp_full) = spval - cps%ndep_prof(beg:end,1:nlevdecomp_full) = spval - cps%alt(beg:end) = spval - cps%altmax(beg:end) = spval - cps%altmax_lastyear(beg:end) = spval - cps%alt_indx(beg:end) = huge(1) - cps%altmax_indx(beg:end) = huge(1) - cps%altmax_lastyear_indx(beg:end) = huge(1) - cps%som_adv_coef(beg:end,1:nlevdecomp_full) = spval - cps%som_diffus_coef(beg:end,1:nlevdecomp_full) = spval - - allocate(cps%frac_h2osfc(beg:end)) - cps%frac_h2osfc(beg:end) = spval - - end subroutine init_column_pstate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_estate_type -! -! !INTERFACE: - subroutine init_column_estate_type(beg, end, ces) -! -! !DESCRIPTION: -! Initialize column energy state variables -! -! !USES: - use clm_varcon, only : spval -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_estate_type), intent(inout):: ces -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - allocate(ces%t_grnd(beg:end)) - allocate(ces%t_soisno(beg:end,-nlevsno+1:nlevgrnd)) - allocate(ces%tsoi17(beg:end)) - - ces%t_grnd(beg:end) = nan - ces%t_soisno(beg:end,-nlevsno+1:nlevgrnd) = spval - ces%tsoi17(beg:end) = spval - - allocate(ces%t_h2osfc(beg:end)) - - ces%t_h2osfc(beg:end) = spval - - end subroutine init_column_estate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_wstate_type -! -! !INTERFACE: - subroutine init_column_wstate_type(beg, end, cws) -! -! !DESCRIPTION: -! Initialize column water state variables -! -! !USES: - use clm_varcon, only : spval -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_wstate_type), intent(inout):: cws !column water state -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(cws%h2osoi_liq(beg:end,-nlevsno+1:nlevgrnd)) -!New variable for methane code -#ifdef LCH4 - allocate(cws%finundated(beg:end)) -#endif - - cws%h2osoi_liq(beg:end,-nlevsno+1:nlevgrnd)= spval -#ifdef LCH4 - cws%finundated(beg:end) = nan -#endif - - end subroutine init_column_wstate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_cstate_type -! -! !INTERFACE: - subroutine init_column_cstate_type(beg, end, ccs) -! -! !DESCRIPTION: -! Initialize column carbon state variables -! -! !USES: - use clm_varcon, only : spval -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_cstate_type), intent(inout):: ccs -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(ccs%cwdc(beg:end)) - allocate(ccs%col_ctrunc(beg:end)) - allocate(ccs%decomp_cpools_vr(beg:end,1:nlevdecomp_full,1:ndecomp_pools)) - allocate(ccs%decomp_cpools(beg:end,1:ndecomp_pools)) - allocate(ccs%decomp_cpools_1m(beg:end,1:ndecomp_pools)) - allocate(ccs%col_ctrunc_vr(beg:end,1:nlevdecomp_full)) - allocate(ccs%seedc(beg:end)) - allocate(ccs%prod10c(beg:end)) - allocate(ccs%prod100c(beg:end)) - allocate(ccs%totprodc(beg:end)) - allocate(ccs%totlitc(beg:end)) - allocate(ccs%totsomc(beg:end)) - allocate(ccs%totlitc_1m(beg:end)) - allocate(ccs%totsomc_1m(beg:end)) - allocate(ccs%totecosysc(beg:end)) - allocate(ccs%totcolc(beg:end)) - - !F. Li and S. Levis - allocate(ccs%rootc_col(beg:end)) - allocate(ccs%totvegc_col(beg:end)) - allocate(ccs%leafc_col(beg:end)) - allocate(ccs%fuelc(beg:end)) - allocate(ccs%fuelc_crop(beg:end)) - allocate(ccs%cpool_col(beg:end)) - - ccs%cwdc(beg:end) = nan - ccs%decomp_cpools_vr(beg:end,1:nlevdecomp_full,1:ndecomp_pools) = nan - ccs%decomp_cpools(beg:end,1:ndecomp_pools) = nan - ccs%decomp_cpools_1m(beg:end,1:ndecomp_pools) = nan - ccs%col_ctrunc(beg:end) = nan - ccs%col_ctrunc_vr(beg:end,1:nlevdecomp_full) = nan - ccs%seedc(beg:end) = nan - ccs%prod10c(beg:end) = nan - ccs%prod100c(beg:end) = nan - ccs%totprodc(beg:end) = nan - ccs%totlitc(beg:end) = nan - ccs%totsomc(beg:end) = nan - ccs%totlitc_1m(beg:end) = nan - ccs%totsomc_1m(beg:end) = nan - ccs%totecosysc(beg:end) = nan - ccs%totcolc(beg:end) = nan - - ccs%rootc_col(beg:end) = nan - ccs%totvegc_col(beg:end) = nan - ccs%leafc_col(beg:end) = nan - ccs%fuelc(beg:end) = spval - ccs%fuelc_crop(beg:end) = nan - ccs%cpool_col(beg:end) = nan - - end subroutine init_column_cstate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_nstate_type -! -! !INTERFACE: - subroutine init_column_nstate_type(beg, end, cns) -! -! !DESCRIPTION: -! Initialize column nitrogen state variables -! -! !USES: - use clm_varcon, only : spval -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_nstate_type), intent(inout):: cns -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -!EOP -!------------------------------------------------------------------------ - - - allocate(cns%decomp_npools(beg:end,1:ndecomp_pools)) - allocate(cns%decomp_npools_1m(beg:end,1:ndecomp_pools)) - allocate(cns%decomp_npools_vr(beg:end,1:nlevdecomp_full,1:ndecomp_pools)) - allocate(cns%sminn_vr(beg:end,1:nlevdecomp_full)) - allocate(cns%col_ntrunc_vr(beg:end,1:nlevdecomp_full)) -#ifdef NITRIF_DENITRIF - allocate(cns%smin_no3_vr(beg:end,1:nlevdecomp_full)) - allocate(cns%smin_nh4_vr(beg:end,1:nlevdecomp_full)) - allocate(cns%smin_no3(beg:end)) - allocate(cns%smin_nh4(beg:end)) -#endif - allocate(cns%cwdn(beg:end)) - allocate(cns%sminn(beg:end)) - allocate(cns%col_ntrunc(beg:end)) - allocate(cns%seedn(beg:end)) - allocate(cns%prod10n(beg:end)) - allocate(cns%prod100n(beg:end)) - allocate(cns%totprodn(beg:end)) - allocate(cns%totlitn(beg:end)) - allocate(cns%totsomn(beg:end)) - allocate(cns%totlitn_1m(beg:end)) - allocate(cns%totsomn_1m(beg:end)) - allocate(cns%totecosysn(beg:end)) - allocate(cns%totcoln(beg:end)) - - cns%decomp_npools(beg:end,1:ndecomp_pools) = nan - cns%decomp_npools_1m(beg:end,1:ndecomp_pools) = nan - cns%decomp_npools_vr(beg:end,1:nlevdecomp_full,1:ndecomp_pools) = nan - cns%sminn_vr(beg:end,1:nlevdecomp_full) = nan - cns%col_ntrunc_vr(beg:end,1:nlevdecomp_full) = nan -#ifdef NITRIF_DENITRIF - cns%smin_no3_vr(beg:end,1:nlevdecomp_full) = nan - cns%smin_nh4_vr(beg:end,1:nlevdecomp_full) = nan - cns%smin_no3(beg:end) = nan - cns%smin_nh4(beg:end) = nan -#endif - cns%cwdn(beg:end) = nan - cns%sminn(beg:end) = nan - cns%col_ntrunc(beg:end) = nan - cns%seedn(beg:end) = nan - cns%prod10n(beg:end) = nan - cns%prod100n(beg:end) = nan - cns%totprodn(beg:end) = nan - cns%totlitn(beg:end) = nan - cns%totsomn(beg:end) = nan - cns%totlitn_1m(beg:end) = nan - cns%totsomn_1m(beg:end) = nan - cns%totecosysn(beg:end) = nan - cns%totcoln(beg:end) = nan - - end subroutine init_column_nstate_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_wflux_type -! -! !INTERFACE: - subroutine init_column_wflux_type(beg, end, cwf) -! -! !DESCRIPTION: -! Initialize column water flux variables -! -! !USES: - use clm_varcon, only : spval -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_wflux_type), intent(inout):: cwf -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(cwf%qflx_surf(beg:end)) - allocate(cwf%qflx_drain(beg:end)) - - cwf%qflx_surf(beg:end) = nan - cwf%qflx_drain(beg:end) = nan - - end subroutine init_column_wflux_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_cflux_type -! -! !INTERFACE: - subroutine init_column_cflux_type(beg, end, ccf) -! - use clm_varcon, only : spval -! -! !DESCRIPTION: -! Initialize column carbon flux variables -! -! !USES: - use clm_varctl , only : crop_prog -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_cflux_type), intent(inout):: ccf -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -!EOP -!------------------------------------------------------------------------ - - allocate(ccf%hrv_deadstemc_to_prod10c(beg:end)) - allocate(ccf%hrv_deadstemc_to_prod100c(beg:end)) - allocate(ccf%m_decomp_cpools_to_fire_vr(beg:end,1:nlevdecomp_full,1:ndecomp_pools)) - allocate(ccf%m_decomp_cpools_to_fire(beg:end,1:ndecomp_pools)) - allocate(ccf%decomp_cascade_hr_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) - allocate(ccf%decomp_cascade_hr(beg:end,1:ndecomp_cascade_transitions)) - allocate(ccf%decomp_cascade_ctransfer_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) - allocate(ccf%decomp_cascade_ctransfer(beg:end,1:ndecomp_cascade_transitions)) - allocate(ccf%decomp_cpools_sourcesink(beg:end,1:nlevdecomp_full,1:ndecomp_pools)) - allocate(ccf%decomp_k(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) - allocate(ccf%t_scalar(beg:end,1:nlevdecomp_full)) - allocate(ccf%w_scalar(beg:end,1:nlevdecomp_full)) - allocate(ccf%hr_vr(beg:end,1:nlevdecomp_full)) - allocate(ccf%o_scalar(beg:end,1:nlevdecomp_full)) - allocate(ccf%som_c_leached(beg:end)) - allocate(ccf%decomp_cpools_leached(beg:end,1:ndecomp_pools)) - allocate(ccf%decomp_cpools_transport_tendency(beg:end,1:nlevdecomp_full,1:ndecomp_pools)) - - allocate(ccf%phenology_c_to_litr_met_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%phenology_c_to_litr_cel_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%phenology_c_to_litr_lig_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%gap_mortality_c_to_litr_met_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%gap_mortality_c_to_litr_cel_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%gap_mortality_c_to_litr_lig_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%gap_mortality_c_to_cwdc(beg:end, 1:nlevdecomp_full)) - allocate(ccf%fire_mortality_c_to_cwdc(beg:end, 1:nlevdecomp_full)) - allocate(ccf%m_c_to_litr_met_fire(beg:end,1:nlevdecomp_full)) - allocate(ccf%m_c_to_litr_cel_fire(beg:end,1:nlevdecomp_full)) - allocate(ccf%m_c_to_litr_lig_fire(beg:end,1:nlevdecomp_full)) - allocate(ccf%harvest_c_to_litr_met_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%harvest_c_to_litr_cel_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%harvest_c_to_litr_lig_c(beg:end, 1:nlevdecomp_full)) - allocate(ccf%harvest_c_to_cwdc(beg:end, 1:nlevdecomp_full)) - -#ifdef NITRIF_DENITRIF - allocate(ccf%phr_vr(beg:end,1:nlevdecomp_full)) -#endif - -!#ifdef CN - !F. Li and S. Levis - allocate(ccf%somc_fire(beg:end)) - allocate(ccf%lf_conv_cflux(beg:end)) - allocate(ccf%dwt_seedc_to_leaf(beg:end)) - allocate(ccf%dwt_seedc_to_deadstem(beg:end)) - allocate(ccf%dwt_conv_cflux(beg:end)) - allocate(ccf%dwt_prod10c_gain(beg:end)) - allocate(ccf%dwt_prod100c_gain(beg:end)) - allocate(ccf%dwt_frootc_to_litr_met_c(beg:end,1:nlevdecomp_full)) - allocate(ccf%dwt_frootc_to_litr_cel_c(beg:end,1:nlevdecomp_full)) - allocate(ccf%dwt_frootc_to_litr_lig_c(beg:end,1:nlevdecomp_full)) - allocate(ccf%dwt_livecrootc_to_cwdc(beg:end,1:nlevdecomp_full)) - allocate(ccf%dwt_deadcrootc_to_cwdc(beg:end,1:nlevdecomp_full)) - allocate(ccf%dwt_closs(beg:end)) - allocate(ccf%landuseflux(beg:end)) - allocate(ccf%landuptake(beg:end)) - allocate(ccf%prod10c_loss(beg:end)) - allocate(ccf%prod100c_loss(beg:end)) - allocate(ccf%product_closs(beg:end)) -!#endif - allocate(ccf%lithr(beg:end)) - allocate(ccf%somhr(beg:end)) - allocate(ccf%hr(beg:end)) - allocate(ccf%sr(beg:end)) - allocate(ccf%er(beg:end)) - allocate(ccf%litfire(beg:end)) - allocate(ccf%somfire(beg:end)) - allocate(ccf%totfire(beg:end)) - allocate(ccf%nep(beg:end)) - allocate(ccf%nbp(beg:end)) - allocate(ccf%nee(beg:end)) - allocate(ccf%col_cinputs(beg:end)) - allocate(ccf%col_coutputs(beg:end)) - allocate(ccf%col_fire_closs(beg:end)) - -!#if (defined CN) - allocate(ccf%cwdc_hr(beg:end)) - allocate(ccf%cwdc_loss(beg:end)) - allocate(ccf%litterc_loss(beg:end)) -!#endif - - ccf%m_c_to_litr_met_fire(beg:end,1:nlevdecomp_full) = nan - ccf%m_c_to_litr_cel_fire(beg:end,1:nlevdecomp_full) = nan - ccf%m_c_to_litr_lig_fire(beg:end,1:nlevdecomp_full) = nan - ccf%hrv_deadstemc_to_prod10c(beg:end) = nan - ccf%hrv_deadstemc_to_prod100c(beg:end) = nan - ccf%m_decomp_cpools_to_fire_vr(beg:end,1:nlevdecomp_full,1:ndecomp_pools) = nan - ccf%m_decomp_cpools_to_fire(beg:end,1:ndecomp_pools) = nan - ccf%decomp_cascade_hr_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions) = nan - ccf%decomp_cascade_hr(beg:end,1:ndecomp_cascade_transitions) = nan - ccf%decomp_cascade_ctransfer_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions) = nan - ccf%decomp_cascade_ctransfer(beg:end,1:ndecomp_cascade_transitions) = nan - ccf%decomp_cpools_sourcesink(beg:end,1:nlevdecomp_full,1:ndecomp_pools) = nan - ccf%decomp_k(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions) = spval -! Initialize these four below to spval to allow history to not average over inactive points. - ccf%t_scalar(beg:end,1:nlevdecomp_full) = spval - ccf%w_scalar(beg:end,1:nlevdecomp_full) = spval - ccf%hr_vr(beg:end, 1:nlevdecomp_full) = spval - ccf%o_scalar(beg:end, 1:nlevdecomp_full) = spval - ccf%som_c_leached(beg:end) = nan - ccf%decomp_cpools_leached(beg:end,1:ndecomp_pools) = nan - ccf%decomp_cpools_transport_tendency(beg:end,1:nlevdecomp_full,1:ndecomp_pools) = nan - - ccf%phenology_c_to_litr_met_c(beg:end, 1:nlevdecomp_full) = nan - ccf%phenology_c_to_litr_cel_c(beg:end, 1:nlevdecomp_full) = nan - ccf%phenology_c_to_litr_lig_c(beg:end, 1:nlevdecomp_full) = nan - ccf%gap_mortality_c_to_litr_met_c(beg:end, 1:nlevdecomp_full) = nan - ccf%gap_mortality_c_to_litr_cel_c(beg:end, 1:nlevdecomp_full) = nan - ccf%gap_mortality_c_to_litr_lig_c(beg:end, 1:nlevdecomp_full) = nan - ccf%gap_mortality_c_to_cwdc(beg:end, 1:nlevdecomp_full) = nan - ccf%fire_mortality_c_to_cwdc(beg:end, 1:nlevdecomp_full) = nan - ccf%harvest_c_to_litr_met_c(beg:end, 1:nlevdecomp_full) = nan - ccf%harvest_c_to_litr_cel_c(beg:end, 1:nlevdecomp_full) = nan - ccf%harvest_c_to_litr_lig_c(beg:end, 1:nlevdecomp_full) = nan - ccf%harvest_c_to_cwdc(beg:end, 1:nlevdecomp_full) = nan - -#ifdef NITRIF_DENITRIF - ccf%phr_vr(beg:end,1:nlevdecomp_full) = nan -#endif -!#if (defined CN) - !F. Li and S. Levis - ccf%somc_fire(beg:end) = nan - ccf%lf_conv_cflux(beg:end) = nan - ccf%dwt_seedc_to_leaf(beg:end) = 0. !nan, followed what Greg did to disable dwt, fzeng - ccf%dwt_seedc_to_deadstem(beg:end) = 0. !nan, followed what Greg did to disable dwt, fzeng - ccf%dwt_conv_cflux(beg:end) = nan - ccf%dwt_prod10c_gain(beg:end) = nan - ccf%dwt_prod100c_gain(beg:end) = nan - ccf%dwt_frootc_to_litr_met_c(beg:end,1:nlevdecomp_full) = nan - ccf%dwt_frootc_to_litr_cel_c(beg:end,1:nlevdecomp_full) = nan - ccf%dwt_frootc_to_litr_lig_c(beg:end,1:nlevdecomp_full) = nan - ccf%dwt_livecrootc_to_cwdc(beg:end,1:nlevdecomp_full) = nan - ccf%dwt_deadcrootc_to_cwdc(beg:end,1:nlevdecomp_full) = nan - ccf%dwt_closs(beg:end) = nan - ccf%landuseflux(beg:end) = nan - ccf%landuptake(beg:end) = nan - ccf%prod10c_loss(beg:end) = nan - ccf%prod100c_loss(beg:end) = nan - ccf%product_closs(beg:end) = nan -!#endif - ccf%lithr(beg:end) = nan - ccf%somhr(beg:end) = nan - ccf%hr(beg:end) = nan - ccf%sr(beg:end) = nan - ccf%er(beg:end) = nan - ccf%litfire(beg:end) = nan - ccf%somfire(beg:end) = nan - ccf%totfire(beg:end) = nan - ccf%nep(beg:end) = nan - ccf%nbp(beg:end) = nan - ccf%nee(beg:end) = nan - ccf%col_cinputs(beg:end) = nan - ccf%col_coutputs(beg:end) = nan - ccf%col_fire_closs(beg:end) = nan - -!#if (defined CN) - ccf%cwdc_hr(beg:end) = nan - ccf%cwdc_loss(beg:end) = nan - ccf%litterc_loss(beg:end) = nan -!#endif - - end subroutine init_column_cflux_type - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_ch4_type -! -! !INTERFACE: -#ifdef LCH4 - subroutine init_column_ch4_type(beg, end, cch4) -! -! !DESCRIPTION: -! Initialize column methane flux variables -! - use clm_varcon, only : spval - use clm_varpar, only : ngases -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_ch4_type), intent(inout):: cch4 -! -! !REVISION HISTORY: -! Created by William J. Riley -! -!EOP -!------------------------------------------------------------------------ - - allocate(cch4%ch4_prod_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_prod_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_prod_depth_lake(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_oxid_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_oxid_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_oxid_depth_lake(beg:end,1:nlevgrnd)) - allocate(cch4%o2_oxid_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%o2_oxid_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%o2_decomp_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%o2_decomp_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%o2_aere_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%o2_aere_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%co2_decomp_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%co2_decomp_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%co2_oxid_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%co2_oxid_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_aere_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_aere_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_tran_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_tran_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%co2_aere_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%co2_aere_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_surf_aere_sat(beg:end)) - allocate(cch4%ch4_surf_aere_unsat(beg:end)) - allocate(cch4%ch4_ebul_depth_sat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_ebul_depth_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_ebul_total_sat(beg:end)) - allocate(cch4%ch4_ebul_total_unsat(beg:end)) - allocate(cch4%ch4_surf_ebul_sat(beg:end)) - allocate(cch4%ch4_surf_ebul_unsat(beg:end)) - allocate(cch4%ch4_surf_ebul_lake(beg:end)) - allocate(cch4%conc_ch4_sat(beg:end,1:nlevgrnd)) - allocate(cch4%conc_ch4_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%conc_ch4_lake(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_surf_diff_sat(beg:end)) - allocate(cch4%ch4_surf_diff_unsat(beg:end)) - allocate(cch4%ch4_surf_diff_lake(beg:end)) - allocate(cch4%conc_o2_sat(beg:end,1:nlevgrnd)) - allocate(cch4%conc_o2_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%conc_o2_lake(beg:end,1:nlevgrnd)) - allocate(cch4%ch4_dfsat_flux(beg:end)) - allocate(cch4%zwt_ch4_unsat(beg:end)) - allocate(cch4%fsat_bef(beg:end)) - allocate(cch4%lake_soilc(beg:end,1:nlevgrnd)) - allocate(cch4%lake_raw(beg:end)) - allocate(cch4%totcolch4(beg:end)) - allocate(cch4%fphr(beg:end,1:nlevgrnd)) - allocate(cch4%annsum_counter(beg:end)) - allocate(cch4%tempavg_somhr(beg:end)) - allocate(cch4%annavg_somhr(beg:end)) - allocate(cch4%tempavg_finrw(beg:end)) - allocate(cch4%annavg_finrw(beg:end)) - allocate(cch4%sif(beg:end)) - allocate(cch4%o2stress_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%o2stress_sat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4stress_unsat(beg:end,1:nlevgrnd)) - allocate(cch4%ch4stress_sat(beg:end,1:nlevgrnd)) - allocate(cch4%qflx_surf_lag(beg:end)) - allocate(cch4%finundated_lag(beg:end)) - allocate(cch4%layer_sat_lag(beg:end,1:nlevgrnd)) - - - cch4%ch4_prod_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%ch4_prod_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%ch4_prod_depth_lake(beg:end,1:nlevgrnd) = nan - cch4%ch4_oxid_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%ch4_oxid_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%ch4_oxid_depth_lake(beg:end,1:nlevgrnd) = nan - cch4%o2_oxid_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%o2_oxid_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%o2_decomp_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%o2_decomp_depth_unsat(beg:end,1:nlevgrnd) = spval ! To detect first time-step for denitrification code - cch4%o2_aere_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%o2_aere_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%co2_decomp_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%co2_decomp_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%co2_oxid_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%co2_oxid_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%ch4_aere_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%ch4_aere_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%ch4_tran_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%ch4_tran_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%co2_aere_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%co2_aere_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%ch4_surf_aere_sat(beg:end) = nan - cch4%ch4_surf_aere_unsat(beg:end) = nan - cch4%ch4_ebul_depth_sat(beg:end,1:nlevgrnd) = nan - cch4%ch4_ebul_depth_unsat(beg:end,1:nlevgrnd) = nan - cch4%ch4_ebul_total_sat(beg:end) = nan - cch4%ch4_ebul_total_unsat(beg:end) = nan - cch4%ch4_surf_ebul_sat(beg:end) = nan - cch4%ch4_surf_ebul_unsat(beg:end) = nan - cch4%ch4_surf_ebul_lake(beg:end) = nan - cch4%conc_ch4_sat(beg:end,1:nlevgrnd) = spval ! To detect file input - cch4%conc_ch4_unsat(beg:end,1:nlevgrnd) = spval ! To detect file input - cch4%conc_ch4_lake(beg:end,1:nlevgrnd) = nan ! Just a diagnostic, so nan is fine - cch4%ch4_surf_diff_sat(beg:end) = nan - cch4%ch4_surf_diff_unsat(beg:end) = nan - cch4%ch4_surf_diff_lake(beg:end) = nan - cch4%conc_o2_sat(beg:end,1:nlevgrnd) = spval ! To detect file input - cch4%conc_o2_unsat(beg:end,1:nlevgrnd) = spval ! To detect file input and detect first time-step for denitrification code - cch4%conc_o2_lake(beg:end,1:nlevgrnd) = nan ! Just a diagnostic, so nan is fine - cch4%ch4_dfsat_flux(beg:end) = nan - cch4%zwt_ch4_unsat(beg:end) = nan - cch4%fsat_bef(beg:end) = spval ! To detect first time-step - cch4%lake_soilc(beg:end,1:nlevgrnd) = spval ! To detect file input - cch4%lake_raw(beg:end) = nan - cch4%totcolch4(beg:end) = spval ! To detect first time-step - cch4%fphr(beg:end,1:nlevgrnd) = nan - cch4%annsum_counter(beg:end) = spval ! To detect first time-step - cch4%tempavg_somhr(beg:end) = nan - cch4%annavg_somhr(beg:end) = spval ! To detect first year - cch4%tempavg_finrw(beg:end) = nan - cch4%annavg_finrw(beg:end) = spval ! To detect first year - cch4%sif(beg:end) = nan - cch4%o2stress_unsat(beg:end,1:nlevgrnd) = spval ! To detect file input - cch4%o2stress_sat(beg:end,1:nlevgrnd) = spval ! To detect file input - cch4%ch4stress_unsat(beg:end,1:nlevgrnd) = nan - cch4%ch4stress_sat(beg:end,1:nlevgrnd) = nan - cch4%qflx_surf_lag(beg:end) = spval ! To detect file input - cch4%finundated_lag(beg:end) = spval ! To detect file input - cch4%layer_sat_lag(beg:end,1:nlevgrnd) = spval ! To detect file input - - -! def CH4 - - end subroutine init_column_ch4_type -#endif - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_column_nflux_type -! -! !INTERFACE: - subroutine init_column_nflux_type(beg, end, cnf) -! - use clm_varcon, only : spval -! !DESCRIPTION: -! Initialize column nitrogen flux variables -! -! !USES: - use clm_varctl , only : crop_prog -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (column_nflux_type), intent(inout):: cnf -! -! !REVISION HISTORY: -! Created by Peter Thornton -! -!EOP -!------------------------------------------------------------------------ - - allocate(cnf%ndep_to_sminn(beg:end)) - allocate(cnf%nfix_to_sminn(beg:end)) - allocate(cnf%fert_to_sminn(beg:end)) - allocate(cnf%soyfixn_to_sminn(beg:end)) - allocate(cnf%hrv_deadstemn_to_prod10n(beg:end)) - allocate(cnf%hrv_deadstemn_to_prod100n(beg:end)) - - allocate(cnf%m_n_to_litr_met_fire(beg:end,1:nlevdecomp_full)) - allocate(cnf%m_n_to_litr_cel_fire(beg:end,1:nlevdecomp_full)) - allocate(cnf%m_n_to_litr_lig_fire(beg:end,1:nlevdecomp_full)) - allocate(cnf%sminn_to_plant(beg:end)) - allocate(cnf%potential_immob(beg:end)) - allocate(cnf%actual_immob(beg:end)) - allocate(cnf%gross_nmin(beg:end)) - allocate(cnf%net_nmin(beg:end)) - allocate(cnf%denit(beg:end)) - allocate(cnf%supplement_to_sminn(beg:end)) - allocate(cnf%m_decomp_npools_to_fire_vr(beg:end,1:nlevdecomp_full,1:ndecomp_pools)) - allocate(cnf%m_decomp_npools_to_fire(beg:end,1:ndecomp_pools)) - allocate(cnf%decomp_cascade_ntransfer_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) - allocate(cnf%decomp_cascade_ntransfer(beg:end,1:ndecomp_cascade_transitions)) - allocate(cnf%decomp_cascade_sminn_flux_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) - allocate(cnf%decomp_cascade_sminn_flux(beg:end,1:ndecomp_cascade_transitions)) - allocate(cnf%decomp_npools_sourcesink(beg:end,1:nlevdecomp_full,1:ndecomp_pools)) - - allocate(cnf%phenology_n_to_litr_met_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%phenology_n_to_litr_cel_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%phenology_n_to_litr_lig_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%gap_mortality_n_to_litr_met_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%gap_mortality_n_to_litr_cel_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%gap_mortality_n_to_litr_lig_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%gap_mortality_n_to_cwdn(beg:end, 1:nlevdecomp_full)) - allocate(cnf%fire_mortality_n_to_cwdn(beg:end, 1:nlevdecomp_full)) - allocate(cnf%harvest_n_to_litr_met_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%harvest_n_to_litr_cel_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%harvest_n_to_litr_lig_n(beg:end, 1:nlevdecomp_full)) - allocate(cnf%harvest_n_to_cwdn(beg:end, 1:nlevdecomp_full)) - -#ifndef NITRIF_DENITRIF - allocate(cnf%sminn_to_denit_decomp_cascade_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions)) - allocate(cnf%sminn_to_denit_decomp_cascade(beg:end,1:ndecomp_cascade_transitions)) - allocate(cnf%sminn_to_denit_excess_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%sminn_to_denit_excess(beg:end)) - allocate(cnf%sminn_leached_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%sminn_leached(beg:end)) -#else - allocate(cnf%f_nit_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%f_denit_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%smin_no3_leached_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%smin_no3_leached(beg:end)) - allocate(cnf%smin_no3_runoff_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%smin_no3_runoff(beg:end)) - allocate(cnf%pot_f_nit_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%pot_f_nit(beg:end)) - allocate(cnf%pot_f_denit_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%pot_f_denit(beg:end)) - allocate(cnf%actual_immob_no3_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%actual_immob_nh4_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%smin_no3_to_plant_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%smin_nh4_to_plant_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%f_nit(beg:end)) - allocate(cnf%f_denit(beg:end)) - allocate(cnf%n2_n2o_ratio_denit_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%f_n2o_denit(beg:end)) - allocate(cnf%f_n2o_denit_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%f_n2o_nit(beg:end)) - allocate(cnf%f_n2o_nit_vr(beg:end,1:nlevdecomp_full)) - - allocate(cnf%smin_no3_massdens_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%soil_bulkdensity(beg:end,1:nlevdecomp_full)) - allocate(cnf%k_nitr_t_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%k_nitr_ph_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%k_nitr_h2o_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%k_nitr_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%wfps_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%fmax_denit_carbonsubstrate_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%fmax_denit_nitrate_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%f_denit_base_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%diffus(beg:end,1:nlevdecomp_full)) - allocate(cnf%ratio_k1(beg:end,1:nlevdecomp_full)) - allocate(cnf%ratio_no3_co2(beg:end,1:nlevdecomp_full)) - allocate(cnf%soil_co2_prod(beg:end,1:nlevdecomp_full)) - allocate(cnf%fr_WFPS(beg:end,1:nlevdecomp_full)) - - allocate(cnf%r_psi(beg:end,1:nlevdecomp_full)) - allocate(cnf%anaerobic_frac(beg:end,1:nlevdecomp_full)) -#endif - allocate(cnf%potential_immob_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%actual_immob_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%sminn_to_plant_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%supplement_to_sminn_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%gross_nmin_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%net_nmin_vr(beg:end,1:nlevdecomp_full)) - allocate(cnf%dwt_seedn_to_leaf(beg:end)) - allocate(cnf%dwt_seedn_to_deadstem(beg:end)) - allocate(cnf%dwt_conv_nflux(beg:end)) - allocate(cnf%dwt_prod10n_gain(beg:end)) - allocate(cnf%dwt_prod100n_gain(beg:end)) - allocate(cnf%dwt_frootn_to_litr_met_n(beg:end,1:nlevdecomp_full)) - allocate(cnf%dwt_frootn_to_litr_cel_n(beg:end,1:nlevdecomp_full)) - allocate(cnf%dwt_frootn_to_litr_lig_n(beg:end,1:nlevdecomp_full)) - allocate(cnf%dwt_livecrootn_to_cwdn(beg:end,1:nlevdecomp_full)) - allocate(cnf%dwt_deadcrootn_to_cwdn(beg:end,1:nlevdecomp_full)) - allocate(cnf%dwt_nloss(beg:end)) - allocate(cnf%prod10n_loss(beg:end)) - allocate(cnf%prod100n_loss(beg:end)) - allocate(cnf%product_nloss(beg:end)) - allocate(cnf%col_ninputs(beg:end)) - allocate(cnf%col_noutputs(beg:end)) - allocate(cnf%col_fire_nloss(beg:end)) - allocate(cnf%som_n_leached(beg:end)) - allocate(cnf%decomp_npools_leached(beg:end,1:ndecomp_pools)) - allocate(cnf%decomp_npools_transport_tendency(beg:end,1:nlevdecomp_full,1:ndecomp_pools)) - - cnf%ndep_to_sminn(beg:end) = nan - cnf%nfix_to_sminn(beg:end) = nan - cnf%fert_to_sminn(beg:end) = nan - cnf%soyfixn_to_sminn(beg:end) = nan - cnf%hrv_deadstemn_to_prod10n(beg:end) = nan - cnf%hrv_deadstemn_to_prod100n(beg:end) = nan - cnf%m_n_to_litr_met_fire(beg:end,1:nlevdecomp_full) = nan - cnf%m_n_to_litr_cel_fire(beg:end,1:nlevdecomp_full) = nan - cnf%m_n_to_litr_lig_fire(beg:end,1:nlevdecomp_full) = nan - cnf%sminn_to_plant(beg:end) = nan - cnf%potential_immob(beg:end) = nan - cnf%actual_immob(beg:end) = nan - cnf%gross_nmin(beg:end) = nan - cnf%net_nmin(beg:end) = nan - cnf%denit(beg:end) = nan - cnf%supplement_to_sminn(beg:end) = nan - cnf%m_decomp_npools_to_fire_vr(beg:end,1:nlevdecomp_full,1:ndecomp_pools) = nan - cnf%m_decomp_npools_to_fire(beg:end,1:ndecomp_pools) = nan - cnf%decomp_cascade_ntransfer_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions) = nan - cnf%decomp_cascade_ntransfer(beg:end,1:ndecomp_cascade_transitions) = nan - cnf%decomp_cascade_sminn_flux_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions) = nan - cnf%decomp_cascade_sminn_flux(beg:end,1:ndecomp_cascade_transitions) = nan - cnf%decomp_npools_sourcesink(beg:end,1:nlevdecomp_full,1:ndecomp_pools) = nan - - cnf%phenology_n_to_litr_met_n(beg:end, 1:nlevdecomp_full) = nan - cnf%phenology_n_to_litr_cel_n(beg:end, 1:nlevdecomp_full) = nan - cnf%phenology_n_to_litr_lig_n(beg:end, 1:nlevdecomp_full) = nan - cnf%gap_mortality_n_to_litr_met_n(beg:end, 1:nlevdecomp_full) = nan - cnf%gap_mortality_n_to_litr_cel_n(beg:end, 1:nlevdecomp_full) = nan - cnf%gap_mortality_n_to_litr_lig_n(beg:end, 1:nlevdecomp_full) = nan - cnf%gap_mortality_n_to_cwdn(beg:end, 1:nlevdecomp_full) = nan - cnf%fire_mortality_n_to_cwdn(beg:end, 1:nlevdecomp_full) = nan - cnf%harvest_n_to_litr_met_n(beg:end, 1:nlevdecomp_full) = nan - cnf%harvest_n_to_litr_cel_n(beg:end, 1:nlevdecomp_full) = nan - cnf%harvest_n_to_litr_lig_n(beg:end, 1:nlevdecomp_full) = nan - cnf%harvest_n_to_cwdn(beg:end, 1:nlevdecomp_full) = nan - -#ifndef NITRIF_DENITRIF - cnf%sminn_to_denit_decomp_cascade_vr(beg:end,1:nlevdecomp_full,1:ndecomp_cascade_transitions) = nan - cnf%sminn_to_denit_decomp_cascade(beg:end,1:ndecomp_cascade_transitions) = nan - cnf%sminn_to_denit_excess_vr(beg:end,1:nlevdecomp_full) = nan - cnf%sminn_to_denit_excess(beg:end) = nan - cnf%sminn_leached_vr(beg:end,1:nlevdecomp_full) = nan - cnf%sminn_leached(beg:end) = nan -#else - cnf%f_nit_vr(beg:end,1:nlevdecomp_full) = nan - cnf%f_denit_vr(beg:end,1:nlevdecomp_full) = nan - cnf%smin_no3_leached_vr(beg:end,1:nlevdecomp_full) = nan - cnf%smin_no3_leached(beg:end) = nan - cnf%smin_no3_runoff_vr(beg:end,1:nlevdecomp_full) = nan - cnf%smin_no3_runoff(beg:end) = nan - cnf%pot_f_nit_vr(beg:end,1:nlevdecomp_full) = nan - cnf%pot_f_nit(beg:end) = nan - cnf%pot_f_denit_vr(beg:end,1:nlevdecomp_full) = nan - cnf%pot_f_denit(beg:end) = nan - cnf%actual_immob_no3_vr(beg:end,1:nlevdecomp_full) = nan - cnf%actual_immob_nh4_vr(beg:end,1:nlevdecomp_full) = nan - cnf%smin_no3_to_plant_vr(beg:end,1:nlevdecomp_full) = nan - cnf%smin_nh4_to_plant_vr(beg:end,1:nlevdecomp_full) = nan - cnf%f_nit(beg:end) = nan - cnf%f_denit(beg:end) = nan - cnf%n2_n2o_ratio_denit_vr(beg:end,1:nlevdecomp_full) = nan - cnf%f_n2o_denit(beg:end) = nan - cnf%f_n2o_denit_vr(beg:end,1:nlevdecomp_full) = nan - cnf%f_n2o_nit(beg:end) = nan - cnf%f_n2o_nit_vr(beg:end,1:nlevdecomp_full) = nan - - cnf%smin_no3_massdens_vr(beg:end,1:nlevdecomp_full) = nan - cnf%soil_bulkdensity(beg:end,1:nlevdecomp_full) = nan - cnf%k_nitr_t_vr(beg:end,1:nlevdecomp_full) = nan - cnf%k_nitr_ph_vr(beg:end,1:nlevdecomp_full) = nan - cnf%k_nitr_h2o_vr(beg:end,1:nlevdecomp_full) = nan - cnf%k_nitr_vr(beg:end,1:nlevdecomp_full) = nan - cnf%wfps_vr(beg:end,1:nlevdecomp_full) = nan - cnf%fmax_denit_carbonsubstrate_vr(beg:end,1:nlevdecomp_full) = nan - cnf%fmax_denit_nitrate_vr(beg:end,1:nlevdecomp_full) = nan - cnf%f_denit_base_vr(beg:end,1:nlevdecomp_full) = nan - cnf%diffus(beg:end,1:nlevdecomp_full) = spval - cnf%ratio_k1(beg:end,1:nlevdecomp_full) = nan - cnf%ratio_no3_co2(beg:end,1:nlevdecomp_full) = spval - cnf%soil_co2_prod(beg:end,1:nlevdecomp_full) = nan - cnf%fr_WFPS(beg:end,1:nlevdecomp_full) = spval - - cnf%r_psi(beg:end,1:nlevdecomp_full) = spval - cnf%anaerobic_frac(beg:end,1:nlevdecomp_full) = spval -#endif - cnf%potential_immob_vr(beg:end,1:nlevdecomp_full) = nan - cnf%actual_immob_vr(beg:end,1:nlevdecomp_full) = nan - cnf%sminn_to_plant_vr(beg:end,1:nlevdecomp_full) = nan - cnf%supplement_to_sminn_vr(beg:end,1:nlevdecomp_full) = nan - cnf%gross_nmin_vr(beg:end,1:nlevdecomp_full) = nan - cnf%net_nmin_vr(beg:end,1:nlevdecomp_full) = nan - cnf%dwt_seedn_to_leaf(beg:end) = nan - cnf%dwt_seedn_to_deadstem(beg:end) = nan - cnf%dwt_conv_nflux(beg:end) = nan - cnf%dwt_prod10n_gain(beg:end) = nan - cnf%dwt_prod100n_gain(beg:end) = nan - cnf%dwt_frootn_to_litr_met_n(beg:end,1:nlevdecomp_full) = nan - cnf%dwt_frootn_to_litr_cel_n(beg:end,1:nlevdecomp_full) = nan - cnf%dwt_frootn_to_litr_lig_n(beg:end,1:nlevdecomp_full) = nan - cnf%dwt_livecrootn_to_cwdn(beg:end,1:nlevdecomp_full) = nan - cnf%dwt_deadcrootn_to_cwdn(beg:end,1:nlevdecomp_full) = nan - cnf%dwt_nloss(beg:end) = nan - cnf%prod10n_loss(beg:end) = nan - cnf%prod100n_loss(beg:end) = nan - cnf%product_nloss(beg:end) = nan - cnf%col_ninputs(beg:end) = nan - cnf%col_noutputs(beg:end) = nan - cnf%col_fire_nloss(beg:end) = nan - cnf%som_n_leached(beg:end) = nan - cnf%decomp_npools_leached(beg:end,1:ndecomp_pools) = nan - cnf%decomp_npools_transport_tendency(beg:end,1:nlevdecomp_full,1:ndecomp_pools) = nan - - - end subroutine init_column_nflux_type - - - - -#if (defined CNDV) -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_gridcell_dgvstate_type -! -! !INTERFACE: - subroutine init_gridcell_dgvstate_type(beg, end, gps) -! -! !DESCRIPTION: -! Initialize gridcell DGVM variables -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (gridcell_dgvstate_type), intent(inout):: gps -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - - allocate(gps%agdd20(beg:end)) - allocate(gps%tmomin20(beg:end)) - allocate(gps%t10min(beg:end)) - gps%agdd20(beg:end) = nan - gps%tmomin20(beg:end) = nan - gps%t10min(beg:end) = nan - - end subroutine init_gridcell_dgvstate_type -#endif - -!------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: init_gridcell_ch4_type -! -! !INTERFACE: -#ifdef LCH4 - subroutine init_gridcell_ch4_type(beg, end, gch4) -! -! !DESCRIPTION: -! Initialize gridcell ch4 variables -! - use clm_varpar, only: ngases -! !ARGUMENTS: - implicit none - integer, intent(in) :: beg, end - type (gridcell_ch4_type), intent(inout):: gch4 -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -!EOP -!------------------------------------------------------------------------ - allocate(gch4%c_atm(beg:end,1:ngases)) - allocate(gch4%ch4co2f(beg:end)) - allocate(gch4%ch4prodg(beg:end)) - allocate(gch4%nem(beg:end)) - - gch4%c_atm(beg:end,1:ngases) = nan - gch4%ch4co2f(beg:end) = nan - gch4%ch4prodg(beg:end) = nan - gch4%nem(beg:end) = nan - - end subroutine init_gridcell_ch4_type -#endif - -end module clmtypeInitMod 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 deleted file mode 100644 index 7b7286cbc..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/compute_rc.F90 +++ /dev/null @@ -1,1891 +0,0 @@ -#define CN -#undef CNDV - - module compute_rc_mod - - use clmtype - use update_model_para4cn, only : LocalTileID - - implicit none - - private - public compute_rc - - contains - - subroutine compute_rc(nch,nveg,tc,qa,t10,tm,pbot,coszen,pardir,pardif, & - albgrd,albgri,elai,esai,ityp,fveg,btran,fwet, & - rc,rcdtc,rcdea,psnsun,psnsha,laisun,laisha, & - dayl_fac,co2v,dtc,dea,parabs,sifsun,sifsha, & - lmrsun,lmrsha,fpar_sf) - - use clm_varcon, only: tfrz - use MAPL_SatVaporMod - - implicit none - - integer, intent(in) :: nch ! vector length - integer, intent(in) :: nveg ! number of PFTs (currently 2 for catchment model) - real, intent(in) :: tc(nch) ! canopy temperature (K) - real, intent(in) :: qa(nch) ! canopy air specific humidity (kg/kg) - 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) :: pbot(nch) ! surface pressure (Pa) - real, intent(in) :: coszen(nch) ! cosine solar zenith angle - real, intent(in) :: pardir(nch) ! direct PAR (W/m2) - real, intent(in) :: pardif(nch) ! diffuse PAR (W/m2) - real, intent(in) :: albgrd(nch,nveg) ! ground albedo visible direct - real, intent(in) :: albgri(nch,nveg) ! ground albedo visible diffuse - real, intent(in) :: elai(nch,nveg) ! one-sided leaf area index - real, intent(in) :: esai(nch,nveg) ! one-sided stem area index - integer, intent(in) :: ityp(nch,nveg) ! canopy vegetation index (PFT) - real, intent(in) :: fveg(nch,nveg) ! canopy vegetation fractions - real, intent(in) :: btran(nch) ! soil water transpiration factor (0-1) - real, intent(in) :: fwet(nch) ! fraction of canopy that is wet (0-1) - real, intent(in) :: co2v(nch) ! atmospheric carbon dioxide concentration - real, intent(in) :: dayl_fac(nch) ! daylength factor (0-1) - real, intent(in), optional :: fpar_sf(nch,nveg) ! FPAR Scale factor = SCALED_FPAR / CLM4_FPAR - - real, intent(out) :: rc(nch) ! canopy stomatal resistance (s/m). NOTE: it's resistance, not conductance, fzeng, 20 Feb 2018 - real, intent(out) :: rcdtc(nch) ! canopy stomatal resistance (s/m) for Tc+d(Tc) - real, intent(out) :: rcdea(nch) ! canopy stomatal resistance (s/m) for ea+d(ea) - real, intent(out) :: psnsun(nch,nveg) ! sunlit foliage photosynthesis (umol co2 /m**2/ s) [always +] - real, intent(out) :: psnsha(nch,nveg) ! shaded foliage photosynthesis (umol co2 /m**2/ s) [always +] - real, intent(out) :: sifsun(nch,nveg) ! sunlit foliage fluorescence - real, intent(out) :: sifsha(nch,nveg) ! shaded foliage fluorescence - real, intent(out) :: laisun(nch,nveg) ! sunlit projected leaf area index - real, intent(out) :: laisha(nch,nveg) ! shaded projected leaf area index - real, intent(out) :: lmrsun(nch,nveg) ! sunlit leaf maintenance respiration rate (umol CO2/m**2/s) - real, intent(out) :: lmrsha(nch,nveg) ! shaded leaf maintenance respiration rate (umol CO2/m**2/s) - real, intent(out) :: parabs(nch,nveg) ! total absorbed PAR - -! local - - real ei(nch) ! vapor pressure inside leaf (sat vapor press at tc) (Pa) - real ea(nch) ! vapor pressure of canopy air (Pa) - real o2(nch) ! atmospheric o2 concentration (Pa) - real co2(nch) ! atmospheric co2 concentration (Pa) - real rb(nch) ! boundary layer resistance (s/m) - real tl(nch) ! canopy temperature (K) - real parsun(nch,nveg) ! par absorbed per unit lai (w/m**2) - real parsha(nch,nveg) ! par absorbed per unit lai (w/m**2) - real rssun(nch,nveg) ! sunlit stomatal resistance (s/m) - real rssha(nch,nveg) ! shaded stomatal resistance (s/m) - real vcmaxcintsun(nch,nveg) ! leaf to canopy scaling coefficient, sunlit leaf vcmax - real vcmaxcintsha(nch,nveg) ! leaf to canopy scaling coefficient, shaded leaf vcmax - real psn(nch,nveg) ! foliage photosynthesis (umol co2 /m**2/ s) [always +] - real sif(nch,nveg) ! foliage fluorescence - real lmr(nch,nveg) ! leaf maintenance respiration rate (umol CO2/m**2/s) - real deldT(nch) ! d(es)/d(T) - - integer n, nv - integer ivt ! pft vegetation type - real*8 par ! photosynthetically active radiation - real*8 cosz ! cosine of solar zenith angle, 0.001 <= cosz <= 1.000 - real*8 extkb ! direct beam extinction coefficient - real*8 chil ! -0.4 <= xl <= 0.6 - real*8 gdir ! leaf projection in solar direction (0-1) - real*8 omega ! fraction of intercepted radiation that is scattered (0 to 1) - real*8 omegal ! omega for leaves - real*8 fsun ! sunlit fraction of canopy - real*8 fabd ! flux absorbed by canopy per unit direct flux - real*8 fabd_sun ! flux absorbed by sunlit canopy per unit direct flux - real*8 fabd_sha ! flux absorbed by shaded canopy per unit direct flux - real*8 fabi ! flux absorbed by canopy per unit diffuse flux - real*8 fabi_sun ! flux absorbed by sunlit canopy per unit diffuse flux - real*8 fabi_sha ! flux absorbed by shaded canopy per unit diffuse flux - real*8 ftdd ! down direct flux below canopy per unit direct flux - real*8 ftid ! down diffuse flux below canopy per unit direct flux - real*8 ftii ! down diffuse flux below canopy per unit diffuse flu - real*8 rho ! leaf/stem reflectance weighted by fraction LAI and SAI - real*8 tau ! leaf/stem transmittance weighted by fraction LAI and SAI - real*8 albd ! surface albedo (direct) - real*8 albi ! surface albedo (diffuse) - real*8 vai ! LAI+SAI - real*8 wl ! fraction of LAI+SAI that is LAI - real*8 ws ! fraction of LAI+SAI that is SAI - real*8 avmu ! average diffuse optical depth - real*8 asu ! single scattering albedo - real*8 betai ! upscatter parameter for diffuse radiation - real*8 betail ! betai for leaves - real*8 betad ! upscatter parameter for direct beam radiation - real*8 betadl ! betad for leaves - real*8 t1, rcs, rs ! temporary - real*8 phi1, phi2, temp0, temp1, temp2 ! temporary - real*8 tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9 ! temporary - real*8 b, c1, d, d1, d2, f, h, sigma, p1, p2, p3, p4, s1, s2, u1, u2, u3, a1, a2 ! temporary - real*8 h1, h2, h3, h4, h5, h6, h7, h8, h9, h10 ! temporary - - real, intent(in) :: dtc ! canopy temperature perturbation (K) [approx 1:10000] - real, intent(in) :: dea ! vapor pressure perturbation (Pa) [approx 1:10000] - - real, pointer :: xl(:) ! ecophys const - leaf/stem orientation index - real, pointer :: rhol(:) ! leaf reflectance (visible) - real, pointer :: rhos(:) ! stem reflectance (visible) - real, pointer :: taul(:) ! leaf transmittance (visible) - real, pointer :: taus(:) ! stem transmittance (visible) - - real, parameter :: omegas = 0.80 ! two-stream parameter omega for snow (visible) - real, parameter :: betads = 0.50 ! two-stream parameter betad for snow - real, parameter :: betais = 0.50 ! two-stream parameter betai for snow - - real, parameter :: mpe = 1.e-06 ! prevents overflow for division by zero - -! real, parameter :: extkn = 0.30 ! nitrogen allocation coefficient - real, parameter :: extkn = 0.11 ! nitrogen allocation coefficient, fzeng changed it back to 0.11 (see Bonan et al., 2012) on 1/15/2019 - -! assign local pointers to derived type arrays -! -------------------------------------------- - xl => pftcon%xl - rhol => pftcon%rhol - rhos => pftcon%rhos - taul => pftcon%taul - taus => pftcon%taus - - o2(:) = 0.20946*pbot ! O2 partial pressure constant ratio - co2(:) = co2v(:)*pbot ! CO2 partial pressure constant ratio [internal leaf CO2 partial pressure] - rb(:) = 10. ! gkw: for now, assume a small value for rb (see 8/3/10 email) - ea(:) = pbot(:) * qa(:) / (0.622 + qa(:)) ! canopy air vapor pressure (Pa) - - parabs(:,:) = 0. ! initialize absorbed PAR to zero - -! compute saturation vapor pressure -! --------------------------------- - do n = 1,nch - ei(n) = MAPL_EQsat(tc(n),DQ=deldT(n)) - end do - -! set solar fluxes -! ---------------- - do n = 1,nch - - par = pardir(n) + pardif(n) - -! partition PAR into sunlit and shaded canopy for each vegetation type -! -------------------------------------------------------------------- - do nv = 1,nveg - - if(par > 0. .and. elai(n,nv) > 0. .and. fveg(n,nv) > 1.e-4 .and. ityp(n,nv) > 0) then - - ivt = ityp(n,nv) ! mapped PFT - -! Sun/shade big leaf code uses only one layer, with canopy integrated values from above and also canopy-integrated scaling coefficients -! ------------------------------------------------------------------------------------------------------------------------------------- - -! Calculate two-stream parameters omega, betad, betai, avmu, gdir, ext. -! 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. - -! Weight reflectance/transmittance by lai and sai -! Only perform on vegetated pfts where coszen > 0 -! ----------------------------------------------- - - vai = elai(n,nv) + esai(n,nv) ! elai+esai - - wl = elai(n,nv) / max(vai,mpe) ! fraction of LAI+SAI that is LAI - ws = esai(n,nv) / max(vai,mpe) ! fraction of LAI+SAI that is SAI - - rho = max( rhol(ivt)*wl + rhos(ivt)*ws, mpe ) ! weighted reflectance, 3.11 - tau = max( taul(ivt)*wl + taus(ivt)*ws, mpe ) ! weighted transmittance, 3.12 - -! leaf projection in solar direction (0-1) -! CLM4.5 SurfaceAlbedoMod.F90 -! ---------------------------------------- - - cosz = max(0.001, coszen(n)) - - chil = min(max(xl(ivt),-0.4),0.6) - if(abs(chil) <= 0.01) chil = 0.01 - phi1 = 0.5 - 0.633*chil - 0.330*chil*chil - phi2 = 0.877 * (1. - 2.*phi1) - gdir = phi1 + phi2*cosz ! 3.3 - extkb = gdir/cosz ! same as twostext in SurfacdAlbedoMod.F90 - avmu = (1. - phi1/phi2 * log((phi1+phi2)/phi1)) / phi2 ! average diffuse optical depth, 3.4 - temp0 = gdir + phi2*cosz - temp1 = phi1*cosz - temp2 = ( 1. - temp1/temp0 * log((temp1+temp0)/temp1) ) - - omegal = rho + tau ! snow-free visible scattering coefficient - asu = 0.5*omegal*gdir/temp0 *temp2 ! single scattering albedo, 3.16 - betadl = (1.+avmu*extkb)/(omegal*avmu*extkb)*asu ! betad for leaves, 3.15 - betail = 0.5 * ((rho+tau) + (rho-tau) * ((1.+chil)/2.)**2) / omegal ! betai for leaves, 3.13, 3.14 - -! Adjust omega, betad, and betai for intercepted snow -! CLM4.5 SurfaceAlbedoMod.F90 -! --------------------------------------------------- - - if (tc(n) > tfrz) then ! no snow - tmp0 = omegal ! 3.8 - tmp1 = betadl ! 3.10 - tmp2 = betail ! 3.9 - else - tmp0 = (1.-fwet(n))*omegal + fwet(n)*omegas ! 3.5 - tmp1 = ((1.-fwet(n))*omegal*betadl + fwet(n)*omegas*betads) / tmp0 ! 3.7 - tmp2 = ((1.-fwet(n))*omegal*betail + fwet(n)*omegas*betais) / tmp0 ! 3.6 - end if - omega = tmp0 - betad = tmp1 ! upscatter parameter for direct beam radiation - betai = tmp2 ! upscatter parameter for diffuse radiation - -! Common terms -! CLM4.5 SurfaceAlbedoMod.F90 -! --------------------------- - - b = 1. - omega + omega*betai ! 3.31 - c1 = omega*betai ! 3.32 - tmp0 = avmu*extkb - d = tmp0 * omega*betad ! 3.33 - f = tmp0 * omega*(1.-betad) ! 3.34 - tmp1 = b*b - c1*c1 - h = sqrt(tmp1) / avmu ! 3.35 - sigma = tmp0*tmp0 - tmp1 ! 3.36 - p1 = b + avmu*h ! 3.42 - p2 = b - avmu*h ! 3.43 - p3 = b + tmp0 ! 3.44 - p4 = b - tmp0 ! 3.45 - -! Absorbed, reflected, transmitted fluxes per unit incoming radiation for full canopy -! CLM4.5 SurfaceAlbedoMod.F90 -! ----------------------------------------------------------------------------------- - - t1 = min(h*vai, 40.) - s1 = exp(-t1) ! 3.40 - t1 = min(extkb*vai, 40.) - s2 = exp(-t1) ! 3.41 - -! Direct beam -! CLM4.5 SurfaceAlbedoMod.F90 -! --------------------------- - - u1 = b - c1/albgrd(n,nv) ! 3.37 - u2 = b - c1*albgrd(n,nv) ! 3.38 - u3 = f + c1*albgrd(n,nv) ! 3.39 - - tmp2 = u1 - avmu*h - tmp3 = u1 + avmu*h - d1 = p1*tmp2/s1 - p2*tmp3*s1 ! 3.46 - tmp4 = u2 + avmu*h - tmp5 = u2 - avmu*h - d2 = tmp4/s1 - tmp5*s1 ! 3.47 - h1 = -d*p4 - c1*f ! 3.48 - - tmp6 = d - h1*p3/sigma - tmp7 = (d - c1 - h1/sigma*(u1+tmp0)) * s2 - h2 = (tmp6*tmp2/s1 - p2*tmp7) / d1 ! 3.49 - h3 = -(tmp6*tmp3*s1 - p1*tmp7) / d1 ! 3.50 - h4 = -f*p3 - c1*d ! 3.51 - tmp8 = h4/sigma - tmp9 = (u3 - tmp8*(u2-tmp0)) * s2 - h5 = -(tmp8*tmp4/s1 + tmp9) / d2 ! 3.52 - h6 = (tmp8*tmp5*s1 + tmp9) / d2 ! 3.53 - - albd = h1/sigma + h2 + h3 ! Flux reflected by vegetation (direct), 3.17 - ftid = h4*s2/sigma + h5*s1 + h6/s1 ! Downward diffuse flux below vegetation, 3.19 - ftdd = s2 ! Downward direct flux below vegetation - fabd = 1. - albd - (1.-albgrd(n,nv))*ftdd - (1.-albgri(n,nv))*ftid ! Flux absorbed by vegetation (direct), 3.21 - - a1 = h1 / sigma * (1. - s2*s2) / (2. * extkb) & ! 3.25 - + h2 * (1. - s2*s1) / (extkb + h) & - + h3 * (1. - s2/s1) / (extkb - h) - - a2 = h4 / sigma * (1. - s2*s2) / (2. * extkb) & ! 3.26 - + h5 * (1. - s2*s1) / (extkb + h) & - + h6 * (1. - s2/s1) / (extkb - h) - - fabd_sun = (1. - omega) * ( 1. - s2 + 1. / avmu * (a1 + a2) ) ! Flux absorbed by vegetation (direct), sunlit, 3.23 - fabd_sha = fabd - fabd_sun ! Flux absorbed by vegetation (direct), shaded, 3.24 - -! Diffuse -! CLM4.5 SurfaceAlbedoMod.F90 -! --------------------------- - - u1 = b - c1/albgri(n,nv) - u2 = b - c1*albgri(n,nv) - tmp2 = u1 - avmu*h - tmp3 = u1 + avmu*h - d1 = p1*tmp2/s1 - p2*tmp3*s1 - tmp4 = u2 + avmu*h - tmp5 = u2 - avmu*h - d2 = tmp4/s1 - tmp5*s1 - h7 = (c1*tmp2) / (d1*s1) ! 3.54 - h8 = (-c1*tmp3*s1) / d1 ! 3.55 - h9 = tmp4 / (d2*s1) ! 3.56 - h10 = (-tmp5*s1) / d2 ! 3.57 - - albi = h7 + h8 ! Flux reflected by vegetation (indirect), 3.18 - ftii = h9*s1 + h10/s1 ! Downward direct and diffuse fluxes below vegetation, 3.20 - fabi = 1. - albi - (1.-albgri(n,nv))*ftii ! Flux absorbed by vegetation (indirect), 3.22 - - a1 = h7 * (1. - s2*s1) / (extkb + h) + h8 * (1. - s2/s1) / (extkb - h) ! 3.29 - a2 = h9 * (1. - s2*s1) / (extkb + h) + h10 * (1. - s2/s1) / (extkb - h) ! 3.30 - - fabi_sun = (1. - omega) / avmu * (a1 + a2) ! 3.27 - fabi_sha = fabi - fabi_sun ! 3.28 - -! PAR absorbed by vegetation -! -------------------------- -! parabs(n) = parabs(n) + (pardir(n)*fabd + pardif(n)*fabi)*fveg(n,nv)*wl ! save leaf-absorbed PAR for FPAR calculation - -! sunlit fraction of canopy -! ------------------------- - fsun = (1. - s2) / t1 - -! if(fsun<=0. .or. fsun>=1.) then -! print *, 'elai =',elai(n,nv),'fsun =',fsun -! stop 'compute_rc: fsun out of bound!!' -! end if - -! leaf to canopy scaling coefficients. Need to separate for nlevcan==1 and nlevcan>1 cases!! -! See L807-818 in SurfaceAlbedoMod.F90. This is default though. -! ------------------------------------------------------------- - - vcmaxcintsun(n,nv) = (1. - exp(-(extkn+extkb)*elai(n,nv))) / (extkn + extkb) - vcmaxcintsha(n,nv) = (1. - exp(-extkn*elai(n,nv))) / extkn - vcmaxcintsun(n,nv) - - if(elai(n,nv) .gt. 0.01) then - - ! absorbed PAR (per unit sun/shade lai+sai) - ! ----------------------------------------- - fabd_sun = fabd_sun / (fsun*vai) - fabi_sun = fabi_sun / (fsun*vai) - fabd_sha = fabd_sha / ((1. - fsun)*vai) - fabi_sha = fabi_sha / ((1. - fsun)*vai) - - ! sunlit & shaded leaf area - ! ------------------------- - laisun(n,nv) = elai(n,nv)*fsun - laisha(n,nv) = elai(n,nv)*(1.-fsun) - - vcmaxcintsun(n,nv) = vcmaxcintsun(n,nv) / laisun(n,nv) - vcmaxcintsha(n,nv) = vcmaxcintsha(n,nv) / laisha(n,nv) - - else ! special case for low elai, when fsun can be > 1.0 - - ! absorbed PAR (per unit sun/shade lai+sai) - ! ----------------------------------------- - fabd_sun = fabd_sun / vai - fabi_sun = fabi_sun / vai - fabd_sha = 0. - fabi_sha = 0. - - ! sunlit & shaded leaf area - ! ------------------------- - laisun(n,nv) = elai(n,nv) - laisha(n,nv) = 0. - - vcmaxcintsun(n,nv) = vcmaxcintsun(n,nv) / laisun(n,nv) - vcmaxcintsha(n,nv) = 0. - - endif - - ! CLM4.5 SurfaceRadiationMod.F90, L453-458 - parsun(n,nv) = pardir(n)*fabd_sun + pardif(n)*fabi_sun ! sunlit canopy PAR for leaves per vai - parsha(n,nv) = pardir(n)*fabd_sha + pardif(n)*fabi_sha ! shaded canopy PAR for leaves per vai - - else - -! elai=0, no vegetation, or PAR=0 (night) -! --------------------------------------- - laisun(n,nv) = 0. - laisha(n,nv) = elai(n,nv) - parsun(n,nv) = 0. - parsha(n,nv) = 0. - vcmaxcintsun(n,nv) = 0. - if(ityp(n,nv) > 0) then - vcmaxcintsha(n,nv) = (1. - exp(-extkn*elai(n,nv))) / extkn - if(elai(n,nv) > 0.) then - vcmaxcintsha(n,nv) = vcmaxcintsha(n,nv) / elai(n,nv) - else - vcmaxcintsha(n,nv) = 0. - end if - else - vcmaxcintsha(n,nv) = 0. - endif - endif - - if(present (fpar_sf)) then - - ! scaling to match MODIS FPAR - - parsun(n,nv) = parsun(n,nv) * fpar_sf(n,nv) ! sunlit canopy PAR for leaves per vai - parsha(n,nv) = parsha(n,nv) * fpar_sf(n,nv) ! shaded canopy PAR for leaves per vai - - endif - -! save leaf-absorbed PAR for FPAR calculation - parabs(n,nv) = parsun(n,nv) * laisun(n,nv) + parsha(n,nv) * laisha(n,nv) - - end do ! end PFT loop - - end do ! end column loop - -! compute stomatal resistance using CLM routine; also compute photosynthesis - -! obtain stomatal resistance and photosynthesis - - call Photosynthesis(nch, nveg, ei, ea, o2, co2, rb, dayl_fac, pbot, ityp, tm, t10, tc, & - btran, elai, laisun, parsun, vcmaxcintsun, rssun, psnsun, sifsun, lmrsun) ! sunlit - call Photosynthesis(nch, nveg, ei, ea, o2, co2, rb, dayl_fac, pbot, ityp, tm, t10, tc, & - btran, elai, laisha, parsha, vcmaxcintsha, rssha, psnsha, sifsha, lmrsha) ! shaded - -! combine resistance as reciprocal of vegetation weighted conductance (weighted harmonic sum) - -!DIR$ NOVECTOR - do n = 1,nch - rcs = 0. - do nv = 1,nveg - rs = laisun(n,nv)/rssun(n,nv) + laisha(n,nv)/rssha(n,nv) ! rssun and rssha: stomatal resistance; rs: stomatal conductance, fzeng, 20 Feb 2018 - rcs = rcs + fveg(n,nv)*rs - end do - rc(n) = 1./max(rcs,5.e-5) + rb(n) ! rc: stomatal resistance, fzeng, 20 Feb 2018 - end do - - -! compute resistance with small delta ea - - ea(:) = ea(:) + dea - - call Photosynthesis(nch, nveg, ei, ea, o2, co2, rb, dayl_fac, pbot, ityp, tm, t10, tc, & - btran, elai, laisun, parsun, vcmaxcintsun, rssun, psn, sif, lmr) ! sunlit - call Photosynthesis(nch, nveg, ei, ea, o2, co2, rb, dayl_fac, pbot, ityp, tm, t10, tc, & - btran, elai, laisha, parsha, vcmaxcintsha, rssha, psn, sif, lmr) ! shaded - -!DIR$ NOVECTOR - do n = 1,nch - rcs = 0. - do nv = 1,nveg - rs = laisun(n,nv)/rssun(n,nv) + laisha(n,nv)/rssha(n,nv) - rcs = rcs + fveg(n,nv)*rs - end do - rcdea(n) = 1./max(rcs,5.e-5) + rb(n) - end do - - -! compute resistance with small delta Tc - - tl(:) = tc(:) + dtc - ei(:) = ei(:) + deldT(:)*dtc ! ei=esat(Tc)+[d(esat)/d(Tc)]dTc - - ea(:) = pbot(:) * qa(:) / (0.622 + qa(:)) ! reset input canopy air vapor pressure (Pa) - - call Photosynthesis(nch, nveg, ei, ea, o2, co2, rb, dayl_fac, pbot, ityp, tm, t10, tl, & - btran, elai, laisun, parsun, vcmaxcintsun, rssun, psn, sif, lmr) ! sunlit - call Photosynthesis(nch, nveg, ei, ea, o2, co2, rb, dayl_fac, pbot, ityp, tm, t10, tl, & - btran, elai, laisha, parsha, vcmaxcintsha, rssha, psn, sif, lmr) ! shaded - -!DIR$ NOVECTOR - do n = 1,nch - rcs = 0. - do nv = 1,nveg - rs = laisun(n,nv)/rssun(n,nv) + laisha(n,nv)/rssha(n,nv) - rcs = rcs + fveg(n,nv)*rs - end do - rcdtc(n) = 1./max(rcs,5.e-5) + rb(n) - end do - - end subroutine compute_rc - -!******************************************************************************* -! fzeng: this is how "btran" and "btran2" are calculated in CanopyFluxes - -!!! real(r8), parameter :: btran0 = 0.0_r8 ! initial value - -!!! ! Initialize -!!! -!!! do f = 1, fn -!!! p = filterp(f) -!!! btran(p) = btran0 -!!! btran2(p) = btran0 -!!! end do -!!! -!!! ! Effective porosity of soil, partial volume of ice and liquid (needed for btran) -!!! ! and root resistance factors -!!! -!!! do j = 1,nlevgrnd -!!! do f = 1, fn -!!! p = filterp(f) -!!! c = pcolumn(p) -!!! l = plandunit(p) -!!! -!!! ! Root resistance factors -!!! -!!! vol_ice = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) -!!! eff_porosity = watsat(c,j)-vol_ice -!!! vol_liq = min(eff_porosity, h2osoi_liq(c,j)/(dz(c,j)*denh2o)) -!!! if (vol_liq .le. 0._r8 .or. t_soisno(c,j) .le. tfrz-2._r8) then -!!! rootr(p,j) = 0._r8 -!!! else -!!! s_node = max(vol_liq/eff_porosity,0.01_r8) -!!! smp_node = max(smpsc(ivt(p)), -sucsat(c,j)*s_node**(-bsw(c,j))) -!!! -!!! rresis(p,j) = min( (eff_porosity/watsat(c,j))* & -!!! (smp_node - smpsc(ivt(p))) / (smpso(ivt(p)) - smpsc(ivt(p))), 1._r8) -!!! if (.not. (perchroot .or. perchroot_alt) ) then -!!! rootr(p,j) = rootfr(p,j)*rresis(p,j) -!!! else -!!! rootr(p,j) = rootfr_unf(p,j)*rresis(p,j) -!!! end if -!!! btran(p) = btran(p) + rootr(p,j) -!!! smp_node_lf = max(smpsc(ivt(p)), -sucsat(c,j)*(h2osoi_vol(c,j)/watsat(c,j))**(-bsw(c,j))) -!!! btran2(p) = btran2(p) +rootfr(p,j)*min((smp_node_lf - smpsc(ivt(p))) / (smpso(ivt(p)) - smpsc(ivt(p))), 1._r8) -!!! endif -!!! end do -!!! end do -!******************************************************************************* - -!******************************************************************************* -! gkw: this is how rb is calculated in CanopyFluxes -! fzeng: no change from CLM4 to CLM4.5 - -! Determine aerodynamic resistances & Bulk boundary layer resistance of leaves -! gkw: code imported from CanopyFluxes for later use 8/3/2010 - -!!! do n = 1,nch -!!! ram1 = 1./(ustar(n)*ustar(n)/um(n)) ! gkw: 5.55 -!!! uaf = um(p)*sqrt( 1./(ram1*um(n)) ) ! gkw: 5.100 -!!! rb(n) = 100.*sqrt(dleaf(ivt))/sqrt(uaf) ! gkw: 5.109 -!!! end do -!******************************************************************************* - - subroutine Photosynthesis (nch, nveg, esat_tv, eair, oair, cair, rb, dayl_factor, forc_pbot, ityp, tgcm, t10, t_veg, & - btran_in, tlai, lai, apar, vcmaxcint, rs, psn, sif, lmr) -! -! !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 -! -! !REVISION HISTORY: - -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clmtype - use clm_varcon , only : rgas, tfrz - use clm_varpar , only : nlevcan - use pftvarcon , only : nbrdlf_dcd_tmp_shrub - use pftvarcon , only : nsoybean, nsoybeanirrig, npcropmin -!#if (defined CN) - use CNAllocationMod, only : CNAllocation_Carbon_only -!#endif - implicit none - -! !ARGUMENTS: - integer , intent(in) :: nch ! number of land tiles - integer , intent(in) :: nveg ! number of PFTs - real(r8), intent(in) :: esat_tv(nch) ! saturation vapor pressure at t_veg (Pa) - real(r8), intent(in) :: eair(nch) ! vapor pressure of canopy air (Pa) - real(r8), intent(in) :: oair(nch) ! Atmospheric O2 partial pressure (Pa) - real(r8), intent(in) :: cair(nch) ! Atmospheric CO2 partial pressure (Pa) - real(r8), intent(in) :: rb(nch) ! boundary layer resistance (s/m) - real(r8), intent(in) :: dayl_factor(nch) ! scalar (0-1) for daylength - real(r8), intent(in) :: forc_pbot(nch) ! atmospheric pressure (Pa) - integer, intent(in) :: ityp(nch,nveg) ! vegetation type - real(r8), intent(in) :: tgcm(nch) ! air temperature at agcm reference height (kelvin) -!KO - real(r8), intent(in) :: t10(nch) ! 10-day running mean of the 2 m temperature (K) -!KO - real(r8), intent(in) :: t_veg(nch) ! vegetation temperature (Kelvin) - - real(r8), intent(in) :: btran_in(nch) ! soil water transpiration factor (0 to 1) - -! gkw & fzeng: - real(r8), intent(in) :: tlai(nch,nveg) ! total leaf area index - real(r8), intent(in) :: lai(nch,nveg) ! leaf area index for canopy layer, sunlit or shaded - real(r8), intent(in) :: apar(nch,nveg) ! par absorbed per unit lai (w/m**2) - real(r8), intent(in) :: vcmaxcint(nch,nveg) ! leaf to canopy scaling coefficient - real(r8), intent(out) :: rs(nch,nveg) ! leaf stomatal resistance (s/m) - real(r8), intent(out) :: psn(nch,nveg) ! foliage photosynthesis (umol co2 /m**2/ s) [always +] - real(r8), intent(out) :: sif(nch,nveg) ! foliage fluorescence - real(r8), intent(out) :: lmr(nch,nveg) ! leaf maintenance respiration rate (umol CO2/m**2/s) - -! !CALLED FROM: -! subroutine CanopyFluxes in this module - -! !LOCAL VARIABLES: -! -! local pointers to implicit in variables - real(r8), pointer :: c3psn(:) ! photosynthetic pathway: 0. = c4, 1. = c3 - real(r8), pointer :: slatop(:) ! specific leaf area at top of canopy, projected area basis [m^2/gC] - real(r8), pointer :: flnr(:) ! fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) - real(r8), pointer :: fnitr(:) ! foliage nitrogen limitation factor (-) - real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN) - - integer :: nrad(nch) ! number of canopy layers, above snow for radiative transfer - real(r8) :: tlai_z(nch,nlevcan) ! total leaf area index for canopy layer - real(r8) :: lai_z(nch,nlevcan) ! leaf area index for canopy layer, sunlit or shaded - real(r8) :: par_z(nch,nlevcan) ! par absorbed per unit lai for canopy layer (w/m**2) - -!! fzeng: comment out C13 for now. Add it back later!! - !!! C13 -! real(r8), pointer :: alphapsn(nch) ! 13C fractionation factor for PSN () - -! local pointers to implicit out variables - real(r8) :: psn_z(nch,nlevcan) ! canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] - real(r8) :: lmr_z(nch,nlevcan) ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) - real(r8) :: rs_z(nch,nlevcan) ! canopy layer: leaf stomatal resistance (s/m) - real(r8) :: ci_z(nch,nlevcan) ! intracellular leaf CO2 (Pa) - real(r8) :: psn_wc(nch) ! Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - real(r8) :: psn_wj(nch) ! RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - real(r8) :: psn_wp(nch) ! product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - -!KO - real(r8) :: rh_leaf(nch) ! fractional humidity at leaf surface (dimensionless) -!KO - -! Leaf photosynthesis parameters - real(r8) :: vcmax_z(nch,nlevcan) ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8) :: jmax_z(nch,nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) - real(r8) :: tpu_z(nch,nlevcan) ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8) :: kp_z(nch,nlevcan) ! initial slope of CO2 response curve (C4 plants) - - logical :: c3flag(nch) ! true if C3 and false if C4 - real(r8) :: lnc(nch) ! leaf N concentration (gN leaf/m^2) - real(r8) :: kc(nch) ! Michaelis-Menten constant for CO2 (Pa) - real(r8) :: ko(nch) ! Michaelis-Menten constant for O2 (Pa) - real(r8) :: cp(nch) ! CO2 compensation point (Pa) - real(r8) :: bbbopt(nch) ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) - real(r8) :: bbb(nch) ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8) :: mbbopt(nch) ! Ball-Berry slope of conductance-photosynthesis relationship, unstressed - real(r8) :: mbb(nch) ! Ball-Berry slope of conductance-photosynthesis relationship - real(r8) :: kn(nch) ! leaf nitrogen decay coefficient - real(r8) :: btran(nch) ! transpiration 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 ! leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) - real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) - real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - real(r8) :: kp25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C - real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) - real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) - real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) - - real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) - real(r8) :: jmaxha ! activation energy for jmax (J/mol) - real(r8) :: tpuha ! activation energy for tpu (J/mol) - real(r8) :: lmrha ! activation energy for lmr (J/mol) - real(r8) :: kcha ! activation energy for kc (J/mol) - real(r8) :: koha ! activation energy for ko (J/mol) - real(r8) :: cpha ! activation energy for cp (J/mol) - - real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) - real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) - real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) - real(r8) :: lmrhd ! deactivation energy for lmr (J/mol) - - real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) - real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) - real(r8) :: tpuse ! entropy term for tpu (J/mol/K) - real(r8) :: lmrse ! entropy term for lmr (J/mol/K) - - real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: lmrc ! scaling factor for high temperature inhibition (25 C = 1.0) - - real(r8) :: qe(nch) ! quantum efficiency, used only for C4 (mol CO2 / mol photons) - real(r8) :: fnps ! fraction of light absorbed by non-photosynthetic pigments - real(r8) :: theta_psii ! empirical curvature parameter for electron transport rate - - real(r8) :: theta_cj(nch) ! empirical curvature parameter for ac, aj photosynthesis co-limitation - real(r8) :: theta_ip ! empirical curvature parameter for ap photosynthesis co-limitation - -! Other - integer :: n,p,g,iv,nv,ivt ! 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 ! CO2 partial pressure at 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) :: cc ! 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(nch) ! electron transport rate (umol electrons/m**2/s) - real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) - real(r8) :: aquad,bquad,cquad ! terms for quadratic equations - real(r8) :: r1,r2 ! roots of quadratic equation - real(r8) :: ceair ! vapor pressure of air, constrained (Pa) - real(r8) :: fnr ! (gRubisco/gN in Rubisco) - real(r8) :: act25 ! (umol/mgRubisco/min) Rubisco activity at 25 C - integer :: niter ! iteration loop index - real(r8) :: nscaler ! leaf nitrogen scaling coefficient - - real(r8) :: ac(nch,nlevcan) ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: aj(nch,nlevcan) ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap(nch,nlevcan) ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ag(nch,nlevcan) ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: an(nch,nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: gs_mol(nch,nlevcan) ! leaf stomatal conductance (umol H2O/m**2/s) - real(r8) :: gb_mol(nch) ! leaf boundary layer conductance (umol H2O/m**2/s) - - real(r8) :: psn_wc_z(nch,nlevcan) ! Rubisco-limited contribution to psn_z (umol CO2/m**2/s) - real(r8) :: psn_wj_z(nch,nlevcan) ! RuBP-limited contribution to psn_z (umol CO2/m**2/s) - real(r8) :: psn_wp_z(nch,nlevcan) ! product-limited contribution to psn_z (umol CO2/m**2/s) - - real(r8) :: psncan ! canopy sum of psn_z - real(r8) :: psncan_wc ! canopy sum of psn_wc_z - real(r8) :: psncan_wj ! canopy sum of psn_wj_z - real(r8) :: psncan_wp ! canopy sum of psn_wp_z - real(r8) :: lmrcan ! canopy sum of lmr_z - real(r8) :: gscan ! canopy sum of leaf conductance - real(r8) :: laican ! canopy sum of lai_z - real(r8) :: rh_can - -! gkw & fzeng: added for SIF; taken from stomata, may not correct here -! -------------------------------------------------------------------- - real(r8) :: cican ! canopy mean intracellular leaf CO2 (Pa) - real(r8) :: ppf ! absorb photosynthetic photon flux (umol photons/m**2/s) - real(r8) :: j ! electron transport (umol co2/m**2/s) - real(r8) :: je_sif ! actual electron transport - real(r8) :: xn ! je/j - real(r8) :: fs ! fluorescnce yield at Fs - - integer :: iulog = 6 - -!------------------------------------------------------------------------------ - - ! 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,cc) = cc / ( 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)) ) - - ! fzeng: in CLM4.5 BiogeophysRestMod.F90 nrad is set to nlevcan (set to 1 in CLM4.5 clm_varpar.F90) if it's not in the restart file. - - if (nlevcan == 1) then - nrad(:) = nlevcan ! gkw: nlevcan, unless it's buried by snow; could compare elai and tlai. fzeng: need modification if nlevcan>1 - else - stop 'compute_rc: nlevcan not equals 1' - endif - btran = btran_in ! gkw & fzeng: make local copy, because btran is modified in this routine. Confirmed by Randy. - - ! Assign local pointers to pft constants - - c3psn => pftcon%c3psn - leafcn => pftcon%leafcn - flnr => pftcon%flnr - fnitr => pftcon%fnitr - slatop => pftcon%slatop - - !==============================================================================! - ! Photosynthesis and stomatal conductance parameters, from: - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - !==============================================================================! - - ! vcmax25 parameters, from CN - - fnr = 7.16_r8 - act25 = 3.6_r8 !umol/mgRubisco/min - ! Convert rubisco activity units from umol/mgRubisco/min -> umol/gRubisco/s - act25 = act25 * 1000.0_r8 / 60.0_r8 - - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 - - kcha = 79430._r8 - koha = 36380._r8 - cpha = 37830._r8 -!KO vcmaxha = 65330._r8 -!KO jmaxha = 43540._r8 -!KO tpuha = 53100._r8 -!KO - vcmaxha = 72000._r8 - jmaxha = 50000._r8 - tpuha = 72000._r8 -!KO - lmrha = 46390._r8 - - ! High temperature deactivation, from: - ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 - ! The factor "c" scales the deactivation to a value of 1.0 at 25C - -!KO vcmaxhd = 149250._r8 -!KO jmaxhd = 152040._r8 -!KO tpuhd = 150650._r8 -!KO - vcmaxhd = 200000._r8 - jmaxhd = 200000._r8 - tpuhd = 200000._r8 -!KO - lmrhd = 150650._r8 - -!KO vcmaxse = 485._r8 -!KO jmaxse = 495._r8 -!KO tpuse = 490._r8 - lmrse = 490._r8 - -!KO vcmaxc = fth25 (vcmaxhd, vcmaxse) -!KO jmaxc = fth25 (jmaxhd, jmaxse) -!KO tpuc = fth25 (tpuhd, tpuse) - lmrc = fth25 (lmrhd, lmrse) - - ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - - fnps = 0.15_r8 - theta_psii = 0.7_r8 - theta_ip = 0.95_r8 - - do nv = 1,nveg ! gkw: loop over the four vegetation types - - do n = 1,nlevcan ! fzeng: need modification if nlevcan>1 - tlai_z(:,n) = tlai(:,nv) ! gkw: tlai - lai_z(:,n) = lai(:,nv) ! gkw: lai - par_z(:,n) = apar(:,nv) ! gkw: par - end do - - do p = 1,nch ! gkw: loop over tiles - - if(ityp(p,nv) > 0) then - - g = p ! fzeng: do so to allow fewer modifications from the original CLM4.5 code - ivt = ityp(p,nv) ! mapped vegetation type into CLM PFT - - ! Modification for shrubs proposed by X.D.Z - ! Why does he prefer this line here instead of in subr. - ! CanopyFluxes? (slevis) - ! Equivalent modification for soy following AgroIBIS -#if (defined CNDV) - if (ivt == nbrdlf_dcd_tmp_shrub .or. ivt == nbrdlf_dcd_tmp_shrub2) btran(p) = min(1._r8, btran(p) * 3.33_r8) ! gkw: should we do this for the seasonal deciduous split type? -#endif - if (ivt == nsoybean .or. ivt == nsoybeanirrig) btran(p) = min(1._r8, btran(p) * 1.25_r8) - - ! C3 or C4 photosynthesis logical variable - - if (nint(c3psn(ivt)) == 1) then - c3flag(p) = .true. - else if (nint(c3psn(ivt)) == 0) then - c3flag(p) = .false. - end if - - ! C3 and C4 dependent parameters - - if (c3flag(p)) then - qe(p) = 0._r8 - theta_cj(p) = 0.98_r8 - bbbopt(p) = 10000._r8 - mbbopt(p) = 9._r8 - else - qe(p) = 0.05_r8 - theta_cj(p) = 0.80_r8 - bbbopt(p) = 40000._r8 - mbbopt(p) = 4._r8 - end if - - ! Soil water stress applied to Ball-Berry parameters - - bbb(p) = max (bbbopt(p)*btran(p), 1._r8) - mbb(p) = mbbopt(p) - - ! kc, ko, cp, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! - ! kc25 = 404.9 umol/mol - ! ko25 = 278.4 mmol/mol - ! cp25 = 42.75 umol/mol - ! - ! Derive sco from 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 = (404.9_r8 / 1.e06_r8) * forc_pbot(g) - ko25 = (278.4_r8 / 1.e03_r8) * forc_pbot(g) - sco = 0.5_r8 * 0.209_r8 / (42.75_r8 / 1.e06_r8) - cp25 = 0.5_r8 * oair(p) / sco - - kc(p) = kc25 * ft(t_veg(p), kcha) - ko(p) = ko25 * ft(t_veg(p), koha) - cp(p) = cp25 * ft(t_veg(p), cpha) - - endif - - 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 p = 1,nch ! gkw: loop over tiles - - if(ityp(p,nv) > 0) then - - g = p - ivt = ityp(p,nv) ! mapped vegetation type into CLM PFT - - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - - lnc(p) = 1._r8 / (slatop(ivt) * leafcn(ivt)) - - ! vcmax25 at canopy top, as in CN but using lnc at top of the canopy - - vcmax25top = lnc(p) * flnr(ivt) * fnr * act25 * dayl_factor(p) -!#ifndef CN -! vcmax25top = vcmax25top * fnitr(ivt) -!#else - if ( CNAllocation_Carbon_only() ) vcmax25top = vcmax25top * fnitr(ivt) -!#endif - - ! 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. - -!KO jmax25top = 1.97_r8 * vcmax25top -!KO - jmax25top = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrz),11._r8),35._r8)) * vcmax25top -!KO - tpu25top = 0.167_r8 * vcmax25top - kp25top = 20000._r8 * vcmax25top - - ! 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 (defined CN) - ! 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 - ! Leaf maintenance respiration in proportion to vcmax25top - - if (c3flag(p)) then - lmr25top = vcmax25top * 0.015_r8 - else - lmr25top = vcmax25top * 0.025_r8 - end if - -#endif - - ! 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) ! gkw: only one canopy layer, this will be 0 if vegetation covered by snow; use 1 for now - - ! 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 = vcmaxcint(p,nv) - else if (nlevcan > 1) then - nscaler = exp(-kn(p) * laican) - end if - - ! Maintenance respiration - - lmr25 = lmr25top * nscaler - if (c3flag(p)) then - lmr_z(p,iv) = lmr25 * ft(t_veg(p), lmrha) * fth(t_veg(p), lmrhd, lmrse, lmrc) - else - lmr_z(p,iv) = lmr25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) - lmr_z(p,iv) = lmr_z(p,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) - end if - - if (par_z(p,iv) <= 0._r8) then ! night time - - vcmax_z(p,iv) = 0._r8 - jmax_z(p,iv) = 0._r8 - tpu_z(p,iv) = 0._r8 - kp_z(p,iv) = 0._r8 - -!! fzeng: comment out C13 for now. Add it back later!! -! if ( use_c13 ) then -! alphapsn(p) = 1._r8 -! end if - - else ! day time - - vcmax25 = vcmax25top * nscaler - jmax25 = jmax25top * nscaler - tpu25 = tpu25top * nscaler - kp25 = kp25top * nscaler - - ! Adjust for temperature - -!KO - vcmaxse = 668.39_r8 - 1.07_r8 * min(max((t10(p)-tfrz),11._r8),35._r8) - jmaxse = 659.70_r8 - 0.75_r8 * min(max((t10(p)-tfrz),11._r8),35._r8) - tpuse = vcmaxse - vcmaxc = fth25 (vcmaxhd, vcmaxse) - jmaxc = fth25 (jmaxhd, jmaxse) - tpuc = fth25 (tpuhd, tpuse) -!KO - vcmax_z(p,iv) = vcmax25 * ft(t_veg(p), vcmaxha) * fth(t_veg(p), vcmaxhd, vcmaxse, vcmaxc) - jmax_z(p,iv) = jmax25 * ft(t_veg(p), jmaxha) * fth(t_veg(p), jmaxhd, jmaxse, jmaxc) - tpu_z(p,iv) = tpu25 * ft(t_veg(p), tpuha) * fth(t_veg(p), tpuhd, tpuse, tpuc) - - if (.not. c3flag(p)) then - vcmax_z(p,iv) = vcmax25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) - vcmax_z(p,iv) = vcmax_z(p,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg(p)) )) - vcmax_z(p,iv) = vcmax_z(p,iv) / (1._r8 + exp( 0.3_r8*(t_veg(p)-(tfrz+40._r8)) )) - end if - - kp_z(p,iv) = kp25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) - - end if - - ! Adjust for soil water - - vcmax_z(p,iv) = vcmax_z(p,iv) * btran(p) - lmr_z(p,iv) = lmr_z(p,iv) * btran(p) - - end do ! canopy layer loop - endif - end do ! fzeng: tile loop - - !==============================================================================! - ! Leaf-level photosynthesis and stomatal conductance - !==============================================================================! - - rsmax0 = 2.e4_r8 - - do p = 1,nch ! gkw: loop over tiles - - if(ityp(p,nv) > 0) then - - g = p - ivt = ityp(p,nv) ! mapped vegetation type into CLM PFT - - ! Leaf boundary layer conductance, umol/m**2/s - - cf = forc_pbot(g)/(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(p,iv) <= 0._r8) then ! night time - - ac(p,iv) = 0._r8 - aj(p,iv) = 0._r8 - ap(p,iv) = 0._r8 - ag(p,iv) = 0._r8 - an(p,iv) = ag(p,iv) - lmr_z(p,iv) - psn_z(p,iv) = 0._r8 - psn_wc_z(p,iv) = 0._r8 - psn_wj_z(p,iv) = 0._r8 - psn_wp_z(p,iv) = 0._r8 - rs_z(p,iv) = min(rsmax0, 1._r8/bbb(p) * cf) - ci_z(p,iv) = 0._r8 -!KO - rh_leaf(p) = 0._r8 -!KO - - else ! day time - - !now the constraint is no longer needed, Jinyun Tang - ceair = min( eair(p), esat_tv(p) ) - rh_can = ceair / esat_tv(p) - - ! Electron transport rate for C3 plants. Convert par from W/m2 to - ! umol photons/m**2/s using the factor 4.6 - - qabs = 0.5_r8 * (1._r8 - fnps) * par_z(p,iv) * 4.6_r8 - aquad = theta_psii - bquad = -(qabs + jmax_z(p,iv)) - cquad = qabs * jmax_z(p,iv) - call quadratic (aquad, bquad, cquad, r1, r2) - je(p) = min(r1,r2) - - ! Iterative loop for ci beginning with initial guess - - if (c3flag(p)) then - ci_z(p,iv) = 0.7_r8 * cair(p) - else - ci_z(p,iv) = 0.4_r8 * cair(p) - end if - - niter = 0 - - ! Increment iteration counter. Stop if too many iterations - - niter = niter + 1 - - ! Save old ci - - ciold = ci_z(p,iv) - - !find ci and stomatal conductance - - ! gkw & fzeng: modified the arguments - call hybrid(ciold, gb_mol(p), je(p), cair(p), oair(p), & - lmr_z(p,iv), par_z(p,iv), rh_can, gs_mol(p,iv), niter, & - c3flag(p), vcmax_z(p,iv), cp(p), kc(p), ko(p), qe(p), tpu_z(p,iv), kp_z(p,iv), & - theta_cj(p), forc_pbot(g), bbb(p), mbb(p), ac(p,iv), aj(p,iv), ap(p,iv), ag(p,iv), an(p,iv)) - - ! End of ci iteration. Check for an < 0, in which case gs_mol = bbb - - ! Modified by Jinyun Tang, Jan 2017 - ! if (an(p,iv) < 0._r8) gs_mol(p,iv) = bbb(p) - ! Brutely force an to zero if gs_mol is at its minimal value - if(abs(gs_mol(p,iv)-bbb(p))<1.e-14_r8) then - an(p,iv)=1.e-20 ! 0._r8 - ag(p,iv)=max(lmr_z(p,iv),1.e-20) ! lmr_z(p,iv) - end if - - ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) - - cs = cair(p) - 1.4_r8/gb_mol(p) * an(p,iv) * forc_pbot(g) - cs = max(cs,1.e-06_r8) - -! ci_z(p,iv) = cair(p) - an(p,iv) * forc_pbot(g) * (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv)) - - ! suggested by Jinyun Tang, Jan 2017: only update ci_z when gs_mol(p,iv) is very close to bbb - if(abs(gs_mol(p,iv)-bbb(p))<1.e-14_r8) then - ci_z(p,iv) = cair(p) - an(p,iv) * forc_pbot(g) * (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv)) - else - ci_z(p,iv) = ciold - end if - - ! Make sure ci is correct. fzeng, 24 Jan 2017 - if(an(p,iv)<0) then - print *, 'negative an:',an(p,iv) - stop 'Photosynthesis: negative an' - end if - if(ci_z(p,iv)<0. .or. ci_z(p,iv)>cair(p)) then - print *, 'ci out of bound:',ci_z(p,iv),'cair:',cair(p) - print *, 'an:',an(p,iv),'forc_pbot:',forc_pbot(g),'gs_mol:',gs_mol(p,iv),'gb_mol:',gb_mol(p),'bbb:',bbb(p) - stop 'Photosynthesis: ci out of bound' - end if - - ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) - - gs = gs_mol(p,iv) / cf - rs_z(p,iv) = min(1._r8/gs, rsmax0) - - ! Photosynthesis. Save rate-limiting photosynthesis - - psn_z(p,iv) = ag(p,iv) - - psn_wc_z(p,iv) = 0._r8 - psn_wj_z(p,iv) = 0._r8 - psn_wp_z(p,iv) = 0._r8 - if (ac(p,iv) <= aj(p,iv) .and. ac(p,iv) <= ap(p,iv)) then - psn_wc_z(p,iv) = psn_z(p,iv) - else if (aj(p,iv) < ac(p,iv) .and. aj(p,iv) <= ap(p,iv)) then - psn_wj_z(p,iv) = psn_z(p,iv) - else if (ap(p,iv) < ac(p,iv) .and. ap(p,iv) < aj(p,iv)) then - psn_wp_z(p,iv) = psn_z(p,iv) - end if - - ! Make sure iterative solution is correct - - if (gs_mol(p,iv) < 0._r8) then - write (iulog,*) 'Negative stomatal conductance:' - write (iulog,*) gs_mol(p,iv) - stop ! call endrun() - end if - - ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b - - hs = (gb_mol(p)*ceair + gs_mol(p,iv)*esat_tv(p)) / ((gb_mol(p)+gs_mol(p,iv))*esat_tv(p)) -!KO - rh_leaf(p) = hs -!KO - gs_mol_err = mbb(p)*max(an(p,iv), 0._r8)*hs/cs*forc_pbot(g) + bbb(p) - -!! if (abs(gs_mol(p,iv)-gs_mol_err) > 1.e-01_r8) then ! gkw: too stringent for 32-bit real - if (abs(gs_mol(p,iv)-gs_mol_err) > 1.e-6*gs_mol_err) then - write (iulog,*) 'Ball-Berry error check - stomatal conductance error:' - write (iulog,*) gs_mol(p,iv), gs_mol_err - end if - - end if ! night or day if branch - end do ! canopy layer loop - end if ! vegetated or not if branch - end do ! tile 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 p = 1,nch - - if(ityp(p,nv) > 0) then - - psncan = 0._r8 - psncan_wc = 0._r8 - psncan_wj = 0._r8 - psncan_wp = 0._r8 - lmrcan = 0._r8 - gscan = 0._r8 - cican = 0._r8 ! gkw: for sif calculation - laican = 0._r8 - do iv = 1, nrad(p) - psncan = psncan + psn_z(p,iv) * lai_z(p,iv) - psncan_wc = psncan_wc + psn_wc_z(p,iv) * lai_z(p,iv) - psncan_wj = psncan_wj + psn_wj_z(p,iv) * lai_z(p,iv) - psncan_wp = psncan_wp + psn_wp_z(p,iv) * lai_z(p,iv) - lmrcan = lmrcan + lmr_z(p,iv) * lai_z(p,iv) - gscan = gscan + lai_z(p,iv) / (rb(p)+rs_z(p,iv)) - cican = cican + ci_z(p,iv) * lai_z(p,iv) - laican = laican + lai_z(p,iv) - end do - if (laican > 0._r8) then - psn(p,nv) = psncan / laican - psn_wc(p) = psncan_wc / laican - psn_wj(p) = psncan_wj / laican - psn_wp(p) = psncan_wp / laican - lmr(p,nv) = lmrcan / laican - cican = cican / laican - rs(p,nv) = laican / gscan - rb(p) - - ! fluorescence; code from Jung-Eun Lee, implemented & modified by gkw 1/28/14; adapted from stomata 8/15/15; needs work - - if(apar(p,nv) > 0.) then - ivt = ityp(p,nv) - - ! fzeng: assume pftcon%qe25 values in CN_Driver just to get the code compiling. - ! Need to ask Jung-Eun Lee for the CLM4.5 version of fluorescence calculation!! - ppf = 4.6 * apar(p,nv) ! gkw: taken from stomata, may not be correct usage - j = ppf * pftcon%qe25(ivt) ! gkw: taken from stomata; may not be correct usage - - je_sif = max(psn(p,nv)*(cican+2.*cp(p))/max(cican+2.*cp(p)-3.*c3psn(ivt)*cp(p),1.e-8) , 0.) ! gkw: may not be correct here - - xn=1.-je_sif/j ! gkw: 0.8 factor removed 20141108 (email from Jung-Eun) ! gkw: could use je(p) here... - xn=max(xn,0.) ! gkw: added 1/31/14 - - if (psn_wj(p) <= 0.) xn=0. - call fluorescence(xn,fs) - sif(p,nv) = fs*ppf - else - sif(p,nv) = 0. - endif - - else ! vegetated point but LAI=0 - psn(p,nv) = 0._r8 - psn_wc(p) = 0._r8 - psn_wj(p) = 0._r8 - psn_wp(p) = 0._r8 - lmr(p,nv) = 0._r8 - rs(p,nv) = rsmax0 - sif(p,nv) = 0._r8 - end if - - else - -! noveg: ITYP=0 -! ------------- - psn(p,nv) = 0. - psn_wc(p) = 0. - psn_wj(p) = 0. - psn_wp(p) = 0. - lmr(p,nv) = 0. - rs(p,nv) = rsmax0 - sif(p,nv) = 0. - - endif - end do - - end do ! end FVEG loop - - end subroutine Photosynthesis - -!------------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: ci_func -! -! !INTERFACE: - subroutine ci_func(ci, fval, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - - ! - !! 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 clmtype structure. - - ! !REVISION HISTORY: - ! Dec 14, 2012: Created by Jinyun Tang - ! - !!USES - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - use clmtype - - ! - !!ARGUMENTS: - implicit none - - 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 - 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) - -! gkw & fzeng: make the following argument list variables; modify this subroutine, hybrid, and brent - logical, intent(in) :: c3flag ! true if C3 and false if C4 - real(r8), intent(in) :: vcmax_z ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: cp ! CO2 compensation point (Pa) - real(r8), intent(in) :: kc ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(in) :: ko ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(in) :: qe ! quantum efficiency, used only for C4 (mol CO2 / mol photons) - real(r8), intent(in) :: tpu_z ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8), intent(in) :: kp_z ! initial slope of CO2 response curve (C4 plants) - real(r8), intent(in) :: theta_cj ! empirical curvature parameter for ac, aj photosynthesis co-limitation - real(r8), intent(in) :: forc_pbot ! atmospheric pressure (Pa) - real(r8), intent(in) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8), intent(in) :: mbb ! Ball-Berry slope of conductance-photosynthesis relationship - real(r8), intent(out) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: ap ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: ag ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: an ! net leaf photosynthesis (umol CO2/m**2/s) - -!!CALLED FROM: -! subroutine hybrid and brent in this module - - !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 - real(r8) :: fnps ! fraction of light absorbed by non-photosynthetic pigments - real(r8) :: theta_psii ! empirical curvature parameter for electron transport rate - real(r8) :: theta_ip ! empirical curvature parameter for ap photosynthesis co-limitation - - ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - fnps = 0.15_r8 - theta_psii = 0.7_r8 - theta_ip = 0.95_r8 - - if (c3flag) then - - ! C3: Rubisco-limited photosynthesis - ac = vcmax_z * max(ci-cp, 0._r8) / (ci+kc*(1._r8+oair/ko)) - - ! C3: RuBP-limited photosynthesis - aj = je * max(ci-cp, 0._r8) / (4._r8*ci+8._r8*cp) - - ! C3: Product-limited photosynthesis - ap = 3._r8 * tpu_z - - else - - ! C4: Rubisco-limited photosynthesis - ac = vcmax_z - - ! C4: RuBP-limited photosynthesis - aj = qe * par_z * 4.6_r8 - - ! C4: PEP carboxylase-limited (CO2-limited) - ap = kp_z * max(ci, 0._r8) / forc_pbot - - end if - - ! Gross photosynthesis. First co-limit ac and aj. Then co-limit ap - - aquad = theta_cj - bquad = -(ac + aj) - cquad = ac * aj - call quadratic (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) - - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic (aquad, bquad, cquad, r1, r2) - ag = min(r1,r2) - - ! Net photosynthesis. Exit iteration if an < 0 - - an = ag - lmr_z -! if (an < 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 - - if(an<=0.0)then - gs_mol=bbb - if(aj<=1.e-20_r8)then - fval = 0._r8 - else - fval = ci-cair - endif - else - cs = cair - 1.4_r8/gb_mol * an * forc_pbot - cs = max(cs,1.e-06_r8) - aquad = cs - bquad = cs*(gb_mol - bbb) - mbb*an*forc_pbot - cquad = -gb_mol*(cs*bbb + mbb*an*forc_pbot*rh_can) - call quadratic (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - ! Derive new estimate for ci - fval = ci - cair + an * forc_pbot * (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) - endif - - end subroutine ci_func - -!------------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: quadratic -! -! !INTERFACE: - 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. -! -! !CALLED FROM: -! subroutine Photosynthesis in this module -! -! !REVISION HISTORY: -! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson -! -! !USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - 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 - - integer :: iulog = 6 ! gkw -!------------------------------------------------------------------------------ - - if (a == 0._r8) then - write (iulog,*) 'Quadratic solution error: a = ',a - stop ! call endrun() - end if - - if (b >= 0._r8) then - q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) - else - q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) - end if - - r1 = q / a - if (q /= 0._r8) then - r2 = c / q - else - r2 = 1.e36_r8 - end if - - end subroutine quadratic - -!------------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: brent -! -! !INTERFACE: - subroutine brent(x, x1, x2, f1, f2, tol, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - - ! - !!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 - ! - !!USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - - ! - !!ARGUMENTS: - implicit none - - 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 - real(r8), intent(out) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) - -! gkw & fzeng: make the following argument list variables; modify this subroutine, hybrid, and brent - logical, intent(in) :: c3flag ! true if C3 and false if C4 - real(r8), intent(in) :: vcmax_z ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: cp ! CO2 compensation point (Pa) - real(r8), intent(in) :: kc ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(in) :: ko ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(in) :: qe ! quantum efficiency, used only for C4 (mol CO2 / mol photons) - real(r8), intent(in) :: tpu_z ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8), intent(in) :: kp_z ! initial slope of CO2 response curve (C4 plants) - real(r8), intent(in) :: theta_cj ! empirical curvature parameter for ac, aj photosynthesis co-limitation - real(r8), intent(in) :: forc_pbot ! atmospheric pressure (Pa) - real(r8), intent(in) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8), intent(in) :: mbb ! Ball-Berry slope of conductance-photosynthesis relationship - real(r8), intent(out) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: ap ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: ag ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: an ! net leaf photosynthesis (umol CO2/m**2/s) - -! !CALLED FROM: -! subroutine hybrid in this module - - integer, parameter :: ITMAX=30 !maximum number of iterations, increased from 20 to 30 by Jinyun Tang, Jan 2017 - 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 - - integer :: iulog = 6 ! gkw - - 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' - stop 'brent' ! call endrun() - 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, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - if(abs(fb)<1.e-5_r8) then - exit - endif - enddo -! if(iter==ITMAX)write(iulog,*) 'brent exceeding maximum iterations', b, fb - x=b - return - end subroutine brent - -!------------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: hybrid -! -! !INTERFACE: - - subroutine hybrid(x0, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, iter, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - ! - !! 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 - !Jan 2017: modified by Jinyun Tang - - ! - !!USES: - use MAPL_ConstantsMod, ONLY: r8 => MAPL_R4 - - ! - !! 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) - 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 - -! gkw & fzeng: make the following argument list variables; modify this subroutine, ci_func, and brent - logical, intent(in) :: c3flag ! true if C3 and false if C4 - real(r8), intent(in) :: vcmax_z ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: cp ! CO2 compensation point (Pa) - real(r8), intent(in) :: kc ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(in) :: ko ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(in) :: qe ! quantum efficiency, used only for C4 (mol CO2 / mol photons) - real(r8), intent(in) :: tpu_z ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8), intent(in) :: kp_z ! initial slope of CO2 response curve (C4 plants) - real(r8), intent(in) :: theta_cj ! empirical curvature parameter for ac, aj photosynthesis co-limitation - real(r8), intent(in) :: forc_pbot ! atmospheric pressure (Pa) - real(r8), intent(in) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - real(r8), intent(in) :: mbb ! Ball-Berry slope of conductance-photosynthesis relationship - real(r8), intent(out) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: ap ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: ag ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8), intent(out) :: an ! net leaf photosynthesis (umol CO2/m**2/s) - -! !CALLED FROM: -! subroutine photosynthesis in this module - - !local variables - 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 - - real(r8) :: ci_val(5) - real(r8) :: fi_val(5) - integer :: ii, mi - - integer :: iulog = 6 - - iter=0 - call ci_func(x0, f0, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - if(abs(f0) < 1.e-14_r8)return - ci_val(3)=x0 - fi_val(3)=f0 - - !compute the minimum ci value - if(c3flag)then - ci_val(1)=cp+1.e-6_r8 - else - ci_val(1)=1.e-6_r8 - endif - call ci_func(ci_val(1), fi_val(1), gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - - ci_val(2)=(ci_val(1)+ci_val(3))*0.5 - call ci_func(ci_val(2), fi_val(2), gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - - ci_val(4)=(cair+ci_val(3))*0.5 - call ci_func(ci_val(4), fi_val(4), gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - - !compute the maximum ci value - ci_val(5)=cair*0.999_r8 - call ci_func(ci_val(5), fi_val(5), gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - - mi = -1 - do ii = 1, 4 - if(fi_val(ii)*fi_val(ii+1)<0._r8)then - mi = ii - endif - end do - if(mi > 0)then - - x0 = ci_val(mi) - f0 = fi_val(mi) - x1 = ci_val(mi+1) - f1 = fi_val(mi+1) - tol = 0.5 * (x0 + x1) * eps ! This is missing in Jinyun's modifications. fzeng added following CanopyFluxesMod.F90, 9 Nov 2017 - call brent(x, x0, x1, f0, f1, tol, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - c3flag, vcmax_z, cp, kc, ko, qe, tpu_z, kp_z, theta_cj, forc_pbot, bbb, mbb, ac, aj, ap, ag, an) - - ! fzeng added for debugging, 24 Jan 2017 -! if(an<=0) then -! write(iulog,'(L8,16(X,E15.8),X)')c3flag,ci_val(1),fi_val(1),ci_val(2),fi_val(2),& -! ci_val(3),fi_val(3),ci_val(4),fi_val(4),ci_val(5),fi_val(5),x,& -! ag,an,lmr_z,gs_mol,bbb -! endif - - x0=x - - else - - ! write(iulog,'(I8,13(X,E15.8),X,L8)')p,ci_val(1),fi_val(1),ci_val(2),fi_val(2),& - ! ci_val(3),fi_val(3),ci_val(4),fi_val(4),ci_val(5),fi_val(5),photosyns_vars%aj_patch(p,iv),& - ! photosyns_vars%ag_patch(p,iv),photosyns_vars%an_patch(p,iv), all(fi_val<0._r8) - ! write(iulog,*)'no solution for ci and gs_mol is forced to be the minimum for pft',p - ! write(iulog,*)'no solution found for ci' - ! call endrun(decomp_index=p, clmlevel=namep, msg=errmsg(__FILE__, __LINE__)) - - ! Jinyun commented this print statements out. - ! It seems that when the if condition above is not met, all(fi_val<0) is true. - ! So the aj, ag, an etc. from call ci_func(ci_val(5), fi_val(5) ...) are the final output of hybrid. - ! fzeng, 9 Nov 2017 - -! write(iulog,*)'no solution found for ci' -! write(iulog,'(L8,16(X,E15.8),X,L8)')c3flag,ci_val(1),fi_val(1),ci_val(2),fi_val(2),& -! ci_val(3),fi_val(3),ci_val(4),fi_val(4),ci_val(5),fi_val(5),aj,& -! ag,an,lmr_z,gs_mol,bbb,all(fi_val<0._r8) - - x0=ci_val(5) ! fzeng, 9 Nov 2017 - - endif - - end subroutine hybrid - -!------------------------------------------------------------------------------ -! -! !IROUTINE: Fluorescence -! -! !INTERFACE: - subroutine fluorescence(x,fs) -! -! !DESCRIPTION: -! Chlorophyll fluorescence -! writen by Jung-Eun Lee using van der Tol and Berry (2012) - -! !USES: - implicit none - real, intent(in) :: x ! degree of light saturation - real, intent(out) :: fs ! fluorescence yield - real :: Kn ! rate constant for non-photochemical quenching - real :: Kf ! rate constant for fluorescence - real :: Kd ! rate constant for thermal deactivation at Fm - real :: Kp ! rate constant for photochemisty - real :: po0 - real :: ps - real :: fo0 - real :: fo ! fluorescnce yield at Fo - real :: fm ! fluorescnce yield at Fm - real :: fm0 - real :: eta - real :: qQ - real :: qE - - Kf = 0.05 ! rate constant for fluorescence - Kd = 0.95 ! rate constant for thermal deactivation at Fm - Kp = 4.0 ! rate constant for photochemisty - - po0 = Kp/(Kf+Kd+Kp) ! dark photochemistry fraction (Genty et al., 1989) - ps = po0*(1.-x) ! photochemical yield - Kn = (6.2473 * x - 0.5944)*x ! empirical fit to Flexas' data -! Kn = (3.9867 * x - 1.0589)*x ! empirical fit to Flexas, Daumard, Rascher, Berry data - - fo0 = Kf/(Kf+Kp+Kd) ! dark adapted fluorescence yield Fo - fo = Kf/(Kf+Kp+Kd+Kn) ! dark adapted fluorescence yield Fo - fm = Kf/(Kf +Kd+Kn) ! light adapted fluorescence yield Fm - fm0 = Kf/(Kf +Kd) ! light adapted fluorescence yield Fm - fs = fm*(1.-ps) ! fluorescence as fraction of PAR - eta = fs/fo0 ! fluorescence as fraction of dark adapted - - qQ = 1.-(fs-fo)/(fm-fo) ! photochemical quenching - qE = 1.-(fm-fo)/(fm0-fo0) !non-photochemical quenching - - end subroutine fluorescence - - end module compute_rc_mod - 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 deleted file mode 100644 index 1f178058f..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/getco2.F90 +++ /dev/null @@ -1,144 +0,0 @@ -!------------------------------------------------------------------------- -!NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1, GEOS/DAS! -!------------------------------------------------------------------------- -!BOP -! -! !INTERFACE: - - REAL FUNCTION GetCO2(Year, DayOfYear) - -! !DESCRIPTION: -! -! Given the year and day-of-year, this function returns the RCP45 CO2 concentration in -! mole fraction (volume mixing ratio). If Year is less than 1765, the value for 1765 -! is returned. If Year is greater than 2150, the value for 2150 is returned. In the -! original dataset, the value for 2150 is used for all years through 2500. We choose -! to truncate the list at 2151 for this application. -! -! DayOfYear is expected to have a value of 1.00 at 0:00 UTC Jan 1. -! -! In-line documentation from the source dataset is reproduced below: -! -! RCP45 Midyear Atmospheric CO2 Concentrations (ppmv) -! -! CONTENT: CMIP5 recommendations for annual average, global mean concentrations. -! RUN: RCP4.5, FINAL RELEASE, 26 Nov. 2009 -! RCP4.5 CONTACT: MiniCAM group, Allison Thomson (Allison.Thomson@pnl.gov) -! DATE: 26/11/2009 09:00:37 (updated description, 30 May 2010) -! MAGICC-VERSION: 6.3.09, 25 November 2009 -! FILE PRODUCED BY: RCP Concentration Calculation & Data Group, M. Meinshausen, S. Smith, -! K. Riahi, D. van Vuuren -! DOCUMENTATION: M. Meinshausen, S. Smith et al. "The RCP GHG concentrations and -! their extension from 1765 to 2500", in prep., Climatic Change. -! CMIP5 INFO: http://cmip-pcmdi.llnl.gov/cmip5/ -! RCP DATABASE: http://www.iiasa.ac.at/web-apps/tnt/RcpDb -! FURTHER INFO: For data sources, aknowledgements and further information, see -! http://www.pik-potsdam.de/~mmalte/rcps -! NOTES: RCP4.5 starts 2005; 20th century data and earlier is provided for -! convenience. -! -! !REVISION HISTORY: -! 29 Oct 2010 Nielsen, adapted for GEOS-5. -! -!EOP -! --------------------------------------------------------------------------------- - - IMPLICIT NONE - INTEGER, INTENT(IN) :: Year - INTEGER, INTENT(IN) :: DayOfYear - - REAL :: f,i,n - INTEGER :: previous,current,next - - INTEGER, PARAMETER :: firstYear = 1764 - INTEGER, PARAMETER :: finalYear = 2151 - INTEGER, PARAMETER :: tableLength = finalYear-firstYear+1 - - REAL, SAVE :: CO2ppmv(tableLength) = (/ 278.052, & - 278.052, 278.106, 278.220, 278.343, 278.471, 278.600, 278.733, 278.869, & - 279.009, 279.153, 279.302, 279.457, 279.618, 279.782, 279.943, 280.097, & - 280.243, 280.382, 280.518, 280.657, 280.803, 280.957, 281.118, 281.282, & - 281.443, 281.598, 281.747, 281.891, 282.031, 282.167, 282.299, 282.427, & - 282.551, 282.671, 282.787, 282.899, 283.007, 283.111, 283.211, 283.307, & - 283.400, 283.490, 283.578, 283.661, 283.735, 283.797, 283.847, 283.889, & - 283.926, 283.963, 284.001, 284.043, 284.086, 284.129, 284.167, 284.198, & - 284.223, 284.244, 284.263, 284.281, 284.300, 284.320, 284.340, 284.360, & - 284.380, 284.400, 284.385, 284.280, 284.125, 283.975, 283.825, 283.675, & - 283.525, 283.425, 283.400, 283.400, 283.425, 283.500, 283.600, 283.725, & - 283.900, 284.075, 284.225, 284.400, 284.575, 284.725, 284.875, 285.000, & - 285.125, 285.275, 285.425, 285.575, 285.725, 285.900, 286.075, 286.225, & - 286.375, 286.500, 286.625, 286.775, 286.900, 287.000, 287.100, 287.225, & - 287.375, 287.525, 287.700, 287.900, 288.125, 288.400, 288.700, 289.025, & - 289.400, 289.800, 290.225, 290.700, 291.200, 291.675, 292.125, 292.575, & - 292.975, 293.300, 293.575, 293.800, 294.000, 294.175, 294.325, 294.475, & - 294.600, 294.700, 294.800, 294.900, 295.025, 295.225, 295.500, 295.800, & - 296.125, 296.475, 296.825, 297.200, 297.625, 298.075, 298.500, 298.900, & - 299.300, 299.700, 300.075, 300.425, 300.775, 301.100, 301.400, 301.725, & - 302.075, 302.400, 302.700, 303.025, 303.400, 303.775, 304.125, 304.525, & - 304.975, 305.400, 305.825, 306.300, 306.775, 307.225, 307.700, 308.175, & - 308.600, 309.000, 309.400, 309.750, 310.000, 310.175, 310.300, 310.375, & - 310.375, 310.300, 310.200, 310.125, 310.100, 310.125, 310.200, 310.325, & - 310.500, 310.750, 311.100, 311.500, 311.925, 312.425, 313.000, 313.600, & - 314.225, 314.848, 315.500, 316.272, 317.075, 317.795, 318.397, 318.925, & - 319.647, 320.647, 321.605, 322.635, 323.902, 324.985, 325.855, 327.140, & - 328.677, 329.742, 330.585, 331.747, 333.272, 334.848, 336.525, 338.360, & - 339.728, 340.793, 342.198, 343.783, 345.283, 346.797, 348.645, 350.737, & - 352.487, 353.855, 355.017, 355.885, 356.777, 358.128, 359.837, 361.462, & - 363.155, 365.323, 367.348, 368.865, 370.467, 372.522, 374.760, 376.812, & - 378.812, 380.828, 382.777, 384.800, 386.952, 389.128, 391.274, 393.421, & - 395.583, 397.764, 399.966, 402.184, 404.411, 406.643, 408.882, 411.129, & - 413.378, 415.639, 417.936, 420.274, 422.656, 425.080, 427.538, 430.021, & - 432.523, 435.046, 437.589, 440.131, 442.664, 445.207, 447.770, 450.355, & - 452.963, 455.586, 458.215, 460.845, 463.475, 466.093, 468.678, 471.234, & - 473.780, 476.328, 478.881, 481.438, 483.993, 486.535, 489.060, 491.536, & - 493.932, 496.244, 498.474, 500.645, 502.768, 504.847, 506.884, 508.871, & - 510.799, 512.647, 514.401, 516.065, 517.629, 519.096, 520.488, 521.818, & - 523.089, 524.302, 525.451, 526.509, 527.457, 528.296, 529.027, 529.643, & - 530.144, 530.553, 530.883, 531.138, 531.319, 531.490, 531.702, 531.942, & - 532.205, 532.487, 532.776, 533.070, 533.388, 533.741, 534.131, 534.558, & - 535.011, 535.480, 535.955, 536.435, 536.920, 537.399, 537.871, 538.358, & - 538.872, 539.388, 539.884, 540.352, 540.782, 541.168, 541.510, 541.808, & - 542.053, 542.246, 542.408, 542.559, 542.712, 542.866, 543.013, 543.139, & - 543.239, 543.311, 543.355, 543.360, 543.327, 543.288, 543.266, 543.264, & - 543.282, 543.310, 543.337, 543.354, 543.361, 543.356, 543.330, 543.283, & - 543.238, 543.208, 543.197, 543.205, 543.223, 543.239, 543.246, 543.242, & - 543.227, 543.190, 543.131, 543.072, 543.025, 542.993, 542.979, 542.973, & - 542.963, 542.955, 542.955 /) - -! Establish location in table for current, previous and next year. -! ---------------------------------------------------------------- - current = Year-firstYear+1 - current = MAX(current,1) - current = MIN(current,tableLength) - - previous = current-1 - previous = MAX(previous,1) - previous = MIN(previous,tableLength) - IF(Year > finalYear) previous = tableLength - - next = current+1 - next = MAX(next,1) - next = MIN(next,tableLength) - IF(Year < firstYear) next = 1 - -! Divide the year into halves. -! ---------------------------- - IF(dayOfYear <= 182) THEN - i = CO2ppmv(previous) - f = CO2ppmv(current) - n = dayOfYear+183 - ELSE - i = CO2ppmv(current) - f = CO2ppmv(next) - n = dayOfYear-183 - END IF - -! Linear interpolation to the given day-of-year. -! ---------------------------------------------- - GetCO2 = i + (f-i)*n/365.00 - -! Convert to mole fraction (volume mixing ratio). -! ----------------------------------------------- - GetCO2 = GetCO2*1.00E-06 - - END FUNCTION GetCO2 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 deleted file mode 100644 index 4f8585ac5..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/pftvarcon.F90 +++ /dev/null @@ -1,57 +0,0 @@ -module pftvarcon - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: pftvarcon -! -! !DESCRIPTION: -! Module containing vegetation constants and method to -! read and initialize vegetation (PFT) constants. -! -! !USES: -! -! !PUBLIC TYPES: - implicit none - save -! -! Vegetation type constants -! -! fzeng: these are CLM types -! - integer, parameter :: noveg = 0 ! Bare - integer, parameter :: ndllf_evr_tmp_tree = 1 ! Needleleaf evergreen temperate tree - integer, parameter :: ndllf_evr_brl_tree = 2 ! Needleleaf evergreen boreal tree - integer, parameter :: ndllf_dcd_brl_tree = 3 ! Needleleaf deciduous boreal tree - integer, parameter :: nbrdlf_evr_trp_tree = 4 ! Broadleaf evergreen tropical tree - integer, parameter :: nbrdlf_evr_tmp_tree = 5 ! Broadleaf evergreen temperate tree - integer, parameter :: nbrdlf_dcd_trp_tree = 6 ! Broadleaf deciduous tropical tree - integer, parameter :: nbrdlf_dcd_tmp_tree = 7 ! Broadleaf deciduous temperate tree - integer, parameter :: nbrdlf_dcd_brl_tree = 8 ! Broadleaf deciduous boreal tree - integer, parameter :: nbrdlf_evr_shrub = 9 ! Broadleaf evergreen temperate shrub - integer, parameter :: nbrdlf_dcd_tmp_shrub = 10 ! Broadleaf deciduous temperate shrub [moisture + deciduous] - integer, parameter :: nbrdlf_dcd_tmp_shrub2 = 11 ! Broadleaf deciduous temperate shrub [moisture stress only] - integer, parameter :: nbrdlf_dcd_brl_shrub = 12 ! Broadleaf deciduous boreal shrub - integer, parameter :: nc3_arctic_grass = 13 ! Arctic c3 grass - integer, parameter :: nc3_nonarctic_grass = 14 ! Cool c3 grass [moisture + deciduous] - integer, parameter :: nc3_nonarctic_grass2 = 15 ! Cool c3 grass [moisture stress only] - integer, parameter :: nc4_grass = 16 ! Warm c4 grass [moisture + deciduous] - integer, parameter :: nc4_grass2 = 17 ! Warm c4 grass [moisture stress only] - integer, parameter :: nc3crop = 18 ! C3_crop [moisture + deciduous] - integer, parameter :: nc3crop2 = 19 ! C3_crop [moisture stress only] -! Although we don't use prognostic crops, we need to keep these below because the CN code needs npcropmin, fzeng, 10 May 2018 - integer, parameter :: ncorn = 20 ! Corn - integer, parameter :: ncornirrig = 21 ! Irrigated corn - integer, parameter :: nscereal = 22 ! Spring temperate cereal - integer, parameter :: nscerealirrig = 23 ! Irrigated spring temperate cereal - integer, parameter :: nwcereal = 24 ! winter temperate cereal - integer, parameter :: nwcerealirrig = 25 ! Irrigated winter temperate cereal - integer, parameter :: nsoybean = 26 ! Soybean - integer, parameter :: nsoybeanirrig = 27 ! Irrigated Soybean - - integer, parameter :: ntree = nbrdlf_dcd_brl_tree !value for last type of tree - integer, parameter :: npcropmin = ncorn ! first prognostic crop - integer, parameter :: npcropmax = nsoybeanirrig ! last prognostic crop in list - -end module pftvarcon - 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 deleted file mode 100644 index 9a1de71ef..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/subgridAveMod.F90 +++ /dev/null @@ -1,314 +0,0 @@ -module subgridAveMod - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: subgridAveMod -! -! !DESCRIPTION: -! Utilities to perfrom subgrid averaging -! -! !USES: - use clmtype - use clm_varcon, only : spval -! use abortutils, only : endrun - -! !PUBLIC TYPES: - implicit none - save -! -! !PUBLIC MEMBER FUNCTIONS: - public :: p2c ! Perfrom an average from pfts to columns - - interface p2c - module procedure p2c_1d - module procedure p2c_2d - module procedure p2c_1d_filter - module procedure p2c_2d_filter - end interface -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein 12/03 -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: p2c_1d -! -! !INTERFACE: - subroutine p2c_1d (lbp, ubp, lbc, ubc, parr, carr, p2c_scale_type) -! -! !DESCRIPTION: -! Perfrom subgrid-average from pfts to columns. -! Averaging is only done for points that are not equal to "spval". -! -! !USES: - use clm_varpar, only : max_pft_per_col -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: lbp, ubp ! beginning and ending pft - integer , intent(in) :: lbc, ubc ! beginning and ending column - real, intent(in) :: parr(lbp:ubp) ! pft array - real, intent(out) :: carr(lbc:ubc) ! column array - character(len=*), intent(in) :: p2c_scale_type ! scale type -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein 12/03 -! -! -! !LOCAL VARIABLES: -!EOP - integer :: pi,p,c,index ! indices - real :: scale_p2c(lbp:ubp) ! scale factor for column->landunit mapping - logical :: found ! temporary for error check - real :: sumwt(lbc:ubc) ! sum of weights - logical, pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details), fzeng adopted a modified/simpler way to set pactive in CN_Driver - real, pointer :: wtcol(:) ! weight of pft relative to column - integer , pointer :: pcolumn(:) ! column index of corresponding pft - integer , pointer :: npfts(:) ! number of pfts in column - integer , pointer :: pfti(:) ! initial pft index in column -!------------------------------------------------------------------------ - - pactive => pft%active - wtcol => pft%wtcol - pcolumn => pft%column - npfts => col%npfts - pfti => col%pfti - - if (p2c_scale_type == 'unity') then - do p = lbp,ubp - scale_p2c(p) = 1.0 - end do - else - write(6,*)'p2c_1d error: scale type ',p2c_scale_type,' not supported' - stop 12 ! call endrun() - end if - - carr(lbc:ubc) = spval - sumwt(lbc:ubc) = 0. - do p = lbp,ubp - if (pactive(p) .and. wtcol(p) /= 0.) then - if (parr(p) /= spval) then - c = pcolumn(p) - if (sumwt(c) == 0.) carr(c) = 0. - carr(c) = carr(c) + parr(p) * scale_p2c(p) * wtcol(p) - sumwt(c) = sumwt(c) + wtcol(p) - end if - end if - end do - found = .false. - do c = lbc,ubc - if (sumwt(c) > 1.0 + 1.e-6) then - found = .true. - index = c - else if (sumwt(c) /= 0.) then - carr(c) = carr(c)/sumwt(c) - end if - end do - if (found) then - write(6,*)'p2c error: sumwt is greater than 1.0 at c= ',index - stop 13 ! call endrun() - end if - - end subroutine p2c_1d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: p2c_2d -! -! !INTERFACE: - subroutine p2c_2d (lbp, ubp, lbc, ubc, num2d, parr, carr, p2c_scale_type) -! -! !DESCRIPTION: -! Perfrom subgrid-average from landunits to gridcells. -! Averaging is only done for points that are not equal to "spval". -! -! !USES: - use clm_varpar, only : max_pft_per_col -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: lbp, ubp ! beginning and ending pft - integer , intent(in) :: lbc, ubc ! beginning and ending column - integer , intent(in) :: num2d ! size of second dimension - real, intent(in) :: parr(lbp:ubp,num2d) ! pft array - real, intent(out) :: carr(lbc:ubc,num2d) ! column array - character(len=*), intent(in) :: p2c_scale_type ! scale type -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein 12/03 -! -! -! !LOCAL VARIABLES: -!EOP - integer :: j,pi,p,c,index ! indices - real :: scale_p2c(lbp:ubp) ! scale factor for column->landunit mapping - logical :: found ! temporary for error check - real :: sumwt(lbc:ubc) ! sum of weights - logical, pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details), fzeng adopted a modified/simpler way to set pactive in CN_Driver - real, pointer :: wtcol(:) ! weight of pft relative to column - integer , pointer :: pcolumn(:) ! column index of corresponding pft - integer , pointer :: npfts(:) ! number of pfts in column - integer , pointer :: pfti(:) ! initial pft index in column -!------------------------------------------------------------------------ - - pactive => pft%active - wtcol => pft%wtcol - pcolumn => pft%column - npfts => col%npfts - pfti => col%pfti - - if (p2c_scale_type == 'unity') then - do p = lbp,ubp - scale_p2c(p) = 1.0 - end do - else - write(6,*)'p2c_2d error: scale type ',p2c_scale_type,' not supported' - stop 12 ! call endrun() - end if - - carr(:,:) = spval - do j = 1,num2d - sumwt(:) = 0. - do p = lbp,ubp - if (pactive(p) .and. wtcol(p) /= 0.) then - if (parr(p,j) /= spval) then - c = pcolumn(p) - if (sumwt(c) == 0.) carr(c,j) = 0. - carr(c,j) = carr(c,j) + parr(p,j) * scale_p2c(p) * wtcol(p) - sumwt(c) = sumwt(c) + wtcol(p) - end if - end if - end do - found = .false. - do c = lbc,ubc - if (sumwt(c) > 1.0 + 1.e-6) then - found = .true. - index = c - else if (sumwt(c) /= 0.) then - carr(c,j) = carr(c,j)/sumwt(c) - end if - end do - if (found) then - write(6,*)'p2c_2d error: sumwt is greater than 1.0 at c= ',index,' lev= ',j - stop 13 ! call endrun() - end if - end do - end subroutine p2c_2d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: p2c_1d_filter -! -! !INTERFACE: - subroutine p2c_1d_filter (numfc, filterc, pftarr, colarr) -! -! !DESCRIPTION: -! perform pft to column averaging for single level pft arrays -! -! !USES: - use clm_varpar, only : max_pft_per_col -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: numfc - integer , intent(in) :: filterc(numfc) - real, pointer :: pftarr(:) - real, pointer :: colarr(:) -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein 12/03 -! -! -! !LOCAL VARIABLES: -!EOP - integer :: fc,c,pi,p ! indices - logical, pointer :: pactive(:)! true=>do computations on this pft (see reweightMod for details), fzeng adopted a modified/simpler way to set pactive in CN_Driver - integer , pointer :: npfts(:) - integer , pointer :: pfti(:) - integer , pointer :: pftf(:) - real, pointer :: wtcol(:) -! real, pointer :: wtgcell(:) -!----------------------------------------------------------------------- - - pactive => pft%active - npfts => col%npfts - pfti => col%pfti - pftf => col%pftf - wtcol => pft%wtcol -! wtgcell => pft%wtgcell - - do fc = 1,numfc - c = filterc(fc) - colarr(c) = 0. - do p = pfti(c), pftf(c) -! if (wtgcell(p) > 0.) colarr(c) = colarr(c) + pftarr(p) * wtcol(p) - if (pactive(p)) colarr(c) = colarr(c) + pftarr(p) * wtcol(p) - end do - end do - - end subroutine p2c_1d_filter - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: p2c_2d_filter -! -! !INTERFACE: - subroutine p2c_2d_filter (lev, numfc, filterc, pftarr, colarr) -! -! !DESCRIPTION: -! perform pft to column averaging for multi level pft arrays -! -! !USES: - use clm_varpar, only : max_pft_per_col - -! !ARGUMENTS: - implicit none - integer , intent(in) :: lev - integer , intent(in) :: numfc - integer , intent(in) :: filterc(numfc) - real, pointer :: pftarr(:,:) - real, pointer :: colarr(:,:) -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein 12/03 -! -! -! !LOCAL VARIABLES: -!EOP - integer :: fc,c,pi,p,j ! indices - logical , pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details), fzeng adopted a modified/simpler way to set pactive in CN_Driver - integer , pointer :: npfts(:) - integer , pointer :: pfti(:) - integer , pointer :: pftf(:) - real, pointer :: wtcol(:) -!----------------------------------------------------------------------- - - pactive => pft%active - npfts => col%npfts - pfti => col%pfti - pftf => col%pftf - wtcol => pft%wtcol - - do j = 1,lev - do fc = 1,numfc - c = filterc(fc) - colarr(c,j) = 0. - do p = pfti(c), pftf(c) - if (pactive(p)) colarr(c,j) = colarr(c,j) + pftarr(p,j) * wtcol(p) - end do - end do - end do - - end subroutine p2c_2d_filter - -end module subgridAveMod 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 deleted file mode 100644 index db2b3638f..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -esma_set_this () - -string (REPLACE GEOScatchCNCLM45_GridComp_ "" is_openmp ${this}) - -esma_add_subdirectories (CLM45) - -set (srcs - GEOS_CatchCNCLM45GridComp.F90 - ) - -esma_add_library (${this} - SRCS ${srcs} - DEPENDENCIES MAPL GEOS_Shared GEOS_LandShared CLM45 GEOS_CatchCNShared ESMF::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/CLM51/ActiveLayerMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/ActiveLayerMod.F90 new file mode 100644 index 000000000..84b3bc687 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/AnnualFluxDribbler.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/AnnualFluxDribbler.F90 new file mode 100644 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 100644 index 000000000..96dcf78a6 --- /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 + CNCLM_Photosynthesis.F90 + ActiveLayerMod.F90 + atm2lndType.F90 + CanopyStateType.F90 + ch4Mod.F90 + CNDVType.F90 + CNFireBaseMod.F90 + CNProductsMod.F90 + CNVegCarbonFluxType.F90 + CNVegCarbonStateType.F90 + CNVegNitrogenFluxType.F90 + CNVegNitrogenStateType.F90 + CNVegStateType.F90 + ColumnType.F90 + CropType.F90 + decompMod.F90 + CNCLM_DriverMod.F90 + dynSubgridControlMod.F90 + EnergyFluxType.F90 + filterMod.F90 + FireDataBaseType.F90 + FrictionVelocityMod.F90 + GridcellType.F90 + initVerticalMod.F90 + LandunitType.F90 + OzoneBaseMod.F90 + PatchType.F90 + pftconMod.F90 + SaturatedExcessRunoffMod.F90 + SoilBiogeochemCarbonFluxType.F90 + SoilBiogeochemCarbonStateType.F90 + SoilBiogeochemCompetitionMod.F90 + SoilBiogeochemDecompCascadeConType.F90 + SoilBiogeochemNitrogenFluxType.F90 + SoilBiogeochemNitrogenStateType.F90 + SoilBiogeochemStateType.F90 + SoilStateType.F90 + SolarAbsorbedType.F90 + SurfaceAlbedoType.F90 + TemperatureType.F90 + Wateratm2lndBulkType.F90 + Wateratm2lndType.F90 + WaterDiagnosticType.F90 + WaterDiagnosticBulkType.F90 + WaterFluxBulkType.F90 + WaterFluxType.F90 + WaterStateBulkType.F90 + WaterStateType.F90 + 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 + CNCLM_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 100644 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 100644 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 100644 index 000000000..c10a48c9c --- /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/CNCLM_DriverMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_DriverMod.F90 new file mode 100644 index 000000000..3536ef2f5 --- /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 CNCLM_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_Photosynthesis.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_Photosynthesis.F90 new file mode 100644 index 000000000..36e752e47 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_Photosynthesis.F90 @@ -0,0 +1,538 @@ + 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,sifsun_out,sifsha_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 + real, dimension(nch,num_veg,num_zon), intent(out) :: sifsun_out + real, dimension(nch,num_veg,num_zon), intent(out) :: sifsha_out + + +! LOCAL + + ! 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] + real(r8) , allocatable, dimension(:) :: sifsun ! sunlit solar induced fluorescence + real(r8) , allocatable, dimension(:) :: sifsha ! shaded solar induced fluorescence + + ! 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)) + allocate(sifsun(bounds%begp:bounds%endp)) + allocate(sifsha(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, sifsun, sifsha) + + 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, sifsun, sifsha) + + 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, sifsun, sifsha) + + 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) + + ! solar induced fluorescence + + sifsun_out(nc,nv,nz) = sifsun(np) + sifsha_out(nc,nv,nz) = sifsha(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) + deallocate(sifsun) + deallocate(sifsha) + + 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_init_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_init_mod.F90 new file mode 100644 index 000000000..0ae6280e0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNCLM_init_mod.F90 @@ -0,0 +1,308 @@ +#include "MAPL_Generic.h" + +module CNCLM_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 + use ESMF + + implicit none + private + + 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(waterflux_type), public :: waterflux_inst + type(waterfluxbulk_type), public :: waterfluxbulk_inst + + + +! !PUBLIC MEMBER FUNCTIONS: + public :: CN_init + + contains + +!------------------------------------------------------ + subroutine CN_init(NLFilename, nch,ityp,fveg,cncol,cnpft,lats,lons,dtcn,paramfile,water_inst,bgc_vegetation_inst,cn5_cold_start) + + !ARGUMENTS + implicit none + !INPUT/OUTPUT + character(256), intent(in) :: NLFilename ! len=256 for consistency with SHR_KIND_CL of CLM51/shr_kind_mod.F90 + 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 + character(len=ESMF_MAXSTR), intent(in) :: paramfile + 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(Netcdf4_fileformatter) :: ncid + integer :: rc, status, ndt + + !----------------------------------------- + +! 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 + + 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 (paramfile) + + 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) + + + ! 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 CNCLM_initMod + + 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 100644 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 100644 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 100644 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/CNDVType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNDVType.F90 new file mode 100644 index 000000000..d9f528bbf --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/CNDriverMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNDriverMod.F90 new file mode 100644 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 100644 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/CNFireBaseMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireBaseMod.F90 new file mode 100644 index 000000000..0b70acadc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/CNFireEmissionsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNFireEmissionsMod.F90 new file mode 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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/CNProductsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNProductsMod.F90 new file mode 100644 index 000000000..416316c82 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNProductsMod.F90 @@ -0,0 +1,482 @@ +module CNProductsMod + +#include "MAPL_Generic.h" +#include "shr_assert.h" + + use shr_kind_mod , only : r8 => shr_kind_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/CNRootDynMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNRootDynMod.F90 new file mode 100644 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 100644 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/CNVegCarbonFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegCarbonFluxType.F90 new file mode 100644 index 000000000..642c87c1d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegCarbonFluxType.F90 @@ -0,0 +1,2270 @@ +module CNVegCarbonFluxType + +#include "MAPL_Generic.h" +#include "shr_assert.h" + + use shr_kind_mod , only : r8 => shr_kind_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/CNVegCarbonStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegCarbonStateType.F90 new file mode 100644 index 000000000..0a06ce606 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegCarbonStateType.F90 @@ -0,0 +1,758 @@ +module CNVegCarbonStateType + +#include "shr_assert.h" + + use shr_kind_mod , only : r8 => shr_kind_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/CNVegNitrogenFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegNitrogenFluxType.F90 new file mode 100644 index 000000000..3710e26b1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegNitrogenFluxType.F90 @@ -0,0 +1,1432 @@ +module CNVegNitrogenFluxType + + use shr_kind_mod , only : r8 => shr_kind_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/CNVegNitrogenStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegNitrogenStateType.F90 new file mode 100644 index 000000000..6354b3163 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegNitrogenStateType.F90 @@ -0,0 +1,630 @@ +module CNVegNitrogenStateType + + use shr_kind_mod , only : r8 => shr_kind_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/CNVegStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegStateType.F90 new file mode 100644 index 000000000..6b911b12c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegStateType.F90 @@ -0,0 +1,256 @@ +module CNVegStateType + + use shr_kind_mod , only : r8 => shr_kind_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/CNVegStructUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegStructUpdateMod.F90 new file mode 100644 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 100644 index 000000000..21206d102 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CNVegetationFacade.F90 @@ -0,0 +1,1683 @@ +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 ESMF + 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(len=ESMF_MAXSTR), 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/CanopyStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CanopyStateType.F90 new file mode 100644 index 000000000..b9b4c616c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CanopyStateType.F90 @@ -0,0 +1,251 @@ +#include "MAPL_Generic.h" + +module CanopyStateType + + use shr_kind_mod , only : r8 => shr_kind_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/ColumnType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/ColumnType.F90 new file mode 100644 index 000000000..8576968dd --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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 shr_kind_mod , only : r8 => shr_kind_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/CropType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CropType.F90 new file mode 100644 index 000000000..6bef1e43e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/CropType.F90 @@ -0,0 +1,73 @@ +module CropType + + use shr_kind_mod , only : r8 => shr_kind_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/EnergyFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/EnergyFluxType.F90 new file mode 100644 index 000000000..8d4b00da1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/FireDataBaseType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/FireDataBaseType.F90 new file mode 100644 index 000000000..1a4ad1fb9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/FireMethodType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/FireMethodType.F90 new file mode 100644 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/FrictionVelocityMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/FrictionVelocityMod.F90 new file mode 100644 index 000000000..5cfa4db40 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/GridcellType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/GridcellType.F90 new file mode 100644 index 000000000..53a01a68d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/GridcellType.F90 @@ -0,0 +1,108 @@ +module GridcellType + + use MAPL_Constants , ONLY : MAPL_PI + use shr_kind_mod , only : r8 => shr_kind_r8 + 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/LandunitType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/LandunitType.F90 new file mode 100644 index 000000000..e020e7f1d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/NutrientCompetitionCLM45defaultMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/NutrientCompetitionCLM45defaultMod.F90 new file mode 100644 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 100644 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 100644 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 100644 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/OzoneBaseMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/OzoneBaseMod.F90 new file mode 100644 index 000000000..83f8d6db5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/OzoneBaseMod.F90 @@ -0,0 +1,64 @@ +module OzoneBaseMod + + use shr_kind_mod , only : r8 => shr_kind_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/PatchType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/PatchType.F90 new file mode 100644 index 000000000..7781c2e59 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/PatchType.F90 @@ -0,0 +1,152 @@ +module PatchType + + use shr_kind_mod , only : r8 => shr_kind_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/PhotosynthesisMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/PhotosynthesisMod.F90 new file mode 100644 index 000000000..b1cc0f0c8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/PhotosynthesisMod.F90 @@ -0,0 +1,3877 @@ +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 :: fluorescence ! fluorescence function based on the formulation by Jung-Eun Lee using van der Tol and Berry (2012) + ! initially adapted to Catchment-CN by Greg Walker and adapted for CNCLM51 by jkolassa + 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, sif_sun, sif_sha) + ! + ! !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 + + real(r8) , intent(out) :: sif_sun( bounds%begp: ) ! sunlit solar induced fluorescence; added by jkolassa Jul 2025 + real(r8) , intent(out) :: sif_sha( bounds%begp: ) ! shaded solar induced fluores cence; added by jkolassa Jul 2025 + ! + ! !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 + + ! variables for fluorescence calculations + + real(r8) :: xn_sun ! sunlit ratio of actual electron transport to eletron transport + real(r8) :: xn_sha ! shaded ratio of actual electron transport to eletron transport + real(r8) :: fs_sun ! sunlit fluorescence yield + real(r8) :: fs_sha ! shaded fluorescence yield + real(r8) :: je_sun_act ! sunlit actual electron transport (umol electrons/m**2/s) + real(r8) :: je_sha_act ! shaded actual electron transport (umol electrons/m**2/s) + real(r8) :: ci_sun ! sunlit patch-level intracellular leaf CO2 (Pa) + real(r8) :: ci_sha ! shaded patch-level intracellular leaf CO2 (Pa) + real(r8) :: fsun ! patch-level sunlit fraction of canopy + + !------------------------------------------------------------------------------ + + ! 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 + + ! FLUORESCENCE: code from Jung-Eun Lee, originally implemented & modified by gkw 1/28/14 + ! adapted for CNCLM51 by jkolassa Jul 2025 + ! ------------ + + ci_sun = 0. + ci_sha = 0. + fsun = 0. + do iv = 1, nrad(p) + ci_sun = ci_sun + ci_z_sun(p,iv) + ci_sha = ci_sha + ci_z_sha(p,iv) + fsun = fsun + surfalb_inst%fsun_z_patch(p,iv) + end do + ci_sun = ci_sun/nrad(p) + ci_sha = ci_sha/nrad(p) + fsun = fsun/nrad(p) + + je_sun_act = max(psn_sun(p)*(ci_sun+2.*cp(p))/max(ci_sun+2.*cp(p)-3.*c3psn(patch%itype(p))*cp(p),1.e-8) , 0.) + je_sha_act = max(psn_sha(p)*(ci_sha+2.*cp(p))/max(ci_sha+2.*cp(p)-3.*c3psn(patch%itype(p))*cp(p),1.e-8) , 0.) + + xn_sun=1.-je_sun_act/je_sun ! gkw: 0.8 factor removed 20141108 (email from Jung-Eun) + xn_sun=max(xn_sun,0.) ! gkw: added 1/31/14 + xn_sha=1.-je_sha_act/je_sha ! gkw: 0.8 factor removed 20141108 (email from Jung-Eun) + xn_sha=max(xn_sha,0.) ! gkw: added 1/31/14 + + if (psn_wj_sun(p) <= 0.) xn_sun=0. + call fluorescence(xn_sun,fs_sun) + sif_sun(p) = fs_sun*qabs + + if (psn_wj_sha(p) <= 0.) xn_sha=0. + call fluorescence(xn_sha,fs_sha) + sif_sha(p) = fs_sha*qabs + + + + end do + + end associate + + end subroutine PhotosynthesisHydraulicStress + !------------------------------------------------------------------------------ +! +! !IROUTINE: Fluorescence +! +! !INTERFACE: + subroutine fluorescence(x,fs) +! +! !DESCRIPTION: +! Chlorophyll fluorescence +! writen by Jung-Eun Lee using van der Tol and Berry (2012) + +! !USES: + implicit none + real(r8), intent(in) :: x ! degree of light saturation + real(r8), intent(out) :: fs ! fluorescence yield + real :: Kn ! rate constant for non-photochemical quenching + real :: Kf ! rate constant for fluorescence + real :: Kd ! rate constant for thermal deactivation at Fm + real :: Kp ! rate constant for photochemisty + real :: po0 + real :: ps + real :: fo0 + real :: fo ! fluorescnce yield at Fo + real :: fm ! fluorescnce yield at Fm + real :: fm0 + real :: eta + real :: qQ + real :: qE + + Kf = 0.05 ! rate constant for fluorescence + Kd = 0.95 ! rate constant for thermal deactivation at Fm + Kp = 4.0 ! rate constant for photochemisty + + po0 = Kp/(Kf+Kd+Kp) ! dark photochemistry fraction (Genty et al., 1989) + ps = po0*(1.-x) ! photochemical yield + Kn = (6.2473 * x - 0.5944)*x ! empirical fit to Flexas' data +! Kn = (3.9867 * x - 1.0589)*x ! empirical fit to Flexas, Daumard, Rascher, Berry data + + fo0 = Kf/(Kf+Kp+Kd) ! dark adapted fluorescence yield Fo + fo = Kf/(Kf+Kp+Kd+Kn) ! dark adapted fluorescence yield Fo + fm = Kf/(Kf +Kd+Kn) ! light adapted fluorescence yield Fm + fm0 = Kf/(Kf +Kd) ! light adapted fluorescence yield Fm + fs = fm*(1.-ps) ! fluorescence as fraction of PAR + eta = fs/fo0 ! fluorescence as fraction of dark adapted + + qQ = 1.-(fs-fo)/(fm-fo) ! photochemical quenching + qE = 1.-(fm-fo)/(fm0-fo0) !non-photochemical quenching + + end subroutine fluorescence + + !-------------------------------------------------------------------------------- + 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 100644 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 100644 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/SaturatedExcessRunoffMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SaturatedExcessRunoffMod.F90 new file mode 100644 index 000000000..745d0d212 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/SoilBiogeochemCarbonFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemCarbonFluxType.F90 new file mode 100644 index 000000000..36172d307 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemCarbonFluxType.F90 @@ -0,0 +1,398 @@ +module SoilBiogeochemCarbonFluxType + + use shr_kind_mod , only : r8 => shr_kind_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/SoilBiogeochemCarbonStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemCarbonStateType.F90 new file mode 100644 index 000000000..73475539b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemCarbonStateType.F90 @@ -0,0 +1,385 @@ +module SoilBiogeochemCarbonStateType + + use shr_kind_mod , only : r8 => shr_kind_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/SoilBiogeochemCompetitionMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemCompetitionMod.F90 new file mode 100644 index 000000000..76c1da3ac --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/SoilBiogeochemDecompCascadeBGCMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeBGCMod.F90 new file mode 100644 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 100644 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/SoilBiogeochemDecompCascadeConType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeConType.F90 new file mode 100644 index 000000000..9cd2b30b9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompCascadeConType.F90 @@ -0,0 +1,150 @@ +module SoilBiogeochemDecompCascadeConType + + use shr_kind_mod , only : r8 => shr_kind_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/SoilBiogeochemDecompMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemDecompMod.F90 new file mode 100644 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 100644 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 100644 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 100644 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 100644 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/SoilBiogeochemNitrogenFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNitrogenFluxType.F90 new file mode 100644 index 000000000..626780f75 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNitrogenFluxType.F90 @@ -0,0 +1,621 @@ +module SoilBiogeochemNitrogenFluxType + + use shr_kind_mod , only : r8 => shr_kind_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/SoilBiogeochemNitrogenStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNitrogenStateType.F90 new file mode 100644 index 000000000..4d1f3057e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemNitrogenStateType.F90 @@ -0,0 +1,455 @@ + module SoilBiogeochemNitrogenStateType + + use shr_kind_mod , only : r8 => shr_kind_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/SoilBiogeochemPotentialMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemPotentialMod.F90 new file mode 100644 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 100644 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/SoilBiogeochemStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemStateType.F90 new file mode 100644 index 000000000..20fc62c3a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemStateType.F90 @@ -0,0 +1,142 @@ +#include "MAPL_Generic.h" + +module SoilBiogeochemStateType + + use shr_kind_mod , only : r8 => shr_kind_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/SoilBiogeochemVerticalProfileMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilBiogeochemVerticalProfileMod.F90 new file mode 100644 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 100644 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/SoilStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilStateType.F90 new file mode 100644 index 000000000..ccd806309 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilStateType.F90 @@ -0,0 +1,163 @@ +module SoilStateType + + use shr_kind_mod , only : r8 => shr_kind_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/SoilWaterRetentionCurveMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SoilWaterRetentionCurveMod.F90 new file mode 100644 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/SolarAbsorbedType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SolarAbsorbedType.F90 new file mode 100644 index 000000000..63a930170 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SolarAbsorbedType.F90 @@ -0,0 +1,149 @@ +module SolarAbsorbedType + + use shr_kind_mod , only : r8 => shr_kind_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/SurfaceAlbedoMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceAlbedoMod.F90 new file mode 100644 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/SurfaceAlbedoType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceAlbedoType.F90 new file mode 100644 index 000000000..94531140d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceAlbedoType.F90 @@ -0,0 +1,175 @@ +module SurfaceAlbedoType + + use shr_kind_mod , only : r8 => shr_kind_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/SurfaceRadiationMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/SurfaceRadiationMod.F90 new file mode 100644 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/TemperatureType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/TemperatureType.F90 new file mode 100644 index 000000000..dc6f1ebf8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/TemperatureType.F90 @@ -0,0 +1,243 @@ +module TemperatureType + + use shr_kind_mod , only : r8 => shr_kind_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/TridiagonalMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/TridiagonalMod.F90 new file mode 100644 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/WaterDiagnosticBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterDiagnosticBulkType.F90 new file mode 100644 index 000000000..d480f85b8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterDiagnosticBulkType.F90 @@ -0,0 +1,140 @@ +module WaterDiagnosticBulkType + + use shr_kind_mod , only : r8 => shr_kind_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/WaterDiagnosticType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterDiagnosticType.F90 new file mode 100644 index 000000000..25536d7b3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/WaterFluxBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterFluxBulkType.F90 new file mode 100644 index 000000000..71752183a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterFluxBulkType.F90 @@ -0,0 +1,112 @@ +module WaterFluxBulkType + + use shr_kind_mod , only : r8 => shr_kind_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/WaterFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterFluxType.F90 new file mode 100644 index 000000000..104f1e37e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterFluxType.F90 @@ -0,0 +1,274 @@ +module WaterFluxType + + use shr_kind_mod , only : r8 => shr_kind_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/WaterStateBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterStateBulkType.F90 new file mode 100644 index 000000000..4f9e59a03 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/WaterStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterStateType.F90 new file mode 100644 index 000000000..fe0ba4f39 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/WaterType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/WaterType.F90 new file mode 100644 index 000000000..7178e03a3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/Wateratm2lndBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/Wateratm2lndBulkType.F90 new file mode 100644 index 000000000..8f92193b0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/Wateratm2lndType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/Wateratm2lndType.F90 new file mode 100644 index 000000000..d70183036 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/abortutils.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/abortutils.F90 new file mode 100644 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/atm2lndType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/atm2lndType.F90 new file mode 100644 index 000000000..9608c05f8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/atm2lndType.F90 @@ -0,0 +1,148 @@ +module atm2lndType + + use shr_kind_mod , only : r8 => shr_kind_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/ch4Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/ch4Mod.F90 new file mode 100644 index 000000000..80b17936d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/ch4Mod.F90 @@ -0,0 +1,225 @@ +module ch4Mod + + use shr_kind_mod , only : r8 => shr_kind_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/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 100644 index 000000000..63bfcf85b --- /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 shr_kind_mod , only: r8 => shr_kind_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 100644 index 000000000..2c7bacfaa --- /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 shr_kind_mod , only: r8 => shr_kind_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 100644 index 000000000..37e240c96 --- /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 shr_kind_mod, only: r8 => shr_kind_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 100644 index 000000000..21ecad8bc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/clm_varpar.F90 @@ -0,0 +1,217 @@ +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 => NUM_PFT_CN_51, & + NUM_ZON => NUM_ZON_CN, & + NUM_VEG => NUM_VEG_CN_51 + +! !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; jkolassa Aug 2022: changed b/c having more urban than ground layers caused an issue w/ initialization of 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, public, parameter, dimension(NUM_ZON) :: CN_zone_weight = (/0.10,0.45,0.45/) ! gkw: tunable; must sum to 1 + + integer, public, parameter :: 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 + +! =================== EOF ============================================================ 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 100644 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 100644 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/decompMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/decompMod.F90 new file mode 100644 index 000000000..e84e23cd6 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/decompMod.F90 @@ -0,0 +1,142 @@ +module decompMod + + use shr_kind_mod , only: r8 => shr_kind_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/dynSubgridControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/dynSubgridControlMod.F90 new file mode 100644 index 000000000..73bca29a4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/fileutils.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/fileutils.F90 new file mode 100644 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 100644 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/filterMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/filterMod.F90 new file mode 100644 index 000000000..ad15933f5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/filterMod.F90 @@ -0,0 +1,260 @@ +module filterMod + + use shr_kind_mod, only: r8 => shr_kind_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/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 100644 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/initVerticalMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/initVerticalMod.F90 new file mode 100644 index 000000000..d883d2f54 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/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/landunit_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/landunit_varcon.F90 new file mode 100644 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 100644 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 100644 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 100644 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/pftconMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/pftconMod.F90 new file mode 100644 index 000000000..37bbcfc52 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/pftconMod.F90 @@ -0,0 +1,1001 @@ +#include "MAPL_Generic.h" + +module pftconMod + + use shr_kind_mod , only: r8 => shr_kind_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 + use ESMF + + ! !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,paramfile) + + ! !DESCRIPTION: +! Initialize CTSM PFT constants +! + use abortutils , only : endrun + +! !ARGUMENTS: + implicit none + !INPUT/OUTPUT + class(pftcon_type) :: this + character(len=ESMF_MAXSTR), intent(in) :: paramfile + + + 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 + +!--------------------------------------------------------- + + 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 !# + + 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__)) + + 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__)) + + 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/quadraticMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/quadraticMod.F90 new file mode 100644 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 100644 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 100644 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/GEOScatchCNCLM45_GridComp/CLM45/shr_const_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_const_mod.F90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/shr_const_mod.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_const_mod.F90 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 100644 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 100644 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 100644 index 000000000..3c35d0a60 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/shr_kind_mod.F90 @@ -0,0 +1,27 @@ +MODULE shr_kind_mod + + use MAPL_ConstantsMod, ONLY: & + MAPL_R8, & + MAPL_R4, & + MAPL_RN, & + MAPL_I8, & + MAPL_I4, & + MAPL_IN + + !---------------------------------------------------------------------------- + ! 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 100644 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 100644 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 100644 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 100644 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 100644 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 100644 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/GEOScatchCNCLM45_GridComp/CLM45/update_model_para4cn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/update_model_para4cn.F90 similarity index 54% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/CLM45/update_model_para4cn.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51/update_model_para4cn.F90 index 570596ea5..98de6e8b1 100644 --- 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/GEOScatchCNCLM51_GridComp/CLM51/update_model_para4cn.F90 @@ -5,26 +5,29 @@ MODULE update_model_para4cn 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, LocalTileID + 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 + 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_tileid (tileid) +! +! implicit none +! integer :: NT +! integer, intent (in) :: tileid (:) +! +! NT = size (tileid) +! allocate (LocalTileID(1:NT)) +! LocalTileID = tileid +! +! end subroutine upd_tileid ! --------------------------------------- @@ -34,7 +37,15 @@ subroutine upd_curr_date_time( year,month,day,dofyr,hour,min,sec ) 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 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ActiveLayerMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ActiveLayerMod.F90 new file mode 100644 index 000000000..ca980fe15 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ActiveLayerMod.F90 @@ -0,0 +1,350 @@ +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 landunit_varcon , only : istsoil, istcrop + use TemperatureType , only : temperature_type + use GridcellType , only : grc + use LandunitType , only : lun + use ColumnType , only : col + ! + implicit none + save + private + ! + ! !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 + ! Public routines + procedure, public :: alt_calc + procedure, public :: Init + procedure, public :: Restart + + ! Private routines + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + end type active_layer_type + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public:: alt_calc + !----------------------------------------------------------------------- + +contains + + ! ======================================================================== + ! Science routines + ! ======================================================================== + + !----------------------------------------------------------------------- + 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 + + ! ======================================================================== + ! Infrastructure routines (for initialization & restart) + ! ======================================================================== + + !----------------------------------------------------------------------- + subroutine Init(this, bounds) + ! + ! !ARGUMENTS: + class(active_layer_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Init' + !----------------------------------------------------------------------- + + call this%InitAllocate(bounds) + call this%InitHistory(bounds) + call this%InitCold(bounds) + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! + ! !ARGUMENTS: + class(active_layer_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'InitAllocate' + !----------------------------------------------------------------------- + + 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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! !USES: + use histFileMod , only: hist_addfld1d + ! + ! !ARGUMENTS: + class(active_layer_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + character(len=:), allocatable :: active_if_cn + + character(len=*), parameter :: subname = 'InitHistory' + !----------------------------------------------------------------------- + + associate( & + begc => bounds%begc, & + endc => bounds%endc & + ) + + if (use_cn) then + active_if_cn = 'active' + else + active_if_cn = 'inactive' + end if + + this%alt_col(begc:endc) = spval + call hist_addfld1d (fname='ALT', units='m', & + avgflag='A', long_name='current active layer thickness', & + ptr_col=this%alt_col, default=active_if_cn) + + this%altmax_col(begc:endc) = spval + call hist_addfld1d (fname='ALTMAX', units='m', & + avgflag='A', long_name='maximum annual active layer thickness', & + ptr_col=this%altmax_col, default=active_if_cn) + + this%altmax_lastyear_col(begc:endc) = spval + call hist_addfld1d (fname='ALTMAX_LASTYEAR', units='m', & + avgflag='A', long_name='maximum prior year active layer thickness', & + ptr_col=this%altmax_lastyear_col, default='inactive') + + end associate + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !ARGUMENTS: + class(active_layer_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: l, c + + character(len=*), parameter :: subname = 'InitCold' + !----------------------------------------------------------------------- + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%alt_col(c) = 0._r8 !iniitialized to spval for all columns + this%altmax_col(c) = 0._r8 !iniitialized to spval for all columns + this%altmax_lastyear_col(c) = 0._r8 !iniitialized to spval for all columns + this%alt_indx_col(c) = 0 !initiialized to huge for all columns + this%altmax_indx_col(c) = 0 !initiialized to huge for all columns + this%altmax_lastyear_indx_col = 0 !initiialized to huge for all columns + end if + end do + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart(this, bounds, ncid, flag) + ! + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_double, ncd_int + use restUtilMod + ! + ! !ARGUMENTS: + class(active_layer_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: + logical :: readvar ! determine if variable is on initial file + + character(len=*), parameter :: subname = 'Restart' + !----------------------------------------------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='altmax', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%altmax_col) + + call restartvar(ncid=ncid, flag=flag, varname='altmax_lastyear', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%altmax_lastyear_col) + + call restartvar(ncid=ncid, flag=flag, varname='altmax_indx', xtype=ncd_int, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%altmax_indx_col) + + call restartvar(ncid=ncid, flag=flag, varname='altmax_lastyear_indx', xtype=ncd_int, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%altmax_lastyear_indx_col) + + end subroutine Restart + + + +end module ActiveLayerMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/AnnualFluxDribbler.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/AnnualFluxDribbler.F90 new file mode 100644 index 000000000..aa1e3bbcd --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/AnnualFluxDribbler.F90 @@ -0,0 +1,615 @@ +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 + + +end module AnnualFluxDribbler diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNAnnualUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNAnnualUpdateMod.F90 new file mode 100644 index 000000000..7e1d34464 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNBalanceCheckMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNBalanceCheckMod.F90 new file mode 100644 index 000000000..07dc04e3b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNBalanceCheckMod.F90 @@ -0,0 +1,636 @@ +module CNBalanceCheckMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for carbon/nitrogen mass balance checking. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + 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 + procedure , private :: InitAllocate + end type cn_balance_type + ! + + 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 + + call this%InitAllocate(bounds) + + 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 InitAllocate(this, bounds) + 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 + end subroutine InitAllocate + + !----------------------------------------------------------------------- + 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_orig_files/CNCStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNCStateUpdate1Mod.F90 new file mode 100644 index 000000000..2599c386c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNCStateUpdate2Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNCStateUpdate2Mod.F90 new file mode 100644 index 000000000..d273520af --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNCStateUpdate3Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNCStateUpdate3Mod.F90 new file mode 100644 index 000000000..4ed4b828b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNDVType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNDVType.F90 new file mode 100644 index 000000000..065e972a1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNDVType.F90 @@ -0,0 +1,519 @@ +module CNDVType + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !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 + ! + ! !PUBLIC TYPES: + implicit none + private + ! + ! !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 + procedure , public :: Restart + procedure , public :: InitAccBuffer + procedure , public :: InitAccVars + procedure , public :: UpdateAccVars + procedure , private :: InitAllocate + procedure , private :: InitCold + procedure , private :: InitHistory + end type dgvs_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(dgvs_type) :: this + type(bounds_type), intent(in) :: bounds + + ! Note - need allocation so that associate statements can be used + ! at run time for NAG (allocation of variables is needed) - history + ! should only be initialized if use_cndv is true + + call this%InitAllocate (bounds) + + if (use_cndv) then + call this%InitCold (bounds) + call this%InitHistory (bounds) + end if + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + 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: + class(dgvs_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + 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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_TKFRZ + use decompMod , only : bounds_type + ! + ! !ARGUMENTS: + class(dgvs_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p ! patch index + !----------------------------------------------------------------------- + + do p = bounds%begp,bounds%endp + this%present_patch(p) = .false. + this%crownarea_patch(p) = 0._r8 + this%nind_patch(p) = 0._r8 + this%agdd20_patch(p) = 0._r8 + this%tmomin20_patch(p) = SHR_CONST_TKFRZ - 5._r8 !initialize this way for Phenology code + end do + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize history variables + ! + ! !USES: + use histFileMod, only : hist_addfld1d + ! + ! !ARGUMENTS: + class(dgvs_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'InitHistory' + !----------------------------------------------------------------------- + + call hist_addfld1d (fname='AGDD', units='K', & + avgflag='A', long_name='growing degree-days base 5C', & + ptr_patch=this%agdd_patch) + + end subroutine InitHistory + + + !----------------------------------------------------------------------- + subroutine Restart(this, bounds, ncid, flag) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use clm_varcon , only : spval + use spmdMod , only : masterproc + use decompMod , only : get_proc_global + use restUtilMod + use ncdio_pio + use pio + ! + ! !ARGUMENTS: + class(dgvs_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,p ! indices + logical :: readvar ! determine if variable is on initial file + logical :: do_io ! whether to do i/o for the given variable + integer :: nump_global ! total number of patches, globally + integer :: dimlen ! dimension length + integer :: ier ! error status + integer :: itemp ! temporary + integer , pointer :: iptemp(:) ! pointer to memory to be allocated + integer :: err_code ! error code + !----------------------------------------------------------------------- + + ! Get expected total number of points, for later error checks + call get_proc_global(np=nump_global) + + call restartvar(ncid=ncid, flag=flag, varname='CROWNAREA', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%crownarea_patch) + + call restartvar(ncid=ncid, flag=flag, varname='nind', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%nind_patch) + + call restartvar(ncid=ncid, flag=flag, varname='fpcgrid', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fpcgrid_patch) + + call restartvar(ncid=ncid, flag=flag, varname='fpcgridold', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fpcgridold_patch) + + ! tmomin20 + do_io = .true. + if (flag == 'read') then + ! On a read, confirm that this variable has the expected size; if not, don't + ! read it (instead leave it at its arbitrary initial value). This is needed to + ! support older initial conditions for which this variable had a different size. + call ncd_inqvdlen(ncid, 'TMOMIN20', 1, dimlen, err_code) + if (dimlen /= nump_global) then + do_io = .false. + end if + end if + if (do_io) then + call restartvar(ncid=ncid, flag=flag, varname='TMOMIN20', xtype=ncd_double, & + dim1name='pft', & + long_name='',units='', & + interpinic_flag='interp', readvar=readvar, data=this%tmomin20_patch) + end if + + ! agdd20 + do_io = .true. + if (flag == 'read') then + ! On a read, confirm that this variable has the expected size; if not, don't + ! read it (instead leave it at its arbitrary initial value). This is needed to + ! support older initial conditions for which this variable had a different size. + call ncd_inqvdlen(ncid, 'AGDD20', 1, dimlen, err_code) + if (dimlen /= nump_global) then + do_io = .false. + end if + end if + if (do_io) then + call restartvar(ncid=ncid, flag=flag, varname='AGDD20', xtype=ncd_double, & + dim1name='pft',& + long_name='',units='', & + interpinic_flag='interp', readvar=readvar, data=this%agdd20_patch) + end if + + ! present + if (flag == 'read' .or. flag == 'write') then + allocate (iptemp(bounds%begp:bounds%endp), stat=ier) + end if + if (flag == 'write') then + do p = bounds%begp,bounds%endp + iptemp(p) = 0 + if (this%present_patch(p)) iptemp(p) = 1 + end do + end if + call restartvar(ncid=ncid, flag=flag, varname='present', xtype=ncd_int, & + dim1name='pft',& + long_name='',units='', & + interpinic_flag='interp', readvar=readvar, data=iptemp) + if (flag=='read' .and. readvar) then + do p = bounds%begp,bounds%endp + this%present_patch(p) = .false. + if (iptemp(p) == 1) this%present_patch(p) = .true. + end do + end if + if (flag == 'read' .or. flag == 'write') then + deallocate (iptemp) + end if + + call restartvar(ncid=ncid, flag=flag, varname='heatstress', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%heatstress_patch) + + call restartvar(ncid=ncid, flag=flag, varname='greffic', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%greffic_patch) + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! Each interval and accumulation type is unique to each field processed. + ! Routine [initAccBuffer] defines the fields to be processed + ! and the type of accumulation. + ! Routine [updateCNDVAccVars] does the actual accumulation for a given field. + ! Fields are accumulated by calls to subroutine [update_accum_field]. + ! To accumulate a field, it must first be defined in subroutine [initAccVars] + ! and then accumulated by calls to [updateCNDVAccVars]. + ! + ! This should only be called if use_cndv is true. + ! + ! !USES + use accumulMod , only : init_accum_field + ! + ! !ARGUMENTS: + class(dgvs_type) :: this + type(bounds_type), intent(in) :: bounds + + ! + ! !LOCAL VARIABLES: + integer, parameter :: not_used = huge(1) + + !--------------------------------------------------------------------- + + ! The following are accumulated fields. + ! These types of fields are accumulated until a trigger value resets + ! the accumulation to zero (see subroutine update_accum_field). + ! Hence, [accper] is not valid. + + call init_accum_field (name='AGDDTW', units='K', & + desc='growing degree-days base twmax', accum_type='runaccum', accum_period=not_used, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field (name='AGDD', units='K', & + desc='growing degree-days base 5C', accum_type='runaccum', accum_period=not_used, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + subroutine InitAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! This should only be called if use_cndv is true. + ! + ! !USES + use accumulMod , only : extract_accum_field + use clm_time_manager , only : get_nstep + ! + ! !ARGUMENTS: + class(dgvs_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: nstep + integer :: ier ! error status + real(r8), pointer :: rbufslp(:) ! temporary + + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)' in ' + call endrun(msg=" allocation error for rbufslp"//& + errMsg(sourcefile, __LINE__)) + endif + + nstep = get_nstep() + + call extract_accum_field ('AGDDTW', rbufslp, nstep) + this%agddtw_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('AGDD', rbufslp, nstep) + this%agdd_patch(begp:endp) = rbufslp(begp:endp) + + deallocate(rbufslp) + + end subroutine InitAccVars + + !----------------------------------------------------------------------- + subroutine UpdateAccVars(this, bounds, t_a10_patch, t_ref2m_patch) + ! + ! !DESCRIPTION: + ! Update accumulated variables. Should be called every time step. + ! + ! This should only be called if use_cndv is true. + ! + ! !USES: + use shr_const_mod , only : SHR_CONST_CDAY, SHR_CONST_TKFRZ + use clm_time_manager , only : get_step_size, get_nstep, get_curr_date + use pftconMod , only : ndllf_dcd_brl_tree + use accumulMod , only : update_accum_field, extract_accum_field, accumResetVal + ! + ! !ARGUMENTS: + class(dgvs_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + ! COMPILER_BUG(wjs, 2014-11-30, pgi 14.7) These arrays get resized to 0 when running + ! with threading with pgi 14.7 on yellowstone. My standard workarounds weren't + ! working; the only thing that I can find that works is to change them to pointers +! real(r8) , intent(in) :: t_a10_patch( bounds%begp:) ! 10-day running mean of the 2 m temperature (K) +! real(r8) , intent(in) :: t_ref2m_patch( bounds%begp:) ! 2 m height surface air temperature (K) + 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: + integer :: p ! index + integer :: ier ! error status + integer :: dtime ! timestep size [seconds] + integer :: nstep ! timestep number + integer :: year ! year (0, ...) for nstep + integer :: month ! month (1, ..., 12) for nstep + integer :: day ! day of month (1, ..., 31) for nstep + integer :: secs ! seconds into current date for nstep + integer :: begp, endp + real(r8), pointer :: rbufslp(:) ! temporary single level - patch level + !----------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(t_a10_patch) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(t_ref2m_patch) == (/endp/)), sourcefile, __LINE__) + + dtime = get_step_size() + nstep = get_nstep() + call get_curr_date (year, month, day, secs) + + ! Allocate needed dynamic memory for single level patch field + + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)'update_accum_hist allocation error for rbuf1dp' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + ! Accumulate growing degree days based on 10-day running mean temperature. + ! The trigger to reset the accumulated values to zero is -99999. + + ! Accumulate and extract AGDDTW (gdd base twmax, which is 23 deg C + ! for boreal woody patches) + + do p = begp,endp + rbufslp(p) = max(0._r8, & + (t_a10_patch(p) - SHR_CONST_TKFRZ - dgv_ecophyscon%twmax(ndllf_dcd_brl_tree)) & + * dtime/SHR_CONST_CDAY) + if (month==1 .and. day==1 .and. secs==int(dtime)) rbufslp(p) = accumResetVal + end do + call update_accum_field ('AGDDTW', rbufslp, nstep) + call extract_accum_field ('AGDDTW', this%agddtw_patch, nstep) + + ! Accumulate and extract AGDD + + do p = begp,endp + rbufslp(p) = max(0.0_r8, & + (t_ref2m_patch(p) - (SHR_CONST_TKFRZ + 5.0_r8)) * dtime/SHR_CONST_CDAY) + ! + ! Fix (for bug 1858) from Sam Levis to reset the annual AGDD variable + ! + if (month==1 .and. day==1 .and. secs==int(dtime)) rbufslp(p) = accumResetVal + end do + call update_accum_field ('AGDD', rbufslp, nstep) + call extract_accum_field ('AGDD', this%agdd_patch, nstep) + + deallocate(rbufslp) + + end subroutine UpdateAccVars + +end module CNDVType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNDriverMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNDriverMod.F90 new file mode 100644 index 000000000..f9d1a7370 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNDriverMod.F90 @@ -0,0 +1,1153 @@ +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 + use SoilWaterRetentionCurveMod , only : soil_water_retention_curve_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, NLFilename) + + 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, & + soil_water_retention_curve, 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 + class(soil_water_retention_curve_type) , intent(in) :: soil_water_retention_curve + 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, soil_water_retention_curve, & + 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_first_step_of_this_run_segment,is_beg_curr_year,is_end_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_orig_files/CNFUNMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFUNMod.F90 new file mode 100644 index 000000000..12dbda862 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFUNMod.F90 @@ -0,0 +1,1811 @@ +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 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 :: 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_orig_files/CNFireBaseMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireBaseMod.F90 new file mode 100644 index 000000000..d18153367 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireBaseMod.F90 @@ -0,0 +1,1311 @@ +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 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, NLFilename ) + ! + ! !DESCRIPTION: + ! Initialize CN Fire module + ! !ARGUMENTS: + class(cnfire_base_type) :: this + type(bounds_type), intent(in) :: bounds + character(len=*), intent(in) :: NLFilename + !----------------------------------------------------------------------- + ! Call the base-class Initialization method + call this%BaseFireInit( bounds, NLFilename ) + + ! 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, assignment(=) + ! + ! !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 InitHistory( this, bounds ) + ! + ! Initailizae history variables + use clm_varcon , only : spval + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + class(cnfire_base_type) :: this + type(bounds_type), intent(in) :: bounds + !----------------------------------------------------------------------- + integer :: begp, endp + !------------------------------------------------------------------------ + begp = bounds%begp; endp= bounds%endp + this%btran2_patch(begp:endp) = spval + call hist_addfld1d(fname='BTRAN2', units='unitless', & + avgflag='A', long_name='root zone soil wetness factor', & + ptr_patch=this%btran2_patch, l2g_scale_type='veg') + end subroutine InitHistory + + !---------------------------------------------------------------------- + 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_orig_files/CNFireEmissionsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireEmissionsMod.F90 new file mode 100644 index 000000000..d3344baaa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireEmissionsMod.F90 @@ -0,0 +1,377 @@ +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 + ! + ! !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 + contains + procedure, public :: Init + procedure, private :: InitAllocate + procedure, private :: InitHistory + end type fireemis_type + !------------------------------------------------------------------------ +contains + + !----------------------------------------------------------------------- + subroutine Init(this, bounds) + + use shr_fire_emis_mod, only : shr_fire_emis_factors_file + use FireEmisFactorsMod, only : fire_emis_factors_init, fire_emis_factors_get + use clm_varpar, only : maxveg + + implicit none + + ! args + class(fireemis_type) :: this + type(bounds_type), intent(in) :: bounds + + ! local vars + integer :: nmech, nemis + real(r8) :: factors(maxveg) + real(r8) :: molec_wght + type(shr_fire_emis_comp_t), pointer :: emis_cmp + + if ( shr_fire_emis_mechcomps_n < 1) return + + call fire_emis_factors_init( shr_fire_emis_factors_file ) + + emis_cmp => shr_fire_emis_linkedlist + do while(associated(emis_cmp)) + allocate(emis_cmp%emis_factors(maxveg)) + call fire_emis_factors_get( trim(emis_cmp%name), factors, molec_wght ) + emis_cmp%emis_factors = factors*1.e-3_r8 ! convert g/kg dry fuel to kg/kg + emis_cmp%molec_weight = molec_wght + emis_cmp => emis_cmp%next_emiscomp + enddo + + call this%InitAllocate(bounds) + call this%InitHistory(bounds) + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! + ! Allocate memory for module datatypes + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varcon , only : spval + + ! !ARGUMENTS: + class(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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + use clm_varcon , only : spval + use histFileMod , only : hist_addfld1d + + ! !ARGUMENTS: + class(fireemis_type) :: this + type(bounds_type), intent(in) :: bounds + + ! !LOCAL VARIABLES + integer :: begp, endp + integer :: imech, icomp + type(shr_fire_emis_comp_t), pointer :: emis_cmp + + if (shr_fire_emis_mechcomps_n>0) then + + emis_cmp => shr_fire_emis_linkedlist + + ! loop over fire components + emis_cmp_loop: do while(associated(emis_cmp)) + + icomp = emis_cmp%index + + call hist_addfld1d (fname='FireComp_'//trim(emis_cmp%name), units='kg/m2/sec', & + avgflag='A', long_name='fire emissions flux of '//trim(emis_cmp%name), & + ptr_patch=this%comp(icomp)%emis, default='inactive') + + emis_cmp => emis_cmp%next_emiscomp + + enddo emis_cmp_loop + + ! loop over atm chem mechanism species + do imech = 1,shr_fire_emis_mechcomps_n + + call hist_addfld1d (fname='FireMech_'//trim(shr_fire_emis_mechcomps(imech)%name), units='kg/m2/sec', & + avgflag='A', long_name='fire emissions flux of '//trim(shr_fire_emis_mechcomps(imech)%name), & + ptr_patch=this%mech(imech)%emis, default='inactive') + + enddo + + call hist_addfld1d (fname='FireEmis_TOT', units='gC/m2/sec', & + avgflag='A', long_name='Total fire emissions flux ', & + ptr_patch=this%totfire%emis, default='inactive') + + call hist_addfld1d (fname='FireEmis_ZTOP', units='m', & + avgflag='A', long_name='Top of vertical fire emissions distribution ', & + ptr_patch=this%ztop_patch, default='inactive') + endif + + + end subroutine InitHistory + + !----------------------------------------------------------------------- + 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_orig_files/CNFireFactoryMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireFactoryMod.F90 new file mode 100644 index 000000000..dbd9b70d1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNFireLi2014Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireLi2014Mod.F90 new file mode 100644 index 000000000..e87fac728 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireLi2014Mod.F90 @@ -0,0 +1,1493 @@ +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 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, soil_water_retention_curve, & + 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 + ) + + 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) + 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_orig_files/CNFireLi2016Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireLi2016Mod.F90 new file mode 100644 index 000000000..afd661cd2 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireLi2016Mod.F90 @@ -0,0 +1,656 @@ +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 + ! + 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, soil_water_retention_curve, & + 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 + ) + + 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) + 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_orig_files/CNFireLi2021Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireLi2021Mod.F90 new file mode 100644 index 000000000..aa61e291e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireLi2021Mod.F90 @@ -0,0 +1,658 @@ +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 + ! + 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, soil_water_retention_curve, & + 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 + ) + + 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) + 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_orig_files/CNFireNoFireMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireNoFireMod.F90 new file mode 100644 index 000000000..0dc1ee39d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNFireNoFireMod.F90 @@ -0,0 +1,141 @@ +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 SoilWaterRetentionCurveMod , only : soil_water_retention_curve_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, soil_water_retention_curve, & + 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 + 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 :: 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_orig_files/CNGRespMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNGRespMod.F90 new file mode 100644 index 000000000..d95761e61 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNGapMortalityMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNGapMortalityMod.F90 new file mode 100644 index 000000000..19407316f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNMRespMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNMRespMod.F90 new file mode 100644 index 000000000..3a7052d0b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNMRespMod.F90 @@ -0,0 +1,298 @@ +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 + ! + ! !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 + !----------------------------------------------------------------------- + + 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_orig_files/CNNDynamicsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNNDynamicsMod.F90 new file mode 100644 index 000000000..216f8c23f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNNStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNNStateUpdate1Mod.F90 new file mode 100644 index 000000000..3aabe0c3f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNNStateUpdate2Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNNStateUpdate2Mod.F90 new file mode 100644 index 000000000..15423f19a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNNStateUpdate3Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNNStateUpdate3Mod.F90 new file mode 100644 index 000000000..c0de9f890 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNPhenologyMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNPhenologyMod.F90 new file mode 100644 index 000000000..e5a170c95 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNPhenologyMod.F90 @@ -0,0 +1,3780 @@ +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) + + 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) + frootc_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_orig_files/CNPrecisionControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNPrecisionControlMod.F90 new file mode 100644 index 000000000..e904c7f2b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNProductsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNProductsMod.F90 new file mode 100644 index 000000000..0586815ee --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNProductsMod.F90 @@ -0,0 +1,752 @@ +module CNProductsMod + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculate loss fluxes from wood products pools, and update product pool state variables + ! + ! !USES: +#include "shr_assert.h" + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun + use clm_time_manager , only : get_step_size_real + use SpeciesBaseType , only : species_base_type + use PatchType , only : patch + ! + implicit none + private + ! + ! !PUBLIC TYPES: + type, public :: cn_products_type + private + ! ------------------------------------------------------------------------ + ! 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 + + ! Infrastructure routines + procedure, public :: Init + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, public :: Restart + + ! Science routines + procedure, public :: UpdateProducts + procedure, private :: PartitionWoodFluxes + procedure, private :: PartitionGrainFluxes + procedure, private :: ComputeSummaryVars + + end type cn_products_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine Init(this, bounds, species) + ! !ARGUMENTS: + class(cn_products_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + + ! species tells whether this object is being used for C, N, C13, C14, etc. This is + ! just used for naming history and restart fields + class(species_base_type), intent(in) :: species + + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Init' + !----------------------------------------------------------------------- + + allocate(this%species, source = species) + + call this%InitAllocate(bounds) + call this%InitHistory(bounds) + call this%InitCold(bounds) + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! !ARGUMENTS: + class(cn_products_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp,endp + integer :: begg,endg + + character(len=*), parameter :: subname = 'InitAllocate' + !----------------------------------------------------------------------- + + 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(:) = nan + 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(:) = nan + 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 + + end subroutine InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! !USES: + use histFileMod, only : hist_addfld1d + use clm_varcon , only : spval + ! + ! !ARGUMENTS: + class(cn_products_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begg,endg + character(len=:), allocatable :: active_if_non_isotope + + character(len=*), parameter :: subname = 'InitHistory' + !----------------------------------------------------------------------- + + begg = bounds%begg + endg = bounds%endg + + if (this%species%is_isotope()) then + active_if_non_isotope = 'inactive' + else + active_if_non_isotope = 'active' + end if + + this%cropprod1_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('CROPPROD1'), & + units = 'g' // this%species%get_species() // '/m^2', & + avgflag = 'A', & + long_name = '1-yr crop product (grain+biofuel) ' // this%species%get_species(), & + ptr_gcell = this%cropprod1_grc, default=active_if_non_isotope) + + this%prod10_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('PROD10'), & + units = 'g' // this%species%get_species() // '/m^2', & + avgflag = 'A', & + long_name = '10-yr wood product ' // this%species%get_species(), & + ptr_gcell = this%prod10_grc, default='inactive') + + this%prod100_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('PROD100'), & + units = 'g' // this%species%get_species() // '/m^2', & + avgflag = 'A', & + long_name = '100-yr wood product ' // this%species%get_species(), & + ptr_gcell = this%prod100_grc, default='inactive') + + this%tot_woodprod_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('TOT_WOODPROD'), & + units = 'g' // this%species%get_species() // '/m^2', & + avgflag = 'A', & + long_name = 'total wood product ' // this%species%get_species(), & + ptr_gcell = this%tot_woodprod_grc, default=active_if_non_isotope) + + this%dwt_prod10_gain_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('DWT_PROD10', suffix='_GAIN'), & + units = 'g' // this%species%get_species() // '/m^2/s', & + avgflag = 'A', & + long_name = 'landcover change-driven addition to 10-yr wood product pool', & + ptr_gcell = this%dwt_prod10_gain_grc, default='inactive') + + this%dwt_prod100_gain_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('DWT_PROD100', suffix='_GAIN'), & + units = 'g' // this%species%get_species() // '/m^2/s', & + avgflag = 'A', & + long_name = 'landcover change-driven addition to 100-yr wood product pool', & + ptr_gcell = this%dwt_prod100_gain_grc, default='inactive') + + this%dwt_woodprod_gain_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('DWT_WOODPROD', suffix='_GAIN'), & + units = 'g' // this%species%get_species() // '/m^2/s', & + avgflag = 'A', & + long_name = 'landcover change-driven addition to wood product pools', & + ptr_gcell = this%dwt_woodprod_gain_grc, default=active_if_non_isotope) + + this%dwt_cropprod1_gain_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('DWT_CROPPROD1', suffix='_GAIN'), & + units = 'g' // this%species%get_species() // '/m^2/s', & + avgflag = 'A', & + long_name = 'landcover change-driven addition to 1-year crop product pool', & + ptr_gcell = this%dwt_cropprod1_gain_grc, default=active_if_non_isotope) + + this%cropprod1_loss_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('CROPPROD1', suffix='_LOSS'), & + units = 'g' // this%species%get_species() // '/m^2/s', & + avgflag = 'A', & + long_name = 'loss from 1-yr crop product pool', & + ptr_gcell = this%cropprod1_loss_grc, default=active_if_non_isotope) + + this%prod10_loss_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('PROD10', suffix='_LOSS'), & + units = 'g' // this%species%get_species() // '/m^2/s', & + avgflag = 'A', & + long_name = 'loss from 10-yr wood product pool', & + ptr_gcell = this%prod10_loss_grc, default='inactive') + + this%prod100_loss_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('PROD100', suffix='_LOSS'), & + units = 'g' // this%species%get_species() // '/m^2/s', & + avgflag = 'A', & + long_name = 'loss from 100-yr wood product pool', & + ptr_gcell = this%prod100_loss_grc, default='inactive') + + this%tot_woodprod_loss_grc(begg:endg) = spval + call hist_addfld1d( & + fname = this%species%hist_fname('TOT_WOODPROD', suffix='_LOSS'), & + units = 'g' // this%species%get_species() // '/m^2/s', & + avgflag = 'A', & + long_name = 'total loss from wood product pools', & + ptr_gcell = this%tot_woodprod_loss_grc, default=active_if_non_isotope) + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! !ARGUMENTS: + class(cn_products_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g, p + + character(len=*), parameter :: subname = 'InitCold' + !----------------------------------------------------------------------- + + do g = bounds%begg, bounds%endg + this%cropprod1_grc(g) = 0._r8 + this%prod10_grc(g) = 0._r8 + this%prod100_grc(g) = 0._r8 + this%tot_woodprod_grc(g) = 0._r8 + end do + + ! Need to set these patch-level fluxes to 0 everywhere for the sake of special + ! landunits (because they don't get set over special landunits in the run loop) + do p = bounds%begp, bounds%endp + this%hrv_deadstem_to_prod10_patch(p) = 0._r8 + this%hrv_deadstem_to_prod100_patch(p) = 0._r8 + this%grain_to_cropprod1_patch(p) = 0._r8 + end do + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart(this, bounds, ncid, flag, & + template_for_missing_fields, template_multiplier) + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_double + use restUtilMod, only : restartvar, set_missing_from_template, set_grc_field_from_col_field + ! + ! !ARGUMENTS: + class(cn_products_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid + character(len=*), intent(in) :: flag ! 'read' or 'write' + + ! If template_for_missing_fields and template_multiplier are provided, then: When + ! reading the restart file, for any field not present on the restart file, the field + ! in this object is set equal to the corresponding field in + ! template_for_missing_fields times template_multiplier. + ! + ! The Restart routine must have been called on template_for_missing_fields before + ! calling it on this object. + ! + ! (Must provide both template_for_missing_fields and template_multiplier or neither) + class(cn_products_type), optional, intent(in) :: template_for_missing_fields + real(r8), optional, intent(in) :: template_multiplier + + ! + ! !LOCAL VARIABLES: + logical :: template_provided + logical :: readvar + + character(len=*), parameter :: subname = 'Restart' + !----------------------------------------------------------------------- + + if (present(template_for_missing_fields) .and. present(template_multiplier)) then + template_provided = .true. + else if (present(template_for_missing_fields)) then + call endrun(& + msg='template_for_missing_fields provided; must also provide template_multiplier' // & + errMsg(sourcefile, __LINE__)) + else if (present(template_multiplier)) then + call endrun(& + msg='template_multiplier provided; must also provide template_for_missing_fields' // & + errMsg(sourcefile, __LINE__)) + else + template_provided = .false. + end if + + ! NOTE(wjs, 2016-03-29) Adding '_g' suffixes to the end of the restart field names to + ! distinguish these gridcell-level restart fields from the obsolete column-level + ! restart fields that are present on old restart files. + + call restartvar(ncid=ncid, flag=flag, & + varname=this%species%rest_fname('cropprod1', suffix='_g'), & + xtype=ncd_double, dim1name='gridcell', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%cropprod1_grc) + if (flag == 'read' .and. .not. readvar) then + ! BACKWARDS_COMPATIBILITY(wjs, 2016-03-31) If the gridcell-level field isn't + ! present, try to find a column-level field (which may be present on an older + ! restart file). + call set_grc_field_from_col_field( & + bounds = bounds, & + ncid = ncid, & + varname = this%species%rest_fname('cropprod1'), & + data_grc = this%cropprod1_grc, & + readvar = readvar) + + ! If we still haven't found an appropriate field on the restart file, then set + ! this field from the template, if provided + if (.not. readvar .and. template_provided) then + call set_missing_from_template(this%cropprod1_grc, & + template_for_missing_fields%cropprod1_grc, & + multiplier = template_multiplier) + end if + end if + + call restartvar(ncid=ncid, flag=flag, & + varname=this%species%rest_fname('prod10', suffix='_g'), & + xtype=ncd_double, dim1name='gridcell', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%prod10_grc) + if (flag == 'read' .and. .not. readvar) then + ! BACKWARDS_COMPATIBILITY(wjs, 2016-03-31) If the gridcell-level field isn't + ! present, try to find a column-level field (which may be present on an older + ! restart file). + call set_grc_field_from_col_field( & + bounds = bounds, & + ncid = ncid, & + varname = this%species%rest_fname('prod10'), & + data_grc = this%prod10_grc, & + readvar = readvar) + + ! If we still haven't found an appropriate field on the restart file, then set + ! this field from the template, if provided + if (.not. readvar .and. template_provided) then + call set_missing_from_template(this%prod10_grc, & + template_for_missing_fields%prod10_grc, & + multiplier = template_multiplier) + end if + end if + + call restartvar(ncid=ncid, flag=flag, & + varname=this%species%rest_fname('prod100', suffix='_g'), & + xtype=ncd_double, dim1name='gridcell', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%prod100_grc) + if (flag == 'read' .and. .not. readvar) then + ! BACKWARDS_COMPATIBILITY(wjs, 2016-03-31) If the gridcell-level field isn't + ! present, try to find a column-level field (which may be present on an older + ! restart file). + call set_grc_field_from_col_field( & + bounds = bounds, & + ncid = ncid, & + varname = this%species%rest_fname('prod100'), & + data_grc = this%prod100_grc, & + readvar = readvar) + + ! If we still haven't found an appropriate field on the restart file, then set + ! this field from the template, if provided + if (.not. readvar .and. template_provided) then + call set_missing_from_template(this%prod100_grc, & + template_for_missing_fields%prod100_grc, & + multiplier = template_multiplier) + end if + end if + + if (flag == 'read') then + call this%ComputeSummaryVars(bounds) + end if + + end subroutine Restart + + !----------------------------------------------------------------------- + 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_orig_files/CNRootDynMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNRootDynMod.F90 new file mode 100644 index 000000000..8929f7f90 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNSharedParamsMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNSharedParamsMod.F90 new file mode 100644 index 000000000..8a4eafc99 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNSharedParamsMod.F90 @@ -0,0 +1,191 @@ +module CNSharedParamsMod + + !----------------------------------------------------------------------- + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + 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 = .false. ! Use the FUN2.0 model + integer, public :: nlev_soildecomp_standard = 5 + + 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=*), 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_orig_files/CNVegCarbonFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegCarbonFluxType.F90 new file mode 100644 index 000000000..274424137 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegCarbonFluxType.F90 @@ -0,0 +1,5136 @@ +module CNVegCarbonFluxType + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + 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_varcon , only : spval, dzsoi_decomp + use clm_varctl , only : use_cndv, use_c13, use_c14, use_nitrif_denitrif, use_crop, use_matrixcn, use_soil_matrixcn + use clm_varctl , only : use_grainproduct + use clm_varctl , only : iulog + use landunit_varcon , only : istsoil, istcrop, istdlak + use pftconMod , only : npcropmin + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use AnnualFluxDribbler , only : annual_flux_dribbler_type, annual_flux_dribbler_gridcell + use dynSubgridControlMod , only : get_for_testing_allow_non_annual_changes + use abortutils , only : endrun + use SPMMod , only : sparse_matrix_type, diag_matrix_type, vector_type + ! + ! !PUBLIC TYPES: + implicit none + private + ! + 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) patch-level wood C loss + + 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 + integer :: NE_AKallvegc ! Number of entries in AKallvegc + integer,pointer,dimension(:) :: RI_AKallvegc ! Row indices in Akallvegc + integer,pointer,dimension(:) :: CI_AKallvegc ! Column indices in AKallvegc + integer,pointer,dimension(:) :: RI_phc ! Row indices of non-diagonal entires in Aph for C cycle + integer,pointer,dimension(:) :: CI_phc ! Column indices of non-diagonal entries in Aph for C cycle + integer,pointer,dimension(:) :: RI_gmc ! Row indices of non-diagonal entires in Agm for C cycle + integer,pointer,dimension(:) :: CI_gmc ! Column indices of non-diagonal entries in Agm for C cycle + integer,pointer,dimension(:) :: RI_fic ! Row indices of non-diagonal entires in Afi for C cycle + integer,pointer,dimension(:) :: CI_fic ! Column indices of non-diagonal entries in Afi for C cycle + type(diag_matrix_type) :: Kvegc ! Temporary variable of Kph, Kgm or Kfi for C cycle in diagonal 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 :: Init + procedure , private :: InitTransfer + procedure , private :: InitAllocate + procedure , private :: InitHistory + procedure , private :: InitCold + procedure , public :: Restart + procedure , private :: RestartBulkOnly ! Handle restart fields only present for bulk C + procedure , private :: RestartAllIsotopes ! Handle restart fields present for both bulk C and isotopes + procedure , public :: SetValues + procedure , public :: ZeroDWT + procedure , public :: Summary => Summary_carbonflux + + end type cnveg_carbonflux_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, carbon_type, dribble_crophrv_xsmrpool_2atm) + + class(cnveg_carbonflux_type) :: this + type(bounds_type), intent(in) :: bounds + character(len=3) , intent(in) :: carbon_type ! one of ['c12', c13','c14'] + logical , intent(in) :: dribble_crophrv_xsmrpool_2atm + + this%dribble_crophrv_xsmrpool_2atm = dribble_crophrv_xsmrpool_2atm + call this%InitAllocate ( bounds, carbon_type) + if(use_matrixcn)then + call this%InitTransfer () + end if + call this%InitHistory ( bounds, carbon_type ) + call this%InitCold (bounds ) + + end subroutine Init + + subroutine InitTransfer (this) + ! + ! !AGRUMENTS: + class (cnveg_carbonflux_type) :: this + + 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 + + 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 + + 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 + + end subroutine InitTransfer + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds, carbon_type) + ! + ! !ARGUMENTS: + class (cnveg_carbonflux_type) :: this + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: carbon_type ! one of ['c12', c13','c14'] + ! + ! !LOCAL VARIABLES: + integer :: begp,endp + integer :: begc,endc + integer :: begg,endg + logical :: allows_non_annual_delta + character(len=:), allocatable :: carbon_type_suffix + !------------------------------------------------------------------------ + + 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(:) = nan + + 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 (:) = nan + 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 (:) = nan + allocate(this%npp_patch (begp:endp)) ; this%npp_patch (:) = nan + 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 (:) = nan + allocate(this%fire_closs_patch (begp:endp)) ; this%fire_closs_patch (:) = nan + 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 (:) = nan + 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 (:) = nan + 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 (:) = nan + 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 +! Matrix + if(use_matrixcn)then + allocate(this%matrix_Cinput_patch (begp:endp)) ; this%matrix_Cinput_patch (:) = nan + allocate(this%matrix_C13input_patch (begp:endp)) ; this%matrix_C13input_patch (:) = nan !for isotop + allocate(this%matrix_C14input_patch (begp:endp)) ; this%matrix_C14input_patch (:) = nan + allocate(this%matrix_alloc_patch (begp:endp,1:nvegcpool)) ; this%matrix_alloc_patch (:,:) = nan + + allocate(this%matrix_phtransfer_patch (begp:endp,1:ncphtrans)) ; this%matrix_phtransfer_patch (:,:) = nan + allocate(this%matrix_phturnover_patch (begp:endp,1:nvegcpool)) ; this%matrix_phturnover_patch (:,:) = nan + allocate(this%matrix_phtransfer_doner_patch (1:ncphtrans)) ; this%matrix_phtransfer_doner_patch(:) = -9999 + allocate(this%matrix_phtransfer_receiver_patch (1:ncphtrans)) ; this%matrix_phtransfer_receiver_patch(:) = -9999 + + allocate(this%matrix_gmtransfer_patch (begp:endp,1:ncgmtrans)) ; this%matrix_gmtransfer_patch (:,:) = nan + allocate(this%matrix_gmturnover_patch (begp:endp,1:nvegcpool)) ; this%matrix_gmturnover_patch (:,:) = nan + allocate(this%matrix_gmtransfer_doner_patch (1:ncgmtrans)) ; this%matrix_gmtransfer_doner_patch(:) = -9999 + allocate(this%matrix_gmtransfer_receiver_patch (1:ncgmtrans)) ; this%matrix_gmtransfer_receiver_patch(:) = -9999 + + allocate(this%matrix_fitransfer_patch (begp:endp,1:ncfitrans)) ; this%matrix_fitransfer_patch (:,:) = nan + allocate(this%matrix_fiturnover_patch (begp:endp,1:nvegcpool)) ; this%matrix_fiturnover_patch (:,:) = nan + allocate(this%matrix_fitransfer_doner_patch (1:ncfitrans)) ; this%matrix_fitransfer_doner_patch(:) = -9999 + allocate(this%matrix_fitransfer_receiver_patch (1:ncfitrans)) ; this%matrix_fitransfer_receiver_patch(:) = -9999 + + allocate(this%list_phc_phgmc (1:ncphtrans+nvegcpool)) ; this%list_phc_phgmc(:) = -9999 + allocate(this%list_gmc_phgmc (1:nvegcpool)) ; this%list_gmc_phgmc(:) = -9999 + allocate(this%list_phc_phgmfic (1:ncphtrans+nvegcpool)); this%list_phc_phgmfic(:) = -9999 + allocate(this%list_gmc_phgmfic (1:nvegcpool)) ; this%list_gmc_phgmfic(:) = -9999 + allocate(this%list_fic_phgmfic (1:ncfitrans+nvegcpool)); this%list_fic_phgmfic(:) = -9999 + + allocate(this%list_aphc(1:ncphtrans-ncphouttrans)); this%list_aphc = -9999 + allocate(this%list_agmc(1:ncgmtrans-ncgmouttrans)); this%list_agmc = -9999 + allocate(this%list_afic(1:ncfitrans-ncfiouttrans)); this%list_afic = -9999 + + call this%AKphvegc%InitSM(nvegcpool,begp,endp,ncphtrans-ncphouttrans+nvegcpool) + call this%AKgmvegc%InitSM(nvegcpool,begp,endp,ncgmtrans-ncgmouttrans+nvegcpool) + call this%AKfivegc%InitSM(nvegcpool,begp,endp,ncfitrans-ncfiouttrans+nvegcpool) + call this%AKallvegc%InitSM(nvegcpool,begp,endp,ncphtrans-ncphouttrans+ncfitrans-ncfiouttrans+nvegcpool) + this%NE_AKallvegc = (ncphtrans-ncphouttrans+nvegcpool) + (ncgmtrans-ncgmouttrans+nvegcpool) + & + ncfitrans-ncfiouttrans+nvegcpool + allocate(this%RI_AKallvegc(1:this%NE_AKallvegc));this%RI_AKallvegc(:) = -9999 + allocate(this%CI_AKallvegc(1:this%NE_AKallvegc));this%CI_AKallvegc(:) = -9999 + allocate(this%RI_phc(1:ncphtrans-ncphouttrans+nvegcpool));this%RI_phc(:) = -9999 + allocate(this%CI_phc(1:ncphtrans-ncphouttrans+nvegcpool));this%CI_phc(:) = -9999 + allocate(this%RI_gmc(1:ncgmtrans-ncgmouttrans+nvegcpool));this%RI_gmc(:) = -9999 + allocate(this%CI_gmc(1:ncgmtrans-ncgmouttrans+nvegcpool));this%CI_gmc(:) = -9999 + allocate(this%RI_fic(1:ncfitrans-ncfiouttrans+nvegcpool));this%RI_fic(:) = -9999 + allocate(this%CI_fic(1:ncfitrans-ncfiouttrans+nvegcpool));this%CI_fic(:) = -9999 + call this%Kvegc%InitDM(nvegcpool,begp,endp) + call this%Xvegc%InitV(nvegcpool,begp,endp) + if(use_c13)then + call this%Xveg13c%InitV(nvegcpool,begp,endp) + end if + if(use_c14)then + call this%Xveg14c%InitV(nvegcpool,begp,endp) + end if + end if + + ! 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 + + ! Note that, for both of these dribblers, we set allows_non_annual_delta to false + ! because we expect both land cover change and harvest to be applied entirely at the + ! start of the year, and want to be notified if this changes. If this behavior is + ! changed intentionally, then this setting of allows_non_annual_delta to .false. can + ! safely be removed. + ! + ! However, we do keep allows_non_annual_delta = .true. for the dwt_conv_cflux_dribbler if + ! running with CNDV, because (in contrast with other land cover change) CNDV currently + ! still interpolates land cover change throughout the year. + if (get_for_testing_allow_non_annual_changes()) then + allows_non_annual_delta = .true. + else 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 InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds, carbon_type) + ! + ! !DESCRIPTION: + ! add history fields for all CN variables, always set as default='inactive' + ! + ! !USES: + use clm_varpar , only : nlevdecomp, nlevdecomp_full, nlevgrnd + use clm_varctl , only : hist_wrtch4diag + use CNSharedParamsMod, only: use_fun + use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + ! + ! !ARGUMENTS: + class(cnveg_carbonflux_type) :: this + type(bounds_type) , intent(in) :: bounds + character(len=3) , intent(in) :: carbon_type ! one of ['c12', c13','c14'] + ! + ! !LOCAL VARIABLES: + integer :: k,l,ii,jj + character(8) :: vr_suffix + character(10) :: active + integer :: begp,endp + integer :: begc,endc + integer :: begg,endg + character(24) :: fieldname + character(100) :: longname + real(r8), pointer :: data1dptr(:) ! temp. pointer for slicing larger arrays + real(r8), pointer :: data2dptr(:,:) ! temp. pointer for slicing larger arrays + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + + if (nlevdecomp > 1) then + vr_suffix = "_vr" + else + vr_suffix = "" + endif + + !------------------------------- + ! C flux variables - patch + !------------------------------- + + if (carbon_type == 'c12') then + + if (use_crop) then + this%grainc_to_food_patch(begp:endp) = spval + call hist_addfld1d (fname='GRAINC_TO_FOOD', units='gC/m^2/s', & + avgflag='A', long_name='grain C to food', & + ptr_patch=this%grainc_to_food_patch) + + this%leafc_to_biofuelc_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_TO_BIOFUELC', units='gC/m^2/s', & + avgflag='A', long_name='leaf C to biofuel C', & + ptr_patch=this%leafc_to_biofuelc_patch) + + this%livestemc_to_biofuelc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_TO_BIOFUELC', units='gC/m^2/s', & + avgflag='A', long_name='livestem C to biofuel C', & + ptr_patch=this%livestemc_to_biofuelc_patch) + + this%grainc_to_seed_patch(begp:endp) = spval + call hist_addfld1d (fname='GRAINC_TO_SEED', units='gC/m^2/s', & + avgflag='A', long_name='grain C to seed', & + ptr_patch=this%grainc_to_seed_patch) + end if + + this%litterc_loss_col(begc:endc) = spval + call hist_addfld1d (fname='LITTERC_LOSS', units='gC/m^2/s', & + avgflag='A', long_name='litter C loss', & + ptr_col=this%litterc_loss_col) + + this%woodc_alloc_patch(begp:endp) = spval + call hist_addfld1d (fname='WOODC_ALLOC', units='gC/m^2/s', & + avgflag='A', long_name='wood C eallocation', & + ptr_patch=this%woodc_alloc_patch) + + this%woodc_loss_patch(begp:endp) = spval + call hist_addfld1d (fname='WOODC_LOSS', units='gC/m^2/s', & + avgflag='A', long_name='wood C loss', & + ptr_patch=this%woodc_loss_patch) + + this%leafc_loss_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_LOSS', units='gC/m^2/s', & + avgflag='A', long_name='leaf C loss', & + ptr_patch=this%leafc_loss_patch) + + this%leafc_alloc_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_ALLOC', units='gC/m^2/s', & + avgflag='A', long_name='leaf C allocation', & + ptr_patch=this%leafc_alloc_patch) + + this%frootc_loss_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_LOSS', units='gC/m^2/s', & + avgflag='A', long_name='fine root C loss', & + ptr_patch=this%frootc_loss_patch) + + this%frootc_alloc_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_ALLOC', units='gC/m^2/s', & + avgflag='A', long_name='fine root C allocation', & + ptr_patch=this%frootc_alloc_patch) + + this%m_leafc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='leaf C mortality', & + ptr_patch=this%m_leafc_to_litter_patch, default='inactive') + + this%m_frootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='fine root C mortality', & + ptr_patch=this%m_frootc_to_litter_patch, default='inactive') + + this%m_leafc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_STORAGE_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='leaf C storage mortality', & + ptr_patch=this%m_leafc_storage_to_litter_patch, default='inactive') + + this%m_frootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_STORAGE_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='fine root C storage mortality', & + ptr_patch=this%m_frootc_storage_to_litter_patch, default='inactive') + + this%m_livestemc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_STORAGE_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='live stem C storage mortality', & + ptr_patch=this%m_livestemc_storage_to_litter_patch, default='inactive') + + this%m_deadstemc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_STORAGE_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C storage mortality', & + ptr_patch=this%m_deadstemc_storage_to_litter_patch, default='inactive') + + this%m_livecrootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTC_STORAGE_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root C storage mortality', & + ptr_patch=this%m_livecrootc_storage_to_litter_patch, default='inactive') + + this%m_deadcrootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTC_STORAGE_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root C storage mortality', & + ptr_patch=this%m_deadcrootc_storage_to_litter_patch, default='inactive') + + this%m_leafc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_XFER_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='leaf C transfer mortality', & + ptr_patch=this%m_leafc_xfer_to_litter_patch, default='inactive') + + this%m_frootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_XFER_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='fine root C transfer mortality', & + ptr_patch=this%m_frootc_xfer_to_litter_patch, default='inactive') + + this%m_livestemc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_XFER_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='live stem C transfer mortality', & + ptr_patch=this%m_livestemc_xfer_to_litter_patch, default='inactive') + + this%m_deadstemc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_XFER_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C transfer mortality', & + ptr_patch=this%m_deadstemc_xfer_to_litter_patch, default='inactive') + + this%m_livecrootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTC_XFER_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root C transfer mortality', & + ptr_patch=this%m_livecrootc_xfer_to_litter_patch, default='inactive') + + this%m_deadcrootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTC_XFER_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root C transfer mortality', & + ptr_patch=this%m_deadcrootc_xfer_to_litter_patch, default='inactive') + + this%m_livestemc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='live stem C mortality', & + ptr_patch=this%m_livestemc_to_litter_patch, default='inactive') + + this%m_deadstemc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C mortality', & + ptr_patch=this%m_deadstemc_to_litter_patch, default='inactive') + + this%m_livecrootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root C mortality', & + ptr_patch=this%m_livecrootc_to_litter_patch, default='inactive') + + this%m_deadcrootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root C mortality', & + ptr_patch=this%m_deadcrootc_to_litter_patch, default='inactive') + + this%m_gresp_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_GRESP_STORAGE_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration storage mortality', & + ptr_patch=this%m_gresp_storage_to_litter_patch, default='inactive') + + this%m_gresp_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_GRESP_XFER_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration transfer mortality', & + ptr_patch=this%m_gresp_xfer_to_litter_patch, default='inactive') + + this%m_leafc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='leaf C fire loss', & + ptr_patch=this%m_leafc_to_fire_patch, default='inactive') + + this%m_leafc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_STORAGE_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='leaf C storage fire loss', & + ptr_patch=this%m_leafc_storage_to_fire_patch, default='inactive') + + this%m_leafc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_XFER_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='leaf C transfer fire loss', & + ptr_patch=this%m_leafc_xfer_to_fire_patch, default='inactive') + + this%m_livestemc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live stem C fire loss', & + ptr_patch=this%m_livestemc_to_fire_patch, default='inactive') + + this%m_livestemc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_STORAGE_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live stem C storage fire loss', & + ptr_patch=this%m_livestemc_storage_to_fire_patch, default='inactive') + + this%m_livestemc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_XFER_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live stem C transfer fire loss', & + ptr_patch=this%m_livestemc_xfer_to_fire_patch, default='inactive') + + this%m_deadstemc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C fire loss', & + ptr_patch=this%m_deadstemc_to_fire_patch, default='inactive') + + this%m_deadstemc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_STORAGE_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C storage fire loss', & + ptr_patch=this%m_deadstemc_storage_to_fire_patch, default='inactive') + + this%m_deadstemc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_XFER_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C transfer fire loss', & + ptr_patch=this%m_deadstemc_xfer_to_fire_patch, default='inactive') + + this%m_frootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='fine root C fire loss', & + ptr_patch=this%m_frootc_to_fire_patch, default='inactive') + + this%m_frootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_STORAGE_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='fine root C storage fire loss', & + ptr_patch=this%m_frootc_storage_to_fire_patch, default='inactive') + + this%m_frootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_XFER_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='fine root C transfer fire loss', & + ptr_patch=this%m_frootc_xfer_to_fire_patch, default='inactive') + + this%m_livecrootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVEROOTC_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live root C fire loss', & + ptr_patch=this%m_livecrootc_to_fire_patch, default='inactive') + + this%m_livecrootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVEROOTC_STORAGE_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live root C storage fire loss', & + ptr_patch=this%m_livecrootc_storage_to_fire_patch, default='inactive') + + this%m_livecrootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVEROOTC_XFER_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live root C transfer fire loss', & + ptr_patch=this%m_livecrootc_xfer_to_fire_patch, default='inactive') + + this%m_deadcrootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADROOTC_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead root C fire loss', & + ptr_patch=this%m_deadcrootc_to_fire_patch, default='inactive') + + this%m_deadcrootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADROOTC_STORAGE_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead root C storage fire loss', & + ptr_patch=this%m_deadcrootc_storage_to_fire_patch, default='inactive') + + this%m_deadcrootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADROOTC_XFER_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead root C transfer fire loss', & + ptr_patch=this%m_deadcrootc_xfer_to_fire_patch, default='inactive') + + this%m_gresp_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_GRESP_STORAGE_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration storage fire loss', & + ptr_patch=this%m_gresp_storage_to_fire_patch, default='inactive') + + this%m_gresp_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_GRESP_XFER_TO_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration transfer fire loss', & + ptr_patch=this%m_gresp_xfer_to_fire_patch, default='inactive') + + this%m_leafc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='leaf C fire mortality to litter', & + ptr_patch=this%m_leafc_to_litter_fire_patch, default='inactive') + + ! add by F. Li and S. Levis + this%m_leafc_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='leaf C fire mortality to litter', & + ptr_patch=this%m_leafc_storage_to_litter_fire_patch, default='inactive') + + this%m_leafc_xfer_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFC_XFER_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='leaf C transfer fire mortality to litter', & + ptr_patch=this%m_leafc_xfer_to_litter_fire_patch, default='inactive') + + this%m_livestemc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live stem C fire mortality to litter', & + ptr_patch=this%m_livestemc_to_litter_fire_patch, default='inactive') + + this%m_livestemc_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live stem C storage fire mortality to litter', & + ptr_patch=this%m_livestemc_storage_to_litter_fire_patch, default='inactive') + + this%m_livestemc_xfer_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_XFER_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live stem C transfer fire mortality to litter', & + ptr_patch=this%m_livestemc_xfer_to_litter_fire_patch, default='inactive') + + this%m_livestemc_to_deadstemc_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMC_TO_DEADSTEMC_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live stem C fire mortality to dead stem C', & + ptr_patch=this%m_livestemc_to_deadstemc_fire_patch, default='inactive') + + this%m_deadstemc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C fire mortality to litter', & + ptr_patch=this%m_deadstemc_to_litter_fire_patch, default='inactive') + + this%m_deadstemc_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C storage fire mortality to litter', & + ptr_patch=this%m_deadstemc_storage_to_litter_fire_patch, default='inactive') + + this%m_deadstemc_xfer_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMC_XFER_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C transfer fire mortality to litter', & + ptr_patch=this%m_deadstemc_xfer_to_litter_fire_patch, default='inactive') + + this%m_frootc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='fine root C fire mortality to litter', & + ptr_patch=this%m_frootc_to_litter_fire_patch, default='inactive') + + this%m_frootc_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='fine root C storage fire mortality to litter', & + ptr_patch=this%m_frootc_storage_to_litter_fire_patch, default='inactive') + + this%m_frootc_xfer_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTC_XFER_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='fine root C transfer fire mortality to litter', & + ptr_patch=this%m_frootc_xfer_to_litter_fire_patch, default='inactive') + + this%m_livecrootc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVEROOTC_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live root C fire mortality to litter', & + ptr_patch=this%m_livecrootc_to_litter_fire_patch, default='inactive') + + this%m_livecrootc_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVEROOTC_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live root C storage fire mortality to litter', & + ptr_patch=this%m_livecrootc_storage_to_litter_fire_patch, default='inactive') + + this%m_livecrootc_xfer_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVEROOTC_XFER_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live root C transfer fire mortality to litter', & + ptr_patch=this%m_livecrootc_xfer_to_litter_fire_patch, default='inactive') + + this%m_livecrootc_to_deadcrootc_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVEROOTC_TO_DEADROOTC_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live root C fire mortality to dead root C', & + ptr_patch=this%m_livecrootc_to_deadcrootc_fire_patch, default='inactive') + + + this%m_deadcrootc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADROOTC_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead root C fire mortality to litter', & + ptr_patch=this%m_deadcrootc_to_litter_fire_patch, default='inactive') + + this%m_deadcrootc_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADROOTC_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead root C storage fire mortality to litter', & + ptr_patch=this%m_deadcrootc_storage_to_litter_fire_patch, default='inactive') + + this%m_deadcrootc_xfer_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADROOTC_XFER_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead root C transfer fire mortality to litter', & + ptr_patch=this%m_deadcrootc_xfer_to_litter_fire_patch, default='inactive') + + this%m_livecrootc_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTC_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root C fire mortality to litter', & + ptr_patch=this%m_livecrootc_storage_to_litter_fire_patch, default='inactive') + + this%m_deadcrootc_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTC_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root C storage fire mortality to litter', & + ptr_patch=this%m_deadcrootc_storage_to_litter_fire_patch, default='inactive') + + this%m_gresp_storage_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_GRESP_STORAGE_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration storage fire mortality to litter', & + ptr_patch=this%m_gresp_storage_to_litter_fire_patch, default='inactive') + + this%m_gresp_xfer_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_GRESP_XFER_TO_LITTER_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration transfer fire mortality to litter', & + ptr_patch=this%m_gresp_xfer_to_litter_fire_patch, default='inactive') + + this%leafc_xfer_to_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_XFER_TO_LEAFC', units='gC/m^2/s', & + avgflag='A', long_name='leaf C growth from storage', & + ptr_patch=this%leafc_xfer_to_leafc_patch, default='inactive') + + this%frootc_xfer_to_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_XFER_TO_FROOTC', units='gC/m^2/s', & + avgflag='A', long_name='fine root C growth from storage', & + ptr_patch=this%frootc_xfer_to_frootc_patch, default='inactive') + + this%livestemc_xfer_to_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_XFER_TO_LIVESTEMC', units='gC/m^2/s', & + avgflag='A', long_name='live stem C growth from storage', & + ptr_patch=this%livestemc_xfer_to_livestemc_patch, default='inactive') + + this%deadstemc_xfer_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC_XFER_TO_DEADSTEMC', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C growth from storage', & + ptr_patch=this%deadstemc_xfer_to_deadstemc_patch, default='inactive') + + this%livecrootc_xfer_to_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC_XFER_TO_LIVECROOTC', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root C growth from storage', & + ptr_patch=this%livecrootc_xfer_to_livecrootc_patch, default='inactive') + + this%deadcrootc_xfer_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTC_XFER_TO_DEADCROOTC', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root C growth from storage', & + ptr_patch=this%deadcrootc_xfer_to_deadcrootc_patch, default='inactive') + + this%leafc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='leaf C litterfall', & + ptr_patch=this%leafc_to_litter_patch, default='inactive') + + if ( use_fun ) then + this%leafc_to_litter_fun_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_TO_LITTER_FUN', units='gC/m^2/s', & + avgflag='A', long_name='leaf C litterfall used by FUN', & + ptr_patch=this%leafc_to_litter_fun_patch) + end if + + this%frootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='fine root C litterfall', & + ptr_patch=this%frootc_to_litter_patch, default='inactive') + + this%cpool_to_resp_patch(begp:endp) = spval + call hist_addfld1d (fname='EXCESSC_MR', units='gC/m^2/s', & + avgflag='A', long_name='excess C maintenance respiration', & + ptr_patch=this%cpool_to_resp_patch, default='inactive') + this%leaf_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAF_MR', units='gC/m^2/s', & + avgflag='A', long_name='leaf maintenance respiration', & + ptr_patch=this%leaf_mr_patch) + + this%froot_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOT_MR', units='gC/m^2/s', & + avgflag='A', long_name='fine root maintenance respiration', & + ptr_patch=this%froot_mr_patch, default='inactive') + + this%livestem_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEM_MR', units='gC/m^2/s', & + avgflag='A', long_name='live stem maintenance respiration', & + ptr_patch=this%livestem_mr_patch, default='inactive') + + this%livecroot_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOT_MR', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root maintenance respiration', & + ptr_patch=this%livecroot_mr_patch, default='inactive') + + this%psnsun_to_cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='PSNSUN_TO_CPOOL', units='gC/m^2/s', & + avgflag='A', long_name='C fixation from sunlit canopy', & + ptr_patch=this%psnsun_to_cpool_patch) + + this%psnshade_to_cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='PSNSHADE_TO_CPOOL', units='gC/m^2/s', & + avgflag='A', long_name='C fixation from shaded canopy', & + ptr_patch=this%psnshade_to_cpool_patch) + + this%cpool_to_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_LEAFC', units='gC/m^2/s', & + avgflag='A', long_name='allocation to leaf C', & + ptr_patch=this%cpool_to_leafc_patch, default='inactive') + + this%cpool_to_leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_LEAFC_STORAGE', units='gC/m^2/s', & + avgflag='A', long_name='allocation to leaf C storage', & + ptr_patch=this%cpool_to_leafc_storage_patch, default='inactive') + + this%cpool_to_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_FROOTC', units='gC/m^2/s', & + avgflag='A', long_name='allocation to fine root C', & + ptr_patch=this%cpool_to_frootc_patch, default='inactive') + + this%cpool_to_frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_FROOTC_STORAGE', units='gC/m^2/s', & + avgflag='A', long_name='allocation to fine root C storage', & + ptr_patch=this%cpool_to_frootc_storage_patch, default='inactive') + + this%cpool_to_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_LIVESTEMC', units='gC/m^2/s', & + avgflag='A', long_name='allocation to live stem C', & + ptr_patch=this%cpool_to_livestemc_patch, default='inactive') + + this%cpool_to_livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_LIVESTEMC_STORAGE', units='gC/m^2/s', & + avgflag='A', long_name='allocation to live stem C storage', & + ptr_patch=this%cpool_to_livestemc_storage_patch, default='inactive') + + this%cpool_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_DEADSTEMC', units='gC/m^2/s', & + avgflag='A', long_name='allocation to dead stem C', & + ptr_patch=this%cpool_to_deadstemc_patch, default='inactive') + + this%cpool_to_deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_DEADSTEMC_STORAGE', units='gC/m^2/s', & + avgflag='A', long_name='allocation to dead stem C storage', & + ptr_patch=this%cpool_to_deadstemc_storage_patch, default='inactive') + + this%cpool_to_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_LIVECROOTC', units='gC/m^2/s', & + avgflag='A', long_name='allocation to live coarse root C', & + ptr_patch=this%cpool_to_livecrootc_patch, default='inactive') + + this%cpool_to_livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_LIVECROOTC_STORAGE', units='gC/m^2/s', & + avgflag='A', long_name='allocation to live coarse root C storage', & + ptr_patch=this%cpool_to_livecrootc_storage_patch, default='inactive') + + this%cpool_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_DEADCROOTC', units='gC/m^2/s', & + avgflag='A', long_name='allocation to dead coarse root C', & + ptr_patch=this%cpool_to_deadcrootc_patch, default='inactive') + + this%cpool_to_deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_DEADCROOTC_STORAGE', units='gC/m^2/s', & + avgflag='A', long_name='allocation to dead coarse root C storage', & + ptr_patch=this%cpool_to_deadcrootc_storage_patch, default='inactive') + + this%cpool_to_gresp_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_TO_GRESP_STORAGE', units='gC/m^2/s', & + avgflag='A', long_name='allocation to growth respiration storage', & + ptr_patch=this%cpool_to_gresp_storage_patch, default='inactive') + + this%cpool_leaf_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_LEAF_GR', units='gC/m^2/s', & + avgflag='A', long_name='leaf growth respiration', & + ptr_patch=this%cpool_leaf_gr_patch, default='inactive') + + this%cpool_leaf_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_LEAF_STORAGE_GR', units='gC/m^2/s', & + avgflag='A', long_name='leaf growth respiration to storage', & + ptr_patch=this%cpool_leaf_storage_gr_patch, default='inactive') + + this%transfer_leaf_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='TRANSFER_LEAF_GR', units='gC/m^2/s', & + avgflag='A', long_name='leaf growth respiration from storage', & + ptr_patch=this%transfer_leaf_gr_patch, default='inactive') + + this%cpool_froot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_FROOT_GR', units='gC/m^2/s', & + avgflag='A', long_name='fine root growth respiration', & + ptr_patch=this%cpool_froot_gr_patch, default='inactive') + + this%cpool_froot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_FROOT_STORAGE_GR', units='gC/m^2/s', & + avgflag='A', long_name='fine root growth respiration to storage', & + ptr_patch=this%cpool_froot_storage_gr_patch, default='inactive') + + this%transfer_froot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='TRANSFER_FROOT_GR', units='gC/m^2/s', & + avgflag='A', long_name='fine root growth respiration from storage', & + ptr_patch=this%transfer_froot_gr_patch, default='inactive') + + this%cpool_livestem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_LIVESTEM_GR', units='gC/m^2/s', & + avgflag='A', long_name='live stem growth respiration', & + ptr_patch=this%cpool_livestem_gr_patch, default='inactive') + + this%cpool_livestem_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_LIVESTEM_STORAGE_GR', units='gC/m^2/s', & + avgflag='A', long_name='live stem growth respiration to storage', & + ptr_patch=this%cpool_livestem_storage_gr_patch, default='inactive') + + this%transfer_livestem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='TRANSFER_LIVESTEM_GR', units='gC/m^2/s', & + avgflag='A', long_name='live stem growth respiration from storage', & + ptr_patch=this%transfer_livestem_gr_patch, default='inactive') + + this%cpool_deadstem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_DEADSTEM_GR', units='gC/m^2/s', & + avgflag='A', long_name='dead stem growth respiration', & + ptr_patch=this%cpool_deadstem_gr_patch, default='inactive') + + this%cpool_deadstem_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_DEADSTEM_STORAGE_GR', units='gC/m^2/s', & + avgflag='A', long_name='dead stem growth respiration to storage', & + ptr_patch=this%cpool_deadstem_storage_gr_patch, default='inactive') + + this%transfer_deadstem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='TRANSFER_DEADSTEM_GR', units='gC/m^2/s', & + avgflag='A', long_name='dead stem growth respiration from storage', & + ptr_patch=this%transfer_deadstem_gr_patch, default='inactive') + + this%cpool_livecroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_LIVECROOT_GR', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root growth respiration', & + ptr_patch=this%cpool_livecroot_gr_patch, default='inactive') + + this%cpool_livecroot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_LIVECROOT_STORAGE_GR', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root growth respiration to storage', & + ptr_patch=this%cpool_livecroot_storage_gr_patch, default='inactive') + + this%transfer_livecroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='TRANSFER_LIVECROOT_GR', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root growth respiration from storage', & + ptr_patch=this%transfer_livecroot_gr_patch, default='inactive') + + this%cpool_deadcroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_DEADCROOT_GR', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root growth respiration', & + ptr_patch=this%cpool_deadcroot_gr_patch, default='inactive') + + this%cpool_deadcroot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL_DEADCROOT_STORAGE_GR', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root growth respiration to storage', & + ptr_patch=this%cpool_deadcroot_storage_gr_patch, default='inactive') + + this%transfer_deadcroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='TRANSFER_DEADCROOT_GR', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root growth respiration from storage', & + ptr_patch=this%transfer_deadcroot_gr_patch, default='inactive') + + this%leafc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_STORAGE_TO_XFER', units='gC/m^2/s', & + avgflag='A', long_name='leaf C shift storage to transfer', & + ptr_patch=this%leafc_storage_to_xfer_patch, default='inactive') + + this%frootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_STORAGE_TO_XFER', units='gC/m^2/s', & + avgflag='A', long_name='fine root C shift storage to transfer', & + ptr_patch=this%frootc_storage_to_xfer_patch, default='inactive') + + this%livestemc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_STORAGE_TO_XFER', units='gC/m^2/s', & + avgflag='A', long_name='live stem C shift storage to transfer', & + ptr_patch=this%livestemc_storage_to_xfer_patch, default='inactive') + + this%deadstemc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC_STORAGE_TO_XFER', units='gC/m^2/s', & + avgflag='A', long_name='dead stem C shift storage to transfer', & + ptr_patch=this%deadstemc_storage_to_xfer_patch, default='inactive') + + this%livecrootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC_STORAGE_TO_XFER', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root C shift storage to transfer', & + ptr_patch=this%livecrootc_storage_to_xfer_patch, default='inactive') + + this%deadcrootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTC_STORAGE_TO_XFER', units='gC/m^2/s', & + avgflag='A', long_name='dead coarse root C shift storage to transfer', & + ptr_patch=this%deadcrootc_storage_to_xfer_patch, default='inactive') + + this%gresp_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='GRESP_STORAGE_TO_XFER', units='gC/m^2/s', & + avgflag='A', long_name='growth respiration shift storage to transfer', & + ptr_patch=this%gresp_storage_to_xfer_patch, default='inactive') + + this%livestemc_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_TO_DEADSTEMC', units='gC/m^2/s', & + avgflag='A', long_name='live stem C turnover', & + ptr_patch=this%livestemc_to_deadstemc_patch, default='inactive') + + this%livecrootc_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC_TO_DEADCROOTC', units='gC/m^2/s', & + avgflag='A', long_name='live coarse root C turnover', & + ptr_patch=this%livecrootc_to_deadcrootc_patch, default='inactive') + + this%gpp_before_downreg_patch(begp:endp) = spval + call hist_addfld1d (fname='INIT_GPP', units='gC/m^2/s', & + avgflag='A', long_name='GPP flux before downregulation', & + ptr_patch=this%gpp_before_downreg_patch, default='inactive') + + this%current_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='CURRENT_GR', units='gC/m^2/s', & + avgflag='A', long_name='growth resp for new growth displayed in this timestep', & + ptr_patch=this%current_gr_patch, default='inactive') + + this%transfer_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='TRANSFER_GR', units='gC/m^2/s', & + avgflag='A', long_name='growth resp for transfer growth displayed in this timestep', & + ptr_patch=this%transfer_gr_patch, default='inactive') + + this%storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='STORAGE_GR', units='gC/m^2/s', & + avgflag='A', long_name='growth resp for growth sent to storage for later display', & + ptr_patch=this%storage_gr_patch, default='inactive') + + this%availc_patch(begp:endp) = spval + call hist_addfld1d (fname='AVAILC', units='gC/m^2/s', & + avgflag='A', long_name='C flux available for allocation', & + ptr_patch=this%availc_patch, default='inactive') + + this%plant_calloc_patch(begp:endp) = spval + call hist_addfld1d (fname='PLANT_CALLOC', units='gC/m^2/s', & + avgflag='A', long_name='total allocated C flux', & + ptr_patch=this%plant_calloc_patch, default='inactive') + + this%excess_cflux_patch(begp:endp) = spval + call hist_addfld1d (fname='EXCESS_CFLUX', units='gC/m^2/s', & + avgflag='A', long_name='C flux not allocated due to downregulation', & + ptr_patch=this%excess_cflux_patch, default='inactive') + + this%prev_leafc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='PREV_LEAFC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='previous timestep leaf C litterfall flux', & + ptr_patch=this%prev_leafc_to_litter_patch, default='inactive') + + this%prev_frootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='PREV_FROOTC_TO_LITTER', units='gC/m^2/s', & + avgflag='A', long_name='previous timestep froot C litterfall flux', & + ptr_patch=this%prev_frootc_to_litter_patch, default='inactive') + + this%xsmrpool_recover_patch(begp:endp) = spval + call hist_addfld1d (fname='XSMRPOOL_RECOVER', units='gC/m^2/s', & + avgflag='A', long_name='C flux assigned to recovery of negative xsmrpool', & + ptr_patch=this%xsmrpool_recover_patch) + + this%gpp_patch(begp:endp) = spval + call hist_addfld1d (fname='GPP', units='gC/m^2/s', & + avgflag='A', long_name='gross primary production', & + ptr_patch=this%gpp_patch) + + this%rr_patch(begp:endp) = spval + call hist_addfld1d (fname='RR', units='gC/m^2/s', & + avgflag='A', long_name='root respiration (fine root MR + total root GR)', & + ptr_patch=this%rr_patch) + + this%mr_patch(begp:endp) = spval + call hist_addfld1d (fname='MR', units='gC/m^2/s', & + avgflag='A', long_name='maintenance respiration', & + ptr_patch=this%mr_patch) + + this%gr_patch(begp:endp) = spval + call hist_addfld1d (fname='GR', units='gC/m^2/s', & + avgflag='A', long_name='total growth respiration', & + ptr_patch=this%gr_patch) + + this%ar_patch(begp:endp) = spval + call hist_addfld1d (fname='AR', units='gC/m^2/s', & + avgflag='A', long_name='autotrophic respiration (MR + GR)', & + ptr_patch=this%ar_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP', units='gC/m^2/s', & + avgflag='A', long_name='net primary production', & + ptr_patch=this%npp_patch) + + this%agnpp_patch(begp:endp) = spval + call hist_addfld1d (fname='AGNPP', units='gC/m^2/s', & + avgflag='A', long_name='aboveground NPP', & + ptr_patch=this%agnpp_patch) + + this%bgnpp_patch(begp:endp) = spval + call hist_addfld1d (fname='BGNPP', units='gC/m^2/s', & + avgflag='A', long_name='belowground NPP', & + ptr_patch=this%bgnpp_patch) + + this%litfall_patch(begp:endp) = spval + call hist_addfld1d (fname='LITFALL', units='gC/m^2/s', & + avgflag='A', long_name='litterfall (leaves and fine roots)', & + ptr_patch=this%litfall_patch) + + this%wood_harvestc_patch(begp:endp) = spval + call hist_addfld1d (fname='WOOD_HARVESTC', units='gC/m^2/s', & + avgflag='A', long_name='wood harvest carbon (to product pools)', & + ptr_patch=this%wood_harvestc_patch) + + this%slash_harvestc_patch(begp:endp) = spval + call hist_addfld1d (fname='SLASH_HARVESTC', units='gC/m^2/s', & + avgflag='A', long_name='slash harvest carbon (to litter)', & + ptr_patch=this%slash_harvestc_patch) + + this%fire_closs_patch(begp:endp) = spval + call hist_addfld1d (fname='PFT_FIRE_CLOSS', units='gC/m^2/s', & + avgflag='A', long_name='total patch-level fire C loss for non-peat fires outside land-type converted region', & + ptr_patch=this%fire_closs_patch) + + if ( use_fun ) then + this%npp_Nactive_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NACTIVE', units='gC/m^2/s', & + avgflag='A', long_name='Mycorrhizal N uptake used C', & + ptr_patch=this%npp_Nactive_patch) + + ! BUG(wjs, 2016-04-13, bugz 2292) This field has a threading bug. Making it + ! inactive for now. + this%npp_burnedoff_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_BURNEDOFF', units='gC/m^2/s', & + avgflag='A', long_name='C that cannot be used for N uptake', & + ptr_patch=this%npp_burnedoff_patch, default='inactive') + + this%npp_Nnonmyc_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NNONMYC', units='gC/m^2/s', & + avgflag='A', long_name='Non-mycorrhizal N uptake used C', & + ptr_patch=this%npp_Nnonmyc_patch) + + this%npp_Nam_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NAM', units='gC/m^2/s', & + avgflag='A', long_name='AM-associated N uptake used C', & + ptr_patch=this%npp_Nam_patch) + + this%npp_Necm_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NECM', units='gC/m^2/s', & + avgflag='A', long_name='ECM-associated N uptake used C', & + ptr_patch=this%npp_Necm_patch) + + if (use_nitrif_denitrif) then + this%npp_Nactive_no3_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NACTIVE_NO3', units='gC/m^2/s', & + avgflag='A', long_name='Mycorrhizal N uptake used C', & + ptr_patch=this%npp_Nactive_no3_patch) + + this%npp_Nactive_nh4_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NACTIVE_NH4', units='gC/m^2/s', & + avgflag='A', long_name='Mycorrhizal N uptake use C', & + ptr_patch=this%npp_Nactive_nh4_patch) + + this%npp_Nnonmyc_no3_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NNONMYC_NO3', units='gC/m^2/s', & + avgflag='A', long_name='Non-mycorrhizal N uptake use C', & + ptr_patch=this%npp_Nnonmyc_no3_patch) + + this%npp_Nnonmyc_nh4_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NNONMYC_NH4', units='gC/m^2/s', & + avgflag='A', long_name='Non-mycorrhizal N uptake use C', & + ptr_patch=this%npp_Nnonmyc_nh4_patch) + + this%npp_Nam_no3_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NAM_NO3', units='gC/m^2/s', & + avgflag='A', long_name='AM-associated N uptake use C', & + ptr_patch=this%npp_Nam_no3_patch) + + this%npp_Nam_nh4_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NAM_NH4', units='gC/m^2/s', & + avgflag='A', long_name='AM-associated N uptake use C', & + ptr_patch=this%npp_Nam_nh4_patch) + + this%npp_Necm_no3_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NECM_NO3', units='gC/m^2/s', & + avgflag='A', long_name='ECM-associated N uptake used C', & + ptr_patch=this%npp_Necm_no3_patch) + + this%npp_Necm_nh4_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NECM_NH4', units='gC/m^2/s', & + avgflag='A', long_name='ECM-associated N uptake use C', & + ptr_patch=this%npp_Necm_nh4_patch) + end if + + this%npp_Nfix_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NFIX', units='gC/m^2/s', & + avgflag='A', long_name='Symbiotic BNF uptake used C', & + ptr_patch=this%npp_Nfix_patch) + + this%npp_Nretrans_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NRETRANS', units='gC/m^2/s', & + avgflag='A', long_name='Retranslocated N uptake flux', & + ptr_patch=this%npp_Nretrans_patch) + + this%npp_Nuptake_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_NUPTAKE', units='gC/m^2/s', & + avgflag='A', long_name='Total C used by N uptake in FUN', & + ptr_patch=this%npp_Nuptake_patch) + + this%npp_growth_patch(begp:endp) = spval + call hist_addfld1d (fname='NPP_GROWTH', units='gC/m^2/s', & + avgflag='A', long_name='Total C used for growth in FUN', & + ptr_patch=this%npp_growth_patch) + + this%leafc_change_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_CHANGE', units='gC/m^2/s', & + avgflag='A', long_name='C change in leaf', & + ptr_patch=this%leafc_change_patch) + + this%soilc_change_patch(begp:endp) = spval + call hist_addfld1d (fname='SOILC_CHANGE', units='gC/m^2/s', & + avgflag='A', long_name='C change in soil', & + ptr_patch=this%soilc_change_patch) + end if +! FUN Ends + + end if ! end of if-c12 + + !------------------------------- + ! C13 flux variables - patch + !------------------------------- + + if ( carbon_type == 'c13') then + + this%gpp_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_GPP', units='gC13/m^2/s', & + avgflag='A', long_name='C13 gross primary production', & + ptr_patch=this%gpp_patch) + + this%rr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_RR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 root respiration (fine root MR + total root GR)', & + ptr_patch=this%rr_patch, default='inactive') + + this%mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_MR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 maintenance respiration', & + ptr_patch=this%mr_patch, default='inactive') + + this%gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 total growth respiration', & + ptr_patch=this%gr_patch, default='inactive') + + this%ar_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_AR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 autotrophic respiration (MR + GR)', & + ptr_patch=this%ar_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_NPP', units='gC13/m^2/s', & + avgflag='A', long_name='C13 net primary production', & + ptr_patch=this%npp_patch, default='inactive') + + this%agnpp_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_AGNPP', units='gC13/m^2/s', & + avgflag='A', long_name='C13 aboveground NPP', & + ptr_patch=this%agnpp_patch, default='inactive') + + this%bgnpp_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_BGNPP', units='gC13/m^2/s', & + avgflag='A', long_name='C13 belowground NPP', & + ptr_patch=this%bgnpp_patch, default='inactive') + + this%litfall_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LITFALL', units='gC13/m^2/s', & + avgflag='A', long_name='C13 litterfall (leaves and fine roots)', & + ptr_patch=this%litfall_patch, default='inactive') + + this%fire_closs_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_PFT_FIRE_CLOSS', units='gC13/m^2/s', & + avgflag='A', long_name='C13 total patch-level fire C loss', & + ptr_patch=this%fire_closs_patch, default='inactive') + + this%m_leafc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LEAFC_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C mortality', & + ptr_patch=this%m_leafc_to_litter_patch, default='inactive') + + this%m_frootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_FROOTC_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C mortality', & + ptr_patch=this%m_frootc_to_litter_patch, default='inactive') + + this%m_leafc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LEAFC_STORAGE_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C storage mortality', & + ptr_patch=this%m_leafc_storage_to_litter_patch, default='inactive') + + this%m_frootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_FROOTC_STORAGE_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C storage mortality', & + ptr_patch=this%m_frootc_storage_to_litter_patch, default='inactive') + + this%m_livestemc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVESTEMC_STORAGE_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C storage mortality', & + ptr_patch=this%m_livestemc_storage_to_litter_patch, default='inactive') + + this%m_deadstemc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADSTEMC_STORAGE_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C storage mortality', & + ptr_patch=this%m_deadstemc_storage_to_litter_patch, default='inactive') + + this%m_livecrootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVECROOTC_STORAGE_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C storage mortality', & + ptr_patch=this%m_livecrootc_storage_to_litter_patch, default='inactive') + + this%m_deadcrootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADCROOTC_STORAGE_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C storage mortality', & + ptr_patch=this%m_deadcrootc_storage_to_litter_patch, default='inactive') + + this%m_leafc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LEAFC_XFER_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C transfer mortality', & + ptr_patch=this%m_leafc_xfer_to_litter_patch, default='inactive') + + this%m_frootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_FROOTC_XFER_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C transfer mortality', & + ptr_patch=this%m_frootc_xfer_to_litter_patch, default='inactive') + + this%m_livestemc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVESTEMC_XFER_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C transfer mortality', & + ptr_patch=this%m_livestemc_xfer_to_litter_patch, default='inactive') + + this%m_deadstemc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADSTEMC_XFER_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C transfer mortality', & + ptr_patch=this%m_deadstemc_xfer_to_litter_patch, default='inactive') + + this%m_livecrootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVECROOTC_XFER_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C transfer mortality', & + ptr_patch=this%m_livecrootc_xfer_to_litter_patch, default='inactive') + + this%m_deadcrootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADCROOTC_XFER_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C transfer mortality', & + ptr_patch=this%m_deadcrootc_xfer_to_litter_patch, default='inactive') + + this%m_livestemc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVESTEMC_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C mortality', & + ptr_patch=this%m_livestemc_to_litter_patch, default='inactive') + + this%m_deadstemc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADSTEMC_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C mortality', & + ptr_patch=this%m_deadstemc_to_litter_patch, default='inactive') + + this%m_livecrootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVECROOTC_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C mortality', & + ptr_patch=this%m_livecrootc_to_litter_patch, default='inactive') + + this%m_deadcrootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADCROOTC_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C mortality', & + ptr_patch=this%m_deadcrootc_to_litter_patch, default='inactive') + + this%m_gresp_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_GRESP_STORAGE_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 growth respiration storage mortality', & + ptr_patch=this%m_gresp_storage_to_litter_patch, default='inactive') + + this%m_gresp_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_GRESP_XFER_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 growth respiration transfer mortality', & + ptr_patch=this%m_gresp_xfer_to_litter_patch, default='inactive') + + this%m_leafc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LEAFC_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C fire loss', & + ptr_patch=this%m_leafc_to_fire_patch, default='inactive') + + this%m_frootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_FROOTC_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C fire loss', & + ptr_patch=this%m_frootc_to_fire_patch, default='inactive') + + this%m_leafc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LEAFC_STORAGE_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C storage fire loss', & + ptr_patch=this%m_leafc_storage_to_fire_patch, default='inactive') + + this%m_frootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_FROOTC_STORAGE_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C storage fire loss', & + ptr_patch=this%m_frootc_storage_to_fire_patch, default='inactive') + + this%m_livestemc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVESTEMC_STORAGE_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C storage fire loss', & + ptr_patch=this%m_livestemc_storage_to_fire_patch, default='inactive') + + this%m_deadstemc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADSTEMC_STORAGE_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C storage fire loss', & + ptr_patch=this%m_deadstemc_storage_to_fire_patch, default='inactive') + + this%m_livecrootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVECROOTC_STORAGE_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C storage fire loss', & + ptr_patch=this%m_livecrootc_storage_to_fire_patch, default='inactive') + + this%m_deadcrootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADCROOTC_STORAGE_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C storage fire loss', & + ptr_patch=this%m_deadcrootc_storage_to_fire_patch, default='inactive') + + this%m_leafc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LEAFC_XFER_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C transfer fire loss', & + ptr_patch=this%m_leafc_xfer_to_fire_patch, default='inactive') + + this%m_frootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_FROOTC_XFER_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C transfer fire loss', & + ptr_patch=this%m_frootc_xfer_to_fire_patch, default='inactive') + + this%m_livestemc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVESTEMC_XFER_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C transfer fire loss', & + ptr_patch=this%m_livestemc_xfer_to_fire_patch, default='inactive') + + this%m_deadstemc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADSTEMC_XFER_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C transfer fire loss', & + ptr_patch=this%m_deadstemc_xfer_to_fire_patch, default='inactive') + + this%m_livecrootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVECROOTC_XFER_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C transfer fire loss', & + ptr_patch=this%m_livecrootc_xfer_to_fire_patch, default='inactive') + + this%m_deadcrootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADCROOTC_XFER_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C transfer fire loss', & + ptr_patch=this%m_deadcrootc_xfer_to_fire_patch, default='inactive') + + this%m_livestemc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVESTEMC_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C fire loss', & + ptr_patch=this%m_livestemc_to_fire_patch, default='inactive') + + this%m_deadstemc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADSTEMC_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C fire loss', & + ptr_patch=this%m_deadstemc_to_fire_patch, default='inactive') + + this%m_deadstemc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADSTEMC_TO_LITTER_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C fire mortality to litter', & + ptr_patch=this%m_deadstemc_to_litter_fire_patch, default='inactive') + + this%m_livecrootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_LIVECROOTC_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C fire loss', & + ptr_patch=this%m_livecrootc_to_fire_patch, default='inactive') + + this%m_deadcrootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADCROOTC_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C fire loss', & + ptr_patch=this%m_deadcrootc_to_fire_patch, default='inactive') + + this%m_deadcrootc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_DEADCROOTC_TO_LITTER_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C fire mortality to litter', & + ptr_patch=this%m_deadcrootc_to_litter_fire_patch, default='inactive') + + this%m_gresp_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_GRESP_STORAGE_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 growth respiration storage fire loss', & + ptr_patch=this%m_gresp_storage_to_fire_patch, default='inactive') + + this%m_gresp_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_M_GRESP_XFER_TO_FIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 growth respiration transfer fire loss', & + ptr_patch=this%m_gresp_xfer_to_fire_patch, default='inactive') + + this%leafc_xfer_to_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_XFER_TO_LEAFC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C growth from storage', & + ptr_patch=this%leafc_xfer_to_leafc_patch, default='inactive') + + this%frootc_xfer_to_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC_XFER_TO_FROOTC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C growth from storage', & + ptr_patch=this%frootc_xfer_to_frootc_patch, default='inactive') + + this%livestemc_xfer_to_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC_XFER_TO_LIVESTEMC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C growth from storage', & + ptr_patch=this%livestemc_xfer_to_livestemc_patch, default='inactive') + + this%deadstemc_xfer_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADSTEMC_XFER_TO_DEADSTEMC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C growth from storage', & + ptr_patch=this%deadstemc_xfer_to_deadstemc_patch, default='inactive') + + this%livecrootc_xfer_to_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC_XFER_TO_LIVECROOTC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C growth from storage', & + ptr_patch=this%livecrootc_xfer_to_livecrootc_patch, default='inactive') + + this%deadcrootc_xfer_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADCROOTC_XFER_TO_DEADCROOTC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C growth from storage', & + ptr_patch=this%deadcrootc_xfer_to_deadcrootc_patch, default='inactive') + + this%leafc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C litterfall', & + ptr_patch=this%leafc_to_litter_patch, default='inactive') + + this%frootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC_TO_LITTER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C litterfall', & + ptr_patch=this%frootc_to_litter_patch, default='inactive') + + this%leaf_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAF_MR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf maintenance respiration', & + ptr_patch=this%leaf_mr_patch, default='inactive') + + this%froot_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOT_MR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root maintenance respiration', & + ptr_patch=this%froot_mr_patch, default='inactive') + + this%livestem_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEM_MR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem maintenance respiration', & + ptr_patch=this%livestem_mr_patch, default='inactive') + + this%livecroot_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOT_MR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root maintenance respiration', & + ptr_patch=this%livecroot_mr_patch, default='inactive') + + this%psnsun_to_cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_PSNSUN_TO_CPOOL', units='gC13/m^2/s', & + avgflag='A', long_name='C13 C fixation from sunlit canopy', & + ptr_patch=this%psnsun_to_cpool_patch, default='inactive') + + this%psnshade_to_cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_PSNSHADE_TO_CPOOL', units='gC13/m^2/s', & + avgflag='A', long_name='C13 C fixation from shaded canopy', & + ptr_patch=this%psnshade_to_cpool_patch, default='inactive') + + this%cpool_to_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_LEAFC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to leaf C', & + ptr_patch=this%cpool_to_leafc_patch, default='inactive') + + this%cpool_to_leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_LEAFC_STORAGE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to leaf C storage', & + ptr_patch=this%cpool_to_leafc_storage_patch, default='inactive') + + this%cpool_to_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_FROOTC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to fine root C', & + ptr_patch=this%cpool_to_frootc_patch, default='inactive') + + this%cpool_to_frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_FROOTC_STORAGE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to fine root C storage', & + ptr_patch=this%cpool_to_frootc_storage_patch, default='inactive') + + this%cpool_to_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_LIVESTEMC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to live stem C', & + ptr_patch=this%cpool_to_livestemc_patch, default='inactive') + + this%cpool_to_livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_LIVESTEMC_STORAGE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to live stem C storage', & + ptr_patch=this%cpool_to_livestemc_storage_patch, default='inactive') + + this%cpool_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_DEADSTEMC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to dead stem C', & + ptr_patch=this%cpool_to_deadstemc_patch, default='inactive') + + this%cpool_to_deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_DEADSTEMC_STORAGE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to dead stem C storage', & + ptr_patch=this%cpool_to_deadstemc_storage_patch, default='inactive') + + this%cpool_to_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_LIVECROOTC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to live coarse root C', & + ptr_patch=this%cpool_to_livecrootc_patch, default='inactive') + + this%cpool_to_livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_LIVECROOTC_STORAGE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to live coarse root C storage', & + ptr_patch=this%cpool_to_livecrootc_storage_patch, default='inactive') + + this%cpool_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_DEADCROOTC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to dead coarse root C', & + ptr_patch=this%cpool_to_deadcrootc_patch, default='inactive') + + this%cpool_to_deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_DEADCROOTC_STORAGE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to dead coarse root C storage', & + ptr_patch=this%cpool_to_deadcrootc_storage_patch, default='inactive') + + this%cpool_to_gresp_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_TO_GRESP_STORAGE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 allocation to growth respiration storage', & + ptr_patch=this%cpool_to_gresp_storage_patch, default='inactive') + + this%cpool_leaf_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_LEAF_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf growth respiration', & + ptr_patch=this%cpool_leaf_gr_patch, default='inactive') + + this%cpool_leaf_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_LEAF_STORAGE_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf growth respiration to storage', & + ptr_patch=this%cpool_leaf_storage_gr_patch, default='inactive') + + this%transfer_leaf_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TRANSFER_LEAF_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf growth respiration from storage', & + ptr_patch=this%transfer_leaf_gr_patch, default='inactive') + + this%cpool_froot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_FROOT_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root growth respiration', & + ptr_patch=this%cpool_froot_gr_patch, default='inactive') + + this%cpool_froot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_FROOT_STORAGE_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root growth respiration to storage', & + ptr_patch=this%cpool_froot_storage_gr_patch, default='inactive') + + this%transfer_froot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TRANSFER_FROOT_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root growth respiration from storage', & + ptr_patch=this%transfer_froot_gr_patch, default='inactive') + + this%cpool_livestem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_LIVESTEM_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem growth respiration', & + ptr_patch=this%cpool_livestem_gr_patch, default='inactive') + + this%cpool_livestem_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_LIVESTEM_STORAGE_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem growth respiration to storage', & + ptr_patch=this%cpool_livestem_storage_gr_patch, default='inactive') + + this%transfer_livestem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TRANSFER_LIVESTEM_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem growth respiration from storage', & + ptr_patch=this%transfer_livestem_gr_patch, default='inactive') + + this%cpool_deadstem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_DEADSTEM_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem growth respiration', & + ptr_patch=this%cpool_deadstem_gr_patch, default='inactive') + + this%cpool_deadstem_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_DEADSTEM_STORAGE_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem growth respiration to storage', & + ptr_patch=this%cpool_deadstem_storage_gr_patch, default='inactive') + + this%transfer_deadstem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TRANSFER_DEADSTEM_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem growth respiration from storage', & + ptr_patch=this%transfer_deadstem_gr_patch, default='inactive') + + this%cpool_livecroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_LIVECROOT_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root growth respiration', & + ptr_patch=this%cpool_livecroot_gr_patch, default='inactive') + + this%cpool_livecroot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_LIVECROOT_STORAGE_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root growth respiration to storage', & + ptr_patch=this%cpool_livecroot_storage_gr_patch, default='inactive') + + this%transfer_livecroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TRANSFER_LIVECROOT_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root growth respiration from storage', & + ptr_patch=this%transfer_livecroot_gr_patch, default='inactive') + + this%cpool_deadcroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_DEADCROOT_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root growth respiration', & + ptr_patch=this%cpool_deadcroot_gr_patch, default='inactive') + + this%cpool_deadcroot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL_DEADCROOT_STORAGE_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root growth respiration to storage', & + ptr_patch=this%cpool_deadcroot_storage_gr_patch, default='inactive') + + this%transfer_deadcroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TRANSFER_DEADCROOT_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root growth respiration from storage', & + ptr_patch=this%transfer_deadcroot_gr_patch, default='inactive') + + this%leafc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_STORAGE_TO_XFER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 leaf C shift storage to transfer', & + ptr_patch=this%leafc_storage_to_xfer_patch, default='inactive') + + this%frootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC_STORAGE_TO_XFER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C shift storage to transfer', & + ptr_patch=this%frootc_storage_to_xfer_patch, default='inactive') + + this%livestemc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC_STORAGE_TO_XFER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C shift storage to transfer', & + ptr_patch=this%livestemc_storage_to_xfer_patch, default='inactive') + + this%deadstemc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADSTEMC_STORAGE_TO_XFER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead stem C shift storage to transfer', & + ptr_patch=this%deadstemc_storage_to_xfer_patch, default='inactive') + + this%livecrootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC_STORAGE_TO_XFER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C shift storage to transfer', & + ptr_patch=this%livecrootc_storage_to_xfer_patch, default='inactive') + + this%deadcrootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADCROOTC_STORAGE_TO_XFER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 dead coarse root C shift storage to transfer', & + ptr_patch=this%deadcrootc_storage_to_xfer_patch, default='inactive') + + this%gresp_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_GRESP_STORAGE_TO_XFER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 growth respiration shift storage to transfer', & + ptr_patch=this%gresp_storage_to_xfer_patch, default='inactive') + + this%livestemc_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC_TO_DEADSTEMC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live stem C turnover', & + ptr_patch=this%livestemc_to_deadstemc_patch, default='inactive') + + this%livecrootc_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC_TO_DEADCROOTC', units='gC13/m^2/s', & + avgflag='A', long_name='C13 live coarse root C turnover', & + ptr_patch=this%livecrootc_to_deadcrootc_patch, default='inactive') + + this%current_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CURRENT_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 growth resp for new growth displayed in this timestep', & + ptr_patch=this%current_gr_patch, default='inactive') + + this%transfer_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TRANSFER_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 growth resp for transfer growth displayed in this timestep', & + ptr_patch=this%transfer_gr_patch, default='inactive') + + this%storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_STORAGE_GR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 growth resp for growth sent to storage for later display', & + ptr_patch=this%storage_gr_patch, default='inactive') + + this%xsmrpool_c13ratio_patch(begp:endp) = spval + call hist_addfld1d (fname='XSMRPOOL_C13RATIO', units='proportion', & + avgflag='A', long_name='C13/C(12+13) ratio for xsmrpool', & + ptr_patch=this%xsmrpool_c13ratio_patch, default='inactive') + + endif + + !------------------------------- + ! C14 flux variables - patch + !------------------------------- + + if ( carbon_type == 'c14' ) then + + this%m_leafc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LEAFC_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C mortality', & + ptr_patch=this%m_leafc_to_litter_patch, default='inactive') + + this%m_frootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_FROOTC_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C mortality', & + ptr_patch=this%m_frootc_to_litter_patch, default='inactive') + + this%m_leafc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LEAFC_STORAGE_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C storage mortality', & + ptr_patch=this%m_leafc_storage_to_litter_patch, default='inactive') + + this%m_frootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_FROOTC_STORAGE_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C storage mortality', & + ptr_patch=this%m_frootc_storage_to_litter_patch, default='inactive') + + this%m_livestemc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVESTEMC_STORAGE_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C storage mortality', & + ptr_patch=this%m_livestemc_storage_to_litter_patch, default='inactive') + + this%m_deadstemc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADSTEMC_STORAGE_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C storage mortality', & + ptr_patch=this%m_deadstemc_storage_to_litter_patch, default='inactive') + + this%m_livecrootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVECROOTC_STORAGE_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C storage mortality', & + ptr_patch=this%m_livecrootc_storage_to_litter_patch, default='inactive') + + this%m_deadcrootc_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADCROOTC_STORAGE_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C storage mortality', & + ptr_patch=this%m_deadcrootc_storage_to_litter_patch, default='inactive') + + this%m_leafc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LEAFC_XFER_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C transfer mortality', & + ptr_patch=this%m_leafc_xfer_to_litter_patch, default='inactive') + + this%m_frootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_FROOTC_XFER_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C transfer mortality', & + ptr_patch=this%m_frootc_xfer_to_litter_patch, default='inactive') + + this%m_livestemc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVESTEMC_XFER_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C transfer mortality', & + ptr_patch=this%m_livestemc_xfer_to_litter_patch, default='inactive') + + this%m_deadstemc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADSTEMC_XFER_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C transfer mortality', & + ptr_patch=this%m_deadstemc_xfer_to_litter_patch, default='inactive') + + this%m_livecrootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVECROOTC_XFER_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C transfer mortality', & + ptr_patch=this%m_livecrootc_xfer_to_litter_patch, default='inactive') + + this%m_deadcrootc_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADCROOTC_XFER_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C transfer mortality', & + ptr_patch=this%m_deadcrootc_xfer_to_litter_patch, default='inactive') + + this%m_livestemc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVESTEMC_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C mortality', & + ptr_patch=this%m_livestemc_to_litter_patch, default='inactive') + + this%m_deadstemc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADSTEMC_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C mortality', & + ptr_patch=this%m_deadstemc_to_litter_patch, default='inactive') + + this%m_livecrootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVECROOTC_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C mortality', & + ptr_patch=this%m_livecrootc_to_litter_patch, default='inactive') + + this%m_deadcrootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADCROOTC_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C mortality', & + ptr_patch=this%m_deadcrootc_to_litter_patch, default='inactive') + + this%m_gresp_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_GRESP_STORAGE_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 growth respiration storage mortality', & + ptr_patch=this%m_gresp_storage_to_litter_patch, default='inactive') + + this%m_gresp_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_GRESP_XFER_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 growth respiration transfer mortality', & + ptr_patch=this%m_gresp_xfer_to_litter_patch, default='inactive') + + this%m_leafc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LEAFC_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C fire loss', & + ptr_patch=this%m_leafc_to_fire_patch, default='inactive') + + this%m_frootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_FROOTC_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C fire loss', & + ptr_patch=this%m_frootc_to_fire_patch, default='inactive') + + this%m_leafc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LEAFC_STORAGE_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C storage fire loss', & + ptr_patch=this%m_leafc_storage_to_fire_patch, default='inactive') + + this%m_frootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_FROOTC_STORAGE_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C storage fire loss', & + ptr_patch=this%m_frootc_storage_to_fire_patch, default='inactive') + + this%m_livestemc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVESTEMC_STORAGE_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C storage fire loss', & + ptr_patch=this%m_livestemc_storage_to_fire_patch, default='inactive') + + this%m_deadstemc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADSTEMC_STORAGE_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C storage fire loss', & + ptr_patch=this%m_deadstemc_storage_to_fire_patch, default='inactive') + + this%m_livecrootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVECROOTC_STORAGE_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C storage fire loss', & + ptr_patch=this%m_livecrootc_storage_to_fire_patch, default='inactive') + + this%m_deadcrootc_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADCROOTC_STORAGE_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C storage fire loss', & + ptr_patch=this%m_deadcrootc_storage_to_fire_patch, default='inactive') + + this%m_leafc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LEAFC_XFER_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C transfer fire loss', & + ptr_patch=this%m_leafc_xfer_to_fire_patch, default='inactive') + + this%m_frootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_FROOTC_XFER_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C transfer fire loss', & + ptr_patch=this%m_frootc_xfer_to_fire_patch, default='inactive') + + this%m_livestemc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVESTEMC_XFER_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C transfer fire loss', & + ptr_patch=this%m_livestemc_xfer_to_fire_patch, default='inactive') + + this%m_deadstemc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADSTEMC_XFER_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C transfer fire loss', & + ptr_patch=this%m_deadstemc_xfer_to_fire_patch, default='inactive') + + this%m_livecrootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVECROOTC_XFER_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C transfer fire loss', & + ptr_patch=this%m_livecrootc_xfer_to_fire_patch, default='inactive') + + this%m_deadcrootc_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADCROOTC_XFER_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C transfer fire loss', & + ptr_patch=this%m_deadcrootc_xfer_to_fire_patch, default='inactive') + + this%m_livestemc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVESTEMC_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C fire loss', & + ptr_patch=this%m_livestemc_to_fire_patch, default='inactive') + + this%m_deadstemc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADSTEMC_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C fire loss', & + ptr_patch=this%m_deadstemc_to_fire_patch, default='inactive') + + this%m_deadstemc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADSTEMC_TO_LITTER_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C fire mortality to litter', & + ptr_patch=this%m_deadstemc_to_litter_fire_patch, default='inactive') + + this%m_livecrootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_LIVECROOTC_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C fire loss', & + ptr_patch=this%m_livecrootc_to_fire_patch, default='inactive') + + this%m_deadcrootc_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADCROOTC_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C fire loss', & + ptr_patch=this%m_deadcrootc_to_fire_patch, default='inactive') + + this%m_deadcrootc_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_DEADCROOTC_TO_LITTER_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C fire mortality to litter', & + ptr_patch=this%m_deadcrootc_to_litter_fire_patch, default='inactive') + + this%m_gresp_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_GRESP_STORAGE_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 growth respiration storage fire loss', & + ptr_patch=this%m_gresp_storage_to_fire_patch, default='inactive') + + this%m_gresp_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_M_GRESP_XFER_TO_FIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 growth respiration transfer fire loss', & + ptr_patch=this%m_gresp_xfer_to_fire_patch, default='inactive') + + this%leafc_xfer_to_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_XFER_TO_LEAFC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C growth from storage', & + ptr_patch=this%leafc_xfer_to_leafc_patch, default='inactive') + + this%frootc_xfer_to_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC_XFER_TO_FROOTC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C growth from storage', & + ptr_patch=this%frootc_xfer_to_frootc_patch, default='inactive') + + this%livestemc_xfer_to_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC_XFER_TO_LIVESTEMC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C growth from storage', & + ptr_patch=this%livestemc_xfer_to_livestemc_patch, default='inactive') + + this%deadstemc_xfer_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADSTEMC_XFER_TO_DEADSTEMC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C growth from storage', & + ptr_patch=this%deadstemc_xfer_to_deadstemc_patch, default='inactive') + + this%livecrootc_xfer_to_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC_XFER_TO_LIVECROOTC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C growth from storage', & + ptr_patch=this%livecrootc_xfer_to_livecrootc_patch, default='inactive') + + this%deadcrootc_xfer_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADCROOTC_XFER_TO_DEADCROOTC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C growth from storage', & + ptr_patch=this%deadcrootc_xfer_to_deadcrootc_patch, default='inactive') + + this%leafc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C litterfall', & + ptr_patch=this%leafc_to_litter_patch, default='inactive') + + this%frootc_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC_TO_LITTER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C litterfall', & + ptr_patch=this%frootc_to_litter_patch, default='inactive') + + this%leaf_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAF_MR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf maintenance respiration', & + ptr_patch=this%leaf_mr_patch, default='inactive') + + this%froot_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOT_MR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root maintenance respiration', & + ptr_patch=this%froot_mr_patch, default='inactive') + + this%livestem_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEM_MR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem maintenance respiration', & + ptr_patch=this%livestem_mr_patch, default='inactive') + + this%livecroot_mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOT_MR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root maintenance respiration', & + ptr_patch=this%livecroot_mr_patch, default='inactive') + + this%psnsun_to_cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_PSNSUN_TO_CPOOL', units='gC14/m^2/s', & + avgflag='A', long_name='C14 C fixation from sunlit canopy', & + ptr_patch=this%psnsun_to_cpool_patch, default='inactive') + + this%psnshade_to_cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_PSNSHADE_TO_CPOOL', units='gC14/m^2/s', & + avgflag='A', long_name='C14 C fixation from shaded canopy', & + ptr_patch=this%psnshade_to_cpool_patch, default='inactive') + + this%cpool_to_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_LEAFC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to leaf C', & + ptr_patch=this%cpool_to_leafc_patch, default='inactive') + + this%cpool_to_leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_LEAFC_STORAGE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to leaf C storage', & + ptr_patch=this%cpool_to_leafc_storage_patch, default='inactive') + + this%cpool_to_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_FROOTC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to fine root C', & + ptr_patch=this%cpool_to_frootc_patch, default='inactive') + + this%cpool_to_frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_FROOTC_STORAGE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to fine root C storage', & + ptr_patch=this%cpool_to_frootc_storage_patch, default='inactive') + + this%cpool_to_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_LIVESTEMC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to live stem C', & + ptr_patch=this%cpool_to_livestemc_patch, default='inactive') + + this%cpool_to_livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_LIVESTEMC_STORAGE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to live stem C storage', & + ptr_patch=this%cpool_to_livestemc_storage_patch, default='inactive') + + this%cpool_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_DEADSTEMC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to dead stem C', & + ptr_patch=this%cpool_to_deadstemc_patch, default='inactive') + + this%cpool_to_deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_DEADSTEMC_STORAGE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to dead stem C storage', & + ptr_patch=this%cpool_to_deadstemc_storage_patch, default='inactive') + + this%cpool_to_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_LIVECROOTC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to live coarse root C', & + ptr_patch=this%cpool_to_livecrootc_patch, default='inactive') + + this%cpool_to_livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_LIVECROOTC_STORAGE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to live coarse root C storage', & + ptr_patch=this%cpool_to_livecrootc_storage_patch, default='inactive') + + this%cpool_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_DEADCROOTC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to dead coarse root C', & + ptr_patch=this%cpool_to_deadcrootc_patch, default='inactive') + + this%cpool_to_deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_DEADCROOTC_STORAGE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to dead coarse root C storage', & + ptr_patch=this%cpool_to_deadcrootc_storage_patch, default='inactive') + + this%cpool_to_gresp_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_TO_GRESP_STORAGE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 allocation to growth respiration storage', & + ptr_patch=this%cpool_to_gresp_storage_patch, default='inactive') + + this%cpool_leaf_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_LEAF_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf growth respiration', & + ptr_patch=this%cpool_leaf_gr_patch, default='inactive') + + this%cpool_leaf_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_LEAF_STORAGE_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf growth respiration to storage', & + ptr_patch=this%cpool_leaf_storage_gr_patch, default='inactive') + + this%transfer_leaf_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TRANSFER_LEAF_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf growth respiration from storage', & + ptr_patch=this%transfer_leaf_gr_patch, default='inactive') + + this%cpool_froot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_FROOT_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root growth respiration', & + ptr_patch=this%cpool_froot_gr_patch, default='inactive') + + this%cpool_froot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_FROOT_STORAGE_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root growth respiration to storage', & + ptr_patch=this%cpool_froot_storage_gr_patch, default='inactive') + + this%transfer_froot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TRANSFER_FROOT_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root growth respiration from storage', & + ptr_patch=this%transfer_froot_gr_patch, default='inactive') + + this%cpool_livestem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_LIVESTEM_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem growth respiration', & + ptr_patch=this%cpool_livestem_gr_patch, default='inactive') + + this%cpool_livestem_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_LIVESTEM_STORAGE_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem growth respiration to storage', & + ptr_patch=this%cpool_livestem_storage_gr_patch, default='inactive') + + this%transfer_livestem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TRANSFER_LIVESTEM_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem growth respiration from storage', & + ptr_patch=this%transfer_livestem_gr_patch, default='inactive') + + this%cpool_deadstem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_DEADSTEM_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem growth respiration', & + ptr_patch=this%cpool_deadstem_gr_patch, default='inactive') + + this%cpool_deadstem_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_DEADSTEM_STORAGE_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem growth respiration to storage', & + ptr_patch=this%cpool_deadstem_storage_gr_patch, default='inactive') + + this%transfer_deadstem_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TRANSFER_DEADSTEM_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem growth respiration from storage', & + ptr_patch=this%transfer_deadstem_gr_patch, default='inactive') + + this%cpool_livecroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_LIVECROOT_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root growth respiration', & + ptr_patch=this%cpool_livecroot_gr_patch, default='inactive') + + this%cpool_livecroot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_LIVECROOT_STORAGE_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root growth respiration to storage', & + ptr_patch=this%cpool_livecroot_storage_gr_patch, default='inactive') + + this%transfer_livecroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TRANSFER_LIVECROOT_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root growth respiration from storage', & + ptr_patch=this%transfer_livecroot_gr_patch, default='inactive') + + this%cpool_deadcroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_DEADCROOT_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root growth respiration', & + ptr_patch=this%cpool_deadcroot_gr_patch, default='inactive') + + this%cpool_deadcroot_storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL_DEADCROOT_STORAGE_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root growth respiration to storage', & + ptr_patch=this%cpool_deadcroot_storage_gr_patch, default='inactive') + + this%transfer_deadcroot_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TRANSFER_DEADCROOT_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root growth respiration from storage', & + ptr_patch=this%transfer_deadcroot_gr_patch, default='inactive') + + this%leafc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_STORAGE_TO_XFER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 leaf C shift storage to transfer', & + ptr_patch=this%leafc_storage_to_xfer_patch, default='inactive') + + this%frootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC_STORAGE_TO_XFER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 fine root C shift storage to transfer', & + ptr_patch=this%frootc_storage_to_xfer_patch, default='inactive') + + this%livestemc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC_STORAGE_TO_XFER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C shift storage to transfer', & + ptr_patch=this%livestemc_storage_to_xfer_patch, default='inactive') + + this%deadstemc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADSTEMC_STORAGE_TO_XFER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead stem C shift storage to transfer', & + ptr_patch=this%deadstemc_storage_to_xfer_patch, default='inactive') + + this%livecrootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC_STORAGE_TO_XFER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C shift storage to transfer', & + ptr_patch=this%livecrootc_storage_to_xfer_patch, default='inactive') + + this%deadcrootc_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADCROOTC_STORAGE_TO_XFER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 dead coarse root C shift storage to transfer', & + ptr_patch=this%deadcrootc_storage_to_xfer_patch, default='inactive') + + this%gresp_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_GRESP_STORAGE_TO_XFER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 growth respiration shift storage to transfer', & + ptr_patch=this%gresp_storage_to_xfer_patch, default='inactive') + + this%livestemc_to_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC_TO_DEADSTEMC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live stem C turnover', & + ptr_patch=this%livestemc_to_deadstemc_patch, default='inactive') + + this%livecrootc_to_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC_TO_DEADCROOTC', units='gC14/m^2/s', & + avgflag='A', long_name='C14 live coarse root C turnover', & + ptr_patch=this%livecrootc_to_deadcrootc_patch, default='inactive') + + this%current_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CURRENT_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 growth resp for new growth displayed in this timestep', & + ptr_patch=this%current_gr_patch, default='inactive') + + this%transfer_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TRANSFER_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 growth resp for transfer growth displayed in this timestep', & + ptr_patch=this%transfer_gr_patch, default='inactive') + + this%storage_gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_STORAGE_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 growth resp for growth sent to storage for later display', & + ptr_patch=this%storage_gr_patch, default='inactive') + + this%gpp_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_GPP', units='gC14/m^2/s', & + avgflag='A', long_name='C14 gross primary production', & + ptr_patch=this%gpp_patch) + + this%rr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_RR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 root respiration (fine root MR + total root GR)', & + ptr_patch=this%rr_patch, default='inactive') + + this%mr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_MR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 maintenance respiration', & + ptr_patch=this%mr_patch, default='inactive') + + this%gr_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_GR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 total growth respiration', & + ptr_patch=this%gr_patch, default='inactive') + + this%ar_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_AR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 autotrophic respiration (MR + GR)', & + ptr_patch=this%ar_patch) + + this%npp_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_NPP', units='gC14/m^2/s', & + avgflag='A', long_name='C14 net primary production', & + ptr_patch=this%npp_patch, default='inactive') + + this%agnpp_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_AGNPP', units='gC14/m^2/s', & + avgflag='A', long_name='C14 aboveground NPP', & + ptr_patch=this%agnpp_patch, default='inactive') + + this%bgnpp_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_BGNPP', units='gC14/m^2/s', & + avgflag='A', long_name='C14 belowground NPP', & + ptr_patch=this%bgnpp_patch, default='inactive') + + this%litfall_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LITFALL', units='gC14/m^2/s', & + avgflag='A', long_name='C14 litterfall (leaves and fine roots)', & + ptr_patch=this%litfall_patch, default='inactive') + + this%fire_closs_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_PFT_FIRE_CLOSS', units='gC14/m^2/s', & + avgflag='A', long_name='C14 total patch-level fire C loss', & + ptr_patch=this%fire_closs_patch, default='inactive') + endif + + !------------------------------- + ! C flux variables - column + !------------------------------- + + if (carbon_type == 'c12') then + + this%cwdc_loss_col(begc:endc) = spval + call hist_addfld1d (fname='CWDC_LOSS', units='gC/m^2/s', & + avgflag='A', long_name='coarse woody debris C loss', & + ptr_col=this%cwdc_loss_col) + + this%m_decomp_cpools_to_fire_col(begc:endc,:) = spval + this%m_decomp_cpools_to_fire_vr_col(begc:endc,:,:) = spval + do k = 1, ndecomp_pools + if ( decomp_cascade_con%is_litter(k) .or. decomp_cascade_con%is_cwd(k) ) then + data1dptr => this%m_decomp_cpools_to_fire_col(:,k) + fieldname = 'M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'C_TO_FIRE' + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' C fire loss' + call hist_addfld1d (fname=fieldname, units='gC/m^2/s', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + + if ( nlevdecomp_full > 1 ) then + data2dptr => this%m_decomp_cpools_to_fire_vr_col(:,:,k) + fieldname = 'M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'C_TO_FIRE'//trim(vr_suffix) + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' C fire loss' + call hist_addfld_decomp (fname=fieldname, units='gC/m^3/s', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + endif + end do + + this%dwt_seedc_to_leaf_grc(begg:endg) = spval + call hist_addfld1d (fname='DWT_SEEDC_TO_LEAF', units='gC/m^2/s', & + avgflag='A', long_name='seed source to patch-level leaf', & + ptr_gcell=this%dwt_seedc_to_leaf_grc, default='inactive') + + this%dwt_seedc_to_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='DWT_SEEDC_TO_LEAF_PATCH', units='gC/m^2/s', & + avgflag='A', & + long_name='patch-level seed source to patch-level leaf ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_seedc_to_leaf_patch, default='inactive') + + this%dwt_seedc_to_deadstem_grc(begg:endg) = spval + call hist_addfld1d (fname='DWT_SEEDC_TO_DEADSTEM', units='gC/m^2/s', & + avgflag='A', long_name='seed source to patch-level deadstem', & + ptr_gcell=this%dwt_seedc_to_deadstem_grc, default='inactive') + + this%dwt_seedc_to_deadstem_patch(begp:endp) = spval + call hist_addfld1d (fname='DWT_SEEDC_TO_DEADSTEM_PATCH', units='gC/m^2/s', & + avgflag='A', & + long_name='patch-level seed source to patch-level deadstem ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_seedc_to_deadstem_patch, default='inactive') + + this%dwt_conv_cflux_grc(begg:endg) = spval + call hist_addfld1d (fname='DWT_CONV_CFLUX', units='gC/m^2/s', & + avgflag='A', & + long_name='conversion C flux (immediate loss to atm) (0 at all times except first timestep of year)', & + ptr_gcell=this%dwt_conv_cflux_grc) + + this%dwt_conv_cflux_patch(begp:endp) = spval + call hist_addfld1d (fname='DWT_CONV_CFLUX_PATCH', units='gC/m^2/s', & + avgflag='A', & + long_name='patch-level conversion C flux (immediate loss to atm) ' // & + '(0 at all times except first timestep of year) ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_conv_cflux_patch, default='inactive') + + this%dwt_conv_cflux_dribbled_grc(begg:endg) = spval + call hist_addfld1d (fname='DWT_CONV_CFLUX_DRIBBLED', units='gC/m^2/s', & + avgflag='A', & + long_name='conversion C flux (immediate loss to atm), dribbled throughout the year', & + ptr_gcell=this%dwt_conv_cflux_dribbled_grc) + + this%dwt_wood_productc_gain_patch(begp:endp) = spval + call hist_addfld1d (fname='DWT_WOOD_PRODUCTC_GAIN_PATCH', units='gC/m^2/s', & + avgflag='A', & + long_name='patch-level landcover change-driven addition to wood product pools' // & + '(0 at all times except first timestep of year) ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_wood_productc_gain_patch, default='inactive') + + this%dwt_slash_cflux_grc(begg:endg) = spval + call hist_addfld1d (fname='DWT_SLASH_CFLUX', units='gC/m^2/s', & + avgflag='A', & + long_name='slash C flux (to litter diagnostic only) (0 at all times except first timestep of year)', & + ptr_gcell=this%dwt_slash_cflux_grc) + + this%dwt_slash_cflux_patch(begp:endp) = spval + call hist_addfld1d (fname='DWT_SLASH_CFLUX_PATCH', units='gC/m^2/s', & + avgflag='A', & + long_name='patch-level slash C flux (to litter diagnostic only) ' // & + '(0 at all times except first timestep of year) ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_slash_cflux_patch, default='inactive') + + this%dwt_frootc_to_litr_met_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_FROOTC_TO_LITR_MET_C', units='gC/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_met_c_col, default='inactive') + + this%dwt_frootc_to_litr_cel_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_FROOTC_TO_LITR_CEL_C', units='gC/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_cel_c_col, default='inactive') + + this%dwt_frootc_to_litr_lig_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_FROOTC_TO_LITR_LIG_C', units='gC/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_lig_c_col, default='inactive') + + this%dwt_livecrootc_to_cwdc_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_LIVECROOTC_TO_CWDC', units='gC/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='live coarse root to CWD due to landcover change', & + ptr_col=this%dwt_livecrootc_to_cwdc_col, default='inactive') + + this%dwt_deadcrootc_to_cwdc_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_DEADCROOTC_TO_CWDC', units='gC/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='dead coarse root to CWD due to landcover change', & + ptr_col=this%dwt_deadcrootc_to_cwdc_col, default='inactive') + + this%crop_seedc_to_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='CROP_SEEDC_TO_LEAF', units='gC/m^2/s', & + avgflag='A', long_name='crop seed source to leaf', & + ptr_patch=this%crop_seedc_to_leaf_patch, default='inactive') + + this%sr_col(begc:endc) = spval + call hist_addfld1d (fname='SR', units='gC/m^2/s', & + avgflag='A', long_name='total soil respiration (HR + root resp)', & + ptr_col=this%sr_col) + + this%er_col(begc:endc) = spval + call hist_addfld1d (fname='ER', units='gC/m^2/s', & + avgflag='A', long_name='total ecosystem respiration, autotrophic + heterotrophic', & + ptr_col=this%er_col) + + this%litfire_col(begc:endc) = spval + call hist_addfld1d (fname='LITFIRE', units='gC/m^2/s', & + avgflag='A', long_name='litter fire losses', & + ptr_col=this%litfire_col, default='inactive') + + this%somfire_col(begc:endc) = spval + call hist_addfld1d (fname='SOMFIRE', units='gC/m^2/s', & + avgflag='A', long_name='soil organic matter fire losses', & + ptr_col=this%somfire_col, default='inactive') + + this%totfire_col(begc:endc) = spval + call hist_addfld1d (fname='TOTFIRE', units='gC/m^2/s', & + avgflag='A', long_name='total ecosystem fire losses', & + ptr_col=this%totfire_col, default='inactive') + + this%fire_closs_col(begc:endc) = spval + call hist_addfld1d (fname='COL_FIRE_CLOSS', units='gC/m^2/s', & + avgflag='A', long_name='total column-level fire C loss for non-peat fires outside land-type converted region', & + ptr_col=this%fire_closs_col) + + this%annsum_npp_patch(begp:endp) = spval + call hist_addfld1d (fname='ANNSUM_NPP', units='gC/m^2/yr', & + avgflag='A', long_name='annual sum of NPP', & + ptr_patch=this%annsum_npp_patch, default='inactive') + + this%annsum_npp_col(begc:endc) = spval + call hist_addfld1d (fname='CANNSUM_NPP', units='gC/m^2/s', & + avgflag='A', long_name='annual sum of column-level NPP', & + ptr_col=this%annsum_npp_col, default='inactive') + + this%nep_col(begc:endc) = spval + call hist_addfld1d (fname='NEP', units='gC/m^2/s', & + avgflag='A', long_name='net ecosystem production, excludes fire, landuse, and harvest flux, positive for sink', & + ptr_col=this%nep_col) + + this%nbp_grc(begg:endg) = spval + call hist_addfld1d (fname='NBP', units='gC/m^2/s', & + avgflag='A', long_name='net biome production, includes fire, landuse,'& + //' harvest and hrv_xsmrpool flux (latter smoothed over the year), positive for sink'& + //' (same as net carbon exchange between land and atmosphere)', & + ptr_gcell=this%nbp_grc) + + this%nee_grc(begg:endg) = spval + call hist_addfld1d (fname='NEE', units='gC/m^2/s', & + avgflag='A', long_name='net ecosystem exchange of carbon,'& + //' includes fire and hrv_xsmrpool (latter smoothed over the year),'& + //' excludes landuse and harvest flux, positive for source', & + ptr_gcell=this%nee_grc) + + this%landuseflux_grc(begg:endg) = spval + call hist_addfld1d (fname='LAND_USE_FLUX', units='gC/m^2/s', & + avgflag='A', & + long_name='total C emitted from land cover conversion (smoothed over the year)'& + //' and wood and grain product pools (NOTE: not a net value)', & + ptr_gcell=this%landuseflux_grc) + + end if + !------------------------------- + ! C13 flux variables - column + !------------------------------- + + if ( carbon_type == 'c13' ) then + + this%m_decomp_cpools_to_fire_col(begc:endc,:) = spval + this%m_decomp_cpools_to_fire_vr_col(begc:endc,:,:) = spval + do k = 1, ndecomp_pools + if ( decomp_cascade_con%is_litter(k) .or. decomp_cascade_con%is_cwd(k) ) then + data1dptr => this%m_decomp_cpools_to_fire_col(:,k) + fieldname = 'C13_M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'C_TO_FIRE' + longname = 'C13 '//trim(decomp_cascade_con%decomp_pool_name_long(k))//' C fire loss' + call hist_addfld1d (fname=fieldname, units='gC13/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + + if ( nlevdecomp_full > 1 ) then + data2dptr => this%m_decomp_cpools_to_fire_vr_col(:,:,k) + fieldname = 'C13_M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'C_TO_FIRE'//trim(vr_suffix) + longname = 'C13 '//trim(decomp_cascade_con%decomp_pool_name_long(k))//' C fire loss' + call hist_addfld_decomp (fname=fieldname, units='gC13/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + end if + endif + end do + + this%dwt_seedc_to_leaf_grc(begg:endg) = spval + call hist_addfld1d (fname='C13_DWT_SEEDC_TO_LEAF', units='gC13/m^2/s', & + avgflag='A', long_name='C13 seed source to patch-level leaf', & + ptr_gcell=this%dwt_seedc_to_leaf_grc, default='inactive') + + this%dwt_seedc_to_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DWT_SEEDC_TO_LEAF_PATCH', units='gC13/m^2/s', & + avgflag='A', & + long_name='patch-level C13 seed source to patch-level leaf ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_seedc_to_leaf_patch, default='inactive') + + this%dwt_seedc_to_deadstem_grc(begg:endg) = spval + call hist_addfld1d (fname='C13_DWT_SEEDC_TO_DEADSTEM', units='gC13/m^2/s', & + avgflag='A', long_name='C13 seed source to patch-level deadstem', & + ptr_gcell=this%dwt_seedc_to_deadstem_grc, default='inactive') + + this%dwt_seedc_to_deadstem_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DWT_SEEDC_TO_DEADSTEM_PATCH', units='gC13/m^2/s', & + avgflag='A', & + long_name='patch-level C13 seed source to patch-level deadstem ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_seedc_to_deadstem_patch, default='inactive') + + this%dwt_conv_cflux_grc(begg:endg) = spval + call hist_addfld1d (fname='C13_DWT_CONV_CFLUX', units='gC13/m^2/s', & + avgflag='A', long_name='C13 conversion C flux (immediate loss to atm) ' // & + '(0 at all times except first timestep of year)', & + ptr_gcell=this%dwt_conv_cflux_grc, default='inactive') + + this%dwt_conv_cflux_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DWT_CONV_CFLUX_PATCH', units='gC13/m^2/s', & + avgflag='A', & + long_name='patch-level C13 conversion C flux (immediate loss to atm) ' // & + '(0 at all times except first timestep of year) ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_conv_cflux_patch, default='inactive') + + this%dwt_conv_cflux_dribbled_grc(begg:endg) = spval + call hist_addfld1d (fname='C13_DWT_CONV_CFLUX_DRIBBLED', units='gC13/m^2/s', & + avgflag='A', & + long_name='C13 conversion C flux (immediate loss to atm), dribbled throughout the year', & + ptr_gcell=this%dwt_conv_cflux_dribbled_grc, default='inactive') + + this%dwt_slash_cflux_grc(begg:endg) = spval + call hist_addfld1d (fname='C13_DWT_SLASH_CFLUX', units='gC13/m^2/s', & + avgflag='A', long_name='C13 slash C flux (to litter diagnostic only)' // & + '(0 at all times except first timestep of year)', & + ptr_gcell=this%dwt_slash_cflux_grc, default='inactive') + + this%dwt_slash_cflux_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DWT_SLASH_CFLUX_PATCH', units='gC13/m^2/s', & + avgflag='A', & + long_name='patch-level C13 slash C flux (to litter diagnostic only) ' // & + '(0 at all times except first timestep of year) ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_slash_cflux_patch, default='inactive') + + this%dwt_frootc_to_litr_met_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C13_DWT_FROOTC_TO_LITR_MET_C', units='gC13/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C13 fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_met_c_col, default='inactive') + + this%dwt_frootc_to_litr_cel_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C13_DWT_FROOTC_TO_LITR_CEL_C', units='gC13/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C13 fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_cel_c_col, default='inactive') + + this%dwt_frootc_to_litr_lig_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C13_DWT_FROOTC_TO_LITR_LIG_C', units='gC13/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C13 fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_lig_c_col, default='inactive') + + this%dwt_livecrootc_to_cwdc_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C13_DWT_LIVECROOTC_TO_CWDC', units='gC13/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C13 live coarse root to CWD due to landcover change', & + ptr_col=this%dwt_livecrootc_to_cwdc_col, default='inactive') + + this%dwt_deadcrootc_to_cwdc_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C13_DWT_DEADCROOTC_TO_CWDC', units='gC13/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C13 dead coarse root to CWD due to landcover change', & + ptr_col=this%dwt_deadcrootc_to_cwdc_col, default='inactive') + + this%crop_seedc_to_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CROP_SEEDC_TO_LEAF', units='gC13/m^2/s', & + avgflag='A', long_name='C13 crop seed source to leaf', & + ptr_patch=this%crop_seedc_to_leaf_patch, default='inactive') + + this%sr_col(begc:endc) = spval + call hist_addfld1d (fname='C13_SR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 total soil respiration (HR + root resp)', & + ptr_col=this%sr_col, default='inactive') + + this%er_col(begc:endc) = spval + call hist_addfld1d (fname='C13_ER', units='gC13/m^2/s', & + avgflag='A', long_name='C13 total ecosystem respiration, autotrophic + heterotrophic', & + ptr_col=this%er_col, default='inactive') + + this%litfire_col(begc:endc) = spval + call hist_addfld1d (fname='C13_LITFIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 litter fire losses', & + ptr_col=this%litfire_col, default='inactive') + + this%somfire_col(begc:endc) = spval + call hist_addfld1d (fname='C13_SOMFIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 soil organic matter fire losses', & + ptr_col=this%somfire_col, default='inactive') + + this%totfire_col(begc:endc) = spval + call hist_addfld1d (fname='C13_TOTFIRE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 total ecosystem fire losses', & + ptr_col=this%totfire_col, default='inactive') + + this%fire_closs_col(begc:endc) = spval + call hist_addfld1d (fname='C13_COL_FIRE_CLOSS', units='gC13/m^2/s', & + avgflag='A', long_name='C13 total column-level fire C loss', & + ptr_col=this%fire_closs_col, default='inactive') + + this%nep_col(begc:endc) = spval + call hist_addfld1d (fname='C13_NEP', units='gC13/m^2/s', & + avgflag='A', long_name='C13 net ecosystem production, excludes fire flux, positive for sink', & + ptr_col=this%nep_col, default='inactive') + + this%nee_grc(begg:endg) = spval + call hist_addfld1d (fname='C13_NEE', units='gC13/m^2/s', & + avgflag='A', long_name='C13 net ecosystem exchange of carbon, includes fire flux, positive for source', & + ptr_gcell=this%nee_grc, default='inactive') + + this%nbp_grc(begg:endg) = spval + call hist_addfld1d (fname='C13_NBP', units='gC13/m^2/s', & + avgflag='A', long_name='C13 net biome production, includes fire, landuse,'& + //' harvest and hrv_xsmrpool flux (latter smoothed over the year), positive for sink'& + //' (same as net carbon exchange between land and atmosphere)', & + ptr_gcell=this%nbp_grc) + + endif + + !------------------------------- + ! C14 flux variables - column + !------------------------------- + + if (carbon_type == 'c14') then + + this%m_decomp_cpools_to_fire_col(begc:endc,:) = spval + this%m_decomp_cpools_to_fire_vr_col(begc:endc,:,:) = spval + do k = 1, ndecomp_pools + if ( decomp_cascade_con%is_litter(k) .or. decomp_cascade_con%is_cwd(k) ) then + data1dptr => this%m_decomp_cpools_to_fire_col(:,k) + fieldname = 'C14_M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'C_TO_FIRE' + longname = 'C14 '//trim(decomp_cascade_con%decomp_pool_name_long(k))//' C fire loss' + call hist_addfld1d (fname=fieldname, units='gC14/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + + if ( nlevdecomp_full > 1 ) then + data2dptr => this%m_decomp_cpools_to_fire_vr_col(:,:,k) + fieldname = 'C14_M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'C_TO_FIRE'//trim(vr_suffix) + longname = 'C14 '//trim(decomp_cascade_con%decomp_pool_name_long(k))//' C fire loss' + call hist_addfld_decomp (fname=fieldname, units='gC14/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + end if + endif + end do + + this%dwt_seedc_to_leaf_grc(begg:endg) = spval + call hist_addfld1d (fname='C14_DWT_SEEDC_TO_LEAF', units='gC14/m^2/s', & + avgflag='A', long_name='C14 seed source to patch-level leaf', & + ptr_gcell=this%dwt_seedc_to_leaf_grc, default='inactive') + + this%dwt_seedc_to_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DWT_SEEDC_TO_LEAF_PATCH', units='gC14/m^2/s', & + avgflag='A', & + long_name='patch-level C14 seed source to patch-level leaf ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_seedc_to_leaf_patch, default='inactive') + + this%dwt_seedc_to_deadstem_grc(begg:endg) = spval + call hist_addfld1d (fname='C14_DWT_SEEDC_TO_DEADSTEM', units='gC14/m^2/s', & + avgflag='A', long_name='C14 seed source to patch-level deadstem', & + ptr_gcell=this%dwt_seedc_to_deadstem_grc, default='inactive') + + this%dwt_seedc_to_deadstem_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DWT_SEEDC_TO_DEADSTEM_PATCH', units='gC14/m^2/s', & + avgflag='A', & + long_name='patch-level C14 seed source to patch-level deadstem ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_seedc_to_deadstem_patch, default='inactive') + + this%dwt_conv_cflux_grc(begg:endg) = spval + call hist_addfld1d (fname='C14_DWT_CONV_CFLUX', units='gC14/m^2/s', & + avgflag='A', long_name='C14 conversion C flux (immediate loss to atm) ' // & + '(0 at all times except first timestep of year)', & + ptr_gcell=this%dwt_conv_cflux_grc, default='inactive') + + this%dwt_conv_cflux_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DWT_CONV_CFLUX_PATCH', units='gC14/m^2/s', & + avgflag='A', & + long_name='patch-level C14 conversion C flux (immediate loss to atm) ' // & + '(0 at all times except first timestep of year) ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_conv_cflux_patch, default='inactive') + + this%dwt_conv_cflux_dribbled_grc(begg:endg) = spval + call hist_addfld1d (fname='C14_DWT_CONV_CFLUX_DRIBBLED', units='gC14/m^2/s', & + avgflag='A', & + long_name='C14 conversion C flux (immediate loss to atm), dribbled throughout the year', & + ptr_gcell=this%dwt_conv_cflux_dribbled_grc, default='inactive') + + this%dwt_slash_cflux_grc(begg:endg) = spval + call hist_addfld1d (fname='C14_DWT_SLASH_CFLUX', units='gC14/m^2/s', & + avgflag='A', long_name='C14 slash C flux (to litter diagnostic only)' // & + '(0 at all times except first timestep of year)', & + ptr_gcell=this%dwt_slash_cflux_grc, default='inactive') + + this%dwt_slash_cflux_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DWT_SLASH_CFLUX_PATCH', units='gC14/m^2/s', & + avgflag='A', & + long_name='patch-level C14 slash C flux (to litter diagnostic only)' // & + '(0 at all times except first timestep of year) ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_slash_cflux_patch, default='inactive') + + this%dwt_frootc_to_litr_met_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C14_DWT_FROOTC_TO_LITR_MET_C', units='gC14/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C14 fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_met_c_col, default='inactive') + + this%dwt_frootc_to_litr_cel_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C14_DWT_FROOTC_TO_LITR_CEL_C', units='gC14/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C14 fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_cel_c_col, default='inactive') + + this%dwt_frootc_to_litr_lig_c_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C14_DWT_FROOTC_TO_LITR_LIG_C', units='gC14/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C14 fine root to litter due to landcover change', & + ptr_col=this%dwt_frootc_to_litr_lig_c_col, default='inactive') + + this%dwt_livecrootc_to_cwdc_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C14_DWT_LIVECROOTC_TO_CWDC', units='gC14/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C14 live coarse root to CWD due to landcover change', & + ptr_col=this%dwt_livecrootc_to_cwdc_col, default='inactive') + + this%dwt_deadcrootc_to_cwdc_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='C14_DWT_DEADCROOTC_TO_CWDC', units='gC14/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='C14 dead coarse root to CWD due to landcover change', & + ptr_col=this%dwt_deadcrootc_to_cwdc_col, default='inactive') + + this%crop_seedc_to_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CROP_SEEDC_TO_LEAF', units='gC14/m^2/s', & + avgflag='A', long_name='C14 crop seed source to leaf', & + ptr_patch=this%crop_seedc_to_leaf_patch, default='inactive') + + this%sr_col(begc:endc) = spval + call hist_addfld1d (fname='C14_SR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 total soil respiration (HR + root resp)', & + ptr_col=this%sr_col, default='inactive') + + this%er_col(begc:endc) = spval + call hist_addfld1d (fname='C14_ER', units='gC14/m^2/s', & + avgflag='A', long_name='C14 total ecosystem respiration, autotrophic + heterotrophic', & + ptr_col=this%er_col, default='inactive') + + this%litfire_col(begc:endc) = spval + call hist_addfld1d (fname='C14_LITFIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 litter fire losses', & + ptr_col=this%litfire_col, default='inactive') + + this%somfire_col(begc:endc) = spval + call hist_addfld1d (fname='C14_SOMFIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 soil organic matter fire losses', & + ptr_col=this%somfire_col, default='inactive') + + this%totfire_col(begc:endc) = spval + call hist_addfld1d (fname='C14_TOTFIRE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 total ecosystem fire losses', & + ptr_col=this%totfire_col, default='inactive') + + this%fire_closs_col(begc:endc) = spval + call hist_addfld1d (fname='C14_COL_FIRE_CLOSS', units='gC14/m^2/s', & + avgflag='A', long_name='C14 total column-level fire C loss', & + ptr_col=this%fire_closs_col, default='inactive') + + this%nep_col(begc:endc) = spval + call hist_addfld1d (fname='C14_NEP', units='gC14/m^2/s', & + avgflag='A', long_name='C14 net ecosystem production, excludes fire flux, positive for sink', & + ptr_col=this%nep_col, default='inactive') + + this%nee_grc(begg:endg) = spval + call hist_addfld1d (fname='C14_NEE', units='gC14/m^2/s', & + avgflag='A', long_name='C14 net ecosystem exchange of carbon, includes fire flux, positive for source', & + ptr_gcell=this%nee_grc, default='inactive') + + this%nbp_grc(begg:endg) = spval + call hist_addfld1d (fname='C14_NBP', units='gC13/m^2/s', & + avgflag='A', long_name='C14 net biome production, includes fire, landuse,'& + //' harvest and hrv_xsmrpool flux (latter smoothed over the year), positive for sink'& + //' (same as net carbon exchange between land and atmosphere)', & + ptr_gcell=this%nbp_grc) + + endif + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !ARGUMENTS: + class(cnveg_carbonflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p, c, l, j + integer :: fc ! filter index + integer :: num_special_col ! number of good values in special_col filter + integer :: num_special_patch ! number of good values in special_patch filter + integer :: special_col(bounds%endc-bounds%begc+1) ! special landunit filter - columns + integer :: special_patch(bounds%endp-bounds%begp+1) ! special landunit filter - patches + !----------------------------------------------------------------------- + + ! Set column filters + + num_special_col = 0 + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + num_special_col = num_special_col + 1 + special_col(num_special_col) = c + end if + end do + + ! Set patch filters + + num_special_patch = 0 + do p = bounds%begp,bounds%endp + l = patch%landunit(p) + + if (lun%ifspecial(l)) then + num_special_patch = num_special_patch + 1 + special_patch(num_special_patch) = p + end if + end do + + do p = bounds%begp,bounds%endp + l = patch%landunit(p) + this%gpp_before_downreg_patch(p) = 0._r8 + ! WW should these be considered spval or 0? + if (lun%ifspecial(l)) then + this%availc_patch(p) = spval + if(use_matrixcn)then + this%matrix_Cinput_patch(p) = spval + this%matrix_C13input_patch(p) = spval + this%matrix_C14input_patch(p) = spval + end if + this%xsmrpool_recover_patch(p) = spval + this%excess_cflux_patch(p) = spval + this%plant_calloc_patch(p) = spval + this%prev_leafc_to_litter_patch(p) = spval + this%prev_frootc_to_litter_patch(p) = spval + this%leafc_to_litter_fun_patch(p) = spval + if ( use_c13 ) then + this%xsmrpool_c13ratio_patch(p) = spval + endif + end if + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%availc_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_Cinput_patch(p) = 0._r8 + this%matrix_C13input_patch(p) = 0._r8 + this%matrix_C14input_patch(p) = 0._r8 + end if + this%xsmrpool_recover_patch(p) = 0._r8 + this%excess_cflux_patch(p) = 0._r8 + this%prev_leafc_to_litter_patch(p) = 0._r8 + this%leafc_to_litter_fun_patch(p) = 0._r8 + this%prev_frootc_to_litter_patch(p) = 0._r8 + this%plant_calloc_patch(p) = 0._r8 + end if + end do + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + + ! also initialize dynamic landcover fluxes so that they have + ! real values on first timestep, prior to calling pftdyn_cnbal + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + do j = 1, nlevdecomp_full + 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 if + end do + + do p = bounds%begp,bounds%endp + l = patch%landunit(p) + + this%gpp_patch(p) = 0._r8 + if (lun%ifspecial(l)) then + this%tempsum_npp_patch(p) = spval + this%annsum_npp_patch(p) = spval + this%tempsum_litfall_patch(p) = spval + this%annsum_litfall_patch(p) = spval + end if + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%tempsum_npp_patch(p) = 0._r8 + this%annsum_npp_patch(p) = 0._r8 + this%tempsum_litfall_patch(p) = 0._r8 + this%annsum_litfall_patch(p) = 0._r8 + end if + end do + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + + if (lun%ifspecial(l)) then + this%annsum_npp_col(c) = spval + end if + + ! also initialize dynamic landcover fluxes so that they have + ! real values on first timestep, prior to calling pftdyn_cnbal + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%annsum_npp_col(c) = 0._r8 + end if + end do + + ! initialize fields for special filters + + call this%SetValues (nvegcpool=nvegcpool, & + num_patch=num_special_patch, filter_patch=special_patch, value_patch=0._r8, & + num_column=num_special_col, filter_column=special_col, value_column=0._r8) + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart ( this, bounds, ncid, flag, carbon_type ) + ! + ! !DESCRIPTION: + ! Read/write CN restart data for carbon fluxes + ! + ! !USES: + use ncdio_pio, only : file_desc_t + ! + ! !ARGUMENTS: + class (cnveg_carbonflux_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' + character(len=*) , intent(in) :: carbon_type ! 'c12' or 'c13' or 'c14' + !------------------------------------------------------------------------ + + if (carbon_type == 'c12') then + call this%RestartBulkOnly(bounds, ncid, flag) + end if + + call this%RestartAllIsotopes(bounds, ncid, flag) + + end subroutine Restart + + + !----------------------------------------------------------------------- + subroutine RestartBulkOnly ( this, bounds, ncid, flag ) + ! + ! !DESCRIPTION: + ! Read/write CN restart data for carbon fluxes - fields only present for bulk C + ! + ! !USES: + use shr_infnan_mod , only : isnan => shr_infnan_isnan, nan => shr_infnan_nan, assignment(=) + use clm_time_manager , only : is_restart + use clm_varcon , only : c13ratio, c14ratio + use clm_varctl , only : use_lch4 + use CNSharedParamsMod, only : use_fun + use restUtilMod + use ncdio_pio + ! + ! !ARGUMENTS: + class (cnveg_carbonflux_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_crop) then + + call restartvar(ncid=ncid, flag=flag, varname='grainc_xfer_to_grainc', xtype=ncd_double, & + dim1name='pft', & + long_name='grain C growth from storage', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_xfer_to_grainc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_to_litter', xtype=ncd_double, & + dim1name='pft', & + long_name='live stem C litterfall', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_to_litter_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc_to_food', xtype=ncd_double, & + dim1name='pft', & + long_name='grain C to food', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_to_food_patch) + + call restartvar(ncid=ncid, flag=flag, varname='cpool_to_grainc', xtype=ncd_double, & + dim1name='pft', & + long_name='allocation to grain C', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%cpool_to_grainc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='cpool_to_grainc_storage', xtype=ncd_double, & + dim1name='pft', & + long_name='allocation to grain C storage', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%cpool_to_grainc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='cpool_grain_gr', xtype=ncd_double, & + dim1name='pft', & + long_name='grain growth respiration', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%cpool_grain_gr_patch) + + call restartvar(ncid=ncid, flag=flag, varname='cpool_grain_storage_gr', xtype=ncd_double, & + dim1name='pft', & + long_name='grain growth respiration to storage', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%cpool_grain_storage_gr_patch) + + call restartvar(ncid=ncid, flag=flag, varname='transfer_grain_gr', xtype=ncd_double, & + dim1name='pft', & + long_name='grain growth respiration from storage', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%transfer_grain_gr_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc_storage_to_xfer', xtype=ncd_double, & + dim1name='pft', & + long_name='grain C shift storage to transfer', units='gC/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_storage_to_xfer_patch) + + end if + + call restartvar(ncid=ncid, flag=flag, varname='gpp_pepv', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%gpp_before_downreg_patch) + + call restartvar(ncid=ncid, flag=flag, varname='availc', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%availc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='xsmrpool_recover', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%xsmrpool_recover_patch) + + call restartvar(ncid=ncid, flag=flag, varname='plant_calloc', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%plant_calloc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='excess_cflux', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%excess_cflux_patch) + + call restartvar(ncid=ncid, flag=flag, varname='prev_leafc_to_litter', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%prev_leafc_to_litter_patch) + + call restartvar(ncid=ncid, flag=flag, varname='prev_frootc_to_litter', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%prev_frootc_to_litter_patch) + + call restartvar(ncid=ncid, flag=flag, varname='tempsum_npp', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tempsum_npp_patch) + + call restartvar(ncid=ncid, flag=flag, varname='annsum_npp', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%annsum_npp_patch) + + call restartvar(ncid=ncid, flag=flag, varname='col_lag_npp', xtype=ncd_double, & + dim1name='column', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%lag_npp_col) + + call restartvar(ncid=ncid, flag=flag, varname='cannsum_npp', xtype=ncd_double, & + dim1name='column', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%annsum_npp_col) + + call restartvar(ncid=ncid, flag=flag, varname='tempsum_litfall', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tempsum_litfall_patch) + + call restartvar(ncid=ncid, flag=flag, varname='annsum_litfall', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%annsum_litfall_patch) + + if ( use_fun ) then + call restartvar(ncid=ncid, flag=flag, varname='leafc_to_litter_fun', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_to_litter_fun_patch) + ! BACKWARDS_COMPATIBILITY(wrw, 2018-06-28) re. issue #426 + call set_missing_vals_to_constant(this%leafc_to_litter_fun_patch, 0._r8) + end if + + end subroutine RestartBulkOnly + + + !----------------------------------------------------------------------- + subroutine RestartAllIsotopes ( this, bounds, ncid, flag ) + ! + ! !DESCRIPTION: + ! Read/write CN restart data for carbon fluxes - fields present for both bulk C and isotopes + ! + ! !USES: + use ncdio_pio, only : file_desc_t + ! + ! !ARGUMENTS: + class (cnveg_carbonflux_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' + !----------------------------------------------------------------------- + + call this%dwt_conv_cflux_dribbler%Restart(bounds, ncid, flag) + call this%hrv_xsmrpool_to_atm_dribbler%Restart(bounds, ncid, flag) + + end subroutine RestartAllIsotopes + + !----------------------------------------------------------------------- + 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 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 + + !----------------------------------------------------------------------- + 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%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 + +end module CNVegCarbonFluxType + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegCarbonStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegCarbonStateType.F90 new file mode 100644 index 000000000..f07139d87 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegCarbonStateType.F90 @@ -0,0 +1,4798 @@ +module CNVegCarbonStateType + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_const_mod , only : SHR_CONST_PDB + use shr_log_mod , only : errMsg => shr_log_errMsg + use pftconMod , only : noveg, npcropmin, pftcon, nc3crop, nc3irrig + use clm_varcon , only : spval, c3_r2, c4_r2, c14ratio + use clm_varctl , only : iulog, use_cndv, use_crop, use_matrixcn + use decompMod , only : bounds_type + use abortutils , only : endrun + use spmdMod , only : masterproc + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use CNSpeciesMod , only : species_from_string, CN_SPECIES_C12 + use dynPatchStateUpdaterMod, only : patch_state_updater_type + use CNVegComputeSeedMod, only : ComputeSeedAmounts + ! + ! !PUBLIC TYPES: + implicit none + private + ! + + 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 :: Init + procedure , public :: SetValues + procedure , public :: ZeroDWT + procedure , public :: Restart + procedure , public :: Summary => Summary_carbonstate + procedure , public :: DynamicPatchAdjustments ! adjust state variables when patch areas change + + procedure , private :: InitAllocate ! Allocate arrays + procedure , private :: InitReadNML ! Read in namelist + procedure , private :: InitHistory ! Initialize history + procedure , private :: InitCold ! Initialize arrays for a cold-start + + end type cnveg_carbonstate_type + + 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, carbon_type, ratio, NLFilename, & + dribble_crophrv_xsmrpool_2atm, c12_cnveg_carbonstate_inst) + + class(cnveg_carbonstate_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: ratio + character(len=*) , intent(in) :: carbon_type ! Carbon isotope type C12, C13 or C1 + character(len=*) , intent(in) :: NLFilename ! Namelist filename + logical , intent(in) :: dribble_crophrv_xsmrpool_2atm + type(cnveg_carbonstate_type) , intent(in), optional :: c12_cnveg_carbonstate_inst ! cnveg_carbonstate for C12 (if C13 or C14) + !----------------------------------------------------------------------- + + this%species = species_from_string(carbon_type) + + this%dribble_crophrv_xsmrpool_2atm = dribble_crophrv_xsmrpool_2atm + + call this%InitAllocate ( bounds) + call this%InitReadNML ( NLFilename ) + call this%InitHistory ( bounds, carbon_type) + if (present(c12_cnveg_carbonstate_inst)) then + call this%InitCold ( bounds, ratio, carbon_type, c12_cnveg_carbonstate_inst ) + else + call this%InitCold ( bounds, ratio, carbon_type ) + end if + + 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 InitAllocate(this, bounds) + ! + ! !ARGUMENTS: + class (cnveg_carbonstate_type) :: 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%leafc_patch (begp:endp)) ; this%leafc_patch (:) = nan + 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 (:) = nan + 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 (:) = nan + 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 (:) = nan + 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 (:) = nan + allocate(this%totecosysc_col (begc:endc)) ; this%totecosysc_col (:) = nan + allocate(this%totc_grc (begg:endg)) ; this%totc_grc (:) = nan + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds, carbon_type) + ! + ! !DESCRIPTION: + ! add history fields for all CN variables, always set as default='inactive' + ! + ! !USES: + use clm_varctl , only : use_c13, use_c14, use_matrixcn + use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + ! + ! !ARGUMENTS: + class (cnveg_carbonstate_type) :: this + type(bounds_type) , intent(in) :: bounds + character(len=*) , intent(in) :: carbon_type ! one of ['c12', c13','c14'] + ! + ! !LOCAL VARIABLES: + integer :: k,l,ii,jj + character(10) :: active + integer :: begp,endp + integer :: begc,endc + integer :: begg,endg + character(24) :: fieldname + character(100) :: longname + real(r8), pointer :: data1dptr(:) ! temp. pointer for slicing larger arrays + real(r8), pointer :: data2dptr(:,:) ! temp. pointer for slicing larger arrays + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + + !------------------------------- + ! C12 state variables + !------------------------------- + + if (carbon_type == 'c12') then + + if (use_crop) then + this%grainc_patch(begp:endp) = spval + call hist_addfld1d (fname='GRAINC', units='gC/m^2', & + avgflag='A', long_name='grain C (does not equal yield)', & + ptr_patch=this%grainc_patch) + this%cropseedc_deficit_patch(begp:endp) = spval + call hist_addfld1d (fname='CROPSEEDC_DEFICIT', units='gC/m^2', & + avgflag='A', long_name='C used for crop seed that needs to be repaid', & + ptr_patch=this%cropseedc_deficit_patch) + + this%xsmrpool_loss_patch(begp:endp) = spval + call hist_addfld1d (fname='XSMRPOOL_LOSS', units='gC/m^2', & + avgflag='A', long_name='temporary photosynthate C pool loss', & + ptr_patch=this%xsmrpool_loss_patch, default='inactive') + end if + + this%woodc_patch(begp:endp) = spval + call hist_addfld1d (fname='WOODC', units='gC/m^2', & + avgflag='A', long_name='wood C', & + ptr_patch=this%woodc_patch) + + this%leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC', units='gC/m^2', & + avgflag='A', long_name='leaf C', & + ptr_patch=this%leafc_patch) + + this%leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_STORAGE', units='gC/m^2', & + avgflag='A', long_name='leaf C storage', & + ptr_patch=this%leafc_storage_patch, default='inactive') + + this%leafc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_XFER', units='gC/m^2', & + avgflag='A', long_name='leaf C transfer', & + ptr_patch=this%leafc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_CAP', units='gC/m^2', & + avgflag='I', long_name='leaf C capacity', & + ptr_patch=this%matrix_cap_leafc_patch) + + this%matrix_cap_leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_STORAGE_CAP', units='gC/m^2', & + avgflag='I', long_name='leaf C storage capacity', & + ptr_patch=this%matrix_cap_leafc_storage_patch, default='inactive') + + this%matrix_cap_leafc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_XFER_CAP', units='gC/m^2', & + avgflag='I', long_name='leaf C transfer capacity', & + ptr_patch=this%matrix_cap_leafc_xfer_patch, default='inactive') + end if + + this%leafc_storage_xfer_acc_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFC_STORAGE_XFER_ACC', units='gC/m^2', & + avgflag='A', long_name='Accumulated leaf C transfer', & + ptr_patch=this%leafc_storage_xfer_acc_patch, default='inactive') + + this%storage_cdemand_patch(begp:endp) = spval + call hist_addfld1d (fname='STORAGE_CDEMAND', units='gC/m^2', & + avgflag='A', long_name='C use from the C storage pool', & + ptr_patch=this%storage_cdemand_patch, default='inactive') + + this%frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC', units='gC/m^2', & + avgflag='A', long_name='fine root C', & + ptr_patch=this%frootc_patch) + + this%frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_STORAGE', units='gC/m^2', & + avgflag='A', long_name='fine root C storage', & + ptr_patch=this%frootc_storage_patch, default='inactive') + + this%frootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_XFER', units='gC/m^2', & + avgflag='A', long_name='fine root C transfer', & + ptr_patch=this%frootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_CAP', units='gC/m^2', & + avgflag='I', long_name='fine root C capacity', & + ptr_patch=this%matrix_cap_frootc_patch) + + this%matrix_cap_frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_STORAGE_CAP', units='gC/m^2', & + avgflag='I', long_name='fine root C storage capacity', & + ptr_patch=this%matrix_cap_frootc_storage_patch, default='inactive') + + this%matrix_cap_frootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTC_XFER_CAP', units='gC/m^2', & + avgflag='I', long_name='fine root C transfer capacity', & + ptr_patch=this%matrix_cap_frootc_xfer_patch, default='inactive') + end if + + this%livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC', units='gC/m^2', & + avgflag='A', long_name='live stem C', & + ptr_patch=this%livestemc_patch) + + this%livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_STORAGE', units='gC/m^2', & + avgflag='A', long_name='live stem C storage', & + ptr_patch=this%livestemc_storage_patch, default='inactive') + + this%livestemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_XFER', units='gC/m^2', & + avgflag='A', long_name='live stem C transfer', & + ptr_patch=this%livestemc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_CAP', units='gC/m^2', & + avgflag='I', long_name='live stem C capacity', & + ptr_patch=this%matrix_cap_livestemc_patch) + + this%matrix_cap_livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_STORAGE_CAP', units='gC/m^2', & + avgflag='I', long_name='live stem C storage capcity', & + ptr_patch=this%matrix_cap_livestemc_storage_patch, default='inactive') + + this%matrix_cap_livestemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMC_XFER_CAP', units='gC/m^2', & + avgflag='I', long_name='live stem C transfer capacity', & + ptr_patch=this%matrix_cap_livestemc_xfer_patch, default='inactive') + end if + + this%deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC', units='gC/m^2', & + avgflag='A', long_name='dead stem C', & + ptr_patch=this%deadstemc_patch) + + this%deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC_STORAGE', units='gC/m^2', & + avgflag='A', long_name='dead stem C storage', & + ptr_patch=this%deadstemc_storage_patch, default='inactive') + + this%deadstemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC_XFER', units='gC/m^2', & + avgflag='A', long_name='dead stem C transfer', & + ptr_patch=this%deadstemc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC_CAP', units='gC/m^2', & + avgflag='I', long_name='dead stem C capacity', & + ptr_patch=this%matrix_cap_deadstemc_patch) + + this%matrix_cap_deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC_STORAGE_CAP', units='gC/m^2', & + avgflag='I', long_name='dead stem C storage capacity', & + ptr_patch=this%matrix_cap_deadstemc_storage_patch, default='inactive') + + this%matrix_cap_deadstemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMC_XFER_CAP', units='gC/m^2', & + avgflag='I', long_name='dead stem C transfer capacity', & + ptr_patch=this%matrix_cap_deadstemc_xfer_patch, default='inactive') + end if + + this%livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC', units='gC/m^2', & + avgflag='A', long_name='live coarse root C', & + ptr_patch=this%livecrootc_patch) + + this%livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC_STORAGE', units='gC/m^2', & + avgflag='A', long_name='live coarse root C storage', & + ptr_patch=this%livecrootc_storage_patch, default='inactive') + + this%livecrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC_XFER', units='gC/m^2', & + avgflag='A', long_name='live coarse root C transfer', & + ptr_patch=this%livecrootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC_CAP', units='gC/m^2', & + avgflag='I', long_name='live coarse root C capacity', & + ptr_patch=this%matrix_cap_livecrootc_patch) + + this%matrix_cap_livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC_STORAGE_CAP', units='gC/m^2', & + avgflag='I', long_name='live coarse root C storage capacity', & + ptr_patch=this%matrix_cap_livecrootc_storage_patch, default='inactive') + + this%matrix_cap_livecrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTC_XFER_CAP', units='gC/m^2', & + avgflag='I', long_name='live coarse root C transfer capacity', & + ptr_patch=this%matrix_cap_livecrootc_xfer_patch, default='inactive') + end if + + this%deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTC', units='gC/m^2', & + avgflag='A', long_name='dead coarse root C', & + ptr_patch=this%deadcrootc_patch) + + this%deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTC_STORAGE', units='gC/m^2', & + avgflag='A', long_name='dead coarse root C storage', & + ptr_patch=this%deadcrootc_storage_patch, default='inactive') + + this%deadcrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTC_XFER', units='gC/m^2', & + avgflag='A', long_name='dead coarse root C transfer', & + ptr_patch=this%deadcrootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTC_CAP', units='gC/m^2', & + avgflag='I', long_name='dead coarse root C capacity', & + ptr_patch=this%matrix_cap_deadcrootc_patch) + + this%matrix_cap_deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTC_STORAGE_CAP', units='gC/m^2', & + avgflag='I', long_name='dead coarse root C storage capacity', & + ptr_patch=this%matrix_cap_deadcrootc_storage_patch, default='inactive') + + this%matrix_cap_deadcrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTC_XFER_CAP', units='gC/m^2', & + avgflag='I', long_name='dead coarse root C transfer capacity', & + ptr_patch=this%matrix_cap_deadcrootc_xfer_patch, default='inactive') + end if + + this%gresp_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='GRESP_STORAGE', units='gC/m^2', & + avgflag='A', long_name='growth respiration storage', & + ptr_patch=this%gresp_storage_patch, default='inactive') + + this%gresp_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='GRESP_XFER', units='gC/m^2', & + avgflag='A', long_name='growth respiration transfer', & + ptr_patch=this%gresp_xfer_patch, default='inactive') + + this%cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='CPOOL', units='gC/m^2', & + avgflag='A', long_name='temporary photosynthate C pool', & + ptr_patch=this%cpool_patch) + + this%xsmrpool_patch(begp:endp) = spval + call hist_addfld1d (fname='XSMRPOOL', units='gC/m^2', & + avgflag='A', long_name='temporary photosynthate C pool', & + ptr_patch=this%xsmrpool_patch) + + this%ctrunc_patch(begp:endp) = spval + call hist_addfld1d (fname='PFT_CTRUNC', units='gC/m^2', & + avgflag='A', long_name='patch-level sink for C truncation', & + ptr_patch=this%ctrunc_patch, default='inactive') + + this%dispvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='DISPVEGC', units='gC/m^2', & + avgflag='A', long_name='displayed veg carbon, excluding storage and cpool', & + ptr_patch=this%dispvegc_patch) + + this%storvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='STORVEGC', units='gC/m^2', & + avgflag='A', long_name='stored vegetation carbon, excluding cpool', & + ptr_patch=this%storvegc_patch) + + this%totvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='TOTVEGC', units='gC/m^2', & + avgflag='A', long_name='total vegetation carbon, excluding cpool', & + ptr_patch=this%totvegc_patch) + + this%totc_patch(begp:endp) = spval + call hist_addfld1d (fname='TOTPFTC', units='gC/m^2', & + avgflag='A', long_name='total patch-level carbon, including cpool', & + ptr_patch=this%totc_patch) + + this%seedc_grc(begg:endg) = spval + call hist_addfld1d (fname='SEEDC', units='gC/m^2', & + avgflag='A', long_name='pool for seeding new PFTs via dynamic landcover', & + ptr_gcell=this%seedc_grc) + + this%fuelc_col(begc:endc) = spval + call hist_addfld1d (fname='FUELC', units='gC/m^2', & + avgflag='A', long_name='fuel load', & + ptr_col=this%fuelc_col) + + this%totc_col(begc:endc) = spval + call hist_addfld1d (fname='TOTCOLC', units='gC/m^2', & + avgflag='A', long_name='total column carbon, incl veg and cpool but excl product pools', & + ptr_col=this%totc_col) + + this%totecosysc_col(begc:endc) = spval + call hist_addfld1d (fname='TOTECOSYSC', units='gC/m^2', & + avgflag='A', long_name='total ecosystem carbon, incl veg but excl cpool and product pools', & + ptr_col=this%totecosysc_col) + + end if + + !------------------------------- + ! C13 state variables + !------------------------------- + + if ( carbon_type == 'c13' ) then + + this%leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC', units='gC13/m^2', & + avgflag='A', long_name='C13 leaf C', & + ptr_patch=this%leafc_patch, default='inactive') + + this%leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_STORAGE', units='gC13/m^2', & + avgflag='A', long_name='C13 leaf C storage', & + ptr_patch=this%leafc_storage_patch, default='inactive') + + this%leafc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_XFER', units='gC13/m^2', & + avgflag='A', long_name='C13 leaf C transfer', & + ptr_patch=this%leafc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 leaf C capacity', & + ptr_patch=this%matrix_cap_leafc_patch) + + this%matrix_cap_leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_STORAGE_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 leaf C storage capacity', & + ptr_patch=this%matrix_cap_leafc_storage_patch)!, default='inactive') + + this%matrix_cap_leafc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_XFER_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 leaf C transfer capacity', & + ptr_patch=this%matrix_cap_leafc_xfer_patch)!, default='inactive') + end if + + this%leafc_storage_xfer_acc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LEAFC_STORAGE_XFER_ACC', units='gC13/m^2', & + avgflag='A', long_name='Accumulated C13 leaf C transfer', & + ptr_patch=this%leafc_storage_xfer_acc_patch, default='inactive') + + this%frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC', units='gC13/m^2', & + avgflag='A', long_name='C13 fine root C', & + ptr_patch=this%frootc_patch, default='inactive') + + this%frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC_STORAGE', units='gC13/m^2', & + avgflag='A', long_name='C13 fine root C storage', & + ptr_patch=this%frootc_storage_patch, default='inactive') + + this%frootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC_XFER', units='gC13/m^2', & + avgflag='A', long_name='C13 fine root C transfer', & + ptr_patch=this%frootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 fine root C capacity', & + ptr_patch=this%matrix_cap_frootc_patch) + + this%matrix_cap_frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC_STORAGE_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 fine root C storage capacity', & + ptr_patch=this%matrix_cap_frootc_storage_patch)!, default='inactive') + + this%matrix_cap_frootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_FROOTC_XFER_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 fine root C transfer capacity', & + ptr_patch=this%matrix_cap_frootc_xfer_patch)!, default='inactive') + end if + + this%livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC', units='gC13/m^2', & + avgflag='A', long_name='C13 live stem C', & + ptr_patch=this%livestemc_patch, default='inactive') + + this%livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC_STORAGE', units='gC13/m^2', & + avgflag='A', long_name='C13 live stem C storage', & + ptr_patch=this%livestemc_storage_patch, default='inactive') + + this%livestemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC_XFER', units='gC13/m^2', & + avgflag='A', long_name='C13 live stem C transfer', & + ptr_patch=this%livestemc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 live stem C capacity', & + ptr_patch=this%matrix_cap_livestemc_patch) + + this%matrix_cap_livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC_STORAGE_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 live stem C storage capcity', & + ptr_patch=this%matrix_cap_livestemc_storage_patch)!, default='inactive') + + this%matrix_cap_livestemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVESTEMC_XFER_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 live stem C transfer capacity', & + ptr_patch=this%matrix_cap_livestemc_xfer_patch)!, default='inactive') + end if + + this%deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADSTEMC', units='gC13/m^2', & + avgflag='A', long_name='C13 dead stem C', & + ptr_patch=this%deadstemc_patch, default='inactive') + + this%deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADSTEMC_STORAGE', units='gC13/m^2', & + avgflag='A', long_name='C13 dead stem C storage', & + ptr_patch=this%deadstemc_storage_patch, default='inactive') + + this%deadstemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADSTEMC_XFER', units='gC13/m^2', & + avgflag='A', long_name='C13 dead stem C transfer', & + ptr_patch=this%deadstemc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADSTEMC_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 dead stem C capacity', & + ptr_patch=this%matrix_cap_deadstemc_patch) + + this%matrix_cap_deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADSTEMC_STORAGE_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 dead stem C storage capacity', & + ptr_patch=this%matrix_cap_deadstemc_storage_patch)!, default='inactive') + + this%matrix_cap_deadstemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADSTEMC_XFER_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 dead stem C transfer capacity', & + ptr_patch=this%matrix_cap_deadstemc_xfer_patch)!, default='inactive') + end if + + this%livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC', units='gC13/m^2', & + avgflag='A', long_name='C13 live coarse root C', & + ptr_patch=this%livecrootc_patch, default='inactive') + + this%livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC_STORAGE', units='gC13/m^2', & + avgflag='A', long_name='C13 live coarse root C storage', & + ptr_patch=this%livecrootc_storage_patch, default='inactive') + + this%livecrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC_XFER', units='gC13/m^2', & + avgflag='A', long_name='C13 live coarse root C transfer', & + ptr_patch=this%livecrootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 live coarse root C capacity', & + ptr_patch=this%matrix_cap_livecrootc_patch) + + this%matrix_cap_livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC_STORAGE_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 live coarse root C storage capacity', & + ptr_patch=this%matrix_cap_livecrootc_storage_patch)!, default='inactive') + + this%matrix_cap_livecrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_LIVECROOTC_XFER_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 live coarse root C transfer capacity', & + ptr_patch=this%matrix_cap_livecrootc_xfer_patch)!, default='inactive') + end if + + this%deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADCROOTC', units='gC13/m^2', & + avgflag='A', long_name='C13 dead coarse root C', & + ptr_patch=this%deadcrootc_patch, default='inactive') + + this%deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADCROOTC_STORAGE', units='gC13/m^2', & + avgflag='A', long_name='C13 dead coarse root C storage', & + ptr_patch=this%deadcrootc_storage_patch, default='inactive') + + this%deadcrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADCROOTC_XFER', units='gC13/m^2', & + avgflag='A', long_name='C13 dead coarse root C transfer', & + ptr_patch=this%deadcrootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADCROOTC_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 dead coarse root C capacity', & + ptr_patch=this%matrix_cap_deadcrootc_patch) + + this%matrix_cap_deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADCROOTC_STORAGE_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 dead coarse root C storage capacity', & + ptr_patch=this%matrix_cap_deadcrootc_storage_patch)!, default='inactive') + + this%matrix_cap_deadcrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DEADCROOTC_XFER_CAP', units='gC13/m^2', & + avgflag='I', long_name='C13 dead coarse root C transfer capacity', & + ptr_patch=this%matrix_cap_deadcrootc_xfer_patch)!, default='inactive') + end if + + this%gresp_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_GRESP_STORAGE', units='gC13/m^2', & + avgflag='A', long_name='C13 growth respiration storage', & + ptr_patch=this%gresp_storage_patch, default='inactive') + + this%gresp_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_GRESP_XFER', units='gC13/m^2', & + avgflag='A', long_name='C13 growth respiration transfer', & + ptr_patch=this%gresp_xfer_patch, default='inactive') + + this%cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CPOOL', units='gC13/m^2', & + avgflag='A', long_name='C13 temporary photosynthate C pool', & + ptr_patch=this%cpool_patch, default='inactive') + + this%xsmrpool_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_XSMRPOOL', units='gC13/m^2', & + avgflag='A', long_name='C13 temporary photosynthate C pool', & + ptr_patch=this%xsmrpool_patch, default='inactive') + + this%ctrunc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_PFT_CTRUNC', units='gC13/m^2', & + avgflag='A', long_name='C13 patch-level sink for C truncation', & + ptr_patch=this%ctrunc_patch, default='inactive') + + this%dispvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_DISPVEGC', units='gC13/m^2', & + avgflag='A', long_name='C13 displayed veg carbon, excluding storage and cpool', & + ptr_patch=this%dispvegc_patch, default='inactive') + + this%storvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_STORVEGC', units='gC13/m^2', & + avgflag='A', long_name='C13 stored vegetation carbon, excluding cpool', & + ptr_patch=this%storvegc_patch, default='inactive') + + this%totvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TOTVEGC', units='gC13/m^2', & + avgflag='A', long_name='C13 total vegetation carbon, excluding cpool', & + ptr_patch=this%totvegc_patch) + + this%totc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_TOTPFTC', units='gC13/m^2', & + avgflag='A', long_name='C13 total patch-level carbon, including cpool', & + ptr_patch=this%totc_patch, default='inactive') + + this%seedc_grc(begg:endg) = spval + call hist_addfld1d (fname='C13_SEEDC', units='gC13/m^2', & + avgflag='A', long_name='C13 pool for seeding new PFTs via dynamic landcover', & + ptr_gcell=this%seedc_grc, default='inactive') + + this%totc_col(begc:endc) = spval + call hist_addfld1d (fname='C13_TOTCOLC', units='gC13/m^2', & + avgflag='A', long_name='C13 total column carbon, incl veg and cpool but excl product pools', & + ptr_col=this%totc_col, default='inactive') + + this%totecosysc_col(begc:endc) = spval + call hist_addfld1d (fname='C13_TOTECOSYSC', units='gC13/m^2', & + avgflag='A', long_name='C13 total ecosystem carbon, incl veg but excl cpool and product pools', & + ptr_col=this%totecosysc_col) + + if (use_crop) then + this%grainc_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_GRAINC', units='gC/m^2', & + avgflag='A', long_name='C13 grain C (does not equal yield)', & + ptr_patch=this%grainc_patch, default='inactive') + this%cropseedc_deficit_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_CROPSEEDC_DEFICIT', units='gC/m^2', & + avgflag='A', long_name='C13 C used for crop seed that needs to be repaid', & + ptr_patch=this%cropseedc_deficit_patch, default='inactive') + + this%xsmrpool_loss_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_XSMRPOOL_LOSS', units='gC13/m^2', & + avgflag='A', long_name='C13 temporary photosynthate C pool loss', & + ptr_patch=this%xsmrpool_loss_patch, default='inactive') + end if + + + endif + + !------------------------------- + ! C14 state variables + !------------------------------- + + if ( carbon_type == 'c14') then + + this%leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC', units='gC14/m^2', & + avgflag='A', long_name='C14 leaf C', & + ptr_patch=this%leafc_patch, default='inactive') + + this%leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_STORAGE', units='gC14/m^2', & + avgflag='A', long_name='C14 leaf C storage', & + ptr_patch=this%leafc_storage_patch, default='inactive') + + this%leafc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_XFER', units='gC14/m^2', & + avgflag='A', long_name='C14 leaf C transfer', & + ptr_patch=this%leafc_xfer_patch, default='inactive') + + this%leafc_storage_xfer_acc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_STORAGE_XFER_ACC', units='gC14/m^2', & + avgflag='A', long_name='Accumulated C14 leaf C transfer', & + ptr_patch=this%leafc_storage_xfer_acc_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_leafc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 leaf C capacity', & + ptr_patch=this%matrix_cap_leafc_patch) + + this%matrix_cap_leafc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_STORAGE_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 leaf C storage capacity', & + ptr_patch=this%matrix_cap_leafc_storage_patch)!, default='inactive') + + this%matrix_cap_leafc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LEAFC_XFER_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 leaf C transfer capacity', & + ptr_patch=this%matrix_cap_leafc_xfer_patch)!, default='inactive') + end if + + this%frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC', units='gC14/m^2', & + avgflag='A', long_name='C14 fine root C', & + ptr_patch=this%frootc_patch, default='inactive') + + this%frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC_STORAGE', units='gC14/m^2', & + avgflag='A', long_name='C14 fine root C storage', & + ptr_patch=this%frootc_storage_patch, default='inactive') + + this%frootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC_XFER', units='gC14/m^2', & + avgflag='A', long_name='C14 fine root C transfer', & + ptr_patch=this%frootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_frootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 fine root C capacity', & + ptr_patch=this%matrix_cap_frootc_patch) + + this%matrix_cap_frootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC_STORAGE_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 fine root C storage capacity', & + ptr_patch=this%matrix_cap_frootc_storage_patch)!, default='inactive') + + this%matrix_cap_frootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_FROOTC_XFER_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 fine root C transfer capacity', & + ptr_patch=this%matrix_cap_frootc_xfer_patch)!, default='inactive') + end if + + this%livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC', units='gC14/m^2', & + avgflag='A', long_name='C14 live stem C', & + ptr_patch=this%livestemc_patch, default='inactive') + + this%livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC_STORAGE', units='gC14/m^2', & + avgflag='A', long_name='C14 live stem C storage', & + ptr_patch=this%livestemc_storage_patch, default='inactive') + + this%livestemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC_XFER', units='gC14/m^2', & + avgflag='A', long_name='C14 live stem C transfer', & + ptr_patch=this%livestemc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_livestemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 live stem C capacity', & + ptr_patch=this%matrix_cap_livestemc_patch) + + this%matrix_cap_livestemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC_STORAGE_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 live stem C storage capcity', & + ptr_patch=this%matrix_cap_livestemc_storage_patch)!, default='inactive') + + this%matrix_cap_livestemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVESTEMC_XFER_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 live stem C transfer capacity', & + ptr_patch=this%matrix_cap_livestemc_xfer_patch)!, default='inactive') + end if + + this%deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADSTEMC', units='gC14/m^2', & + avgflag='A', long_name='C14 dead stem C', & + ptr_patch=this%deadstemc_patch, default='inactive') + + this%deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADSTEMC_STORAGE', units='gC14/m^2', & + avgflag='A', long_name='C14 dead stem C storage', & + ptr_patch=this%deadstemc_storage_patch, default='inactive') + + this%deadstemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADSTEMC_XFER', units='gC14/m^2', & + avgflag='A', long_name='C14 dead stem C transfer', & + ptr_patch=this%deadstemc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_deadstemc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADSTEMC_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 dead stem C capacity', & + ptr_patch=this%matrix_cap_deadstemc_patch) + + this%matrix_cap_deadstemc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADSTEMC_STORAGE_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 dead stem C storage capacity', & + ptr_patch=this%matrix_cap_deadstemc_storage_patch)!, default='inactive') + + this%matrix_cap_deadstemc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADSTEMC_XFER_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 dead stem C transfer capacity', & + ptr_patch=this%matrix_cap_deadstemc_xfer_patch)!, default='inactive') + end if + + this%livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC', units='gC14/m^2', & + avgflag='A', long_name='C14 live coarse root C', & + ptr_patch=this%livecrootc_patch, default='inactive') + + this%livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC_STORAGE', units='gC14/m^2', & + avgflag='A', long_name='C14 live coarse root C storage', & + ptr_patch=this%livecrootc_storage_patch, default='inactive') + + this%livecrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC_XFER', units='gC14/m^2', & + avgflag='A', long_name='C14 live coarse root C transfer', & + ptr_patch=this%livecrootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_livecrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 live coarse root C capacity', & + ptr_patch=this%matrix_cap_livecrootc_patch) + + this%matrix_cap_livecrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC_STORAGE_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 live coarse root C storage capacity', & + ptr_patch=this%matrix_cap_livecrootc_storage_patch)!, default='inactive') + + this%matrix_cap_livecrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_LIVECROOTC_XFER_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 live coarse root C transfer capacity', & + ptr_patch=this%matrix_cap_livecrootc_xfer_patch)!, default='inactive') + end if + + this%deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADCROOTC', units='gC14/m^2', & + avgflag='A', long_name='C14 dead coarse root C', & + ptr_patch=this%deadcrootc_patch, default='inactive') + + this%deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADCROOTC_STORAGE', units='gC14/m^2', & + avgflag='A', long_name='C14 dead coarse root C storage', & + ptr_patch=this%deadcrootc_storage_patch, default='inactive') + + this%deadcrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADCROOTC_XFER', units='gC14/m^2', & + avgflag='A', long_name='C14 dead coarse root C transfer', & + ptr_patch=this%deadcrootc_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_deadcrootc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADCROOTC_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 dead coarse root C capacity', & + ptr_patch=this%matrix_cap_deadcrootc_patch) + + this%matrix_cap_deadcrootc_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADCROOTC_STORAGE_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 dead coarse root C storage capacity', & + ptr_patch=this%matrix_cap_deadcrootc_storage_patch)!, default='inactive') + + this%matrix_cap_deadcrootc_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DEADCROOTC_XFER_CAP', units='gC14/m^2', & + avgflag='I', long_name='C14 dead coarse root C transfer capacity', & + ptr_patch=this%matrix_cap_deadcrootc_xfer_patch)!, default='inactive') + end if + + this%gresp_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_GRESP_STORAGE', units='gC14/m^2', & + avgflag='A', long_name='C14 growth respiration storage', & + ptr_patch=this%gresp_storage_patch, default='inactive') + + this%gresp_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_GRESP_XFER', units='gC14/m^2', & + avgflag='A', long_name='C14 growth respiration transfer', & + ptr_patch=this%gresp_xfer_patch, default='inactive') + + this%cpool_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CPOOL', units='gC14/m^2', & + avgflag='A', long_name='C14 temporary photosynthate C pool', & + ptr_patch=this%cpool_patch, default='inactive') + + this%xsmrpool_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_XSMRPOOL', units='gC14/m^2', & + avgflag='A', long_name='C14 temporary photosynthate C pool', & + ptr_patch=this%xsmrpool_patch, default='inactive') + + this%ctrunc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_PFT_CTRUNC', units='gC14/m^2', & + avgflag='A', long_name='C14 patch-level sink for C truncation', & + ptr_patch=this%ctrunc_patch, default='inactive') + + this%dispvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_DISPVEGC', units='gC14/m^2', & + avgflag='A', long_name='C14 displayed veg carbon, excluding storage and cpool', & + ptr_patch=this%dispvegc_patch, default='inactive') + + this%storvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_STORVEGC', units='gC14/m^2', & + avgflag='A', long_name='C14 stored vegetation carbon, excluding cpool', & + ptr_patch=this%storvegc_patch, default='inactive') + + this%totvegc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TOTVEGC', units='gC14/m^2', & + avgflag='A', long_name='C14 total vegetation carbon, excluding cpool', & + ptr_patch=this%totvegc_patch) + + this%totc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_TOTPFTC', units='gC14/m^2', & + avgflag='A', long_name='C14 total patch-level carbon, including cpool', & + ptr_patch=this%totc_patch, default='inactive') + + this%seedc_grc(begg:endg) = spval + call hist_addfld1d (fname='C14_SEEDC', units='gC14/m^2', & + avgflag='A', long_name='C14 pool for seeding new PFTs via dynamic landcover', & + ptr_gcell=this%seedc_grc, default='inactive') + + this%totc_col(begc:endc) = spval + call hist_addfld1d (fname='C14_TOTCOLC', units='gC14/m^2', & + avgflag='A', long_name='C14 total column carbon, incl veg and cpool but excl product pools', & + ptr_col=this%totc_col, default='inactive') + + this%totecosysc_col(begc:endc) = spval + call hist_addfld1d (fname='C14_TOTECOSYSC', units='gC14/m^2', & + avgflag='A', long_name='C14 total ecosystem carbon, incl veg but excl cpool and product pools', & + ptr_col=this%totecosysc_col) + + if (use_crop) then + this%grainc_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_GRAINC', units='gC/m^2', & + avgflag='A', long_name='C14 grain C (does not equal yield)', & + ptr_patch=this%grainc_patch, default='inactive') + this%cropseedc_deficit_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_CROPSEEDC_DEFICIT', units='gC/m^2', & + avgflag='A', long_name='C14 C used for crop seed that needs to be repaid', & + ptr_patch=this%cropseedc_deficit_patch, default='inactive') + + this%xsmrpool_loss_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_XSMRPOOL_LOSS', units='gC14/m^2', & + avgflag='A', long_name='C14 temporary photosynthate C pool loss', & + ptr_patch=this%xsmrpool_loss_patch, default='inactive') + end if + + + endif + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds, ratio, carbon_type, c12_cnveg_carbonstate_inst) + ! + ! !DESCRIPTION: + ! Initializes time varying variables used only in coupled carbon-nitrogen mode (CN): + ! + ! !USES: + use landunit_varcon , only : istsoil, istcrop + use clm_time_manager , only : is_restart, get_nstep + use clm_varctl, only : MM_Nuptake_opt, spinup_state, use_matrixcn + ! + ! !ARGUMENTS: + class(cnveg_carbonstate_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: ratio ! Standard isotope ratio + character(len=*) , intent(in) :: carbon_type ! 'c12' or 'c13' or 'c14' + type(cnveg_carbonstate_type) , optional, intent(in) :: c12_cnveg_carbonstate_inst + ! + ! !LOCAL VARIABLES: + integer :: p,c,l,g,j,k,i + integer :: fc ! filter index + integer :: num_special_col ! number of good values in special_col filter + integer :: num_special_patch ! number of good values in special_patch filter + integer :: special_col(bounds%endc-bounds%begc+1) ! special landunit filter - columns + integer :: special_patch(bounds%endp-bounds%begp+1) ! special landunit filter - patches + !----------------------------------------------------------------------- + + if (carbon_type == 'c13' .or. carbon_type == 'c14') then + if (.not. present(c12_cnveg_carbonstate_inst)) then + call endrun(msg=' ERROR: for C13 or C14 must pass in c12_cnveg_carbonstate_inst as argument' //& + errMsg(sourcefile, __LINE__)) + end if + else + if ( spinup_state == 2 ) spinup_factor_deadwood = spinup_factor_AD + end if + + ! Set column filters + + num_special_col = 0 + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + num_special_col = num_special_col + 1 + special_col(num_special_col) = c + end if + end do + + ! Set patch filters + + num_special_patch = 0 + do p = bounds%begp,bounds%endp + l = patch%landunit(p) + if (lun%ifspecial(l)) then + num_special_patch = num_special_patch + 1 + special_patch(num_special_patch) = p + end if + end do + + !----------------------------------------------- + ! initialize patch-level carbon state variables + !----------------------------------------------- + + do p = bounds%begp,bounds%endp + + this%leafcmax_patch(p) = 0._r8 + + l = patch%landunit(p) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + + if (patch%itype(p) == noveg) then + this%leafc_patch(p) = 0._r8 + this%leafc_storage_patch(p) = 0._r8 + this%frootc_patch(p) = 0._r8 + this%frootc_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafc_patch(p) = 0._r8 + this%matrix_cap_leafc_storage_patch(p) = 0._r8 + this%matrix_cap_frootc_patch(p) = 0._r8 + this%matrix_cap_frootc_storage_patch(p) = 0._r8 + end if + else + if (pftcon%evergreen(patch%itype(p)) == 1._r8) then + this%leafc_patch(p) = cnvegcstate_const%initial_vegC * ratio + this%leafc_storage_patch(p) = 0._r8 + this%frootc_patch(p) = cnvegcstate_const%initial_vegC * ratio + this%frootc_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafc_patch(p) = cnvegcstate_const%initial_vegC * ratio + this%matrix_cap_leafc_storage_patch(p) = 0._r8 + this%matrix_cap_frootc_patch(p) = cnvegcstate_const%initial_vegC * ratio + this%matrix_cap_frootc_storage_patch(p) = 0._r8 + end if + else if (patch%itype(p) >= npcropmin) then ! prognostic crop types + this%leafc_patch(p) = 0._r8 + this%leafc_storage_patch(p) = 0._r8 + this%frootc_patch(p) = 0._r8 + this%frootc_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafc_patch(p) = 0._r8 + this%matrix_cap_leafc_storage_patch(p) = 0._r8 + this%matrix_cap_frootc_patch(p) = 0._r8 + this%matrix_cap_frootc_storage_patch(p) = 0._r8 + end if + else + this%leafc_patch(p) = 0._r8 + this%leafc_storage_patch(p) = cnvegcstate_const%initial_vegC * ratio + this%frootc_patch(p) = 0._r8 + this%frootc_storage_patch(p) = cnvegcstate_const%initial_vegC * ratio + if(use_matrixcn)then + this%matrix_cap_leafc_patch(p) = 0._r8 + this%matrix_cap_leafc_storage_patch(p) = cnvegcstate_const%initial_vegC * ratio + this%matrix_cap_frootc_patch(p) = 0._r8 + this%matrix_cap_frootc_storage_patch(p) = cnvegcstate_const%initial_vegC * ratio + end if + end if + end if + this%leafc_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafc_xfer_patch(p) = 0._r8 + end if + this%leafc_storage_xfer_acc_patch(p) = 0._r8 + this%storage_cdemand_patch(p) = 0._r8 + + if (MM_Nuptake_opt .eqv. .false.) then ! if not running in floating CN ratio option + this%frootc_patch(p) = 0._r8 + this%frootc_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootc_patch(p) = 0._r8 + this%matrix_cap_frootc_storage_patch(p) = 0._r8 + end if + end if + this%frootc_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootc_xfer_patch(p) = 0._r8 + end if + + this%livestemc_patch(p) = 0._r8 + this%livestemc_storage_patch(p) = 0._r8 + this%livestemc_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_livestemc_patch(p) = 0._r8 + this%matrix_cap_livestemc_storage_patch(p) = 0._r8 + this%matrix_cap_livestemc_xfer_patch(p) = 0._r8 + end if + + if (pftcon%woody(patch%itype(p)) == 1._r8) then + this%deadstemc_patch(p) = 0.1_r8 * ratio + if(use_matrixcn)then + this%matrix_cap_deadstemc_patch(p) = 0.1_r8 * ratio + end if + else + this%deadstemc_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadstemc_patch(p) = 0._r8 + end if + end if + this%deadstemc_storage_patch(p) = 0._r8 + this%deadstemc_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadstemc_storage_patch(p) = 0._r8 + this%matrix_cap_deadstemc_xfer_patch(p) = 0._r8 + end if + + this%livecrootc_patch(p) = 0._r8 + this%livecrootc_storage_patch(p) = 0._r8 + this%livecrootc_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_livecrootc_patch(p) = 0._r8 + this%matrix_cap_livecrootc_storage_patch(p) = 0._r8 + this%matrix_cap_livecrootc_xfer_patch(p) = 0._r8 + end if + + this%deadcrootc_patch(p) = 0._r8 + this%deadcrootc_storage_patch(p) = 0._r8 + this%deadcrootc_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadcrootc_patch(p) = 0._r8 + this%matrix_cap_deadcrootc_storage_patch(p) = 0._r8 + this%matrix_cap_deadcrootc_xfer_patch(p) = 0._r8 + end if + + this%gresp_storage_patch(p) = 0._r8 + this%gresp_xfer_patch(p) = 0._r8 + + this%cpool_patch(p) = 0._r8 + this%xsmrpool_patch(p) = 0._r8 + this%ctrunc_patch(p) = 0._r8 + this%dispvegc_patch(p) = 0._r8 + this%storvegc_patch(p) = 0._r8 + this%woodc_patch(p) = 0._r8 + this%totc_patch(p) = 0._r8 +!!!!initial pool size for matrix + if(use_matrixcn)then + this%leafc0_patch(p) = 1.e-30_r8 + this%leafc0_storage_patch(p) = 1.e-30_r8 + this%leafc0_xfer_patch(p) = 1.e-30_r8 + this%frootc0_patch(p) = 1.e-30_r8 + this%frootc0_storage_patch(p) = 1.e-30_r8 + this%frootc0_xfer_patch(p) = 1.e-30_r8 + + this%livestemc0_patch(p) = 1.e-30_r8 + this%livestemc0_storage_patch(p) = 1.e-30_r8 + this%livestemc0_xfer_patch(p) = 1.e-30_r8 + this%deadstemc0_patch(p) = 1.e-30_r8 + this%deadstemc0_storage_patch(p) = 1.e-30_r8 + this%deadstemc0_xfer_patch(p) = 1.e-30_r8 + + this%livecrootc0_patch(p) = 1.e-30_r8 + this%livecrootc0_storage_patch(p) = 1.e-30_r8 + this%livecrootc0_xfer_patch(p) = 1.e-30_r8 + + this%deadcrootc0_patch(p) = 1.e-30_r8 + this%deadcrootc0_storage_patch(p) = 1.e-30_r8 + this%deadcrootc0_xfer_patch(p) = 1.e-30_r8 + + this%grainc0_patch(p) = 1.e-30_r8 + this%grainc0_storage_patch(p) = 1.e-30_r8 + this%grainc0_xfer_patch(p) = 1.e-30_r8 + + this%leafc_SASUsave_patch(p) = 0._r8 + this%leafc_storage_SASUsave_patch(p) = 0._r8 + this%leafc_xfer_SASUsave_patch(p) = 0._r8 + this%frootc_SASUsave_patch(p) = 0._r8 + this%frootc_storage_SASUsave_patch(p) = 0._r8 + this%frootc_xfer_SASUsave_patch(p) = 0._r8 + this%livestemc_SASUsave_patch(p) = 0._r8 + this%livestemc_storage_SASUsave_patch(p) = 0._r8 + this%livestemc_xfer_SASUsave_patch(p) = 0._r8 + this%deadstemc_SASUsave_patch(p) = 0._r8 + this%deadstemc_storage_SASUsave_patch(p) = 0._r8 + this%deadstemc_xfer_SASUsave_patch(p) = 0._r8 + this%livecrootc_SASUsave_patch(p) = 0._r8 + this%livecrootc_storage_SASUsave_patch(p) = 0._r8 + this%livecrootc_xfer_SASUsave_patch(p) = 0._r8 + this%deadcrootc_SASUsave_patch(p) = 0._r8 + this%deadcrootc_storage_SASUsave_patch(p) = 0._r8 + this%deadcrootc_xfer_SASUsave_patch(p) = 0._r8 + this%grainc_SASUsave_patch(p) = 0._r8 + this%grainc_storage_SASUsave_patch(p) = 0._r8 + + this%matrix_calloc_leaf_acc_patch(p) = 0._r8 + this%matrix_calloc_leafst_acc_patch(p) = 0._r8 + this%matrix_calloc_froot_acc_patch(p) = 0._r8 + this%matrix_calloc_frootst_acc_patch(p) = 0._r8 + this%matrix_calloc_livestem_acc_patch(p) = 0._r8 + this%matrix_calloc_livestemst_acc_patch(p) = 0._r8 + this%matrix_calloc_deadstem_acc_patch(p) = 0._r8 + this%matrix_calloc_deadstemst_acc_patch(p) = 0._r8 + this%matrix_calloc_livecroot_acc_patch(p) = 0._r8 + this%matrix_calloc_livecrootst_acc_patch(p) = 0._r8 + this%matrix_calloc_deadcroot_acc_patch(p) = 0._r8 + this%matrix_calloc_deadcrootst_acc_patch(p) = 0._r8 + + this%matrix_ctransfer_leafst_to_leafxf_acc_patch(p) = 0._r8 + this%matrix_ctransfer_leafxf_to_leaf_acc_patch(p) = 0._r8 + this%matrix_ctransfer_frootst_to_frootxf_acc_patch(p) = 0._r8 + this%matrix_ctransfer_frootxf_to_froot_acc_patch(p) = 0._r8 + this%matrix_ctransfer_livestemst_to_livestemxf_acc_patch(p) = 0._r8 + this%matrix_ctransfer_livestemxf_to_livestem_acc_patch(p) = 0._r8 + this%matrix_ctransfer_deadstemst_to_deadstemxf_acc_patch(p) = 0._r8 + this%matrix_ctransfer_deadstemxf_to_deadstem_acc_patch(p) = 0._r8 + this%matrix_ctransfer_livecrootst_to_livecrootxf_acc_patch(p) = 0._r8 + this%matrix_ctransfer_livecrootxf_to_livecroot_acc_patch(p) = 0._r8 + this%matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_patch(p) = 0._r8 + this%matrix_ctransfer_deadcrootxf_to_deadcroot_acc_patch(p) = 0._r8 + this%matrix_ctransfer_livestem_to_deadstem_acc_patch(p) = 0._r8 + this%matrix_ctransfer_livecroot_to_deadcroot_acc_patch(p) = 0._r8 + + this%matrix_cturnover_leaf_acc_patch(p) = 0._r8 + this%matrix_cturnover_leafst_acc_patch(p) = 0._r8 + this%matrix_cturnover_leafxf_acc_patch(p) = 0._r8 + this%matrix_cturnover_froot_acc_patch(p) = 0._r8 + this%matrix_cturnover_frootst_acc_patch(p) = 0._r8 + this%matrix_cturnover_frootxf_acc_patch(p) = 0._r8 + this%matrix_cturnover_livestem_acc_patch(p) = 0._r8 + this%matrix_cturnover_livestemst_acc_patch(p) = 0._r8 + this%matrix_cturnover_livestemxf_acc_patch(p) = 0._r8 + this%matrix_cturnover_deadstem_acc_patch(p) = 0._r8 + this%matrix_cturnover_deadstemst_acc_patch(p) = 0._r8 + this%matrix_cturnover_deadstemxf_acc_patch(p) = 0._r8 + this%matrix_cturnover_livecroot_acc_patch(p) = 0._r8 + this%matrix_cturnover_livecrootst_acc_patch(p) = 0._r8 + this%matrix_cturnover_livecrootxf_acc_patch(p) = 0._r8 + this%matrix_cturnover_deadcroot_acc_patch(p) = 0._r8 + this%matrix_cturnover_deadcrootst_acc_patch(p) = 0._r8 + this%matrix_cturnover_deadcrootxf_acc_patch(p) = 0._r8 + end if + + + if ( use_crop )then + this%grainc_patch(p) = 0._r8 + this%grainc_storage_patch(p) = 0._r8 + this%grainc_xfer_patch(p) = 0._r8 + this%cropseedc_deficit_patch(p) = 0._r8 + this%xsmrpool_loss_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_grainc_patch(p) = 0._r8 + this%matrix_cap_grainc_storage_patch(p) = 0._r8 + this%matrix_cap_grainc_xfer_patch(p) = 0._r8 + this%matrix_calloc_grain_acc_patch(p) = 0._r8 + this%matrix_calloc_grainst_acc_patch(p) = 0._r8 + this%matrix_ctransfer_grainst_to_grainxf_acc_patch(p) = 0._r8 + this%matrix_ctransfer_grainxf_to_grain_acc_patch(p) = 0._r8 + this%matrix_cturnover_grain_acc_patch(p) = 0._r8 + this%matrix_cturnover_grainst_acc_patch(p) = 0._r8 + this%matrix_cturnover_grainxf_acc_patch(p) = 0._r8 + end if + end if + + endif + + end do + + ! ----------------------------------------------- + ! initialize column-level variables + ! ----------------------------------------------- + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then +! this%totgrainc_col(c) = 0._r8 + + ! total carbon pools + this%totecosysc_col(c) = 0._r8 + this%totc_p2c_col(c) = 0._r8 + this%totc_col(c) = 0._r8 + end if + end do + + + do g = bounds%begg, bounds%endg + this%seedc_grc(g) = 0._r8 + this%totc_grc(g) = 0._r8 + end do + + ! initialize fields for special filters + + call this%SetValues (& + num_patch=num_special_patch, filter_patch=special_patch, value_patch=0._r8, & + num_column=num_special_col, filter_column=special_col, value_column=0._r8) + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart ( this, bounds, ncid, flag, carbon_type, reseed_dead_plants, & + c12_cnveg_carbonstate_inst, filter_reseed_patch, & + num_reseed_patch, spinup_factor4deadwood ) + ! + ! !DESCRIPTION: + ! Read/write CN restart data for carbon state + ! + ! !USES: + use shr_infnan_mod , only : isnan => shr_infnan_isnan, nan => shr_infnan_nan, assignment(=) + use clm_varcon , only : c13ratio, c14ratio + use clm_varctl , only : spinup_state, use_cndv, MM_Nuptake_opt, use_matrixcn + use clm_varctl , only : spinup_state, use_cndv, MM_Nuptake_opt + use clm_time_manager , only : is_restart + use landunit_varcon , only : istsoil, istcrop + use spmdMod , only : mpicom + use shr_mpi_mod , only : shr_mpi_sum + use restUtilMod + use ncdio_pio + ! + ! !ARGUMENTS: + class (cnveg_carbonstate_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' + character(len=*) , intent(in) :: carbon_type ! 'c12' or 'c13' or 'c14' + logical , intent(in) :: reseed_dead_plants + type (cnveg_carbonstate_type) , intent(in), optional :: c12_cnveg_carbonstate_inst + integer , intent(out), optional :: filter_reseed_patch(:) + integer , intent(out), optional :: num_reseed_patch + real(r8) , intent(out), optional :: spinup_factor4deadwood + ! + ! !LOCAL VARIABLES: + integer :: i,j,k,l,c,p + real(r8) :: ratio + character(len=128) :: varname ! temporary + logical :: readvar + integer :: idata + logical :: exit_spinup = .false. + logical :: enter_spinup = .false. + ! flags for comparing the model and restart decomposition cascades + integer :: decomp_cascade_state, restart_file_decomp_cascade_state + ! spinup state as read from restart file, for determining whether to enter or exit spinup mode. + integer :: restart_file_spinup_state + integer :: total_num_reseed_patch ! Total number of patches to reseed across all processors + real(r8), parameter:: totvegcthresh = 1.0_r8 ! Total vegetation carbon threshold to reseed dead vegetation + + !------------------------------------------------------------------------ + + if (carbon_type == 'c13' .or. carbon_type == 'c14') then + if (.not. present(c12_cnveg_carbonstate_inst)) then + call endrun(msg=' ERROR: for C14 must pass in c12_cnveg_carbonstate_inst as argument' //& + errMsg(sourcefile, __LINE__)) + end if + end if + if (carbon_type == 'c12') then + ratio = 1._r8 + else if (carbon_type == 'c13') then + ratio = c13ratio + else if (carbon_type == 'c14') then + ratio = c14ratio + end if + + if ( ( present(num_reseed_patch) .and. .not. present(filter_reseed_patch)) & + .or. (.not. present(num_reseed_patch) .and. present(filter_reseed_patch) ) )then + call endrun(msg=' ERROR: filter_reseed_patch and num_reseed_patch both need to be entered ' //& + errMsg(sourcefile, __LINE__)) + end if + if ( present(num_reseed_patch) )then + num_reseed_patch = 0 + filter_reseed_patch(:) = -1 + end if + + !-------------------------------- + ! patch carbon state variables (c12) + !-------------------------------- + + if (carbon_type == 'c12') then + call restartvar(ncid=ncid, flag=flag, varname='leafc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_xfer_patch) + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='leafc_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_leaf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_leafst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_leafst_to_leafxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_leafst_to_leafxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_leafxf_to_leaf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_leafxf_to_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_leaf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_leafst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctrunover_leafxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leafxf_acc_patch) + + end if + + call restartvar(ncid=ncid, flag=flag, varname='leafc_storage_xfer_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_storage_xfer_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='storage_cdemand', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%storage_cdemand_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_xfer_patch) + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='frootc_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_froot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_frootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_frootst_to_frootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_frootst_to_frootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_frootxf_to_froot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_frootxf_to_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_froot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_frootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_frootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_frootxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='livestemc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_xfer_patch) + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='livestemc_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livestem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livestemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestemst_to_livestemxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestemst_to_livestemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestemxf_to_livestem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestemxf_to_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestem_to_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestem_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestemxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestemxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_xfer_patch) + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadstemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadstemst_to_deadstemxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadstemst_to_deadstemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadstemxf_to_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadstemxf_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstemxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstemxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_xfer_patch) + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livecroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livecrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecrootst_to_livecrootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecrootst_to_livecrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecrootxf_to_livecroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecrootxf_to_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecroot_to_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecroot_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecrootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecrootxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_xfer_patch) + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_xfer_patch) +! + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadcrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadcrootst_to_deadcrootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadcrootxf_to_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadcrootxf_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcrootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcrootxf_acc_patch) + end if + + if(use_matrixcn .and. use_crop)then + call restartvar(ncid=ncid, flag=flag, varname='grainc0', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc0_storage', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C storage', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C transfer', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_grain_acc', xtype=ncd_double, & + dim1name='pft', long_name='C accumulated allocation to grain', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_grainst_acc', xtype=ncd_double, & + dim1name='pft', long_name='C accumulated allocation to grain storage', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_grainst_to_grainxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_grainst_to_grainxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_grainxf_to_grain_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_grainxf_to_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grain_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grainst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grainxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grainxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='gresp_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%gresp_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='gresp_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%gresp_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='cpool', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%cpool_patch) + + call restartvar(ncid=ncid, flag=flag, varname='xsmrpool', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%xsmrpool_patch) + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='xsmrpool_loss', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%xsmrpool_loss_patch) + if (flag == 'read' .and. (.not. readvar) ) then + this%xsmrpool_loss_patch(bounds%begp:bounds%endp) = 0._r8 + end if + end if + + call restartvar(ncid=ncid, flag=flag, varname='pft_ctrunc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ctrunc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafcmax', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafcmax_patch) + + if (flag == 'read') then + call restartvar(ncid=ncid, flag=flag, varname='spinup_state', xtype=ncd_int, & + long_name='Spinup state of the model that wrote this restart file: ' & + // ' 0 = normal model mode, 1 = AD spinup, 2 = AAD spinup', units='', & + interpinic_flag='copy', readvar=readvar, data=idata) + + if (readvar) then + restart_file_spinup_state = idata + else + restart_file_spinup_state = spinup_state + if ( masterproc ) then + write(iulog,*) ' CNRest: WARNING! Restart file does not contain info ' & + // ' on spinup state used to generate the restart file. ' + write(iulog,*) ' Assuming the same as current setting: ', spinup_state + end if + end if + end if + + if (flag == 'read' .and. spinup_state /= restart_file_spinup_state .and. .not. use_cndv) then + if ( masterproc ) write(iulog, *) 'exit_spinup ',exit_spinup,' restart_file_spinup_state ',restart_file_spinup_state + if (spinup_state <= 1 .and. restart_file_spinup_state == 2 ) then + if ( masterproc ) write(iulog,*) ' CNRest: taking Dead wood C pools out of AD spinup mode' + exit_spinup = .true. + if ( masterproc ) write(iulog, *) 'Multiplying stemc and crootc by ', spinup_factor_AD, ' for exit spinup' + do i = bounds%begp,bounds%endp + this%deadstemc_patch(i) = this%deadstemc_patch(i) * spinup_factor_AD + this%deadcrootc_patch(i) = this%deadcrootc_patch(i) * spinup_factor_AD + end do + else if (spinup_state == 2 .and. restart_file_spinup_state <= 1 )then + if (spinup_state == 2 .and. restart_file_spinup_state <= 1 )then + if ( masterproc ) write(iulog,*) ' CNRest: taking Dead wood C pools into AD spinup mode' + enter_spinup = .true. + if ( masterproc ) write(iulog, *) 'Dividing stemc and crootc by ', spinup_factor_AD, 'for enter spinup ' + do i = bounds%begp,bounds%endp + this%deadstemc_patch(i) = this%deadstemc_patch(i) / spinup_factor_AD + this%deadcrootc_patch(i) = this%deadcrootc_patch(i) / spinup_factor_AD + end do + end if + end if + end if + !-------------------------------- + ! C12 carbon state variables + !-------------------------------- + + if (carbon_type == 'c12') then + call restartvar(ncid=ncid, flag=flag, varname='totvegc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%totvegc_patch) + ! totvegc_col needed for resetting soil carbon stocks during AD spinup exit + call restartvar(ncid=ncid, flag=flag, varname='totvegc_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%totvegc_col) + end if + + !-------------------------------- + ! C13 carbon state variables + !-------------------------------- + + if ( carbon_type == 'c13') then + call restartvar(ncid=ncid, flag=flag, varname='totvegc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%totvegc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing cnveg_carbonstate_inst%totvegc with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%totvegc_patch(i) = c12_cnveg_carbonstate_inst%totvegc_patch(i) * c3_r2 + else + this%totvegc_patch(i) = c12_cnveg_carbonstate_inst%totvegc_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='totvegc_col_13', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%totvegc_col) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing cnveg_carbonstate_inst%totvegc with atmospheric c13 value' + do i = bounds%begc,bounds%endc + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%totvegc_col(i) = c12_cnveg_carbonstate_inst%totvegc_col(i) * c3_r2 + else + this%totvegc_col(i) = c12_cnveg_carbonstate_inst%totvegc_col(i) * c4_r2 + endif + end do + end if + + end if + + !-------------------------------- + ! C14 patch carbon state variables + !-------------------------------- + + if ( carbon_type == 'c14') then + call restartvar(ncid=ncid, flag=flag, varname='totvegc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%totvegc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%totvegc_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%totvegc_patch(i) /= spval .and. & + .not. isnan(this%totvegc_patch(i)) ) then + this%totvegc_patch(i) = c12_cnveg_carbonstate_inst%totvegc_patch(i) * c14ratio + endif + end do + endif + + call restartvar(ncid=ncid, flag=flag, varname='totvegc_col_14', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%totvegc_col) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing cnveg_carbonstate_inst%totvegc with atmospheric c14 value' + do i = bounds%begc,bounds%endc + if (this%totvegc_col(i) /= spval .and. & + .not. isnan(this%totvegc_col(i)) ) then + this%totvegc_col(i) = c12_cnveg_carbonstate_inst%totvegc_col(i) * c14ratio + endif + end do + end if + end if + + + if ( flag == 'read' .and. (enter_spinup .or. (reseed_dead_plants .and. .not. is_restart())) .and. .not. use_cndv) then + if ( masterproc ) write(iulog, *) 'Reseeding dead plants for CNVegCarbonState' + ! If a pft is dead or near-dead (indicated by totvegc <= totvegcthresh) then we reseed that + ! pft according to the cold start protocol in the InitCold subroutine. + ! Thus, the variable totvegc is required to be read before here + ! so that if it is zero for a given pft, the pft can be reseeded. + do i = bounds%begp,bounds%endp + if (this%totvegc_patch(i) .le. totvegcthresh) then + !----------------------------------------------- + ! initialize patch-level carbon state variables + !----------------------------------------------- + + this%leafcmax_patch(i) = 0._r8 + + l = patch%landunit(i) + if (lun%itype(l) == istsoil .or. patch%itype(i) == nc3crop .or. patch%itype(i) == nc3irrig)then + if ( present(num_reseed_patch) ) then + num_reseed_patch = num_reseed_patch + 1 + filter_reseed_patch(num_reseed_patch) = i + end if + + if (patch%itype(i) == noveg) then + this%leafc_patch(i) = 0._r8 + this%leafc_storage_patch(i) = 0._r8 + this%frootc_patch(i) = 0._r8 + this%frootc_storage_patch(i) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafc_patch(i) = 0._r8 + this%matrix_cap_leafc_storage_patch(i) = 0._r8 + this%matrix_cap_frootc_patch(i) = 0._r8 + this%matrix_cap_frootc_storage_patch(i) = 0._r8 + end if + else + if (pftcon%evergreen(patch%itype(i)) == 1._r8) then + this%leafc_patch(i) = cnvegcstate_const%initial_vegC * ratio + this%leafc_storage_patch(i) = 0._r8 + this%frootc_patch(i) = cnvegcstate_const%initial_vegC * ratio + this%frootc_storage_patch(i) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafc_patch(i) = cnvegcstate_const%initial_vegC * ratio + this%matrix_cap_leafc_storage_patch(i) = 0._r8 + this%matrix_cap_frootc_patch(i) = cnvegcstate_const%initial_vegC * ratio + this%matrix_cap_frootc_storage_patch(i) = 0._r8 + end if + else + this%leafc_patch(i) = 0._r8 + this%leafc_storage_patch(i) = cnvegcstate_const%initial_vegC * ratio + this%frootc_patch(i) = 0._r8 + this%frootc_storage_patch(i) = cnvegcstate_const%initial_vegC * ratio + if(use_matrixcn)then + this%matrix_cap_leafc_patch(i) = 0._r8 + this%matrix_cap_leafc_storage_patch(i) = cnvegcstate_const%initial_vegC * ratio + this%matrix_cap_frootc_patch(i) = 0._r8 + this%matrix_cap_frootc_storage_patch(i) = cnvegcstate_const%initial_vegC * ratio + end if + end if + end if + this%leafc_xfer_patch(i) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafc_xfer_patch(i) = 0._r8 + end if + this%leafc_storage_xfer_acc_patch(i) = 0._r8 + this%storage_cdemand_patch(i) = 0._r8 + + if (MM_Nuptake_opt .eqv. .false.) then ! if not running in floating CN ratio option + this%frootc_patch(i) = 0._r8 + this%frootc_storage_patch(i) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootc_patch(i) = 0._r8 + this%matrix_cap_frootc_storage_patch(i) = 0._r8 + end if + end if + this%frootc_xfer_patch(i) = 0._r8 + + this%livestemc_patch(i) = 0._r8 + this%livestemc_storage_patch(i) = 0._r8 + this%livestemc_xfer_patch(i) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootc_xfer_patch(i) = 0._r8 + this%matrix_cap_livestemc_patch(i) = 0._r8 + this%matrix_cap_livestemc_storage_patch(i) = 0._r8 + this%matrix_cap_livestemc_xfer_patch(i) = 0._r8 + end if + + if (pftcon%woody(patch%itype(i)) == 1._r8) then + this%deadstemc_patch(i) = 0.1_r8 * ratio + if(use_matrixcn)then + this%matrix_cap_deadstemc_patch(i) = 0.1_r8 * ratio + end if + else + this%deadstemc_patch(i) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadstemc_patch(i) = 0._r8 + end if + end if + this%deadstemc_storage_patch(i) = 0._r8 + this%deadstemc_xfer_patch(i) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadstemc_storage_patch(i) = 0._r8 + this%matrix_cap_deadstemc_xfer_patch(i) = 0._r8 + end if + + this%livecrootc_patch(i) = 0._r8 + this%livecrootc_storage_patch(i) = 0._r8 + this%livecrootc_xfer_patch(i) = 0._r8 + + this%deadcrootc_patch(i) = 0._r8 + this%deadcrootc_storage_patch(i) = 0._r8 + this%deadcrootc_xfer_patch(i) = 0._r8 + + if(use_matrixcn)then + this%matrix_cap_livecrootc_patch(i) = 0._r8 + this%matrix_cap_livecrootc_storage_patch(i) = 0._r8 + this%matrix_cap_livecrootc_xfer_patch(i) = 0._r8 + + this%matrix_cap_deadcrootc_patch(i) = 0._r8 + this%matrix_cap_deadcrootc_storage_patch(i) = 0._r8 + this%matrix_cap_deadcrootc_xfer_patch(i) = 0._r8 + end if + + this%gresp_storage_patch(i) = 0._r8 + this%gresp_xfer_patch(i) = 0._r8 + + this%cpool_patch(i) = 0._r8 + this%xsmrpool_patch(i) = 0._r8 + this%ctrunc_patch(i) = 0._r8 + this%dispvegc_patch(i) = 0._r8 + this%storvegc_patch(i) = 0._r8 + this%woodc_patch(i) = 0._r8 + this%totc_patch(i) = 0._r8 + + if ( use_crop )then + this%grainc_patch(i) = 0._r8 + this%grainc_storage_patch(i) = 0._r8 + this%grainc_xfer_patch(i) = 0._r8 + if(use_matrixcn)then + this%grainc0_patch(i) = 0._r8 + this%grainc0_storage_patch(i) = 0._r8 + this%grainc0_xfer_patch(i) = 0._r8 + this%matrix_cap_grainc_patch(i) = 0._r8 + this%matrix_cap_grainc_storage_patch(i) = 0._r8 + this%matrix_cap_grainc_xfer_patch(i) = 0._r8 + end if + this%cropseedc_deficit_patch(i) = 0._r8 + this%xsmrpool_loss_patch(i) = 0._r8 + end if + + ! calculate totvegc explicitly so that it is available for the isotope + ! code on the first time step. + + this%totvegc_patch(i) = & + this%leafc_patch(i) + & + this%leafc_storage_patch(i) + & + this%leafc_xfer_patch(i) + & + this%frootc_patch(i) + & + this%frootc_storage_patch(i) + & + this%frootc_xfer_patch(i) + & + this%livestemc_patch(i) + & + this%livestemc_storage_patch(i) + & + this%livestemc_xfer_patch(i) + & + this%deadstemc_patch(i) + & + this%deadstemc_storage_patch(i) + & + this%deadstemc_xfer_patch(i) + & + this%livecrootc_patch(i) + & + this%livecrootc_storage_patch(i) + & + this%livecrootc_xfer_patch(i) + & + this%deadcrootc_patch(i) + & + this%deadcrootc_storage_patch(i) + & + this%deadcrootc_xfer_patch(i) + & + this%gresp_storage_patch(i) + & + this%gresp_xfer_patch(i) + & + this%cpool_patch(i) + + if ( use_crop )then + this%totvegc_patch(i) = & + this%totvegc_patch(i) + & + this%grainc_patch(i) + & + this%grainc_storage_patch(i) + & + this%grainc_xfer_patch(i) + end if + + endif + end if + end do + if ( present(num_reseed_patch) ) then + call shr_mpi_sum( num_reseed_patch, total_num_reseed_patch, mpicom ) + if ( masterproc ) write(iulog,*) 'Total num_reseed, over all tasks = ', total_num_reseed_patch + end if + end if + + end if + + !-------------------------------- + ! C13 patch carbon state variables + !-------------------------------- + + if ( carbon_type == 'c13') then + call restartvar(ncid=ncid, flag=flag, varname='leafc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%leafc with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%leafc_patch(i) = c12_cnveg_carbonstate_inst%leafc_patch(i) * c3_r2 + else + this%leafc_patch(i) = c12_cnveg_carbonstate_inst%leafc_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='leafc_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%leafc_storage with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%leafc_storage_patch(i) = c12_cnveg_carbonstate_inst%leafc_storage_patch(i) * c3_r2 + else + this%leafc_storage_patch(i) = c12_cnveg_carbonstate_inst%leafc_storage_patch(i) * c4_r2 + this%leafc_storage_patch(i) = c12_cnveg_carbonstate_inst%leafc_storage_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='leafc_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%leafc_xfer with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%leafc_xfer_patch(i) = c12_cnveg_carbonstate_inst%leafc_xfer_patch(i) * c3_r2 + else + this%leafc_xfer_patch(i) = c12_cnveg_carbonstate_inst%leafc_xfer_patch(i) * c4_r2 + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='leafc_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc_storage_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc_xfer_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_leaf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_leafst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_leafst_to_leafxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_leafst_to_leafxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_leafxf_to_leaf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_leafxf_to_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_leaf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_leafst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctrunover_leafxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leafxf_acc_patch) + + end if + + call restartvar(ncid=ncid, flag=flag, varname='frootc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%frootc with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%frootc_patch(i) = c12_cnveg_carbonstate_inst%frootc_patch(i) * c3_r2 + else + this%frootc_patch(i) = c12_cnveg_carbonstate_inst%frootc_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='frootc_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%frootc_storage with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%frootc_storage_patch(i) = c12_cnveg_carbonstate_inst%frootc_storage_patch(i) * c3_r2 + else + this%frootc_storage_patch(i) = c12_cnveg_carbonstate_inst%frootc_storage_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='frootc_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%frootc_xfer with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%frootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%frootc_xfer_patch(i) * c3_r2 + else + this%frootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%frootc_xfer_patch(i) * c4_r2 + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='frootc_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc_storage_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc_xfer_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_froot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_frootst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_frootst_to_frootxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_frootst_to_frootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_frootxf_to_froot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_frootxf_to_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_froot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_frootst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_frootxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_frootxf_acc_patch) + end if + + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livestemc with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%livestemc_patch(i) = c12_cnveg_carbonstate_inst%livestemc_patch(i) * c3_r2 + else + this%livestemc_patch(i) = c12_cnveg_carbonstate_inst%livestemc_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livestemc_storage with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%livestemc_storage_patch(i) = c12_cnveg_carbonstate_inst%livestemc_storage_patch(i) * c3_r2 + else + this%livestemc_storage_patch(i) = c12_cnveg_carbonstate_inst%livestemc_storage_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livestemc_xfer with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%livestemc_xfer_patch(i) = c12_cnveg_carbonstate_inst%livestemc_xfer_patch(i) * c3_r2 + else + this%livestemc_xfer_patch(i) = c12_cnveg_carbonstate_inst%livestemc_xfer_patch(i) * c4_r2 + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='livestemc_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_storage_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_xfer_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livestem_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livestemst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestemst_to_livestemxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestemst_to_livestemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestemxf_to_livestem_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestemxf_to_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestem_to_deadstem_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestem_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestem_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestemst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestemxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestemxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadstemc with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%deadstemc_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_patch(i) * c3_r2 + else + this%deadstemc_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadstemc_storage with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%deadstemc_storage_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_storage_patch(i) * c3_r2 + else + this%deadstemc_storage_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_storage_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadstemc_xfer with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%deadstemc_xfer_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_xfer_patch(i) * c3_r2 + else + this%deadstemc_xfer_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_xfer_patch(i) * c4_r2 + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_storage_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_xfer_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadstem_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadstemst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadstemst_to_deadstemxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadstemst_to_deadstemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadstemxf_to_deadstem_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadstemxf_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstem_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstemst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstemxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstemxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livecrootc with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%livecrootc_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_patch(i) * c3_r2 + else + this%livecrootc_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livecrootc_storage with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%livecrootc_storage_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_storage_patch(i) * c3_r2 + else + this%livecrootc_storage_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_storage_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livecrootc_xfer with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%livecrootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_xfer_patch(i) * c3_r2 + else + this%livecrootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_xfer_patch(i) * c4_r2 + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_storage_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_xfer_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livecroot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livecrootst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecrootst_to_livecrootxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecrootst_to_livecrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecrootxf_to_livecroot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecrootxf_to_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecroot_to_deadcroot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecroot_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecroot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecrootst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecrootxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecrootxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadcrootc with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%deadcrootc_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_patch(i) * c3_r2 + else + this%deadcrootc_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadcrootc_storage with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%deadcrootc_storage_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_storage_patch(i) * c3_r2 + else + this%deadcrootc_storage_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_storage_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadcrootc_xfer with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%deadcrootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_xfer_patch(i) * c3_r2 + else + this%deadcrootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_xfer_patch(i) * c4_r2 + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_storage_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_xfer_cap_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_xfer_patch) +! + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadcroot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadcrootst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadcrootxf_to_deadcroot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadcrootxf_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcroot_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcrootst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcrootxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcrootxf_acc_patch) + end if + + if(use_matrixcn .and. use_crop)then + call restartvar(ncid=ncid, flag=flag, varname='grainc0_13', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C13', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc0_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C13 storage', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc0_xfer_13', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C13 transfer', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_grain_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='C13 accumulated allocation to grain', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_grainst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='C13 accumulated allocation to grain storage', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_grainst_to_grainxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_grainst_to_grainxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_grainxf_to_grain_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_grainxf_to_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grain_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grainst_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grainxf_acc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grainxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='gresp_storage_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%gresp_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%gresp_storage with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%gresp_storage_patch(i) = c12_cnveg_carbonstate_inst%gresp_storage_patch(i) * c3_r2 + else + this%gresp_storage_patch(i) = c12_cnveg_carbonstate_inst%gresp_storage_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='gresp_xfer_13', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%gresp_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%gresp_xfer with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%gresp_xfer_patch(i) = c12_cnveg_carbonstate_inst%gresp_xfer_patch(i) * c3_r2 + else + this%gresp_xfer_patch(i) = c12_cnveg_carbonstate_inst%gresp_xfer_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='cpool_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%cpool_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%cpool with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%cpool_patch(i) = c12_cnveg_carbonstate_inst%cpool_patch(i) * c3_r2 + else + this%cpool_patch(i) = c12_cnveg_carbonstate_inst%cpool_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='xsmrpool_13', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%xsmrpool_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%xsmrpool with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%xsmrpool_patch(i) = c12_cnveg_carbonstate_inst%xsmrpool_patch(i) * c3_r2 + else + this%xsmrpool_patch(i) = c12_cnveg_carbonstate_inst%xsmrpool_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='xsmrpool_loss_13', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%xsmrpool_loss_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%xsmrpool_loss with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%xsmrpool_loss_patch(i) = c12_cnveg_carbonstate_inst%xsmrpool_loss_patch(i) * c3_r2 + else + this%xsmrpool_loss_patch(i) = c12_cnveg_carbonstate_inst%xsmrpool_loss_patch(i) * c4_r2 + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='pft_ctrunc_13', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ctrunc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%ctrunc with atmospheric c13 value' + do i = bounds%begp,bounds%endp + if (pftcon%c3psn(patch%itype(i)) == 1._r8) then + this%ctrunc_patch(i) = c12_cnveg_carbonstate_inst%ctrunc_patch(i) * c3_r2 + else + this%ctrunc_patch(i) = c12_cnveg_carbonstate_inst%ctrunc_patch(i) * c4_r2 + endif + end do + end if + + end if + + !-------------------------------- + ! C14 patch carbon state variables + !-------------------------------- + + if ( carbon_type == 'c14') then + call restartvar(ncid=ncid, flag=flag, varname='leafc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%leafc_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%leafc_patch(i) /= spval .and. & + .not. isnan(this%leafc_patch(i)) ) then + this%leafc_patch(i) = c12_cnveg_carbonstate_inst%leafc_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='leafc_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%leafc_storage_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%leafc_storage_patch(i) /= spval .and. & + .not. isnan(this%leafc_storage_patch(i)) ) then + this%leafc_storage_patch(i) = c12_cnveg_carbonstate_inst%leafc_storage_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='leafc_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%leafc_xfer_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%leafc_xfer_patch(i) /= spval .and. .not. isnan(this%leafc_xfer_patch(i)) ) then + this%leafc_xfer_patch(i) = c12_cnveg_carbonstate_inst%leafc_xfer_patch(i) * c14ratio + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='leafc_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc_storage_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc_xfer_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafc0_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_leaf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_leafst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_leafst_to_leafxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_leafst_to_leafxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_leafxf_to_leaf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_leafxf_to_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_leaf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_leafst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctrunover_leafxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_leafxf_acc_patch) + + end if + + call restartvar(ncid=ncid, flag=flag, varname='frootc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%frootc_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%frootc_patch(i) /= spval .and. & + .not. isnan(this%frootc_patch(i)) ) then + this%frootc_patch(i) = c12_cnveg_carbonstate_inst%frootc_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='frootc_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%frootc_storage_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%frootc_storage_patch(i) /= spval .and. & + .not. isnan(this%frootc_storage_patch(i)) ) then + this%frootc_storage_patch(i) = c12_cnveg_carbonstate_inst%frootc_storage_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='frootc_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%frootc_xfer_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%frootc_xfer_patch(i) /= spval .and. & + .not. isnan(this%frootc_xfer_patch(i)) ) then + this%frootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%frootc_xfer_patch(i) * c14ratio + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='frootc_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc_storage_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc_xfer_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootc0_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_froot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_frootst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_frootst_to_frootxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_frootst_to_frootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_frootxf_to_froot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_frootxf_to_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_froot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_frootst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_frootxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_frootxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livestemc_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%livestemc_patch(i) /= spval .and. .not. isnan(this%livestemc_patch(i)) ) then + this%livestemc_patch(i) = c12_cnveg_carbonstate_inst%livestemc_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livestemc_storage_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%livestemc_storage_patch(i) /= spval .and. .not. isnan(this%livestemc_storage_patch(i)) ) then + this%livestemc_storage_patch(i) = c12_cnveg_carbonstate_inst%livestemc_storage_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livestemc_xfer_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%livestemc_xfer_patch(i) /= spval .and. .not. isnan(this%livestemc_xfer_patch(i)) ) then + this%livestemc_xfer_patch(i) = c12_cnveg_carbonstate_inst%livestemc_xfer_patch(i) * c14ratio + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='livestemc_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_storage_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc_xfer_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemc0_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livestem_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livestemst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestemst_to_livestemxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestemst_to_livestemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestemxf_to_livestem_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestemxf_to_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livestem_to_deadstem_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livestem_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestem_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestemst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livestemxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livestemxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadstemc_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%deadstemc_patch(i) /= spval .and. .not. isnan(this%deadstemc_patch(i)) ) then + this%deadstemc_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadstemc_storage_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%deadstemc_storage_patch(i) /= spval .and. .not. isnan(this%deadstemc_storage_patch(i)) ) then + this%deadstemc_storage_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_storage_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadstemc_xfer_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%deadstemc_xfer_patch(i) /= spval .and. .not. isnan(this%deadstemc_xfer_patch(i)) ) then + this%deadstemc_xfer_patch(i) = c12_cnveg_carbonstate_inst%deadstemc_xfer_patch(i) * c14ratio + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_storage_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc_xfer_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemc0_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadstem_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadstemst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadstemst_to_deadstemxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadstemst_to_deadstemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadstemxf_to_deadstem_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadstemxf_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstem_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstemst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadstemxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadstemxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livecrootc_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%livecrootc_patch(i) /= spval .and. .not. isnan(this%livecrootc_patch(i)) ) then + this%livecrootc_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livecrootc_storage_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%livecrootc_storage_patch(i) /= spval .and. .not. isnan(this%livecrootc_storage_patch(i)) ) then + this%livecrootc_storage_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_storage_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%livecrootc_xfer_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%livecrootc_xfer_patch(i) /= spval .and. .not. isnan(this%livecrootc_xfer_patch(i)) ) then + this%livecrootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%livecrootc_xfer_patch(i) * c14ratio + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_storage_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc_xfer_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootc0_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livecroot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_livecrootst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecrootst_to_livecrootxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecrootst_to_livecrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecrootxf_to_livecroot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecrootxf_to_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_livecroot_to_deadcroot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_livecroot_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecroot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecrootst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_livecrootxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_livecrootxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadcrootc_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%deadcrootc_patch(i) /= spval .and. .not. isnan(this%deadcrootc_patch(i)) ) then + this%deadcrootc_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadcrootc_storage_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%deadcrootc_storage_patch(i) /= spval .and. .not. isnan(this%deadcrootc_storage_patch(i)) ) then + this%deadcrootc_storage_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_storage_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%deadcrootc_xfer_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%deadcrootc_xfer_patch(i) /= spval .and. .not. isnan(this%deadcrootc_xfer_patch(i)) ) then + this%deadcrootc_xfer_patch(i) = c12_cnveg_carbonstate_inst%deadcrootc_xfer_patch(i) * c14ratio + endif + end do + end if + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_storage_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc_xfer_cap_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootc0_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootc0_xfer_patch) +! + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadcroot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_deadcrootst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_deadcrootxf_to_deadcroot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_deadcrootxf_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcroot_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcrootst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_deadcrootxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_deadcrootxf_acc_patch) + end if + + if(use_matrixcn .and. use_crop)then + call restartvar(ncid=ncid, flag=flag, varname='grainc0_14', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C14', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc0_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C14 storage', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc0_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='initial grain C14 transfer', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_grain_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='C14 accumulated allocation to grain', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_calloc_grainst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='C14 accumulated allocation to grain storage', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_calloc_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_grainst_to_grainxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_grainst_to_grainxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ctransfer_grainxf_to_grain_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ctransfer_grainxf_to_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grain_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grainst_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_cturnover_grainxf_acc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cturnover_grainxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='gresp_storage_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%gresp_storage_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%gresp_storage_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%gresp_storage_patch(i) /= spval .and. .not. isnan(this%gresp_storage_patch(i)) ) then + this%gresp_storage_patch(i) = c12_cnveg_carbonstate_inst%gresp_storage_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='gresp_xfer_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%gresp_xfer_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%gresp_xfer_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%gresp_xfer_patch(i) /= spval .and. .not. isnan(this%gresp_xfer_patch(i)) ) then + this%gresp_xfer_patch(i) = c12_cnveg_carbonstate_inst%gresp_xfer_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='cpool_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%cpool_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%cpool_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%cpool_patch(i) /= spval .and. .not. isnan(this%cpool_patch(i)) ) then + this%cpool_patch(i) = c12_cnveg_carbonstate_inst%cpool_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='xsmrpool_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%xsmrpool_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%xsmrpool_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%xsmrpool_patch(i) /= spval .and. .not. isnan(this%xsmrpool_patch(i)) ) then + this%xsmrpool_patch(i) = c12_cnveg_carbonstate_inst%xsmrpool_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='xsmrpool_loss_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%xsmrpool_loss_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%xsmrpool_loss_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%xsmrpool_loss_patch(i) /= spval .and. .not. isnan(this%xsmrpool_loss_patch(i)) ) then + this%xsmrpool_loss_patch(i) = c12_cnveg_carbonstate_inst%xsmrpool_loss_patch(i) * c14ratio + endif + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='pft_ctrunc_14', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ctrunc_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%ctrunc_patch with atmospheric c14 value' + do i = bounds%begp,bounds%endp + if (this%ctrunc_patch(i) /= spval .and. .not. isnan(this%ctrunc_patch(i)) ) then + this%ctrunc_patch(i) = c12_cnveg_carbonstate_inst%ctrunc_patch(i) * c14ratio + endif + end do + end if + + end if + + !-------------------------------- + ! patch prognostic crop variables + !-------------------------------- + + if (use_crop) then + if (carbon_type == 'c12') then + call restartvar(ncid=ncid, flag=flag, varname='grainc', xtype=ncd_double, & + dim1name='pft', long_name='grain C', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc_storage', xtype=ncd_double, & + dim1name='pft', long_name='grain C storage', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainc_xfer', xtype=ncd_double, & + dim1name='pft', long_name='grain C transfer', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='cropseedc_deficit', xtype=ncd_double, & + dim1name='pft', long_name='pool for seeding new crop growth', units='gC/m2', & + interpinic_flag='interp', readvar=readvar, data=this%cropseedc_deficit_patch) + end if + + if (carbon_type == 'c13') then + call restartvar(ncid=ncid, flag=flag, varname='grainc_13', xtype=ncd_double, & + dim1name='pft', long_name='c13 grain C', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_patch) + if (flag=='read' .and. .not. readvar) then + call set_missing_from_template( & + my_var = this%grainc_patch, & + template_var = c12_cnveg_carbonstate_inst%grainc_patch, & + multiplier = c3_r2) + end if + + call restartvar(ncid=ncid, flag=flag, varname='grainc_13_storage', xtype=ncd_double, & + dim1name='pft', long_name='c13 grain C storage', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_storage_patch) + if (flag=='read' .and. .not. readvar) then + call set_missing_from_template( & + my_var = this%grainc_storage_patch, & + template_var = c12_cnveg_carbonstate_inst%grainc_storage_patch, & + multiplier = c3_r2) + end if + + call restartvar(ncid=ncid, flag=flag, varname='grainc_13_xfer', xtype=ncd_double, & + dim1name='pft', long_name='c13 grain C transfer', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + call set_missing_from_template( & + my_var = this%grainc_xfer_patch, & + template_var = c12_cnveg_carbonstate_inst%grainc_xfer_patch, & + multiplier = c3_r2) + end if + + call restartvar(ncid=ncid, flag=flag, varname='cropseedc_13_deficit', xtype=ncd_double, & + dim1name='pft', long_name='pool for seeding new crop growth', units='gC13/m2', & + interpinic_flag='interp', readvar=readvar, data=this%cropseedc_deficit_patch) + if (flag=='read' .and. .not. readvar) then + call set_missing_from_template( & + my_var = this%cropseedc_deficit_patch, & + template_var = c12_cnveg_carbonstate_inst%cropseedc_deficit_patch, & + multiplier = c3_r2) + end if + end if + + if ( carbon_type == 'c14' ) then + + call restartvar(ncid=ncid, flag=flag, varname='grainc_14', xtype=ncd_double, & + dim1name='pft', long_name='c14 grain C', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_patch) + if (flag=='read' .and. .not. readvar) then + call set_missing_from_template( & + my_var = this%grainc_patch, & + template_var = c12_cnveg_carbonstate_inst%grainc_patch, & + multiplier = c3_r2) + end if + + call restartvar(ncid=ncid, flag=flag, varname='grainc_14_storage', xtype=ncd_double, & + dim1name='pft', long_name='c14 grain C storage', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_storage_patch) + if (flag=='read' .and. .not. readvar) then + call set_missing_from_template( & + my_var = this%grainc_storage_patch, & + template_var = c12_cnveg_carbonstate_inst%grainc_storage_patch, & + multiplier = c3_r2) + end if + + call restartvar(ncid=ncid, flag=flag, varname='grainc_14_xfer', xtype=ncd_double, & + dim1name='pft', long_name='c14 grain C transfer', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainc_xfer_patch) + if (flag=='read' .and. .not. readvar) then + call set_missing_from_template( & + my_var = this%grainc_xfer_patch, & + template_var = c12_cnveg_carbonstate_inst%grainc_xfer_patch, & + multiplier = c3_r2) + end if + + call restartvar(ncid=ncid, flag=flag, varname='cropseedc_14_deficit', xtype=ncd_double, & + dim1name='pft', long_name='pool for seeding new crop growth', units='gC14/m2', & + interpinic_flag='interp', readvar=readvar, data=this%cropseedc_deficit_patch) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%cropseedc_deficit_patch with atmospheric c14 value' + call set_missing_from_template( & + my_var = this%cropseedc_deficit_patch, & + template_var = c12_cnveg_carbonstate_inst%cropseedc_deficit_patch, & + multiplier = c14ratio) + end if + end if + end if + + !-------------------------------- + ! gridcell carbon state variables + !-------------------------------- + + if (carbon_type == 'c12') then + ! BACKWARDS_COMPATIBILITY(wjs, 2017-01-12) Naming this with a _g suffix in order + ! to distinguish it from the old column-level seedc restart variable + call restartvar(ncid=ncid, flag=flag, varname='seedc_g', xtype=ncd_double, & + dim1name='gridcell', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%seedc_grc) + end if + + !-------------------------------- + ! C13 gridcell carbon state variables + !-------------------------------- + + if (carbon_type == 'c13') then + call restartvar(ncid=ncid, flag=flag, varname='seedc_13_g', xtype=ncd_double, & + dim1name='gridcell', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%seedc_grc) + if (flag=='read' .and. .not. readvar) then + call set_missing_from_template( & + my_var = this%seedc_grc, & + template_var = c12_cnveg_carbonstate_inst%seedc_grc, & + multiplier = c3_r2) + end if + end if + + !-------------------------------- + ! C14 column carbon state variables + !-------------------------------- + + if ( carbon_type == 'c14' ) then + call restartvar(ncid=ncid, flag=flag, varname='seedc_14_g', xtype=ncd_double, & + dim1name='gridcell', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%seedc_grc) + if (flag=='read' .and. .not. readvar) then + if ( masterproc ) write(iulog,*) 'initializing this%seedc_grc with atmospheric c14 value' + call set_missing_from_template( & + my_var = this%seedc_grc, & + template_var = c12_cnveg_carbonstate_inst%seedc_grc, & + multiplier = c14ratio) + end if + end if + + ! Output spinup factor for deadwood (dead stem and dead course root) + if ( present(spinup_factor4deadwood) ) spinup_factor4deadwood = spinup_factor_AD + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine SetValues ( this, & + num_patch, filter_patch, value_patch, & + num_column, filter_column, value_column) + ! + ! !DESCRIPTION: + ! Set carbon state variables + ! + ! !ARGUMENTS: + class (cnveg_carbonstate_type) :: this + integer , intent(in) :: num_patch + 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%leafc_patch(i) = value_patch + this%leafc_storage_patch(i) = value_patch + this%leafc_xfer_patch(i) = value_patch + this%leafc_storage_xfer_acc_patch(i) = value_patch + this%storage_cdemand_patch(i) = value_patch + this%frootc_patch(i) = value_patch + this%frootc_storage_patch(i) = value_patch + this%frootc_xfer_patch(i) = value_patch + this%livestemc_patch(i) = value_patch + this%livestemc_storage_patch(i) = value_patch + this%livestemc_xfer_patch(i) = value_patch + this%deadstemc_patch(i) = value_patch + this%deadstemc_storage_patch(i) = value_patch + this%deadstemc_xfer_patch(i) = value_patch + this%livecrootc_patch(i) = value_patch + this%livecrootc_storage_patch(i) = value_patch + this%livecrootc_xfer_patch(i) = value_patch + this%deadcrootc_patch(i) = value_patch + this%deadcrootc_storage_patch(i) = value_patch + this%deadcrootc_xfer_patch(i) = value_patch + if(use_matrixcn)then + this%matrix_cap_leafc_patch(i) = value_patch + this%matrix_cap_leafc_storage_patch(i) = value_patch + this%matrix_cap_leafc_xfer_patch(i) = value_patch + this%matrix_cap_frootc_patch(i) = value_patch + this%matrix_cap_frootc_storage_patch(i) = value_patch + this%matrix_cap_frootc_xfer_patch(i) = value_patch + this%matrix_cap_livestemc_patch(i) = value_patch + this%matrix_cap_livestemc_storage_patch(i) = value_patch + this%matrix_cap_livestemc_xfer_patch(i) = value_patch + this%matrix_cap_deadstemc_patch(i) = value_patch + this%matrix_cap_deadstemc_storage_patch(i) = value_patch + this%matrix_cap_deadstemc_xfer_patch(i) = value_patch + this%matrix_cap_livecrootc_patch(i) = value_patch + this%matrix_cap_livecrootc_storage_patch(i) = value_patch + this%matrix_cap_livecrootc_xfer_patch(i) = value_patch + this%matrix_cap_deadcrootc_patch(i) = value_patch + this%matrix_cap_deadcrootc_storage_patch(i) = value_patch + this%matrix_cap_deadcrootc_xfer_patch(i) = value_patch + + this%leafc0_patch(i) = value_patch + this%leafc0_storage_patch(i) = value_patch + this%leafc0_xfer_patch(i) = value_patch + this%frootc0_patch(i) = value_patch + this%frootc0_storage_patch(i) = value_patch + this%frootc0_xfer_patch(i) = value_patch + this%livestemc0_patch(i) = value_patch + this%livestemc0_storage_patch(i) = value_patch + this%livestemc0_xfer_patch(i) = value_patch + this%deadstemc0_patch(i) = value_patch + this%deadstemc0_storage_patch(i) = value_patch + this%deadstemc0_xfer_patch(i) = value_patch + this%livecrootc0_patch(i) = value_patch + this%livecrootc0_storage_patch(i) = value_patch + this%livecrootc0_xfer_patch(i) = value_patch + this%deadcrootc0_patch(i) = value_patch + this%deadcrootc0_storage_patch(i) = value_patch + this%deadcrootc0_xfer_patch(i) = value_patch + this%grainc0_patch(i) = value_patch + this%grainc0_storage_patch(i) = value_patch + this%grainc0_xfer_patch(i) = value_patch +!!!!matrix + this%matrix_calloc_leaf_acc_patch(i) = value_patch + this%matrix_calloc_leafst_acc_patch(i) = value_patch + this%matrix_calloc_froot_acc_patch(i) = value_patch + this%matrix_calloc_frootst_acc_patch(i) = value_patch + this%matrix_calloc_livestem_acc_patch(i) = value_patch + this%matrix_calloc_livestemst_acc_patch(i) = value_patch + this%matrix_calloc_deadstem_acc_patch(i) = value_patch + this%matrix_calloc_deadstemst_acc_patch(i) = value_patch + this%matrix_calloc_livecroot_acc_patch(i) = value_patch + this%matrix_calloc_livecrootst_acc_patch(i) = value_patch + this%matrix_calloc_deadcroot_acc_patch(i) = value_patch + this%matrix_calloc_deadcrootst_acc_patch(i) = value_patch + + this%matrix_ctransfer_leafst_to_leafxf_acc_patch (i) = value_patch + this%matrix_ctransfer_leafxf_to_leaf_acc_patch (i) = value_patch + this%matrix_ctransfer_frootst_to_frootxf_acc_patch (i) = value_patch + this%matrix_ctransfer_frootxf_to_froot_acc_patch (i) = value_patch + this%matrix_ctransfer_livestemst_to_livestemxf_acc_patch (i) = value_patch + this%matrix_ctransfer_livestemxf_to_livestem_acc_patch (i) = value_patch + this%matrix_ctransfer_deadstemst_to_deadstemxf_acc_patch (i) = value_patch + this%matrix_ctransfer_deadstemxf_to_deadstem_acc_patch (i) = value_patch + this%matrix_ctransfer_livecrootst_to_livecrootxf_acc_patch (i) = value_patch + this%matrix_ctransfer_livecrootxf_to_livecroot_acc_patch (i) = value_patch + this%matrix_ctransfer_deadcrootst_to_deadcrootxf_acc_patch (i) = value_patch + this%matrix_ctransfer_deadcrootxf_to_deadcroot_acc_patch (i) = value_patch + this%matrix_ctransfer_livestem_to_deadstem_acc_patch (i) = value_patch + this%matrix_ctransfer_livecroot_to_deadcroot_acc_patch (i) = value_patch + + this%matrix_cturnover_leaf_acc_patch(i) = value_patch + this%matrix_cturnover_leafst_acc_patch(i) = value_patch + this%matrix_cturnover_leafxf_acc_patch(i) = value_patch + this%matrix_cturnover_froot_acc_patch(i) = value_patch + this%matrix_cturnover_frootst_acc_patch(i) = value_patch + this%matrix_cturnover_frootxf_acc_patch(i) = value_patch + this%matrix_cturnover_livestem_acc_patch(i) = value_patch + this%matrix_cturnover_livestemst_acc_patch(i) = value_patch + this%matrix_cturnover_livestemxf_acc_patch(i) = value_patch + this%matrix_cturnover_deadstem_acc_patch(i) = value_patch + this%matrix_cturnover_deadstemst_acc_patch(i) = value_patch + this%matrix_cturnover_deadstemxf_acc_patch(i) = value_patch + this%matrix_cturnover_livecroot_acc_patch(i) = value_patch + this%matrix_cturnover_livecrootst_acc_patch(i) = value_patch + this%matrix_cturnover_livecrootxf_acc_patch(i) = value_patch + this%matrix_cturnover_deadcroot_acc_patch(i) = value_patch + this%matrix_cturnover_deadcrootst_acc_patch(i) = value_patch + this%matrix_cturnover_deadcrootxf_acc_patch(i) = value_patch + end if + this%gresp_storage_patch(i) = value_patch + this%gresp_xfer_patch(i) = value_patch + this%cpool_patch(i) = value_patch + this%xsmrpool_patch(i) = value_patch + this%ctrunc_patch(i) = value_patch + this%dispvegc_patch(i) = value_patch + this%storvegc_patch(i) = value_patch + this%woodc_patch(i) = value_patch + this%totvegc_patch(i) = value_patch + this%totc_patch(i) = value_patch + if ( use_crop ) then + this%grainc_patch(i) = value_patch + this%grainc_storage_patch(i) = value_patch + this%grainc_xfer_patch(i) = value_patch + if(use_matrixcn)then + this%matrix_cap_grainc_patch(i) = value_patch + this%matrix_cap_grainc_storage_patch(i) = value_patch + this%matrix_cap_grainc_xfer_patch(i) = value_patch + this%matrix_calloc_grain_acc_patch(i) = value_patch + this%matrix_calloc_grainst_acc_patch(i) = value_patch + this%matrix_ctransfer_grainst_to_grainxf_acc_patch (i) = value_patch + this%matrix_ctransfer_grainxf_to_grain_acc_patch (i) = value_patch + this%matrix_cturnover_grain_acc_patch(i) = value_patch + this%matrix_cturnover_grainst_acc_patch(i) = value_patch + this%matrix_cturnover_grainxf_acc_patch(i) = value_patch + end if + this%cropseedc_deficit_patch(i) = value_patch + this%xsmrpool_loss_patch(i) = value_patch + end if + end do + + do fi = 1,num_column + i = filter_column(fi) + this%rootc_col(i) = value_column + this%leafc_col(i) = value_column + this%deadstemc_col(i) = value_column + this%fuelc_col(i) = value_column + this%fuelc_crop_col(i) = value_column + this%totvegc_col(i) = value_column + this%totc_p2c_col(i) = value_column + this%totc_col(i) = value_column + this%totecosysc_col(i) = value_column + end do + + end subroutine SetValues + + !----------------------------------------------------------------------- + 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 + + !----------------------------------------------------------------------- + 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 DynamicPatchAdjustments(this, bounds, & + num_soilp_with_inactive, filter_soilp_with_inactive, & + patch_state_updater, & + leafc_seed, deadstemc_seed, & + conv_cflux, wood_product_cflux, crop_product_cflux, & + dwt_frootc_to_litter, & + dwt_livecrootc_to_litter, & + dwt_deadcrootc_to_litter, & + dwt_leafc_seed, & + dwt_deadstemc_seed) + ! + ! !DESCRIPTION: + ! Adjust state variables and compute associated fluxes when patch areas change due to + ! dynamic landuse + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cnveg_carbonstate_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp_with_inactive ! number of points in filter + integer , intent(in) :: filter_soilp_with_inactive(:) ! soil patch filter that includes inactive points + type(patch_state_updater_type) , intent(in) :: patch_state_updater + real(r8) , intent(in) :: leafc_seed ! seed amount for leaf C + real(r8) , intent(in) :: deadstemc_seed ! seed amount for deadstem C + real(r8) , intent(inout) :: conv_cflux( bounds%begp: ) ! patch-level conversion C flux to atm (expressed per unit GRIDCELL area) + real(r8) , intent(inout) :: wood_product_cflux( bounds%begp: ) ! patch-level product C flux (expressed per unit GRIDCELL area) + real(r8) , intent(inout) :: crop_product_cflux( bounds%begp: ) ! patch-level crop product C flux (expressed per unit GRIDCELL area) + real(r8) , intent(inout) :: dwt_frootc_to_litter( bounds%begp: ) ! patch-level fine root C to litter (expressed per unit COLUMN area) + real(r8) , intent(inout) :: dwt_livecrootc_to_litter( bounds%begp: ) ! patch-level live coarse root C to litter (expressed per unit COLUMN area) + real(r8) , intent(inout) :: dwt_deadcrootc_to_litter( bounds%begp: ) ! patch-level live coarse root C to litter (expressed per unit COLUMN area) + real(r8) , intent(inout) :: dwt_leafc_seed( bounds%begp: ) ! patch-level mass gain due to seeding of new area: leaf C (expressed per unit GRIDCELL area) + real(r8) , intent(inout) :: dwt_deadstemc_seed( bounds%begp: ) ! patch-level mass gain due to seeding of new area: deadstem C (expressed per unit GRIDCELL area) + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + + logical :: old_weight_was_zero(bounds%begp:bounds%endp) + logical :: patch_grew(bounds%begp:bounds%endp) + + ! The following are only set for growing patches: + real(r8) :: seed_leafc_patch(bounds%begp:bounds%endp) + real(r8) :: seed_leafc_storage_patch(bounds%begp:bounds%endp) + real(r8) :: seed_leafc_xfer_patch(bounds%begp:bounds%endp) + real(r8) :: seed_deadstemc_patch(bounds%begp:bounds%endp) + + character(len=*), parameter :: subname = 'DynamicPatchAdjustments' + !----------------------------------------------------------------------- + + begp = bounds%begp + endp = bounds%endp + + SHR_ASSERT_ALL_FL((ubound(conv_cflux) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(wood_product_cflux) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(crop_product_cflux) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_frootc_to_litter) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_livecrootc_to_litter) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_deadcrootc_to_litter) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_leafc_seed) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_deadstemc_seed) == (/endp/)), sourcefile, __LINE__) + + old_weight_was_zero = patch_state_updater%old_weight_was_zero(bounds) + patch_grew = patch_state_updater%patch_grew(bounds) + + call ComputeSeedAmounts(bounds, & + num_soilp_with_inactive, filter_soilp_with_inactive, & + species = this%species, & + leafc_seed = leafc_seed, & + deadstemc_seed = deadstemc_seed, & + leaf_patch = this%leafc_patch(begp:endp), & + leaf_storage_patch = this%leafc_storage_patch(begp:endp), & + leaf_xfer_patch = this%leafc_xfer_patch(begp:endp), & + + ! Calculations only needed for patches that grew: + compute_here_patch = patch_grew(begp:endp), & + + ! For patches that previously had zero area, ignore the current state for the + ! sake of computing leaf proportions: + ignore_current_state_patch = old_weight_was_zero(begp:endp), & + + seed_leaf_patch = seed_leafc_patch(begp:endp), & + seed_leaf_storage_patch = seed_leafc_storage_patch(begp:endp), & + seed_leaf_xfer_patch = seed_leafc_xfer_patch(begp:endp), & + seed_deadstem_patch = seed_deadstemc_patch(begp:endp)) + + call update_patch_state( & + var = this%leafc_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp), & + seed = seed_leafc_patch(begp:endp), & + seed_addition = dwt_leafc_seed(begp:endp)) + + call update_patch_state( & + var = this%leafc_storage_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp), & + seed = seed_leafc_storage_patch(begp:endp), & + seed_addition = dwt_leafc_seed(begp:endp)) + + call update_patch_state( & + var = this%leafc_xfer_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp), & + seed = seed_leafc_xfer_patch(begp:endp), & + seed_addition = dwt_leafc_seed(begp:endp)) + + call update_patch_state( & + var = this%frootc_patch(begp:endp), & + flux_out_col_area = dwt_frootc_to_litter(begp:endp)) + + call update_patch_state( & + var = this%frootc_storage_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%frootc_xfer_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%livestemc_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%livestemc_storage_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%livestemc_xfer_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call patch_state_updater%update_patch_state_partition_flux_by_type(bounds, & + num_soilp_with_inactive, filter_soilp_with_inactive, & + flux1_fraction_by_pft_type = pftcon%pconv, & + var = this%deadstemc_patch(begp:endp), & + flux1_out = conv_cflux(begp:endp), & + flux2_out = wood_product_cflux(begp:endp), & + seed = seed_deadstemc_patch(begp:endp), & + seed_addition = dwt_deadstemc_seed(begp:endp)) + + call update_patch_state( & + var = this%deadstemc_storage_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%deadstemc_xfer_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%livecrootc_patch(begp:endp), & + flux_out_col_area = dwt_livecrootc_to_litter(begp:endp)) + + call update_patch_state( & + var = this%livecrootc_storage_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%livecrootc_xfer_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%deadcrootc_patch(begp:endp), & + flux_out_col_area = dwt_deadcrootc_to_litter(begp:endp)) + + call update_patch_state( & + var = this%deadcrootc_storage_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%deadcrootc_xfer_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%gresp_storage_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%gresp_xfer_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%cpool_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%xsmrpool_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%ctrunc_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + if (use_crop) then + call update_patch_state( & + var = this%grainc_patch(begp:endp), & + flux_out_grc_area = crop_product_cflux(begp:endp)) + + call update_patch_state( & + var = this%grainc_storage_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%grainc_xfer_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + ! This is a negative pool. So any deficit that we haven't repaid gets sucked out + ! of the atmosphere. + call update_patch_state( & + var = this%cropseedc_deficit_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + + call update_patch_state( & + var = this%xsmrpool_loss_patch(begp:endp), & + flux_out_grc_area = conv_cflux(begp:endp)) + end if + + contains + subroutine update_patch_state(var, flux_out_col_area, flux_out_grc_area, & + seed, seed_addition) + ! Wraps call to update_patch_state, in order to remove duplication + real(r8), intent(inout) :: var( bounds%begp: ) + real(r8), intent(inout), optional :: flux_out_col_area( bounds%begp: ) + real(r8), intent(inout), optional :: flux_out_grc_area( bounds%begp: ) + real(r8), intent(in), optional :: seed( bounds%begp: ) + real(r8), intent(inout), optional :: seed_addition( bounds%begp: ) + + call patch_state_updater%update_patch_state(bounds, & + num_soilp_with_inactive, filter_soilp_with_inactive, & + var = var, & + flux_out_col_area = flux_out_col_area, & + flux_out_grc_area = flux_out_grc_area, & + seed = seed, & + seed_addition = seed_addition) + end subroutine update_patch_state + + end subroutine DynamicPatchAdjustments + +end module CNVegCarbonStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegNitrogenFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegNitrogenFluxType.F90 new file mode 100644 index 000000000..94463e51c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegNitrogenFluxType.F90 @@ -0,0 +1,2433 @@ +module CNVegNitrogenFluxType + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools + 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_varcon , only : spval, ispval, dzsoi_decomp + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_crop, use_matrixcn + use CNSharedParamsMod , only : use_fun + use decompMod , only : bounds_type + use abortutils , only : endrun + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use SPMMod , only : sparse_matrix_type, diag_matrix_type, vector_type + ! + ! !PUBLIC TYPES: + implicit none + private + ! + 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 + + type(sparse_matrix_type) :: AKphvegn ! Aph*Kph for N cycle in sparse matrix format + type(sparse_matrix_type) :: AKgmvegn ! Agm*Kgm for N cycle in sparse matrix format + type(sparse_matrix_type) :: AKfivegn ! Afi*Kfi for N cycle in sparse matrix format + type(sparse_matrix_type) :: AKallvegn ! Aph*Kph + Agm*Kgm + Afi*Kfi for N cycle in sparse matrix format + integer :: NE_AKallvegn ! Number of entries in AKallvegn + integer,pointer,dimension(:) :: RI_AKallvegn ! Row indices in Akallvegn + integer,pointer,dimension(:) :: CI_AKallvegn ! Column indices in AKallvegn + integer,pointer,dimension(:) :: RI_phn ! Row indices of non-diagonal entires in Aph for N cycle + integer,pointer,dimension(:) :: CI_phn ! Column indices of non-diagonal entries in Aph for N cycle + integer,pointer,dimension(:) :: RI_gmn ! Row indices of non-diagonal entires in Agm for N cycle + integer,pointer,dimension(:) :: CI_gmn ! Column indices of non-diagonal entries in Agm for N cycle + integer,pointer,dimension(:) :: RI_fin ! Row indices of non-diagonal entires in Afi for N cycle + integer,pointer,dimension(:) :: CI_fin ! Column indices of non-diagonal entries in Afi for N cycle + type(diag_matrix_type) :: Kvegn ! Temporary variable of Kph, Kgm or Kfi for N cycle in diagonal matrix format + type(vector_type) :: Xvegn ! Vegetation N of each compartment in a vector format + + contains + + procedure , public :: Init + procedure , public :: Restart + procedure , public :: SetValues + procedure , public :: ZeroDWT + procedure , public :: Summary => Summary_nitrogenflux + procedure , private :: InitAllocate + procedure , private :: InitTransfer + procedure , private :: InitHistory + procedure , private :: InitCold + + end type cnveg_nitrogenflux_type + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(cnveg_nitrogenflux_type) :: this + type(bounds_type), intent(in) :: bounds + + call this%InitAllocate (bounds) + if(use_matrixcn)then + call this%InitTransfer () + end if + call this%InitHistory (bounds) + call this%InitCold (bounds) + + end subroutine Init + + subroutine InitTransfer (this) + ! + ! !AGRUMENTS: + class (cnveg_nitrogenflux_type) :: this + + 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 + + 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 + + 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 + + end subroutine InitTransfer + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize patch nitrogen flux + ! + ! !ARGUMENTS: + class (cnveg_nitrogenflux_type) :: 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%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 (:) = nan + 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 (:) = nan + 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 (:) = nan + 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 + ! Matrix + if(use_matrixcn)then + allocate(this%matrix_Ninput_patch (begp:endp)) ; this%matrix_Ninput_patch (:) = nan + allocate(this%matrix_nalloc_patch (begp:endp,1:nvegnpool)) ; this%matrix_nalloc_patch (:,:) = nan + + allocate(this%matrix_nphtransfer_patch (begp:endp,1:nnphtrans)) ; this%matrix_nphtransfer_patch (:,:) = nan + allocate(this%matrix_nphturnover_patch (begp:endp,1:nvegnpool)) ; this%matrix_nphturnover_patch (:,:) = nan + allocate(this%matrix_nphtransfer_doner_patch (1:nnphtrans)) ; this%matrix_nphtransfer_doner_patch (:) = -9999 + allocate(this%matrix_nphtransfer_receiver_patch (1:nnphtrans)) ; this%matrix_nphtransfer_receiver_patch(:) = -9999 + + allocate(this%matrix_ngmtransfer_patch (begp:endp,1:nngmtrans)) ; this%matrix_ngmtransfer_patch (:,:) = nan + allocate(this%matrix_ngmturnover_patch (begp:endp,1:nvegnpool)) ; this%matrix_ngmturnover_patch (:,:) = nan + allocate(this%matrix_ngmtransfer_doner_patch (1:nngmtrans)) ; this%matrix_ngmtransfer_doner_patch (:) = -9999 + allocate(this%matrix_ngmtransfer_receiver_patch (1:nngmtrans)) ; this%matrix_ngmtransfer_receiver_patch(:) = -9999 + + allocate(this%matrix_nfitransfer_patch (begp:endp,1:nnfitrans)) ; this%matrix_nfitransfer_patch (:,:) = nan + allocate(this%matrix_nfiturnover_patch (begp:endp,1:nvegnpool)) ; this%matrix_nfiturnover_patch (:,:) = nan + allocate(this%matrix_nfitransfer_doner_patch (1:nnfitrans)) ; this%matrix_nfitransfer_doner_patch (:) = -9999 + allocate(this%matrix_nfitransfer_receiver_patch (1:nnfitrans)) ; this%matrix_nfitransfer_receiver_patch(:) = -9999 + + allocate(this%list_phn_phgmn (1:nnphtrans+nvegnpool)) ; this%list_phn_phgmn = -9999 + allocate(this%list_gmn_phgmn (1:nvegnpool)) ; this%list_gmn_phgmn = -9999 + allocate(this%list_phn_phgmfin (1:nnphtrans+nvegnpool)) ; this%list_phn_phgmfin = -9999 + allocate(this%list_gmn_phgmfin (1:nvegnpool)) ; this%list_gmn_phgmfin = -9999 + allocate(this%list_fin_phgmfin (1:nnfitrans+nvegnpool)) ; this%list_fin_phgmfin = -9999 + + allocate(this%list_aphn (1:nnphtrans-nnphouttrans)); this%list_aphn = -9999 + allocate(this%list_agmn (1:nngmtrans-nngmouttrans)); this%list_agmn = -9999 + allocate(this%list_afin (1:nnfitrans-nnfiouttrans)); this%list_afin = -9999 + + call this%AKphvegn%InitSM (nvegnpool,begp,endp,nnphtrans-nnphouttrans+nvegnpool) + call this%AKgmvegn%InitSM (nvegnpool,begp,endp,nngmtrans-nngmouttrans+nvegnpool) + call this%AKfivegn%InitSM (nvegnpool,begp,endp,nnfitrans-nnfiouttrans+nvegnpool) + + this%NE_AKallvegn = (nnphtrans-nnphouttrans+nvegnpool) + (nngmtrans-nngmouttrans+nvegnpool) + & + nnfitrans-nnfiouttrans+nvegnpool + + call this%AKallvegn%InitSM (nvegnpool,begp,endp,this%NE_AKallvegn) + + allocate(this%RI_AKallvegn (1:this%NE_AKallvegn)) ; this%RI_AKallvegn(:) = -9999 + allocate(this%CI_AKallvegn (1:this%NE_AKallvegn)) ; this%CI_AKallvegn(:) = -9999 + allocate(this%RI_phn (1:nnphtrans-nnphouttrans+nvegnpool)) ; this%RI_phn(:) = -9999 + allocate(this%CI_phn (1:nnphtrans-nnphouttrans+nvegnpool)) ; this%CI_phn(:) = -9999 + allocate(this%RI_gmn (1:nngmtrans-nngmouttrans+nvegnpool)) ; this%RI_gmn(:) = -9999 + allocate(this%CI_gmn (1:nngmtrans-nngmouttrans+nvegnpool)) ; this%CI_gmn(:) = -9999 + allocate(this%RI_fin (1:nnfitrans-nnfiouttrans+nvegnpool)) ; this%RI_fin(:) = -9999 + allocate(this%CI_fin (1:nnfitrans-nnfiouttrans+nvegnpool)) ; this%CI_fin(:) = -9999 + + call this%Kvegn%InitDM (nvegnpool,begp,endp) + call this%Xvegn%InitV (nvegnpool,begp,endp) + end if + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varpar , only : nlevsno, nlevgrnd + use histFileMod , only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + ! + ! !ARGUMENTS: + class(cnveg_nitrogenflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: k,l + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + character(10) :: active + character(24) :: fieldname + character(100) :: longname + character(8) :: vr_suffix + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + ! add suffix if number of soil decomposition depths is greater than 1 + if (nlevdecomp > 1) then + vr_suffix = "_vr" + else + vr_suffix = "" + endif + + this%m_leafn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='leaf N mortality', & + ptr_patch=this%m_leafn_to_litter_patch, default='inactive') + + this%m_frootn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='fine root N mortality', & + ptr_patch=this%m_frootn_to_litter_patch, default='inactive') + + this%m_leafn_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFN_STORAGE_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='leaf N storage mortality', & + ptr_patch=this%m_leafn_storage_to_litter_patch, default='inactive') + + this%m_frootn_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTN_STORAGE_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='fine root N storage mortality', & + ptr_patch=this%m_frootn_storage_to_litter_patch, default='inactive') + + this%m_livestemn_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMN_STORAGE_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='live stem N storage mortality', & + ptr_patch=this%m_livestemn_storage_to_litter_patch, default='inactive') + + this%m_deadstemn_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMN_STORAGE_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N storage mortality', & + ptr_patch=this%m_deadstemn_storage_to_litter_patch, default='inactive') + + this%m_livecrootn_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTN_STORAGE_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N storage mortality', & + ptr_patch=this%m_livecrootn_storage_to_litter_patch, default='inactive') + + this%m_deadcrootn_storage_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTN_STORAGE_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N storage mortality', & + ptr_patch=this%m_deadcrootn_storage_to_litter_patch, default='inactive') + + this%m_leafn_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFN_XFER_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='leaf N transfer mortality', & + ptr_patch=this%m_leafn_xfer_to_litter_patch, default='inactive') + + this%m_frootn_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTN_XFER_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='fine root N transfer mortality', & + ptr_patch=this%m_frootn_xfer_to_litter_patch, default='inactive') + + this%m_livestemn_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMN_XFER_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='live stem N transfer mortality', & + ptr_patch=this%m_livestemn_xfer_to_litter_patch, default='inactive') + + this%m_deadstemn_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMN_XFER_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N transfer mortality', & + ptr_patch=this%m_deadstemn_xfer_to_litter_patch, default='inactive') + + this%m_livecrootn_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTN_XFER_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N transfer mortality', & + ptr_patch=this%m_livecrootn_xfer_to_litter_patch, default='inactive') + + this%m_deadcrootn_xfer_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTN_XFER_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N transfer mortality', & + ptr_patch=this%m_deadcrootn_xfer_to_litter_patch, default='inactive') + + this%m_livestemn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='live stem N mortality', & + ptr_patch=this%m_livestemn_to_litter_patch, default='inactive') + + this%m_deadstemn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N mortality', & + ptr_patch=this%m_deadstemn_to_litter_patch, default='inactive') + + this%m_livecrootn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N mortality', & + ptr_patch=this%m_livecrootn_to_litter_patch, default='inactive') + + this%m_deadcrootn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N mortality', & + ptr_patch=this%m_deadcrootn_to_litter_patch, default='inactive') + + this%m_retransn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='M_RETRANSN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='retranslocated N pool mortality', & + ptr_patch=this%m_retransn_to_litter_patch, default='inactive') + + this%m_leafn_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFN_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='leaf N fire loss', & + ptr_patch=this%m_leafn_to_fire_patch, default='inactive') + + this%m_frootn_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTN_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='fine root N fire loss ', & + ptr_patch=this%m_frootn_to_fire_patch, default='inactive') + + this%m_leafn_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFN_STORAGE_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='leaf N storage fire loss', & + ptr_patch=this%m_leafn_storage_to_fire_patch, default='inactive') + + this%m_frootn_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTN_STORAGE_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='fine root N storage fire loss', & + ptr_patch=this%m_frootn_storage_to_fire_patch, default='inactive') + + this%m_livestemn_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMN_STORAGE_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='live stem N storage fire loss', & + ptr_patch=this%m_livestemn_storage_to_fire_patch, default='inactive') + + this%m_deadstemn_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMN_STORAGE_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N storage fire loss', & + ptr_patch=this%m_deadstemn_storage_to_fire_patch, default='inactive') + + this%m_livecrootn_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTN_STORAGE_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N storage fire loss', & + ptr_patch=this%m_livecrootn_storage_to_fire_patch, default='inactive') + + this%m_deadcrootn_storage_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTN_STORAGE_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N storage fire loss', & + ptr_patch=this%m_deadcrootn_storage_to_fire_patch, default='inactive') + + this%m_leafn_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LEAFN_XFER_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='leaf N transfer fire loss', & + ptr_patch=this%m_leafn_xfer_to_fire_patch, default='inactive') + + this%m_frootn_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_FROOTN_XFER_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='fine root N transfer fire loss', & + ptr_patch=this%m_frootn_xfer_to_fire_patch, default='inactive') + + this%m_livestemn_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMN_XFER_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='live stem N transfer fire loss', & + ptr_patch=this%m_livestemn_xfer_to_fire_patch, default='inactive') + + this%m_deadstemn_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMN_XFER_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N transfer fire loss', & + ptr_patch=this%m_deadstemn_xfer_to_fire_patch, default='inactive') + + this%m_livecrootn_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTN_XFER_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N transfer fire loss', & + ptr_patch=this%m_livecrootn_xfer_to_fire_patch, default='inactive') + + this%m_deadcrootn_xfer_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTN_XFER_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N transfer fire loss', & + ptr_patch=this%m_deadcrootn_xfer_to_fire_patch, default='inactive') + + this%m_livestemn_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVESTEMN_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='live stem N fire loss', & + ptr_patch=this%m_livestemn_to_fire_patch, default='inactive') + + this%m_deadstemn_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMN_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N fire loss', & + ptr_patch=this%m_deadstemn_to_fire_patch, default='inactive') + + this%m_deadstemn_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADSTEMN_TO_LITTER_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N fire mortality to litter', & + ptr_patch=this%m_deadstemn_to_litter_fire_patch, default='inactive') + + this%m_livecrootn_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_LIVECROOTN_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N fire loss', & + ptr_patch=this%m_livecrootn_to_fire_patch, default='inactive') + + this%m_deadcrootn_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTN_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N fire loss', & + ptr_patch=this%m_deadcrootn_to_fire_patch, default='inactive') + + this%m_deadcrootn_to_litter_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_DEADCROOTN_TO_LITTER_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N fire mortality to litter', & + ptr_patch=this%m_deadcrootn_to_litter_fire_patch, default='inactive') + + this%m_retransn_to_fire_patch(begp:endp) = spval + call hist_addfld1d (fname='M_RETRANSN_TO_FIRE', units='gN/m^2/s', & + avgflag='A', long_name='retranslocated N pool fire loss', & + ptr_patch=this%m_retransn_to_fire_patch, default='inactive') + + this%leafn_xfer_to_leafn_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_XFER_TO_LEAFN', units='gN/m^2/s', & + avgflag='A', long_name='leaf N growth from storage', & + ptr_patch=this%leafn_xfer_to_leafn_patch, default='inactive') + + this%frootn_xfer_to_frootn_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN_XFER_TO_FROOTN', units='gN/m^2/s', & + avgflag='A', long_name='fine root N growth from storage', & + ptr_patch=this%frootn_xfer_to_frootn_patch, default='inactive') + + this%livestemn_xfer_to_livestemn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_XFER_TO_LIVESTEMN', units='gN/m^2/s', & + avgflag='A', long_name='live stem N growth from storage', & + ptr_patch=this%livestemn_xfer_to_livestemn_patch, default='inactive') + + this%deadstemn_xfer_to_deadstemn_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMN_XFER_TO_DEADSTEMN', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N growth from storage', & + ptr_patch=this%deadstemn_xfer_to_deadstemn_patch, default='inactive') + + this%livecrootn_xfer_to_livecrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_XFER_TO_LIVECROOTN', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N growth from storage', & + ptr_patch=this%livecrootn_xfer_to_livecrootn_patch, default='inactive') + + this%deadcrootn_xfer_to_deadcrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTN_XFER_TO_DEADCROOTN', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N growth from storage', & + ptr_patch=this%deadcrootn_xfer_to_deadcrootn_patch, default='inactive') + + this%leafn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='leaf N litterfall', & + ptr_patch=this%leafn_to_litter_patch) + + this%leafn_to_retransn_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_TO_RETRANSN', units='gN/m^2/s', & + avgflag='A', long_name='leaf N to retranslocated N pool', & + ptr_patch=this%leafn_to_retransn_patch, default='inactive') + + this%frootn_to_litter_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN_TO_LITTER', units='gN/m^2/s', & + avgflag='A', long_name='fine root N litterfall', & + ptr_patch=this%frootn_to_litter_patch, default='inactive') + + this%retransn_to_npool_patch(begp:endp) = spval + call hist_addfld1d (fname='RETRANSN_TO_NPOOL', units='gN/m^2/s', & + avgflag='A', long_name='deployment of retranslocated N', & + ptr_patch=this%retransn_to_npool_patch) + + this%free_retransn_to_npool_patch(begp:endp) = spval + call hist_addfld1d (fname='FREE_RETRANSN_TO_NPOOL', units='gN/m^2/s', & + avgflag='A', long_name='deployment of retranslocated N', & + ptr_patch=this%free_retransn_to_npool_patch) + + this%sminn_to_npool_patch(begp:endp) = spval + call hist_addfld1d (fname='SMINN_TO_NPOOL', units='gN/m^2/s', & + avgflag='A', long_name='deployment of soil mineral N uptake', & + ptr_patch=this%sminn_to_npool_patch) + + this%npool_to_leafn_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_LEAFN', units='gN/m^2/s', & + avgflag='A', long_name='allocation to leaf N', & + ptr_patch=this%npool_to_leafn_patch, default='inactive') + + this%npool_to_leafn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_LEAFN_STORAGE', units='gN/m^2/s', & + avgflag='A', long_name='allocation to leaf N storage', & + ptr_patch=this%npool_to_leafn_storage_patch, default='inactive') + + this%npool_to_frootn_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_FROOTN', units='gN/m^2/s', & + avgflag='A', long_name='allocation to fine root N', & + ptr_patch=this%npool_to_frootn_patch, default='inactive') + + this%npool_to_frootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_FROOTN_STORAGE', units='gN/m^2/s', & + avgflag='A', long_name='allocation to fine root N storage', & + ptr_patch=this%npool_to_frootn_storage_patch, default='inactive') + + this%npool_to_livestemn_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_LIVESTEMN', units='gN/m^2/s', & + avgflag='A', long_name='allocation to live stem N', & + ptr_patch=this%npool_to_livestemn_patch, default='inactive') + + this%npool_to_livestemn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_LIVESTEMN_STORAGE', units='gN/m^2/s', & + avgflag='A', long_name='allocation to live stem N storage', & + ptr_patch=this%npool_to_livestemn_storage_patch, default='inactive') + + this%npool_to_deadstemn_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_DEADSTEMN', units='gN/m^2/s', & + avgflag='A', long_name='allocation to dead stem N', & + ptr_patch=this%npool_to_deadstemn_patch, default='inactive') + + this%npool_to_deadstemn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_DEADSTEMN_STORAGE', units='gN/m^2/s', & + avgflag='A', long_name='allocation to dead stem N storage', & + ptr_patch=this%npool_to_deadstemn_storage_patch, default='inactive') + + this%npool_to_livecrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_LIVECROOTN', units='gN/m^2/s', & + avgflag='A', long_name='allocation to live coarse root N', & + ptr_patch=this%npool_to_livecrootn_patch, default='inactive') + + this%npool_to_livecrootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_LIVECROOTN_STORAGE', units='gN/m^2/s', & + avgflag='A', long_name='allocation to live coarse root N storage', & + ptr_patch=this%npool_to_livecrootn_storage_patch, default='inactive') + + this%npool_to_deadcrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_DEADCROOTN', units='gN/m^2/s', & + avgflag='A', long_name='allocation to dead coarse root N', & + ptr_patch=this%npool_to_deadcrootn_patch, default='inactive') + + this%npool_to_deadcrootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL_TO_DEADCROOTN_STORAGE', units='gN/m^2/s', & + avgflag='A', long_name='allocation to dead coarse root N storage', & + ptr_patch=this%npool_to_deadcrootn_storage_patch, default='inactive') + + this%leafn_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_STORAGE_TO_XFER', units='gN/m^2/s', & + avgflag='A', long_name='leaf N shift storage to transfer', & + ptr_patch=this%leafn_storage_to_xfer_patch, default='inactive') + + this%frootn_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN_STORAGE_TO_XFER', units='gN/m^2/s', & + avgflag='A', long_name='fine root N shift storage to transfer', & + ptr_patch=this%frootn_storage_to_xfer_patch, default='inactive') + + this%livestemn_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_STORAGE_TO_XFER', units='gN/m^2/s', & + avgflag='A', long_name='live stem N shift storage to transfer', & + ptr_patch=this%livestemn_storage_to_xfer_patch, default='inactive') + + this%deadstemn_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMN_STORAGE_TO_XFER', units='gN/m^2/s', & + avgflag='A', long_name='dead stem N shift storage to transfer', & + ptr_patch=this%deadstemn_storage_to_xfer_patch, default='inactive') + + this%livecrootn_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_STORAGE_TO_XFER', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N shift storage to transfer', & + ptr_patch=this%livecrootn_storage_to_xfer_patch, default='inactive') + + this%deadcrootn_storage_to_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTN_STORAGE_TO_XFER', units='gN/m^2/s', & + avgflag='A', long_name='dead coarse root N shift storage to transfer', & + ptr_patch=this%deadcrootn_storage_to_xfer_patch, default='inactive') + + this%livestemn_to_deadstemn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_TO_DEADSTEMN', units='gN/m^2/s', & + avgflag='A', long_name='live stem N turnover', & + ptr_patch=this%livestemn_to_deadstemn_patch, default='inactive') + + this%livestemn_to_retransn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_TO_RETRANSN', units='gN/m^2/s', & + avgflag='A', long_name='live stem N to retranslocated N pool', & + ptr_patch=this%livestemn_to_retransn_patch, default='inactive') + + this%livecrootn_to_deadcrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_TO_DEADCROOTN', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N turnover', & + ptr_patch=this%livecrootn_to_deadcrootn_patch, default='inactive') + + this%livecrootn_to_retransn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_TO_RETRANSN', units='gN/m^2/s', & + avgflag='A', long_name='live coarse root N to retranslocated N pool', & + ptr_patch=this%livecrootn_to_retransn_patch, default='inactive') + + this%ndeploy_patch(begp:endp) = spval + call hist_addfld1d (fname='NDEPLOY', units='gN/m^2/s', & + avgflag='A', long_name='total N deployed in new growth', & + ptr_patch=this%ndeploy_patch) + + this%wood_harvestn_patch(begp:endp) = spval + call hist_addfld1d (fname='WOOD_HARVESTN', units='gN/m^2/s', & + avgflag='A', long_name='wood harvest N (to product pools)', & + ptr_patch=this%wood_harvestn_patch) + + this%fire_nloss_patch(begp:endp) = spval + call hist_addfld1d (fname='PFT_FIRE_NLOSS', units='gN/m^2/s', & + avgflag='A', long_name='total patch-level fire N loss', & + ptr_patch=this%fire_nloss_patch) + + if (use_crop) then + this%fert_patch(begp:endp) = spval + call hist_addfld1d (fname='NFERTILIZATION', units='gN/m^2/s', & + avgflag='A', long_name='fertilizer added', & + ptr_patch=this%fert_patch) + end if + + if (use_crop .and. .not. use_fun) then + this%soyfixn_patch(begp:endp) = spval + call hist_addfld1d (fname='SOYFIXN', units='gN/m^2/s', & + avgflag='A', long_name='soybean fixation', & + ptr_patch=this%soyfixn_patch) + end if + + if (use_crop) then + this%fert_counter_patch(begp:endp) = spval + call hist_addfld1d (fname='FERT_COUNTER', units='seconds', & + avgflag='A', long_name='time left to fertilize', & + ptr_patch=this%fert_counter_patch, default='inactive') + end if + + !------------------------------- + ! N flux variables - native to column + !------------------------------- + + do k = 1, ndecomp_pools + if ( decomp_cascade_con%is_litter(k) .or. decomp_cascade_con%is_cwd(k) ) then + this%m_decomp_npools_to_fire_col(begc:endc,k) = spval + data1dptr => this%m_decomp_npools_to_fire_col(:,k) + fieldname = 'M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'N_TO_FIRE' + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' N fire loss' + call hist_addfld1d (fname=fieldname, units='gN/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + + if ( nlevdecomp_full > 1 ) then + this%m_decomp_npools_to_fire_vr_col(begc:endc,:,k) = spval + data2dptr => this%m_decomp_npools_to_fire_vr_col(:,:,k) + fieldname = 'M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'N_TO_FIRE'//trim(vr_suffix) + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' N fire loss' + call hist_addfld_decomp (fname=fieldname, units='gN/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + endif + end do + + this%fire_nloss_col(begc:endc) = spval + call hist_addfld1d (fname='COL_FIRE_NLOSS', units='gN/m^2/s', & + avgflag='A', long_name='total column-level fire N loss', & + ptr_col=this%fire_nloss_col) + + this%dwt_seedn_to_leaf_grc(begg:endg) = spval + call hist_addfld1d (fname='DWT_SEEDN_TO_LEAF', units='gN/m^2/s', & + avgflag='A', long_name='seed source to patch-level leaf', & + ptr_gcell=this%dwt_seedn_to_leaf_grc) + + this%dwt_seedn_to_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='DWT_SEEDN_TO_LEAF_PATCH', units='gN/m^2/s', & + avgflag='A', & + long_name='patch-level seed source to patch-level leaf ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_seedn_to_leaf_patch, default='inactive') + + this%dwt_seedn_to_deadstem_grc(begg:endg) = spval + call hist_addfld1d (fname='DWT_SEEDN_TO_DEADSTEM', units='gN/m^2/s', & + avgflag='A', long_name='seed source to patch-level deadstem', & + ptr_gcell=this%dwt_seedn_to_deadstem_grc) + + this%dwt_seedn_to_deadstem_patch(begp:endp) = spval + call hist_addfld1d (fname='DWT_SEEDN_TO_DEADSTEM_PATCH', units='gN/m^2/s', & + avgflag='A', & + long_name='patch-level seed source to patch-level deadstem ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_seedn_to_deadstem_patch, default='inactive') + + this%dwt_conv_nflux_grc(begg:endg) = spval + call hist_addfld1d (fname='DWT_CONV_NFLUX', units='gN/m^2/s', & + avgflag='A', & + long_name='conversion N flux (immediate loss to atm) (0 at all times except first timestep of year)', & + ptr_gcell=this%dwt_conv_nflux_grc) + + this%dwt_conv_nflux_patch(begp:endp) = spval + call hist_addfld1d (fname='DWT_CONV_NFLUX_PATCH', units='gN/m^2/s', & + avgflag='A', & + long_name='patch-level conversion N flux (immediate loss to atm) ' // & + '(0 at all times except first timestep of year) ' // & + '(per-area-gridcell; only makes sense with dov2xy=.false.)', & + ptr_patch=this%dwt_conv_nflux_patch, default='inactive') + + this%dwt_frootn_to_litr_met_n_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_FROOTN_TO_LITR_MET_N', units='gN/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='fine root to litter due to landcover change', & + ptr_col=this%dwt_frootn_to_litr_met_n_col, default='inactive') + + this%dwt_frootn_to_litr_cel_n_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_FROOTN_TO_LITR_CEL_N', units='gN/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='fine root to litter due to landcover change', & + ptr_col=this%dwt_frootn_to_litr_cel_n_col, default='inactive') + + this%dwt_frootn_to_litr_lig_n_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_FROOTN_TO_LITR_LIG_N', units='gN/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='fine root to litter due to landcover change', & + ptr_col=this%dwt_frootn_to_litr_lig_n_col, default='inactive') + + this%dwt_livecrootn_to_cwdn_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_LIVECROOTN_TO_CWDN', units='gN/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='live coarse root to CWD due to landcover change', & + ptr_col=this%dwt_livecrootn_to_cwdn_col, default='inactive') + + this%dwt_deadcrootn_to_cwdn_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='DWT_DEADCROOTN_TO_CWDN', units='gN/m^2/s', type2d='levdcmp', & + avgflag='A', long_name='dead coarse root to CWD due to landcover change', & + ptr_col=this%dwt_deadcrootn_to_cwdn_col, default='inactive') + + this%crop_seedn_to_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='CROP_SEEDN_TO_LEAF', units='gN/m^2/s', & + avgflag='A', long_name='crop seed source to leaf', & + ptr_patch=this%crop_seedn_to_leaf_patch, default='inactive') + + this%plant_ndemand_patch(begp:endp) = spval + call hist_addfld1d (fname='PLANT_NDEMAND', units='gN/m^2/s', & + avgflag='A', long_name='N flux required to support initial GPP', & + ptr_patch=this%plant_ndemand_patch) + + this%avail_retransn_patch(begp:endp) = spval + call hist_addfld1d (fname='AVAIL_RETRANSN', units='gN/m^2/s', & + avgflag='A', long_name='N flux available from retranslocation pool', & + ptr_patch=this%avail_retransn_patch, default='inactive') + + this%plant_nalloc_patch(begp:endp) = spval + call hist_addfld1d (fname='PLANT_NALLOC', units='gN/m^2/s', & + avgflag='A', long_name='total allocated N flux', & + ptr_patch=this%plant_nalloc_patch, default='inactive') + if (use_matrixcn) then + this%matrix_Ninput_patch(begp:endp) = spval + call hist_addfld1d (fname='MATRIX PLANT_NALLOC', units='gN/m^2/s', & + avgflag='A', long_name='total allocated N flux for matrix', & + ptr_patch=this%matrix_Ninput_patch, default='inactive') + end if + + if ( use_fun ) then + this%Nactive_patch(begp:endp) = spval + call hist_addfld1d (fname='NACTIVE', units='gN/m^2/s', & + avgflag='A', long_name='Mycorrhizal N uptake flux', & + ptr_patch=this%Nactive_patch) + + this%Nnonmyc_patch(begp:endp) = spval + call hist_addfld1d (fname='NNONMYC', units='gN/m^2/s', & + avgflag='A', long_name='Non-mycorrhizal N uptake flux', & + ptr_patch=this%Nnonmyc_patch) + + this%Nam_patch(begp:endp) = spval + call hist_addfld1d (fname='NAM', units='gN/m^2/s', & + avgflag='A', long_name='AM-associated N uptake flux', & + ptr_patch=this%Nam_patch) + + this%Necm_patch(begp:endp) = spval + call hist_addfld1d (fname='NECM', units='gN/m^2/s', & + avgflag='A', long_name='ECM-associated N uptake flux', & + ptr_patch=this%Necm_patch) + + if (use_nitrif_denitrif) then + this%Nactive_no3_patch(begp:endp) = spval + call hist_addfld1d (fname='NACTIVE_NO3', units='gN/m^2/s', & + avgflag='A', long_name='Mycorrhizal N uptake flux', & + ptr_patch=this%Nactive_no3_patch) + + this%Nactive_nh4_patch(begp:endp) = spval + call hist_addfld1d (fname='NACTIVE_NH4', units='gN/m^2/s', & + avgflag='A', long_name='Mycorrhizal N uptake flux', & + ptr_patch=this%Nactive_nh4_patch) + + this%Nnonmyc_no3_patch(begp:endp) = spval + call hist_addfld1d (fname='NNONMYC_NO3', units='gN/m^2/s', & + avgflag='A', long_name='Non-mycorrhizal N uptake flux', & + ptr_patch=this%Nnonmyc_no3_patch) + + this%Nnonmyc_nh4_patch(begp:endp) = spval + call hist_addfld1d (fname='NNONMYC_NH4', units='gN/m^2/s', & + avgflag='A', long_name='Non-mycorrhizal N uptake flux', & + ptr_patch=this%Nnonmyc_nh4_patch) + + this%Nam_no3_patch(begp:endp) = spval + call hist_addfld1d (fname='NAM_NO3', units='gN/m^2/s', & + avgflag='A', long_name='AM-associated N uptake flux', & + ptr_patch=this%Nam_no3_patch) + + this%Nam_nh4_patch(begp:endp) = spval + call hist_addfld1d (fname='NAM_NH4', units='gN/m^2/s', & + avgflag='A', long_name='AM-associated N uptake flux', & + ptr_patch=this%Nam_nh4_patch) + + this%Necm_no3_patch(begp:endp) = spval + call hist_addfld1d (fname='NECM_NO3', units='gN/m^2/s', & + avgflag='A', long_name='ECM-associated N uptake flux', & + ptr_patch=this%Necm_no3_patch) + + this%Necm_nh4_patch(begp:endp) = spval + call hist_addfld1d (fname='NECM_NH4', units='gN/m^2/s', & + avgflag='A', long_name='ECM-associated N uptake flux', & + ptr_patch=this%Necm_nh4_patch) + end if + + this%Npassive_patch(begp:endp) = spval + call hist_addfld1d (fname='NPASSIVE', units='gN/m^2/s', & + avgflag='A', long_name='Passive N uptake flux', & + ptr_patch=this%Npassive_patch) + + this%Nfix_patch(begp:endp) = spval + call hist_addfld1d (fname='NFIX', units='gN/m^2/s', & + avgflag='A', long_name='Symbiotic BNF uptake flux', & + ptr_patch=this%Nfix_patch) + + this%Nretrans_patch(begp:endp) = spval + call hist_addfld1d (fname='NRETRANS', units='gN/m^2/s', & + avgflag='A', long_name='Retranslocated N uptake flux', & + ptr_patch=this%Nretrans_patch) + + this%Nretrans_org_patch(begp:endp) = spval + call hist_addfld1d (fname='NRETRANS_REG', units='gN/m^2/s', & + avgflag='A', long_name='Retranslocated N uptake flux', & + ptr_patch=this%Nretrans_org_patch) + + this%Nretrans_season_patch(begp:endp) = spval + call hist_addfld1d (fname='NRETRANS_SEASON', units='gN/m^2/s', & + avgflag='A', long_name='Retranslocated N uptake flux', & + ptr_patch=this%Nretrans_season_patch) + + this%Nretrans_stress_patch(begp:endp) = spval + call hist_addfld1d (fname='NRETRANS_STRESS', units='gN/m^2/s', & + avgflag='A', long_name='Retranslocated N uptake flux', & + ptr_patch=this%Nretrans_stress_patch) + + this%Nuptake_patch(begp:endp) = spval + call hist_addfld1d (fname='NUPTAKE', units='gN/m^2/s', & + avgflag='A', long_name='Total N uptake of FUN', & + ptr_patch=this%Nuptake_patch) + + this%sminn_to_plant_fun_patch(begp:endp) = spval + call hist_addfld1d (fname='SMINN_TO_PLANT_FUN', units='gN/m^2/s',& + avgflag='A', long_name='Total soil N uptake of FUN', & + ptr_patch=this%sminn_to_plant_fun_patch) + + this%cost_nfix_patch(begp:endp) = spval + call hist_addfld1d (fname='COST_NFIX', units='gN/gC', & + avgflag='A', long_name='Cost of fixation', & + ptr_patch=this%cost_nfix_patch) + + this%cost_nactive_patch(begp:endp) = spval + call hist_addfld1d (fname='COST_NACTIVE', units='gN/gC', & + avgflag='A', long_name='Cost of active uptake', & + ptr_patch=this%cost_nactive_patch) + + this%cost_nretrans_patch(begp:endp) = spval + call hist_addfld1d (fname='COST_NRETRANS', units='gN/gC', & + avgflag='A', long_name='Cost of retranslocation', & + ptr_patch=this%cost_nretrans_patch) + + this%nuptake_npp_fraction_patch(begp:endp) = spval + call hist_addfld1d (fname='NUPTAKE_NPP_FRACTION', units='-', & + avgflag='A', long_name='frac of NPP used in N uptake', & + ptr_patch=this%nuptake_npp_fraction_patch) + + + end if + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !DESCRIPTION: + ! Initializes time varying variables used only in coupled carbon-nitrogen mode (CN): + ! + ! !USES: + use landunit_varcon , only : istsoil, istcrop + ! + ! !ARGUMENTS: + class(cnveg_nitrogenflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p,c,l,j + integer :: fp, fc ! filter indices + integer :: num_special_col ! number of good values in special_col filter + integer :: num_special_patch ! number of good values in special_patch filter + integer :: special_col(bounds%endc-bounds%begc+1) ! special landunit filter - columns + integer :: special_patch(bounds%endp-bounds%begp+1) ! special landunit filter - patches + !--------------------------------------------------------------------- + + ! Set column filters + + num_special_col = 0 + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + num_special_col = num_special_col + 1 + special_col(num_special_col) = c + end if + end do + + ! Set patch filters + + num_special_patch = 0 + do p = bounds%begp,bounds%endp + l = patch%landunit(p) + if (lun%ifspecial(l)) then + num_special_patch = num_special_patch + 1 + special_patch(num_special_patch) = p + end if + end do + + !----------------------------------------------- + ! initialize nitrogen flux variables + !----------------------------------------------- + + do p = bounds%begp,bounds%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 + + ! initialize fields for special filters + + call this%SetValues (nvegnpool=nvegnpool, & + num_patch=num_special_patch, filter_patch=special_patch, value_patch=0._r8, & + num_column=num_special_col, filter_column=special_col, value_column=0._r8) + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart (this, bounds, ncid, flag ) + ! + ! !DESCRIPTION: + ! Read/write CN restart data for carbon state + ! + ! !USES: + use restUtilMod + use ncdio_pio + ! + ! !ARGUMENTS: + class (cnveg_nitrogenflux_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 + real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays + real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='fert_counter', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fert_counter_patch) + + call restartvar(ncid=ncid, flag=flag, varname='fert', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fert_patch) + end if + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='grainn_xfer_to_grainn', xtype=ncd_double, & + dim1name='pft', & + long_name='grain N growth from storage', units='gN/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%grainn_xfer_to_grainn_patch) + end if + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='livestemn_to_litter', xtype=ncd_double, & + dim1name='pft', & + long_name='livestem N to litter', units='gN/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%livestemn_to_litter_patch) + end if + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='grainn_to_food', xtype=ncd_double, & + dim1name='pft', & + long_name='grain N to food', units='gN/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%grainn_to_food_patch) + end if + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='npool_to_grainn', xtype=ncd_double, & + dim1name='pft', & + long_name='allocation to grain N', units='gN/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%npool_to_grainn_patch) + end if + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='npool_to_grainn_storage', xtype=ncd_double, & + dim1name='pft', & + long_name='allocation to grain N storage', units='gN/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%npool_to_grainn_storage_patch) + end if + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='grainn_storage_to_xfer', xtype=ncd_double, & + dim1name='pft', & + long_name='grain N shift storage to transfer', units='gN/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%grainn_storage_to_xfer_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='plant_ndemand', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%plant_ndemand_patch) + + call restartvar(ncid=ncid, flag=flag, varname='avail_retransn', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%avail_retransn_patch) + + if ( use_fun ) then +! set_missing_vals_to_constant for BACKWARDS_COMPATIBILITY(wrw, 2018-06-28) re. issue #426 +! special land units previously set to spval, not 0 +! modifications here should correct this + call restartvar(ncid=ncid, flag=flag, varname='Nactive', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nactive_patch) + call set_missing_vals_to_constant(this%Nactive_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nnonmyc', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nnonmyc_patch) + call set_missing_vals_to_constant(this%Nnonmyc_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nam', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nam_patch) + call set_missing_vals_to_constant(this%Nam_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Necm', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Necm_patch) + call set_missing_vals_to_constant(this%Necm_patch, 0._r8) + + if (use_nitrif_denitrif) then + call restartvar(ncid=ncid, flag=flag, varname='Nactive_no3', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nactive_no3_patch) + call set_missing_vals_to_constant(this%Nactive_no3_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nactive_nh4', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nactive_nh4_patch) + call set_missing_vals_to_constant(this%Nactive_nh4_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nnonmyc_no3', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nnonmyc_no3_patch) + call set_missing_vals_to_constant(this%Nnonmyc_no3_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nnonmyc_nh4', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nnonmyc_nh4_patch) + call set_missing_vals_to_constant(this%Nnonmyc_nh4_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nam_no3', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nam_no3_patch) + call set_missing_vals_to_constant(this%Nam_no3_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nam_nh4', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nam_nh4_patch) + call set_missing_vals_to_constant(this%Nam_nh4_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Necm_no3', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Necm_no3_patch) + call set_missing_vals_to_constant(this%Necm_no3_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Necm_nh4', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Necm_nh4_patch) + call set_missing_vals_to_constant(this%Necm_nh4_patch, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='Npassive', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Npassive_patch) + call set_missing_vals_to_constant(this%Npassive_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nfix', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nfix_patch) + call set_missing_vals_to_constant(this%Nfix_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nretrans', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nretrans_patch) + call set_missing_vals_to_constant(this%Nretrans_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nretrans_org', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nretrans_org_patch) + call set_missing_vals_to_constant(this%Nretrans_org_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nretrans_season', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nretrans_season_patch) + call set_missing_vals_to_constant(this%Nretrans_season_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nretrans_stress', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nretrans_stress_patch) + call set_missing_vals_to_constant(this%Nretrans_stress_patch, 0._r8) + + call restartvar(ncid=ncid, flag=flag, varname='Nuptake', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%Nuptake_patch) + call set_missing_vals_to_constant(this%Nuptake_patch, 0._r8) + end if +! End BACKWARDS_COMPATIBILITY(wrw, 2018-06-28) re. issue #426 + + end subroutine Restart + + !----------------------------------------------------------------------- + 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 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 + + !----------------------------------------------------------------------- + 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 + +end module CNVegNitrogenFluxType + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegNitrogenStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegNitrogenStateType.F90 new file mode 100644 index 000000000..3bec5b3fa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegNitrogenStateType.F90 @@ -0,0 +1,2497 @@ +module CNVegNitrogenStateType + +#include "shr_assert.h" + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : isnan => shr_infnan_isnan, nan => shr_infnan_nan, assignment(=) + 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 landunit_varcon , only : istcrop, istsoil + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_century_decomp + use clm_varctl , only : iulog, override_bgc_restart_mismatch_dump + use clm_varctl , only : use_crop, use_matrixcn + use CNSharedParamsMod , only : use_fun + use decompMod , only : bounds_type + use pftconMod , only : npcropmin, noveg, pftcon + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use abortutils , only : endrun + use spmdMod , only : masterproc + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use dynPatchStateUpdaterMod, only : patch_state_updater_type + use CNSpeciesMod , only : CN_SPECIES_N + use CNVegComputeSeedMod, only : ComputeSeedAmounts + ! + ! !PUBLIC TYPES: + implicit none + + private + + + ! + 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 + contains + + procedure , public :: Init + procedure , public :: Restart + procedure , public :: SetValues + procedure , public :: ZeroDWT + procedure , public :: Summary => Summary_nitrogenstate + procedure , public :: DynamicPatchAdjustments ! adjust state variables when patch areas change + procedure , private :: InitAllocate + procedure , private :: InitHistory + procedure , private :: InitCold + + end type cnveg_nitrogenstate_type + !------------------------------------------------------------------------ + + ! !PRIVATE DATA: + character(len=*), parameter :: sourcefile = & + __FILE__ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, & + leafc_patch, leafc_storage_patch, frootc_patch, frootc_storage_patch, deadstemc_patch) + + class(cnveg_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: leafc_patch (bounds%begp:) + real(r8) , intent(in) :: leafc_storage_patch (bounds%begp:) + real(r8) , intent(in) :: frootc_patch (bounds%begp:) + real(r8) , intent(in) :: frootc_storage_patch (bounds%begp:) + real(r8) , intent(in) :: deadstemc_patch (bounds%begp:) + + call this%InitAllocate (bounds ) + call this%InitHistory (bounds) + call this%InitCold ( bounds, & + leafc_patch, leafc_storage_patch, frootc_patch, frootc_storage_patch, deadstemc_patch) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !ARGUMENTS: + class (cnveg_nitrogenstate_type) :: 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%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 (:) = nan + allocate(this%totn_patch (begp:endp)) ; this%totn_patch (:) = nan + + 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 (:) = nan + 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 + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! add history fields for all CN variables, always set as default='inactive' + ! + ! !USES: + use histFileMod, only : hist_addfld1d + ! + ! !ARGUMENTS: + class(cnveg_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: k,l,ii,jj + integer :: begp,endp + integer :: begc,endc + integer :: begg,endg + character(24) :: fieldname + character(100) :: longname + real(r8), pointer :: data1dptr(:) ! temp. pointer for slicing larger arrays + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + + !------------------------------- + ! patch state variables + !------------------------------- + + if (use_crop) then + this%grainn_patch(begp:endp) = spval + call hist_addfld1d (fname='GRAINN', units='gN/m^2', & + avgflag='A', long_name='grain N', & + ptr_patch=this%grainn_patch) + call hist_addfld1d (fname='CROPSEEDN_DEFICIT', units='gN/m^2', & + avgflag='A', long_name='N used for crop seed that needs to be repaid', & + ptr_patch=this%cropseedn_deficit_patch, default='inactive') + end if + + this%leafn_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN', units='gN/m^2', & + avgflag='A', long_name='leaf N', & + ptr_patch=this%leafn_patch) + + this%leafn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_STORAGE', units='gN/m^2', & + avgflag='A', long_name='leaf N storage', & + ptr_patch=this%leafn_storage_patch, default='inactive') + + this%leafn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_XFER', units='gN/m^2', & + avgflag='A', long_name='leaf N transfer', & + ptr_patch=this%leafn_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_leafn_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_CAP', units='gN/m^2', & + avgflag='I', long_name='leaf N capacity', & + ptr_patch=this%matrix_cap_leafn_patch) + + this%matrix_cap_leafn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_STORAGE_CAP', units='gN/m^2', & + avgflag='I', long_name='leaf N storage capacity', & + ptr_patch=this%matrix_cap_leafn_storage_patch, default='inactive') + + this%matrix_cap_leafn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_XFER_CAP', units='gN/m^2', & + avgflag='I', long_name='leaf N transfer capacity', & + ptr_patch=this%matrix_cap_leafn_xfer_patch, default='inactive') + + end if + + if ( use_fun ) then + this%leafn_storage_xfer_acc_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFN_STORAGE_XFER_ACC', units='gN/m^2', & + avgflag='A', long_name='Accmulated leaf N transfer', & + ptr_patch=this%leafn_storage_xfer_acc_patch, default='inactive') + + this%storage_ndemand_patch(begp:endp) = spval + call hist_addfld1d (fname='STORAGE_NDEMAND', units='gN/m^2', & + avgflag='A', long_name='N demand during the offset period', & + ptr_patch=this%storage_ndemand_patch, default='inactive') + end if + + this%frootn_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN', units='gN/m^2', & + avgflag='A', long_name='fine root N', & + ptr_patch=this%frootn_patch) + + this%frootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN_STORAGE', units='gN/m^2', & + avgflag='A', long_name='fine root N storage', & + ptr_patch=this%frootn_storage_patch, default='inactive') + + this%frootn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN_XFER', units='gN/m^2', & + avgflag='A', long_name='fine root N transfer', & + ptr_patch=this%frootn_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_frootn_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN_CAP', units='gN/m^2', & + avgflag='I', long_name='fine root N capacity', & + ptr_patch=this%matrix_cap_frootn_patch) + + this%matrix_cap_frootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN_STORAGE_CAP', units='gN/m^2', & + avgflag='I', long_name='fine root N storage capacity', & + ptr_patch=this%matrix_cap_frootn_storage_patch, default='inactive') + + this%matrix_cap_frootn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='FROOTN_XFER_CAP', units='gN/m^2', & + avgflag='I', long_name='fine root N transfer capacity', & + ptr_patch=this%matrix_cap_frootn_xfer_patch, default='inactive') + + end if + + this%livestemn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN', units='gN/m^2', & + avgflag='A', long_name='live stem N', & + ptr_patch=this%livestemn_patch) + + this%livestemn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_STORAGE', units='gN/m^2', & + avgflag='A', long_name='live stem N storage', & + ptr_patch=this%livestemn_storage_patch, default='inactive') + + this%livestemn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_XFER', units='gN/m^2', & + avgflag='A', long_name='live stem N transfer', & + ptr_patch=this%livestemn_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_livestemn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_CAP', units='gN/m^2', & + avgflag='I', long_name='live stem N capacity', & + ptr_patch=this%matrix_cap_livestemn_patch) + + this%matrix_cap_livestemn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_STORAGE_CAP', units='gN/m^2', & + avgflag='I', long_name='live stem N storage capacity', & + ptr_patch=this%matrix_cap_livestemn_storage_patch, default='inactive') + + this%matrix_cap_livestemn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVESTEMN_XFER_CAP', units='gN/m^2', & + avgflag='I', long_name='live stem N transfer capacity', & + ptr_patch=this%matrix_cap_livestemn_xfer_patch, default='inactive') + + end if + + this%deadstemn_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMN', units='gN/m^2', & + avgflag='A', long_name='dead stem N', & + ptr_patch=this%deadstemn_patch) + + this%deadstemn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMN_STORAGE', units='gN/m^2', & + avgflag='A', long_name='dead stem N storage', & + ptr_patch=this%deadstemn_storage_patch, default='inactive') + + this%deadstemn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMN_XFER', units='gN/m^2', & + avgflag='A', long_name='dead stem N transfer', & + ptr_patch=this%deadstemn_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_deadstemn_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMN_CAP', units='gN/m^2', & + avgflag='I', long_name='dead stem N capacity', & + ptr_patch=this%matrix_cap_deadstemn_patch) + + this%matrix_cap_deadstemn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMN_STORAGE_CAP', units='gN/m^2', & + avgflag='I', long_name='dead stem N storage capacity', & + ptr_patch=this%matrix_cap_deadstemn_storage_patch, default='inactive') + + this%matrix_cap_deadstemn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADSTEMN_XFER_CAP', units='gN/m^2', & + avgflag='I', long_name='dead stem N transfer capacity', & + ptr_patch=this%matrix_cap_deadstemn_xfer_patch, default='inactive') + + end if + + this%livecrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN', units='gN/m^2', & + avgflag='A', long_name='live coarse root N', & + ptr_patch=this%livecrootn_patch) + + this%livecrootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_STORAGE', units='gN/m^2', & + avgflag='A', long_name='live coarse root N storage', & + ptr_patch=this%livecrootn_storage_patch, default='inactive') + + this%livecrootn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_XFER', units='gN/m^2', & + avgflag='A', long_name='live coarse root N transfer', & + ptr_patch=this%livecrootn_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_livecrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_CAP', units='gN/m^2', & + avgflag='I', long_name='live coarse root N capacity', & + ptr_patch=this%matrix_cap_livecrootn_patch) + + this%matrix_cap_livecrootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_STORAGE_CAP', units='gN/m^2', & + avgflag='I', long_name='live coarse root N storage capacity', & + ptr_patch=this%matrix_cap_livecrootn_storage_patch, default='inactive') + + this%matrix_cap_livecrootn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='LIVECROOTN_XFER_CAP', units='gN/m^2', & + avgflag='I', long_name='live coarse root N transfer capacity', & + ptr_patch=this%matrix_cap_livecrootn_xfer_patch, default='inactive') + + end if + + this%deadcrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTN', units='gN/m^2', & + avgflag='A', long_name='dead coarse root N', & + ptr_patch=this%deadcrootn_patch) + + this%deadcrootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTN_STORAGE', units='gN/m^2', & + avgflag='A', long_name='dead coarse root N storage', & + ptr_patch=this%deadcrootn_storage_patch, default='inactive') + + this%deadcrootn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTN_XFER', units='gN/m^2', & + avgflag='A', long_name='dead coarse root N transfer', & + ptr_patch=this%deadcrootn_xfer_patch, default='inactive') + + if(use_matrixcn)then + this%matrix_cap_deadcrootn_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTN_CAP', units='gN/m^2', & + avgflag='I', long_name='dead coarse root N capacity', & + ptr_patch=this%matrix_cap_deadcrootn_patch) + + this%matrix_cap_deadcrootn_storage_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTN_STORAGE_CAP', units='gN/m^2', & + avgflag='I', long_name='dead coarse root N storage capacity', & + ptr_patch=this%matrix_cap_deadcrootn_storage_patch, default='inactive') + + this%matrix_cap_deadcrootn_xfer_patch(begp:endp) = spval + call hist_addfld1d (fname='DEADCROOTN_XFER_CAP', units='gN/m^2', & + avgflag='I', long_name='dead coarse root N transfer capacity', & + ptr_patch=this%matrix_cap_deadcrootn_xfer_patch, default='inactive') + + end if + + this%retransn_patch(begp:endp) = spval + call hist_addfld1d (fname='RETRANSN', units='gN/m^2', & + avgflag='A', long_name='plant pool of retranslocated N', & + ptr_patch=this%retransn_patch) + + this%npool_patch(begp:endp) = spval + call hist_addfld1d (fname='NPOOL', units='gN/m^2', & + avgflag='A', long_name='temporary plant N pool', & + ptr_patch=this%npool_patch) + + this%ntrunc_patch(begp:endp) = spval + call hist_addfld1d (fname='PFT_NTRUNC', units='gN/m^2', & + avgflag='A', long_name='patch-level sink for N truncation', & + ptr_patch=this%ntrunc_patch, default='inactive') + + this%dispvegn_patch(begp:endp) = spval + call hist_addfld1d (fname='DISPVEGN', units='gN/m^2', & + avgflag='A', long_name='displayed vegetation nitrogen', & + ptr_patch=this%dispvegn_patch) + + this%storvegn_patch(begp:endp) = spval + call hist_addfld1d (fname='STORVEGN', units='gN/m^2', & + avgflag='A', long_name='stored vegetation nitrogen', & + ptr_patch=this%storvegn_patch) + + this%totvegn_patch(begp:endp) = spval + call hist_addfld1d (fname='TOTVEGN', units='gN/m^2', & + avgflag='A', long_name='total vegetation nitrogen', & + ptr_patch=this%totvegn_patch) + + this%totn_patch(begp:endp) = spval + call hist_addfld1d (fname='TOTPFTN', units='gN/m^2', & + avgflag='A', long_name='total patch-level nitrogen', & + ptr_patch=this%totn_patch) + + !------------------------------- + ! column state variables + !------------------------------- + + this%seedn_grc(begg:endg) = spval + call hist_addfld1d (fname='SEEDN', units='gN/m^2', & + avgflag='A', long_name='pool for seeding new PFTs via dynamic landcover', & + ptr_gcell=this%seedn_grc) + + this%totecosysn_col(begc:endc) = spval + call hist_addfld1d (fname='TOTECOSYSN', units='gN/m^2', & + avgflag='A', long_name='total ecosystem N, excluding product pools', & + ptr_col=this%totecosysn_col) + + this%totn_col(begc:endc) = spval + call hist_addfld1d (fname='TOTCOLN', units='gN/m^2', & + avgflag='A', long_name='total column-level N, excluding product pools', & + ptr_col=this%totn_col) + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds, & + leafc_patch, leafc_storage_patch, frootc_patch, frootc_storage_patch, deadstemc_patch) + ! + ! !DESCRIPTION: + ! Initializes time varying variables used only in coupled carbon-nitrogen mode (CN): + ! + use clm_varctl , only : MM_Nuptake_opt + ! !ARGUMENTS: + class(cnveg_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: leafc_patch(bounds%begp:) + real(r8) , intent(in) :: leafc_storage_patch(bounds%begp:) + real(r8) , intent(in) :: frootc_patch(bounds%begp:) + real(r8) , intent(in) :: frootc_storage_patch(bounds%begp:) + real(r8) , intent(in) :: deadstemc_patch(bounds%begp:) + ! + ! !LOCAL VARIABLES: + integer :: fc,fp,g,l,c,p,j,k ! indices + integer :: num_special_col ! number of good values in special_col filter + integer :: num_special_patch ! number of good values in special_patch filter + integer :: special_col (bounds%endc-bounds%begc+1) ! special landunit filter - columns + integer :: special_patch (bounds%endp-bounds%begp+1) ! special landunit filter - patches + !------------------------------------------------------------------------ + + SHR_ASSERT_ALL_FL((ubound(leafc_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(leafc_storage_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(frootc_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(frootc_storage_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(deadstemc_patch) == (/bounds%endp/)), sourcefile, __LINE__) + + ! Set column filters + + num_special_patch = 0 + do p = bounds%begp,bounds%endp + l = patch%landunit(p) + if (lun%ifspecial(l)) then + num_special_patch = num_special_patch + 1 + special_patch(num_special_patch) = p + end if + end do + + ! Set patch filters + + num_special_col = 0 + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + num_special_col = num_special_col + 1 + special_col(num_special_col) = c + end if + end do + + !------------------------------------------- + ! initialize patch-level variables + !------------------------------------------- + + do p = bounds%begp,bounds%endp + + l = patch%landunit(p) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + + if (patch%itype(p) == noveg) then + this%leafn_patch(p) = 0._r8 + this%leafn_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafn_patch(p) = 0._r8 + this%matrix_cap_leafn_storage_patch(p) = 0._r8 + end if + if (MM_Nuptake_opt .eqv. .true.) then + this%frootn_patch(p) = 0._r8 + this%frootn_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootn_patch(p) = 0._r8 + this%matrix_cap_frootn_storage_patch(p) = 0._r8 + end if + end if + else + this%leafn_patch(p) = leafc_patch(p) / pftcon%leafcn(patch%itype(p)) + this%leafn_storage_patch(p) = leafc_storage_patch(p) / pftcon%leafcn(patch%itype(p)) + if(use_matrixcn)then + this%matrix_cap_leafn_patch(p) = leafc_patch(p) / pftcon%leafcn(patch%itype(p)) + this%matrix_cap_leafn_storage_patch(p) = leafc_storage_patch(p) / pftcon%leafcn(patch%itype(p)) + end if + if (MM_Nuptake_opt .eqv. .true.) then + this%frootn_patch(p) = frootc_patch(p) / pftcon%frootcn(patch%itype(p)) + this%frootn_storage_patch(p) = frootc_storage_patch(p) / pftcon%frootcn(patch%itype(p)) + if(use_matrixcn)then + this%matrix_cap_frootn_patch(p) = frootc_patch(p) / pftcon%frootcn(patch%itype(p)) + this%matrix_cap_frootn_storage_patch(p) = frootc_storage_patch(p) / pftcon%frootcn(patch%itype(p)) + end if + end if + end if + + this%leafn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafn_xfer_patch(p) = 0._r8 + end if + + this%leafn_storage_xfer_acc_patch(p) = 0._r8 + this%storage_ndemand_patch(p) = 0._r8 + + if ( use_crop )then + this%grainn_patch(p) = 0._r8 + this%grainn_storage_patch(p) = 0._r8 + this%grainn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_grainn_patch(p) = 0._r8 + this%matrix_cap_grainn_storage_patch(p) = 0._r8 + this%matrix_cap_grainn_xfer_patch(p) = 0._r8 + end if + this%cropseedn_deficit_patch(p) = 0._r8 + end if + if (MM_Nuptake_opt .eqv. .false.) then ! if not running in floating CN ratio option + this%frootn_patch(p) = 0._r8 + this%frootn_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootn_patch(p) = 0._r8 + this%matrix_cap_frootn_storage_patch(p) = 0._r8 + end if + end if + this%frootn_xfer_patch(p) = 0._r8 + this%livestemn_patch(p) = 0._r8 + this%livestemn_storage_patch(p) = 0._r8 + this%livestemn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootn_xfer_patch(p) = 0._r8 + this%matrix_cap_livestemn_patch(p) = 0._r8 + this%matrix_cap_livestemn_storage_patch(p) = 0._r8 + this%matrix_cap_livestemn_xfer_patch(p) = 0._r8 + end if + + ! tree types need to be initialized with some stem mass so that + ! roughness length is not zero in canopy flux calculation + + if (pftcon%woody(patch%itype(p)) == 1._r8) then + this%deadstemn_patch(p) = deadstemc_patch(p) / pftcon%deadwdcn(patch%itype(p)) + if(use_matrixcn)then + this%matrix_cap_deadstemn_patch(p) = deadstemc_patch(p) / pftcon%deadwdcn(patch%itype(p)) + end if + else + this%deadstemn_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadstemn_patch(p) = 0._r8 + end if + end if + + this%deadstemn_storage_patch(p) = 0._r8 + this%deadstemn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadstemn_storage_patch(p) = 0._r8 + this%matrix_cap_deadstemn_xfer_patch(p) = 0._r8 + end if + + this%livecrootn_patch(p) = 0._r8 + this%livecrootn_storage_patch(p) = 0._r8 + this%livecrootn_xfer_patch(p) = 0._r8 + this%deadcrootn_patch(p) = 0._r8 + this%deadcrootn_storage_patch(p) = 0._r8 + this%deadcrootn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_livecrootn_patch(p) = 0._r8 + this%matrix_cap_livecrootn_storage_patch(p) = 0._r8 + this%matrix_cap_livecrootn_xfer_patch(p) = 0._r8 + this%matrix_cap_deadcrootn_patch(p) = 0._r8 + this%matrix_cap_deadcrootn_storage_patch(p) = 0._r8 + this%matrix_cap_deadcrootn_xfer_patch(p) = 0._r8 + end if + this%retransn_patch(p) = 0._r8 + this%npool_patch(p) = 0._r8 + this%ntrunc_patch(p) = 0._r8 + this%dispvegn_patch(p) = 0._r8 + this%storvegn_patch(p) = 0._r8 + this%totvegn_patch(p) = 0._r8 + this%totn_patch(p) = 0._r8 + + if(use_matrixcn)then + ! for matrix spin up and capacity calculation + this%leafn0_patch(p) = 1.e-30_r8 + this%leafn0_storage_patch(p) = 1.e-30_r8 + this%leafn0_xfer_patch(p) = 1.e-30_r8 + this%frootn0_patch(p) = 1.e-30_r8 + this%frootn0_storage_patch(p) = 1.e-30_r8 + this%frootn0_xfer_patch(p) = 1.e-30_r8 + this%livestemn0_patch(p) = 1.e-30_r8 + this%livestemn0_storage_patch(p) = 1.e-30_r8 + this%livestemn0_xfer_patch(p) = 1.e-30_r8 + this%deadstemn0_patch(p) = 1.e-30_r8 + this%deadstemn0_storage_patch(p) = 1.e-30_r8 + this%deadstemn0_xfer_patch(p) = 1.e-30_r8 + this%livecrootn0_patch(p) = 1.e-30_r8 + this%livecrootn0_storage_patch(p) = 1.e-30_r8 + this%livecrootn0_xfer_patch(p) = 1.e-30_r8 + this%deadcrootn0_patch(p) = 1.e-30_r8 + this%deadcrootn0_storage_patch(p) = 1.e-30_r8 + this%deadcrootn0_xfer_patch(p) = 1.e-30_r8 + this%grainn0_patch(p) = 1.e-30_r8 + this%grainn0_storage_patch(p) = 1.e-30_r8 + this%grainn0_xfer_patch(p) = 1.e-30_r8 + this%retransn0_patch(p) = 1.e-30_r8 + + this%leafn_SASUsave_patch(p) = 0._r8 + this%leafn_storage_SASUsave_patch(p) = 0._r8 + this%leafn_xfer_SASUsave_patch(p) = 0._r8 + this%frootn_SASUsave_patch(p) = 0._r8 + this%frootn_storage_SASUsave_patch(p) = 0._r8 + this%frootn_xfer_SASUsave_patch(p) = 0._r8 + this%livestemn_SASUsave_patch(p) = 0._r8 + this%livestemn_storage_SASUsave_patch(p) = 0._r8 + this%livestemn_xfer_SASUsave_patch(p) = 0._r8 + this%deadstemn_SASUsave_patch(p) = 0._r8 + this%deadstemn_storage_SASUsave_patch(p) = 0._r8 + this%deadstemn_xfer_SASUsave_patch(p) = 0._r8 + this%livecrootn_SASUsave_patch(p) = 0._r8 + this%livecrootn_storage_SASUsave_patch(p) = 0._r8 + this%livecrootn_xfer_SASUsave_patch(p) = 0._r8 + this%deadcrootn_SASUsave_patch(p) = 0._r8 + this%deadcrootn_storage_SASUsave_patch(p) = 0._r8 + this%deadcrootn_xfer_SASUsave_patch(p) = 0._r8 + this%grainn_SASUsave_patch(p) = 0._r8 + this%grainn_storage_SASUsave_patch(p) = 0._r8 + + this%matrix_nalloc_leaf_acc_patch (p) = 0._r8 + this%matrix_nalloc_leafst_acc_patch (p) = 0._r8 + this%matrix_nalloc_froot_acc_patch (p) = 0._r8 + this%matrix_nalloc_frootst_acc_patch (p) = 0._r8 + this%matrix_nalloc_livestem_acc_patch (p) = 0._r8 + this%matrix_nalloc_livestemst_acc_patch (p) = 0._r8 + this%matrix_nalloc_deadstem_acc_patch (p) = 0._r8 + this%matrix_nalloc_deadstemst_acc_patch (p) = 0._r8 + this%matrix_nalloc_livecroot_acc_patch (p) = 0._r8 + this%matrix_nalloc_livecrootst_acc_patch (p) = 0._r8 + this%matrix_nalloc_deadcroot_acc_patch (p) = 0._r8 + this%matrix_nalloc_deadcrootst_acc_patch (p) = 0._r8 + this%matrix_nalloc_grain_acc_patch (p) = 0._r8 + this%matrix_nalloc_grainst_acc_patch (p) = 0._r8 + + this%matrix_ntransfer_leafst_to_leafxf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_leafxf_to_leaf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_frootst_to_frootxf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_frootxf_to_froot_acc_patch (p) = 0._r8 + this%matrix_ntransfer_livestemst_to_livestemxf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_livestemxf_to_livestem_acc_patch (p) = 0._r8 + this%matrix_ntransfer_deadstemst_to_deadstemxf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_deadstemxf_to_deadstem_acc_patch (p) = 0._r8 + this%matrix_ntransfer_livecrootst_to_livecrootxf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_livecrootxf_to_livecroot_acc_patch (p) = 0._r8 + this%matrix_ntransfer_deadcrootst_to_deadcrootxf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_deadcrootxf_to_deadcroot_acc_patch (p) = 0._r8 + this%matrix_ntransfer_grainst_to_grainxf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_grainxf_to_grain_acc_patch (p) = 0._r8 + this%matrix_ntransfer_livestem_to_deadstem_acc_patch (p) = 0._r8 + this%matrix_ntransfer_livecroot_to_deadcroot_acc_patch (p) = 0._r8 + + this%matrix_ntransfer_retransn_to_leaf_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_leafst_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_froot_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_frootst_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_livestem_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_livestemst_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_deadstem_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_deadstemst_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_livecroot_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_livecrootst_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_deadcroot_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_deadcrootst_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_grain_acc_patch (p) = 0._r8 + this%matrix_ntransfer_retransn_to_grainst_acc_patch (p) = 0._r8 + + this%matrix_ntransfer_leaf_to_retransn_acc_patch (p) = 0._r8 + this%matrix_ntransfer_froot_to_retransn_acc_patch (p) = 0._r8 + this%matrix_ntransfer_livestem_to_retransn_acc_patch (p) = 0._r8 + this%matrix_ntransfer_livecroot_to_retransn_acc_patch (p) = 0._r8 + + this%matrix_nturnover_leaf_acc_patch (p) = 0._r8 + this%matrix_nturnover_leafst_acc_patch (p) = 0._r8 + this%matrix_nturnover_leafxf_acc_patch (p) = 0._r8 + this%matrix_nturnover_froot_acc_patch (p) = 0._r8 + this%matrix_nturnover_frootst_acc_patch (p) = 0._r8 + this%matrix_nturnover_frootxf_acc_patch (p) = 0._r8 + this%matrix_nturnover_livestem_acc_patch (p) = 0._r8 + this%matrix_nturnover_livestemst_acc_patch (p) = 0._r8 + this%matrix_nturnover_livestemxf_acc_patch (p) = 0._r8 + this%matrix_nturnover_deadstem_acc_patch (p) = 0._r8 + this%matrix_nturnover_deadstemst_acc_patch (p) = 0._r8 + this%matrix_nturnover_deadstemxf_acc_patch (p) = 0._r8 + this%matrix_nturnover_livecroot_acc_patch (p) = 0._r8 + this%matrix_nturnover_livecrootst_acc_patch (p) = 0._r8 + this%matrix_nturnover_livecrootxf_acc_patch (p) = 0._r8 + this%matrix_nturnover_deadcroot_acc_patch (p) = 0._r8 + this%matrix_nturnover_deadcrootst_acc_patch (p) = 0._r8 + this%matrix_nturnover_deadcrootxf_acc_patch (p) = 0._r8 + this%matrix_nturnover_grain_acc_patch (p) = 0._r8 + this%matrix_nturnover_grainst_acc_patch (p) = 0._r8 + this%matrix_nturnover_grainxf_acc_patch (p) = 0._r8 + this%matrix_nturnover_retransn_acc_patch (p) = 0._r8 + end if !use_matrixcn + end if + end do + + !------------------------------------------- + ! initialize column-level variables + !------------------------------------------- + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + ! total nitrogen pools + this%totecosysn_col(c) = 0._r8 + this%totn_p2c_col(c) = 0._r8 + this%totn_col(c) = 0._r8 + end if + end do + + + do g = bounds%begg, bounds%endg + this%seedn_grc(g) = 0._r8 + this%totn_grc(g) = 0._r8 + end do + + ! now loop through special filters and explicitly set the variables that + ! have to be in place for biogeophysics + + ! initialize fields for special filters + + call this%SetValues (& + num_patch=num_special_patch, filter_patch=special_patch, value_patch=0._r8, & + num_column=num_special_col, filter_column=special_col, value_column=0._r8) + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart ( this, bounds, ncid, flag, leafc_patch, & + leafc_storage_patch, frootc_patch, frootc_storage_patch, & + deadstemc_patch, filter_reseed_patch, num_reseed_patch, & + spinup_factor_deadwood ) + ! + ! !DESCRIPTION: + ! Read/write restart data + ! + ! !USES: + use restUtilMod + use ncdio_pio + use clm_varctl , only : spinup_state, use_cndv + use clm_time_manager , only : get_nstep, is_restart + use clm_varctl , only : MM_Nuptake_opt + + ! + ! !ARGUMENTS: + class (cnveg_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + type(file_desc_t) , intent(inout) :: ncid + character(len=*) , intent(in) :: flag !'read' or 'write' or 'define' + real(r8) , intent(in) :: leafc_patch(bounds%begp:) + real(r8) , intent(in) :: leafc_storage_patch(bounds%begp:) + real(r8) , intent(in) :: frootc_patch(bounds%begp:) + real(r8) , intent(in) :: frootc_storage_patch(bounds%begp:) + real(r8) , intent(in) :: deadstemc_patch(bounds%begp:) + integer , intent(in) :: filter_reseed_patch(:) + integer , intent(in) :: num_reseed_patch + real(r8) , intent(in) :: spinup_factor_deadwood + ! + ! !LOCAL VARIABLES: + integer :: i, p, l + logical :: readvar + real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays + character(len=128) :: varname ! temporary + logical :: exit_spinup = .false. + logical :: enter_spinup = .false. + integer :: idata + + ! spinup state as read from restart file, for determining whether to enter or exit spinup mode. + integer :: restart_file_spinup_state + + !------------------------------------------------------------------------ + + !-------------------------------- + ! patch nitrogen state variables + !-------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='leafn', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafn_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafn_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafn_xfer_patch) +!matrix + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='leafn_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafn_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafn_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_leafn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafn0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafn0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafn0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafn0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafn0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafn0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_leaf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_leafst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_leafst_to_leafxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_leafst_to_leafxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_leafxf_to_leaf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_leafxf_to_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_restransn_to_leaf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_restransn_to_leafst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_leaf_to_retransn_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_leaf_to_retransn_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_leaf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_leaf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_leafst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_leafst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_leafxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_leafxf_acc_patch) + end if + + if ( use_fun ) then + call restartvar(ncid=ncid, flag=flag, varname='leafn_storage_xfer_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafn_storage_xfer_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='storage_ndemand', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%storage_ndemand_patch) + end if + + + call restartvar(ncid=ncid, flag=flag, varname='frootn', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootn_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootn_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootn_xfer_patch) + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='frootn_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootn_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootn_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_frootn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootn0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootn0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootn0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootn0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='frootn0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frootn0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_froot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_frootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_frootst_to_frootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_frootst_to_frootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_frootxf_to_froot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_frootxf_to_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_froot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_frootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_froot_to_retransn_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_froot_to_retransn_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_froot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_froot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_frootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_frootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_frootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_frootxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='livestemn', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemn_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemn_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootn_xfer_patch) + + if(use_matrixcn)then + call restartvar(ncid=ncid, flag=flag, varname='livestemn_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemn_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemn_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livestemn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadstemn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_livecrootn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn_storage_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn_xfer_cap', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_deadcrootn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemn0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemn0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemn0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemn0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livestemn0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livestemn0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_livestem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_livestemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_livestemst_to_livestemxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_livestemst_to_livestemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_livestemxf_to_livestem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_livestemxf_to_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_livestem_to_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_livestem_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_livestem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_livestemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_livestem_to_retransn_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_livestem_to_retransn_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_livestem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_livestem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_livestemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_livestemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_livestemxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_livestemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemn0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemn0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadstemn0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadstemn0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_deadstemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_deadstemst_to_deadstemxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_deadstemst_to_deadstemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_deadstemxf_to_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_deadstemxf_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_deadstemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_deadstem_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_deadstem_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_deadstemst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_deadstemst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_deadstemxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_deadstemxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootn0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootn0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='livecrootn0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%livecrootn0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_livecroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_livecrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_livecrootst_to_livecrootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_livecrootst_to_livecrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_livecrootxf_to_livecroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_livecrootxf_to_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_livecroot_to_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_livecroot_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_livecroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_livecrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_livecroot_to_retransn_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_livecroot_to_retransn_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_livecroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_livecroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_livecrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_livecrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_livecrootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_livecrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootn0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn0_storage', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootn0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='deadcrootn0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%deadcrootn0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='retransn0', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%retransn0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_deadcrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_deadcrootst_to_deadcrootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_deadcrootst_to_deadcrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_deadcrootxf_to_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_deadcrootxf_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_deadcrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_deadcroot_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_deadcroot_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_deadcrootst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_deadcrootst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_deadcrootxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_deadcrootxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_retransn_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_retransn_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='retransn', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%retransn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='npool', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%npool_patch) + + call restartvar(ncid=ncid, flag=flag, varname='pft_ntrunc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ntrunc_patch) + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='grainn', xtype=ncd_double, & + dim1name='pft', long_name='grain N', units='gN/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainn_storage', xtype=ncd_double, & + dim1name='pft', long_name='grain N storage', units='gN/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainn_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainn_xfer', xtype=ncd_double, & + dim1name='pft', long_name='grain N transfer', units='gN/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainn_xfer_patch) + + if(use_matrixcn)then +! call restartvar(ncid=ncid, flag=flag, varname='grainn_cap', xtype=ncd_double, & +! dim1name='pft', long_name='grain N capacity', units='gN/m2', & +! interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_grainn_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='grainn_storage_cap', xtype=ncd_double, & +! dim1name='pft', long_name='grain N storage capacity', units='gN/m2', & +! interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_grainn_storage_patch) +! +! call restartvar(ncid=ncid, flag=flag, varname='grainn_xfer_cap', xtype=ncd_double, & +! dim1name='pft', long_name='grain N transfer capacity', units='gN/m2', & +! interpinic_flag='interp', readvar=readvar, data=this%matrix_cap_grainn_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainn0', xtype=ncd_double, & + dim1name='pft', long_name='grain N0', units='gN/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainn0_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainn0_storage', xtype=ncd_double, & + dim1name='pft', long_name='grain N0 storage', units='gN/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainn0_storage_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grainn0_xfer', xtype=ncd_double, & + dim1name='pft', long_name='grain N0 transfer', units='gN/m2', & + interpinic_flag='interp', readvar=readvar, data=this%grainn0_xfer_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_grain_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nalloc_grainst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nalloc_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_grainst_to_grainxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_grainst_to_grainxf_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_grainxf_to_grain_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_grainxf_to_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_grain_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_ntransfer_retransn_to_grainst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_ntransfer_retransn_to_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_grain_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_grain_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_grainst_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_grainst_acc_patch) + + call restartvar(ncid=ncid, flag=flag, varname='matrix_nturnover_grainxf_acc', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%matrix_nturnover_grainxf_acc_patch) + end if + + call restartvar(ncid=ncid, flag=flag, varname='cropseedn_deficit', xtype=ncd_double, & + dim1name='pft', long_name='pool for seeding new crop growth', units='gN/m2', & + interpinic_flag='interp', readvar=readvar, data=this%cropseedn_deficit_patch) + end if + + !-------------------------------- + ! gridcell nitrogen state variables + !-------------------------------- + + ! BACKWARDS_COMPATIBILITY(wjs, 2017-01-12) Naming this with a _g suffix in order to + ! distinguish it from the old column-level seedn restart variable + call restartvar(ncid=ncid, flag=flag, varname='seedn_g', xtype=ncd_double, & + dim1name='gridcell', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%seedn_grc) + + + if (flag == 'read') then + call restartvar(ncid=ncid, flag=flag, varname='spinup_state', xtype=ncd_int, & + long_name='Spinup state of the model that wrote this restart file: ' & + // ' 0 = normal model mode, 1 = AD spinup', units='', & + interpinic_flag='copy', readvar=readvar, data=idata) + + if (readvar) then + restart_file_spinup_state = idata + else + restart_file_spinup_state = spinup_state + if ( masterproc ) then + write(iulog,*) ' CNRest: WARNING! Restart file does not contain info ' & + // ' on spinup state used to generate the restart file. ' + write(iulog,*) ' Assuming the same as current setting: ', spinup_state + end if + end if + end if + + if (flag == 'read' .and. spinup_state /= restart_file_spinup_state .and. .not. use_cndv) then + if (spinup_state <= 1 .and. restart_file_spinup_state == 2 ) then + if ( masterproc ) write(iulog,*) ' CNRest: taking Dead wood N pools out of AD spinup mode' + exit_spinup = .true. + if ( masterproc ) write(iulog, *) 'Multiplying stemn and crootn by ', spinup_factor_deadwood, 'for exit spinup ' + do i = bounds%begp,bounds%endp + this%deadstemn_patch(i) = this%deadstemn_patch(i) * spinup_factor_deadwood + this%deadcrootn_patch(i) = this%deadcrootn_patch(i) * spinup_factor_deadwood + end do + else if (spinup_state == 2 .and. restart_file_spinup_state <= 1 ) then + if ( masterproc ) write(iulog,*) ' CNRest: taking Dead wood N pools into AD spinup mode' + enter_spinup = .true. + if ( masterproc ) write(iulog, *) 'Dividing stemn and crootn by ', spinup_factor_deadwood, 'for enter spinup ' + do i = bounds%begp,bounds%endp + this%deadstemn_patch(i) = this%deadstemn_patch(i) / spinup_factor_deadwood + this%deadcrootn_patch(i) = this%deadcrootn_patch(i) / spinup_factor_deadwood + end do + endif + + end if + ! Reseed dead plants + if ( flag == 'read' .and. num_reseed_patch > 0 )then + if ( masterproc ) write(iulog, *) 'Reseed dead plants for CNVegNitrogenState' + do i = 1, num_reseed_patch + p = filter_reseed_patch(i) + + l = patch%landunit(p) + + if (patch%itype(p) == noveg) then + this%leafn_patch(p) = 0._r8 + this%leafn_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafn_patch(p) = 0._r8 + this%matrix_cap_leafn_storage_patch(p) = 0._r8 + end if + if (MM_Nuptake_opt .eqv. .true.) then + this%frootn_patch(p) = 0._r8 + this%frootn_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootn_patch(p) = 0._r8 + this%matrix_cap_frootn_storage_patch(p) = 0._r8 + end if + end if + else + this%leafn_patch(p) = leafc_patch(p) / pftcon%leafcn(patch%itype(p)) + this%leafn_storage_patch(p) = leafc_storage_patch(p) / pftcon%leafcn(patch%itype(p)) + if(use_matrixcn)then + this%matrix_cap_leafn_patch(p) = leafc_patch(p) / pftcon%leafcn(patch%itype(p)) + this%matrix_cap_leafn_storage_patch(p) = leafc_storage_patch(p) / pftcon%leafcn(patch%itype(p)) + end if + if (MM_Nuptake_opt .eqv. .true.) then + this%frootn_patch(p) = frootc_patch(p) / pftcon%frootcn(patch%itype(p)) + this%frootn_storage_patch(p) = frootc_storage_patch(p) / pftcon%frootcn(patch%itype(p)) + if(use_matrixcn)then + this%matrix_cap_frootn_patch(p) = frootc_patch(p) / pftcon%frootcn(patch%itype(p)) + this%matrix_cap_frootn_storage_patch(p) = frootc_storage_patch(p) / pftcon%frootcn(patch%itype(p)) + end if + end if + end if + + this%leafn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_leafn_xfer_patch(p) = 0._r8 + end if + + this%leafn_storage_xfer_acc_patch(p) = 0._r8 + this%storage_ndemand_patch(p) = 0._r8 + + if ( use_crop )then + this%grainn_patch(p) = 0._r8 + this%grainn_storage_patch(p) = 0._r8 + this%grainn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_grainn_patch(p) = 0._r8 + this%matrix_cap_grainn_storage_patch(p) = 0._r8 + this%matrix_cap_grainn_xfer_patch(p) = 0._r8 + end if + this%cropseedn_deficit_patch(p) = 0._r8 + end if + if (MM_Nuptake_opt .eqv. .false.) then ! if not running in floating CN ratio option + this%frootn_patch(p) = 0._r8 + this%frootn_storage_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootn_patch(p) = 0._r8 + this%matrix_cap_frootn_storage_patch(p) = 0._r8 + end if + end if + this%frootn_xfer_patch(p) = 0._r8 + this%livestemn_patch(p) = 0._r8 + this%livestemn_storage_patch(p) = 0._r8 + this%livestemn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_frootn_xfer_patch(p) = 0._r8 + this%matrix_cap_livestemn_patch(p) = 0._r8 + this%matrix_cap_livestemn_storage_patch(p) = 0._r8 + this%matrix_cap_livestemn_xfer_patch(p) = 0._r8 + end if + + ! tree types need to be initialized with some stem mass so that + ! roughness length is not zero in canopy flux calculation + + if (pftcon%woody(patch%itype(p)) == 1._r8) then + this%deadstemn_patch(p) = deadstemc_patch(p) / pftcon%deadwdcn(patch%itype(p)) + if(use_matrixcn)then + this%matrix_cap_deadstemn_patch(p) = deadstemc_patch(p) / pftcon%deadwdcn(patch%itype(p)) + end if + else + this%deadstemn_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadstemn_patch(p) = 0._r8 + end if + end if + + this%deadstemn_storage_patch(p) = 0._r8 + this%deadstemn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_deadstemn_storage_patch(p) = 0._r8 + this%matrix_cap_deadstemn_xfer_patch(p) = 0._r8 + end if + + this%livecrootn_patch(p) = 0._r8 + this%livecrootn_storage_patch(p) = 0._r8 + this%livecrootn_xfer_patch(p) = 0._r8 + this%deadcrootn_patch(p) = 0._r8 + this%deadcrootn_storage_patch(p) = 0._r8 + this%deadcrootn_xfer_patch(p) = 0._r8 + if(use_matrixcn)then + this%matrix_cap_livecrootn_patch(p) = 0._r8 + this%matrix_cap_livecrootn_storage_patch(p) = 0._r8 + this%matrix_cap_livecrootn_xfer_patch(p) = 0._r8 + this%matrix_cap_deadcrootn_patch(p) = 0._r8 + this%matrix_cap_deadcrootn_storage_patch(p) = 0._r8 + this%matrix_cap_deadcrootn_xfer_patch(p) = 0._r8 + end if + this%retransn_patch(p) = 0._r8 + this%npool_patch(p) = 0._r8 + this%ntrunc_patch(p) = 0._r8 + this%dispvegn_patch(p) = 0._r8 + this%storvegn_patch(p) = 0._r8 + this%totvegn_patch(p) = 0._r8 + this%totn_patch(p) = 0._r8 + + ! calculate totvegc explicitly so that it is available for the isotope + ! code on the first time step. + + this%totvegn_patch(p) = & + this%leafn_patch(p) + & + this%leafn_storage_patch(p) + & + this%leafn_xfer_patch(p) + & + this%frootn_patch(p) + & + this%frootn_storage_patch(p) + & + this%frootn_xfer_patch(p) + & + this%livestemn_patch(p) + & + this%livestemn_storage_patch(p) + & + this%livestemn_xfer_patch(p) + & + this%deadstemn_patch(p) + & + this%deadstemn_storage_patch(p) + & + this%deadstemn_xfer_patch(p) + & + this%livecrootn_patch(p) + & + this%livecrootn_storage_patch(p) + & + this%livecrootn_xfer_patch(p) + & + this%deadcrootn_patch(p) + & + this%deadcrootn_storage_patch(p) + & + this%deadcrootn_xfer_patch(p) + & + this%npool_patch(p) + + if ( use_crop )then + this%totvegn_patch(p) = & + this%totvegn_patch(p) + & + this%grainn_patch(p) + & + this%grainn_storage_patch(p) + & + this%grainn_xfer_patch(p) + end if + end do + end if + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine SetValues ( this, & + num_patch, filter_patch, value_patch, & + num_column, filter_column, value_column) + ! + ! !DESCRIPTION: + ! Set nitrogen state variables + ! + ! !ARGUMENTS: + class (cnveg_nitrogenstate_type) :: this + integer , intent(in) :: num_patch + 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 ! indices + !------------------------------------------------------------------------ + + do fi = 1,num_patch + i = filter_patch(fi) + + this%leafn_patch(i) = value_patch + this%leafn_storage_patch(i) = value_patch + this%leafn_xfer_patch(i) = value_patch + this%leafn_storage_xfer_acc_patch(i) = value_patch + this%frootn_patch(i) = value_patch + this%frootn_storage_patch(i) = value_patch + this%frootn_xfer_patch(i) = value_patch + this%livestemn_patch(i) = value_patch + this%livestemn_storage_patch(i) = value_patch + this%livestemn_xfer_patch(i) = value_patch + this%deadstemn_patch(i) = value_patch + this%deadstemn_storage_patch(i) = value_patch + this%deadstemn_xfer_patch(i) = value_patch + this%livecrootn_patch(i) = value_patch + this%livecrootn_storage_patch(i) = value_patch + this%livecrootn_xfer_patch(i) = value_patch + this%deadcrootn_patch(i) = value_patch + this%deadcrootn_storage_patch(i) = value_patch + this%deadcrootn_xfer_patch(i) = value_patch + if(use_matrixcn)then + this%matrix_cap_leafn_patch(i) = value_patch + this%matrix_cap_leafn_storage_patch(i) = value_patch + this%matrix_cap_leafn_xfer_patch(i) = value_patch + this%matrix_cap_frootn_patch(i) = value_patch + this%matrix_cap_frootn_storage_patch(i) = value_patch + this%matrix_cap_frootn_xfer_patch(i) = value_patch + this%matrix_cap_livestemn_patch(i) = value_patch + this%matrix_cap_livestemn_storage_patch(i) = value_patch + this%matrix_cap_livestemn_xfer_patch(i) = value_patch + this%matrix_cap_deadstemn_patch(i) = value_patch + this%matrix_cap_deadstemn_storage_patch(i) = value_patch + this%matrix_cap_deadstemn_xfer_patch(i) = value_patch + this%matrix_cap_livecrootn_patch(i) = value_patch + this%matrix_cap_livecrootn_storage_patch(i) = value_patch + this%matrix_cap_livecrootn_xfer_patch(i) = value_patch + this%matrix_cap_deadcrootn_patch(i) = value_patch + this%matrix_cap_deadcrootn_storage_patch(i) = value_patch + this%matrix_cap_deadcrootn_xfer_patch(i) = value_patch + + this%leafn0_patch(i) = value_patch + this%leafn0_storage_patch(i) = value_patch + this%leafn0_xfer_patch(i) = value_patch + this%frootn0_patch(i) = value_patch + this%frootn0_storage_patch(i) = value_patch + this%frootn0_xfer_patch(i) = value_patch + this%livestemn0_patch(i) = value_patch + this%livestemn0_storage_patch(i) = value_patch + this%livestemn0_xfer_patch(i) = value_patch + this%deadstemn0_patch(i) = value_patch + this%deadstemn0_storage_patch(i) = value_patch + this%deadstemn0_xfer_patch(i) = value_patch + this%livecrootn0_patch(i) = value_patch + this%livecrootn0_storage_patch(i) = value_patch + this%livecrootn0_xfer_patch(i) = value_patch + this%deadcrootn0_patch(i) = value_patch + this%deadcrootn0_storage_patch(i) = value_patch + this%deadcrootn0_xfer_patch(i) = value_patch + if ( use_crop )then + this%grainn0_patch(i) = value_patch + this%grainn0_storage_patch(i) = value_patch + this%grainn0_xfer_patch(i) = value_patch + end if + this%retransn0_patch(i) = value_patch + + this%matrix_nalloc_leaf_acc_patch(i) = value_patch + this%matrix_nalloc_leafst_acc_patch(i) = value_patch + this%matrix_nalloc_froot_acc_patch(i) = value_patch + this%matrix_nalloc_frootst_acc_patch(i) = value_patch + this%matrix_nalloc_livestem_acc_patch(i) = value_patch + this%matrix_nalloc_livestemst_acc_patch(i) = value_patch + this%matrix_nalloc_deadstem_acc_patch(i) = value_patch + this%matrix_nalloc_deadstemst_acc_patch(i) = value_patch + this%matrix_nalloc_livecroot_acc_patch(i) = value_patch + this%matrix_nalloc_livecrootst_acc_patch(i) = value_patch + this%matrix_nalloc_deadcroot_acc_patch(i) = value_patch + this%matrix_nalloc_deadcrootst_acc_patch(i) = value_patch + this%matrix_nalloc_grain_acc_patch(i) = value_patch + this%matrix_nalloc_grainst_acc_patch(i) = value_patch + + this%matrix_ntransfer_leafst_to_leafxf_acc_patch(i) = value_patch + this%matrix_ntransfer_leafxf_to_leaf_acc_patch(i) = value_patch + this%matrix_ntransfer_frootst_to_frootxf_acc_patch(i) = value_patch + this%matrix_ntransfer_frootxf_to_froot_acc_patch(i) = value_patch + this%matrix_ntransfer_livestemst_to_livestemxf_acc_patch(i) = value_patch + this%matrix_ntransfer_livestemxf_to_livestem_acc_patch(i) = value_patch + this%matrix_ntransfer_deadstemst_to_deadstemxf_acc_patch(i) = value_patch + this%matrix_ntransfer_deadstemxf_to_deadstem_acc_patch(i) = value_patch + this%matrix_ntransfer_livecrootst_to_livecrootxf_acc_patch(i) = value_patch + this%matrix_ntransfer_livecrootxf_to_livecroot_acc_patch(i) = value_patch + this%matrix_ntransfer_deadcrootst_to_deadcrootxf_acc_patch(i) = value_patch + this%matrix_ntransfer_deadcrootxf_to_deadcroot_acc_patch(i) = value_patch + if ( use_crop )then + this%matrix_ntransfer_grainst_to_grainxf_acc_patch(i) = value_patch + this%matrix_ntransfer_grainxf_to_grain_acc_patch(i) = value_patch + end if + this%matrix_ntransfer_livestem_to_deadstem_acc_patch(i) = value_patch + this%matrix_ntransfer_livecroot_to_deadcroot_acc_patch(i) = value_patch + + this%matrix_ntransfer_retransn_to_leaf_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_leafst_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_froot_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_frootst_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_livestem_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_livestemst_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_deadstem_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_deadstemst_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_livecroot_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_livecrootst_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_deadcroot_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_deadcrootst_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_grain_acc_patch(i) = value_patch + this%matrix_ntransfer_retransn_to_grainst_acc_patch(i) = value_patch + + this%matrix_ntransfer_leaf_to_retransn_acc_patch(i) = value_patch + this%matrix_ntransfer_froot_to_retransn_acc_patch(i) = value_patch + this%matrix_ntransfer_livestem_to_retransn_acc_patch(i) = value_patch + this%matrix_ntransfer_livecroot_to_retransn_acc_patch(i) = value_patch + + this%matrix_nturnover_leaf_acc_patch(i) = value_patch + this%matrix_nturnover_leafst_acc_patch(i) = value_patch + this%matrix_nturnover_leafxf_acc_patch(i) = value_patch + this%matrix_nturnover_froot_acc_patch(i) = value_patch + this%matrix_nturnover_frootst_acc_patch(i) = value_patch + this%matrix_nturnover_frootxf_acc_patch(i) = value_patch + this%matrix_nturnover_livestem_acc_patch(i) = value_patch + this%matrix_nturnover_livestemst_acc_patch(i) = value_patch + this%matrix_nturnover_livestemxf_acc_patch(i) = value_patch + this%matrix_nturnover_deadstem_acc_patch(i) = value_patch + this%matrix_nturnover_deadstemst_acc_patch(i) = value_patch + this%matrix_nturnover_deadstemxf_acc_patch(i) = value_patch + this%matrix_nturnover_livecroot_acc_patch(i) = value_patch + this%matrix_nturnover_livecrootst_acc_patch(i) = value_patch + this%matrix_nturnover_livecrootxf_acc_patch(i) = value_patch + this%matrix_nturnover_deadcroot_acc_patch(i) = value_patch + this%matrix_nturnover_deadcrootst_acc_patch(i) = value_patch + this%matrix_nturnover_deadcrootxf_acc_patch(i) = value_patch + this%matrix_nturnover_retransn_acc_patch(i) = value_patch + if ( use_crop )then + this%matrix_nturnover_grain_acc_patch(i) = value_patch + this%matrix_nturnover_grainst_acc_patch(i) = value_patch + this%matrix_nturnover_grainxf_acc_patch(i) = value_patch + end if + + end if + this%retransn_patch(i) = value_patch + this%npool_patch(i) = value_patch + this%ntrunc_patch(i) = value_patch + this%dispvegn_patch(i) = value_patch + this%storvegn_patch(i) = value_patch + this%totvegn_patch(i) = value_patch + this%totn_patch(i) = value_patch + end do + + if ( use_crop )then + do fi = 1,num_patch + i = filter_patch(fi) + this%grainn_patch(i) = value_patch + this%grainn_storage_patch(i) = value_patch + this%grainn_xfer_patch(i) = value_patch + this%cropseedn_deficit_patch(i) = value_patch + end do + end if + + do fi = 1,num_column + i = filter_column(fi) + + this%totecosysn_col(i) = value_column + this%totvegn_col(i) = value_column + this%totn_p2c_col(i) = value_column + this%totn_col(i) = value_column + end do + + end subroutine SetValues + + !----------------------------------------------------------------------- + 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 + + !----------------------------------------------------------------------- + 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 DynamicPatchAdjustments(this, bounds, & + num_soilp_with_inactive, filter_soilp_with_inactive, & + patch_state_updater, & + leafc_seed, deadstemc_seed, & + conv_nflux, wood_product_nflux, crop_product_nflux, & + dwt_frootn_to_litter, & + dwt_livecrootn_to_litter, & + dwt_deadcrootn_to_litter, & + dwt_leafn_seed, & + dwt_deadstemn_seed) + ! + ! !DESCRIPTION: + ! Adjust state variables and compute associated fluxes when patch areas change due to + ! dynamic landuse + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cnveg_nitrogenstate_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp_with_inactive ! number of points in filter + integer , intent(in) :: filter_soilp_with_inactive(:) ! soil patch filter that includes inactive points + type(patch_state_updater_type) , intent(in) :: patch_state_updater + real(r8) , intent(in) :: leafc_seed ! seed amount for leaf C + real(r8) , intent(in) :: deadstemc_seed ! seed amount for deadstem C + real(r8) , intent(inout) :: conv_nflux( bounds%begp: ) ! patch-level conversion N flux to atm (expressed per unit GRIDCELL area) + real(r8) , intent(inout) :: wood_product_nflux( bounds%begp: ) ! patch-level product N flux (expressed per unit GRIDCELL area) + real(r8) , intent(inout) :: crop_product_nflux( bounds%begp: ) ! patch-level crop product N flux (expressed per unit GRIDCELL area) + real(r8) , intent(inout) :: dwt_frootn_to_litter( bounds%begp: ) ! patch-level fine root N to litter (expressed per unit COLUMN area) + real(r8) , intent(inout) :: dwt_livecrootn_to_litter( bounds%begp: ) ! patch-level live coarse root N to litter (expressed per unit COLUMN area) + real(r8) , intent(inout) :: dwt_deadcrootn_to_litter( bounds%begp: ) ! patch-level live coarse root N to litter (expressed per unit COLUMN area) + real(r8) , intent(inout) :: dwt_leafn_seed( bounds%begp: ) ! patch-level mass gain due to seeding of new area: leaf N (expressed per unit GRIDCELL area) + real(r8) , intent(inout) :: dwt_deadstemn_seed( bounds%begp: ) ! patch-level mass gain due to seeding of new area: deadstem N (expressed per unit GRIDCELL area) + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + + logical :: old_weight_was_zero(bounds%begp:bounds%endp) + logical :: patch_grew(bounds%begp:bounds%endp) + + ! The following are only set for growing patches: + real(r8) :: seed_leafn_patch(bounds%begp:bounds%endp) + real(r8) :: seed_leafn_storage_patch(bounds%begp:bounds%endp) + real(r8) :: seed_leafn_xfer_patch(bounds%begp:bounds%endp) + real(r8) :: seed_deadstemn_patch(bounds%begp:bounds%endp) + + character(len=*), parameter :: subname = 'DynamicPatchAdjustments' + !----------------------------------------------------------------------- + + begp = bounds%begp + endp = bounds%endp + + SHR_ASSERT_ALL_FL((ubound(conv_nflux) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(wood_product_nflux) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(crop_product_nflux) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_frootn_to_litter) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_livecrootn_to_litter) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_deadcrootn_to_litter) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_leafn_seed) == (/endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dwt_deadstemn_seed) == (/endp/)), sourcefile, __LINE__) + + old_weight_was_zero = patch_state_updater%old_weight_was_zero(bounds) + patch_grew = patch_state_updater%patch_grew(bounds) + + call ComputeSeedAmounts(bounds, & + num_soilp_with_inactive, filter_soilp_with_inactive, & + species = CN_SPECIES_N, & + leafc_seed = leafc_seed, & + deadstemc_seed = deadstemc_seed, & + leaf_patch = this%leafn_patch(begp:endp), & + leaf_storage_patch = this%leafn_storage_patch(begp:endp), & + leaf_xfer_patch = this%leafn_xfer_patch(begp:endp), & + + ! Calculations only needed for patches that grew: + compute_here_patch = patch_grew(begp:endp), & + + ! For patches that previously had zero area, ignore the current state for the + ! sake of computing leaf proportions: + ignore_current_state_patch = old_weight_was_zero(begp:endp), & + + seed_leaf_patch = seed_leafn_patch(begp:endp), & + seed_leaf_storage_patch = seed_leafn_storage_patch(begp:endp), & + seed_leaf_xfer_patch = seed_leafn_xfer_patch(begp:endp), & + seed_deadstem_patch = seed_deadstemn_patch(begp:endp)) + + call update_patch_state( & + var = this%leafn_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp), & + seed = seed_leafn_patch(begp:endp), & + seed_addition = dwt_leafn_seed(begp:endp)) + + call update_patch_state( & + var = this%leafn_storage_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp), & + seed = seed_leafn_storage_patch(begp:endp), & + seed_addition = dwt_leafn_seed(begp:endp)) + + call update_patch_state( & + var = this%leafn_xfer_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp), & + seed = seed_leafn_xfer_patch(begp:endp), & + seed_addition = dwt_leafn_seed(begp:endp)) + + call update_patch_state( & + var = this%frootn_patch(begp:endp), & + flux_out_col_area = dwt_frootn_to_litter(begp:endp)) + + call update_patch_state( & + var = this%frootn_storage_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%frootn_xfer_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%livestemn_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%livestemn_storage_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%livestemn_xfer_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call patch_state_updater%update_patch_state_partition_flux_by_type(bounds, & + num_soilp_with_inactive, filter_soilp_with_inactive, & + flux1_fraction_by_pft_type = pftcon%pconv, & + var = this%deadstemn_patch(begp:endp), & + flux1_out = conv_nflux(begp:endp), & + flux2_out = wood_product_nflux(begp:endp), & + seed = seed_deadstemn_patch(begp:endp), & + seed_addition = dwt_deadstemn_seed(begp:endp)) + + call update_patch_state( & + var = this%deadstemn_storage_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%deadstemn_xfer_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%livecrootn_patch(begp:endp), & + flux_out_col_area = dwt_livecrootn_to_litter(begp:endp)) + + call update_patch_state( & + var = this%livecrootn_storage_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%livecrootn_xfer_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%deadcrootn_patch(begp:endp), & + flux_out_col_area = dwt_deadcrootn_to_litter(begp:endp)) + + call update_patch_state( & + var = this%deadcrootn_storage_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%deadcrootn_xfer_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%retransn_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%npool_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%ntrunc_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + if (use_crop) then + call update_patch_state( & + var = this%grainn_patch(begp:endp), & + flux_out_grc_area = crop_product_nflux(begp:endp)) + + call update_patch_state( & + var = this%grainn_storage_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + call update_patch_state( & + var = this%grainn_xfer_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + + if (use_crop) then + ! This is a negative pool. So any deficit that we haven't repaid gets sucked out + ! of the atmosphere. + call update_patch_state( & + var = this%cropseedn_deficit_patch(begp:endp), & + flux_out_grc_area = conv_nflux(begp:endp)) + end if + end if + + contains + subroutine update_patch_state(var, flux_out_col_area, flux_out_grc_area, & + seed, seed_addition) + ! Wraps call to update_patch_state, in order to remove duplication + real(r8), intent(inout) :: var( bounds%begp: ) + real(r8), intent(inout), optional :: flux_out_col_area( bounds%begp: ) + real(r8), intent(inout), optional :: flux_out_grc_area( bounds%begp: ) + real(r8), intent(in), optional :: seed( bounds%begp: ) + real(r8), intent(inout), optional :: seed_addition( bounds%begp: ) + + call patch_state_updater%update_patch_state(bounds, & + num_soilp_with_inactive, filter_soilp_with_inactive, & + var = var, & + flux_out_col_area = flux_out_col_area, & + flux_out_grc_area = flux_out_grc_area, & + seed = seed, & + seed_addition = seed_addition) + end subroutine update_patch_state + + + end subroutine DynamicPatchAdjustments + +end module CNVegNitrogenStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegStateType.F90 new file mode 100644 index 000000000..afdfa190a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegStateType.F90 @@ -0,0 +1,948 @@ +module CNVegStateType + + use shr_kind_mod , only : r8 => shr_kind_r8 + 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 clm_varpar , only : nlevsno, nlevgrnd, nlevlak, nlevsoi + use clm_varctl , only : use_cn, iulog, fsurdat, use_crop, use_cndv + use clm_varcon , only : spval, ispval, grlnd + use landunit_varcon, only : istsoil, istcrop + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use AnnualFluxDribbler, only : annual_flux_dribbler_type, annual_flux_dribbler_patch + use dynSubgridControlMod, only : get_for_testing_allow_non_annual_changes + ! + ! !PUBLIC TYPES: + implicit none + private + ! + ! !PUBLIC TYPES: + 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 + procedure, public :: Restart + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type cnveg_state_type + !------------------------------------------------------------------------ + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(cnveg_state_type) :: this + type(bounds_type), intent(in) :: bounds + + call this%InitAllocate ( bounds ) + if (use_cn) then + call this%InitHistory ( bounds ) + end if + call this%InitCold ( bounds ) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(cnveg_state_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + logical :: allows_non_annual_delta + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + ! Note that we set allows_non_annual_delta to false because we expect land cover + ! change to be applied entirely at the start of the year. Currently the fire code + ! appears to assume that the land cover change rate is constant throughout the year, + ! in this code (which is accompanied by the comment, 'land cover conversion in CLM4.5 + ! is the same for each timestep except for the beginning'): + ! + ! if( kmo == 1 .and. kda == 1 .and. mcsec == dt)then + ! lfc(c) = dtrotr_col(c)*dayspyr*secspday/dt + ! end if + ! + ! so setting allows_non_annual_delta to .false. helps ensure that remains true. + ! + ! However, we do keep allows_non_annual_delta = .true. if running with CNDV, because + ! (in contrast with other land cover change) CNDV currently still interpolates land + ! cover change throughout the year. Note that there is therefore an inconsistency with + ! the fire code if we're using CNDV, due to the way the annual flux dribbler works: + ! The dwt generated by CNDV on the first time step of the year is dribbled throughout + ! the year by dwt_dribbler_patch, but the CNDV dwt on every other time step comes at + ! its full value. So there will be a lower dwt in the first time step of the year + ! relative to every other time step of the year. If CNDV is the main contributor to + ! dwt, I think this can lead to a large violation of the above assumption of constant + ! dwt in the fire code. However, the fire code doesn't seem designed to work with + ! CNDV at all (because land cover change is assumed to be associated with + ! deforestation, not natural changes in areas), so maybe this inconsistency is the + ! least of the problem: see bug 2392. + if (get_for_testing_allow_non_annual_changes()) then + allows_non_annual_delta = .true. + else if (use_cndv) then + allows_non_annual_delta = .true. + else + allows_non_annual_delta = .false. + end if + this%dwt_dribbler_patch = annual_flux_dribbler_patch( & + bounds = bounds, & + name = 'dwt', & + units = 'fractional area', & + allows_non_annual_delta = allows_non_annual_delta) + + 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 (:) = nan + + 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 + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use histFileMod , only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp, no_snow_normal + ! + ! !ARGUMENTS: + class(cnveg_state_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + character(8) :: vr_suffix + character(10) :: active + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + if ( use_crop) then + this%gddmaturity_patch(begp:endp) = spval + call hist_addfld1d (fname='GDDHARV', units='ddays', & + avgflag='A', long_name='Growing degree days (gdd) needed to harvest', & + ptr_patch=this%gddmaturity_patch, default='inactive') + end if + + this%lfc2_col(begc:endc) = spval + call hist_addfld1d (fname='LFC2', units='per sec', & + avgflag='A', long_name='conversion area fraction of BET and BDT that burned', & + ptr_col=this%lfc2_col) + + this%annsum_counter_col(begc:endc) = spval + call hist_addfld1d (fname='ANNSUM_COUNTER', units='s', & + avgflag='A', long_name='seconds since last annual accumulator turnover', & + ptr_col=this%annsum_counter_col, default='inactive') + + this%annavg_t2m_col(begc:endc) = spval + call hist_addfld1d (fname='CANNAVG_T2M', units='K', & + avgflag='A', long_name='annual average of 2m air temperature', & + ptr_col=this%annavg_t2m_col, default='inactive') + + this%nfire_col(begc:endc) = spval + call hist_addfld1d (fname='NFIRE', units='counts/km2/sec', & + avgflag='A', long_name='fire counts valid only in Reg.C', & + ptr_col=this%nfire_col) + + this%farea_burned_col(begc:endc) = spval + call hist_addfld1d (fname='FAREA_BURNED', units='s-1', & + avgflag='A', long_name='timestep fractional area burned', & + ptr_col=this%farea_burned_col) + + this%baf_crop_col(begc:endc) = spval + call hist_addfld1d (fname='BAF_CROP', units='s-1', & + avgflag='A', long_name='fractional area burned for crop', & + ptr_col=this%baf_crop_col) + + this%baf_peatf_col(begc:endc) = spval + call hist_addfld1d (fname='BAF_PEATF', units='s-1', & + avgflag='A', long_name='fractional area burned in peatland', & + ptr_col=this%baf_peatf_col) + + this%annavg_t2m_patch(begp:endp) = spval + call hist_addfld1d (fname='ANNAVG_T2M', units='K', & + avgflag='A', long_name='annual average 2m air temperature', & + ptr_patch=this%annavg_t2m_patch, default='inactive') + + this%tempavg_t2m_patch(begp:endp) = spval + call hist_addfld1d (fname='TEMPAVG_T2M', units='K', & + avgflag='A', long_name='temporary average 2m air temperature', & + ptr_patch=this%tempavg_t2m_patch, default='inactive') + + this%dormant_flag_patch(begp:endp) = spval + call hist_addfld1d (fname='DORMANT_FLAG', units='none', & + avgflag='A', long_name='dormancy flag', & + ptr_patch=this%dormant_flag_patch, default='inactive') + + this%days_active_patch(begp:endp) = spval + call hist_addfld1d (fname='DAYS_ACTIVE', units='days', & + avgflag='A', long_name='number of days since last dormancy', & + ptr_patch=this%days_active_patch, default='inactive') + + this%onset_flag_patch(begp:endp) = spval + call hist_addfld1d (fname='ONSET_FLAG', units='none', & + avgflag='A', long_name='onset flag', & + ptr_patch=this%onset_flag_patch, default='inactive') + + this%onset_counter_patch(begp:endp) = spval + call hist_addfld1d (fname='ONSET_COUNTER', units='days', & + avgflag='A', long_name='onset days counter', & + ptr_patch=this%onset_counter_patch, default='inactive') + + this%onset_gddflag_patch(begp:endp) = spval + call hist_addfld1d (fname='ONSET_GDDFLAG', units='none', & + avgflag='A', long_name='onset flag for growing degree day sum', & + ptr_patch=this%onset_gddflag_patch, default='inactive') + + this%onset_fdd_patch(begp:endp) = spval + call hist_addfld1d (fname='ONSET_FDD', units='C degree-days', & + avgflag='A', long_name='onset freezing degree days counter', & + ptr_patch=this%onset_fdd_patch, default='inactive') + + this%onset_gdd_patch(begp:endp) = spval + call hist_addfld1d (fname='ONSET_GDD', units='C degree-days', & + avgflag='A', long_name='onset growing degree days', & + ptr_patch=this%onset_gdd_patch, default='inactive') + + this%onset_swi_patch(begp:endp) = spval + call hist_addfld1d (fname='ONSET_SWI', units='none', & + avgflag='A', long_name='onset soil water index', & + ptr_patch=this%onset_swi_patch, default='inactive') + + this%offset_flag_patch(begp:endp) = spval + call hist_addfld1d (fname='OFFSET_FLAG', units='none', & + avgflag='A', long_name='offset flag', & + ptr_patch=this%offset_flag_patch, default='inactive') + + this%offset_counter_patch(begp:endp) = spval + call hist_addfld1d (fname='OFFSET_COUNTER', units='days', & + avgflag='A', long_name='offset days counter', & + ptr_patch=this%offset_counter_patch, default='inactive') + + this%offset_fdd_patch(begp:endp) = spval + call hist_addfld1d (fname='OFFSET_FDD', units='C degree-days', & + avgflag='A', long_name='offset freezing degree days counter', & + ptr_patch=this%offset_fdd_patch, default='inactive') + + this%offset_swi_patch(begp:endp) = spval + call hist_addfld1d (fname='OFFSET_SWI', units='none', & + avgflag='A', long_name='offset soil water index', & + ptr_patch=this%offset_swi_patch, default='inactive') + + this%lgsf_patch(begp:endp) = spval + call hist_addfld1d (fname='LGSF', units='proportion', & + avgflag='A', long_name='long growing season factor', & + ptr_patch=this%lgsf_patch, default='inactive') + + this%bglfr_patch(begp:endp) = spval + call hist_addfld1d (fname='BGLFR', units='1/s', & + avgflag='A', long_name='background litterfall rate', & + ptr_patch=this%bglfr_patch, default='inactive') + + this%bgtr_patch(begp:endp) = spval + call hist_addfld1d (fname='BGTR', units='1/s', & + avgflag='A', long_name='background transfer growth rate', & + ptr_patch=this%bgtr_patch, default='inactive') + + this%c_allometry_patch(begp:endp) = spval + call hist_addfld1d (fname='C_ALLOMETRY', units='none', & + avgflag='A', long_name='C allocation index', & + ptr_patch=this%c_allometry_patch, default='inactive') + + this%n_allometry_patch(begp:endp) = spval + call hist_addfld1d (fname='N_ALLOMETRY', units='none', & + avgflag='A', long_name='N allocation index', & + ptr_patch=this%n_allometry_patch, default='inactive') + + this%tempsum_potential_gpp_patch(begp:endp) = spval + call hist_addfld1d (fname='TEMPSUM_POTENTIAL_GPP', units='gC/m^2/yr', & + avgflag='A', long_name='temporary annual sum of potential GPP', & + ptr_patch=this%tempsum_potential_gpp_patch, default='inactive') + + this%annsum_potential_gpp_patch(begp:endp) = spval + call hist_addfld1d (fname='ANNSUM_POTENTIAL_GPP', units='gN/m^2/yr', & + avgflag='A', long_name='annual sum of potential GPP', & + ptr_patch=this%annsum_potential_gpp_patch, default='inactive') + + this%tempmax_retransn_patch(begp:endp) = spval + call hist_addfld1d (fname='TEMPMAX_RETRANSN', units='gN/m^2', & + avgflag='A', long_name='temporary annual max of retranslocated N pool', & + ptr_patch=this%tempmax_retransn_patch, default='inactive') + + this%annmax_retransn_patch(begp:endp) = spval + call hist_addfld1d (fname='ANNMAX_RETRANSN', units='gN/m^2', & + avgflag='A', long_name='annual max of retranslocated N pool', & + ptr_patch=this%annmax_retransn_patch, default='inactive') + + this%downreg_patch(begp:endp) = spval + call hist_addfld1d (fname='DOWNREG', units='proportion', & + avgflag='A', long_name='fractional reduction in GPP due to N limitation', & + ptr_patch=this%downreg_patch, default='inactive') + + this%leafcn_offset_patch(begp:endp) = spval + call hist_addfld1d (fname='LEAFCN_OFFSET', units='unitless', & + avgflag='A', long_name='Leaf C:N used by FUN', & + ptr_patch=this%leafcn_offset_patch, default='inactive') + + this%plantCN_patch(begp:endp) = spval + call hist_addfld1d (fname='PLANTCN', units='unitless', & + avgflag='A', long_name='Plant C:N used by FUN', & + ptr_patch=this%plantCN_patch, default='inactive') + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine initCold(this, bounds) + ! + ! !USES: + use spmdMod , only : masterproc + use fileutils , only : getfil + use clm_varctl , only : nsrest, nsrStartup + use ncdio_pio + ! + ! !ARGUMENTS: + class(cnveg_state_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g,l,c,p,n,j,m ! indices + real(r8) ,pointer :: gdp (:) ! global gdp data (needs to be a pointer for use in ncdio) + real(r8) ,pointer :: peatf (:) ! global peatf data (needs to be a pointer for use in ncdio) + integer ,pointer :: abm (:) ! global abm data (needs to be a pointer for use in ncdio) + real(r8) ,pointer :: gti (:) ! read in - fmax (needs to be a pointer for use in ncdio) + integer :: dimid ! dimension id + integer :: ier ! error status + type(file_desc_t) :: ncid ! netcdf id + logical :: readvar + character(len=256) :: locfn ! local filename + integer :: begc, endc + integer :: begg, endg + !----------------------------------------------------------------------- + + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + ! -------------------------------------------------------------------- + ! Open surface dataset + ! -------------------------------------------------------------------- + + call getfil (fsurdat, locfn, 0) + call ncd_pio_openfile (ncid, locfn, 0) + + ! -------------------------------------------------------------------- + ! Read in GDP data + ! -------------------------------------------------------------------- + + allocate(gdp(bounds%begg:bounds%endg)) + call ncd_io(ncid=ncid, varname='gdp', flag='read', data=gdp, dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + call endrun(msg=' ERROR: gdp NOT on surfdata file'//errMsg(sourcefile, __LINE__)) + end if + do c = bounds%begc, bounds%endc + g = col%gridcell(c) + this%gdp_lf_col(c) = gdp(g) + end do + deallocate(gdp) + + ! -------------------------------------------------------------------- + ! Read in peatf data + ! -------------------------------------------------------------------- + + allocate(peatf(bounds%begg:bounds%endg)) + call ncd_io(ncid=ncid, varname='peatf', flag='read', data=peatf, dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + call endrun(msg=' ERROR: peatf NOT on surfdata file'//errMsg(sourcefile, __LINE__)) + end if + do c = bounds%begc, bounds%endc + g = col%gridcell(c) + this%peatf_lf_col(c) = peatf(g) + end do + deallocate(peatf) + + ! -------------------------------------------------------------------- + ! Read in ABM data + ! -------------------------------------------------------------------- + + allocate(abm(bounds%begg:bounds%endg)) + call ncd_io(ncid=ncid, varname='abm', flag='read', data=abm, dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + call endrun(msg=' ERROR: abm NOT on surfdata file'//errMsg(sourcefile, __LINE__)) + end if + do c = bounds%begc, bounds%endc + g = col%gridcell(c) + this%abm_lf_col(c) = abm(g) + end do + deallocate(abm) + + ! Close file + + call ncd_pio_closefile(ncid) + + if (masterproc) then + write(iulog,*) 'Successfully read fmax, soil color, sand and clay boundary data' + write(iulog,*) + endif + + ! -------------------------------------------------------------------- + ! Initialize terms needed for dust model + ! TODO - move these terms to DUSTMod module variables + ! -------------------------------------------------------------------- + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + this%annsum_counter_col (c) = spval + this%annavg_t2m_col (c) = spval + this%nfire_col (c) = spval + this%baf_crop_col (c) = spval + this%baf_peatf_col (c) = spval + this%fbac_col (c) = spval + this%fbac1_col (c) = spval + this%farea_burned_col (c) = spval + end if + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%annsum_counter_col(c) = 0._r8 + this%annavg_t2m_col(c) = 280._r8 + + ! fire related variables + this%baf_crop_col(c) = 0._r8 + this%baf_peatf_col(c) = 0._r8 + this%fbac_col(c) = 0._r8 + this%fbac1_col(c) = 0._r8 + this%farea_burned_col(c) = 0._r8 + this%nfire_col(c) = 0._r8 + end if + end do + + ! ecophysiological and phenology variables + + do p = bounds%begp,bounds%endp + l = patch%landunit(p) + + if (lun%ifspecial(l)) then + this%annavg_t2m_patch (p) = spval + this%tempavg_t2m_patch (p) = spval + this%dormant_flag_patch(p) = spval + this%days_active_patch(p) = spval + this%onset_flag_patch(p) = spval + this%onset_counter_patch(p) = spval + this%onset_gddflag_patch(p) = spval + this%onset_fdd_patch(p) = spval + this%onset_gdd_patch(p) = spval + this%onset_swi_patch(p) = spval + this%offset_flag_patch(p) = spval + this%offset_counter_patch(p) = spval + this%offset_fdd_patch(p) = spval + this%offset_swi_patch(p) = spval + this%grain_flag_patch(p) = spval + this%lgsf_patch(p) = spval + this%bglfr_patch(p) = spval + this%bgtr_patch(p) = spval + this%c_allometry_patch(p) = spval + this%n_allometry_patch(p) = spval + this%tempsum_potential_gpp_patch(p) = spval + this%annsum_potential_gpp_patch(p) = spval + this%tempmax_retransn_patch(p) = spval + this%annmax_retransn_patch(p) = spval + this%downreg_patch(p) = spval + this%leafcn_offset_patch(p) = spval + this%plantCN_patch(p) = spval + end if + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + ! phenology variables + this%dormant_flag_patch(p) = 1._r8 + this%days_active_patch(p) = 0._r8 + this%onset_flag_patch(p) = 0._r8 + this%onset_counter_patch(p) = 0._r8 + this%onset_gddflag_patch(p) = 0._r8 + this%onset_fdd_patch(p) = 0._r8 + this%onset_gdd_patch(p) = 0._r8 + this%onset_swi_patch(p) = 0._r8 + this%offset_flag_patch(p) = 0._r8 + this%offset_counter_patch(p) = 0._r8 + this%offset_fdd_patch(p) = 0._r8 + this%offset_swi_patch(p) = 0._r8 + this%lgsf_patch(p) = 0._r8 + this%bglfr_patch(p) = 0._r8 + this%bgtr_patch(p) = 0._r8 + this%annavg_t2m_patch(p) = 280._r8 + this%tempavg_t2m_patch(p) = 0._r8 + this%grain_flag_patch(p) = 0._r8 + + ! non-phenology variables + this%c_allometry_patch(p) = 0._r8 + this%n_allometry_patch(p) = 0._r8 + this%tempsum_potential_gpp_patch(p) = 0._r8 + this%annsum_potential_gpp_patch(p) = 0._r8 + this%tempmax_retransn_patch(p) = 0._r8 + this%annmax_retransn_patch(p) = 0._r8 + this%downreg_patch(p) = 0._r8 + this%leafcn_offset_patch(p) = spval + this%plantCN_patch(p) = spval + end if + + end do + + ! fire variables + + do c = bounds%begc,bounds%endc + this%lfc2_col(c) = 0._r8 + end do + + end subroutine initCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag, cnveg_carbonstate, & + cnveg_nitrogenstate, filter_reseed_patch, num_reseed_patch) + ! + ! !USES: + use shr_log_mod, only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc + use abortutils , only : endrun + use CNVegNitrogenStateType, only: cnveg_nitrogenstate_type + use CNVegCarbonStateType , only: cnveg_carbonstate_type + use restUtilMod + use ncdio_pio + use pftconMod , only : pftcon + ! + ! !ARGUMENTS: + class(cnveg_state_type) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid + character(len=*) , intent(in) :: flag + type(cnveg_nitrogenstate_type), intent(in) :: cnveg_nitrogenstate + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate + integer , intent(out), optional :: filter_reseed_patch(:) + integer , intent(out), optional :: num_reseed_patch + ! + ! !LOCAL VARIABLES: + integer :: j,c,i,p ! indices + logical :: readvar ! determine if variable is on initial file + real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays + real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays + !----------------------------------------------------------------------- + + call this%dwt_dribbler_patch%Restart(bounds, ncid, flag) + + call restartvar(ncid=ncid, flag=flag, varname='dormant_flag', xtype=ncd_double, & + dim1name='pft', & + long_name='dormancy flag', units='unitless', & + interpinic_flag='interp', readvar=readvar, data=this%dormant_flag_patch) + + call restartvar(ncid=ncid, flag=flag, varname='days_active', xtype=ncd_double, & + dim1name='pft', & + long_name='number of days since last dormancy', units='days' , & + interpinic_flag='interp', readvar=readvar, data=this%days_active_patch) + + call restartvar(ncid=ncid, flag=flag, varname='onset_flag', xtype=ncd_double, & + dim1name='pft', & + long_name='flag if critical growing degree-day sum is exceeded', units='unitless' , & + interpinic_flag='interp', readvar=readvar, data=this%onset_flag_patch) + + call restartvar(ncid=ncid, flag=flag, varname='onset_counter', xtype=ncd_double, & + dim1name='pft', & + long_name='onset days counter', units='sec' , & + interpinic_flag='interp', readvar=readvar, data=this%onset_counter_patch) + + call restartvar(ncid=ncid, flag=flag, varname='onset_gddflag', xtype=ncd_double, & + dim1name='pft', & + long_name='onset flag for growing degree day sum', units='' , & + interpinic_flag='interp', readvar=readvar, data=this%onset_gddflag_patch) + + call restartvar(ncid=ncid, flag=flag, varname='onset_fdd', xtype=ncd_double, & + dim1name='pft', & + long_name='onset freezing degree days counter', units='days' , & + interpinic_flag='interp', readvar=readvar, data=this%onset_fdd_patch) + + call restartvar(ncid=ncid, flag=flag, varname='onset_gdd', xtype=ncd_double, & + dim1name='pft', & + long_name='onset growing degree days', units='days' , & + interpinic_flag='interp', readvar=readvar, data=this%onset_gdd_patch) + + call restartvar(ncid=ncid, flag=flag, varname='onset_swi', xtype=ncd_double, & + dim1name='pft', & + long_name='onset soil water index', units='days' , & + interpinic_flag='interp', readvar=readvar, data=this%onset_swi_patch) + + call restartvar(ncid=ncid, flag=flag, varname='offset_flag', xtype=ncd_double, & + dim1name='pft', & + long_name='offset flag', units='unitless' , & + interpinic_flag='interp', readvar=readvar, data=this%offset_flag_patch) + + call restartvar(ncid=ncid, flag=flag, varname='offset_counter', xtype=ncd_double, & + dim1name='pft', & + long_name='offset days counter', units='sec' , & + interpinic_flag='interp', readvar=readvar, data=this%offset_counter_patch) + + call restartvar(ncid=ncid, flag=flag, varname='offset_fdd', xtype=ncd_double, & + dim1name='pft', & + long_name='offset freezing degree days counter', units='days' , & + interpinic_flag='interp', readvar=readvar, data=this%offset_fdd_patch) + + call restartvar(ncid=ncid, flag=flag, varname='offset_swi', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%offset_swi_patch) + + call restartvar(ncid=ncid, flag=flag, varname='lgsf', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%lgsf_patch) + + call restartvar(ncid=ncid, flag=flag, varname='bglfr', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%bglfr_patch) + + call restartvar(ncid=ncid, flag=flag, varname='bgtr', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%bgtr_patch) + + call restartvar(ncid=ncid, flag=flag, varname='annavg_t2m', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%annavg_t2m_patch) + + call restartvar(ncid=ncid, flag=flag, varname='tempavg_t2m', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tempavg_t2m_patch) + + call restartvar(ncid=ncid, flag=flag, varname='c_allometry', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%c_allometry_patch) + + call restartvar(ncid=ncid, flag=flag, varname='n_allometry', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%n_allometry_patch) + + call restartvar(ncid=ncid, flag=flag, varname='tempsum_potential_gpp', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tempsum_potential_gpp_patch) + + call restartvar(ncid=ncid, flag=flag, varname='annsum_potential_gpp', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%annsum_potential_gpp_patch) + + call restartvar(ncid=ncid, flag=flag, varname='tempmax_retransn', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tempmax_retransn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='annmax_retransn', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%annmax_retransn_patch) + + call restartvar(ncid=ncid, flag=flag, varname='downreg', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%downreg_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leafcn_offset', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%leafcn_offset_patch) + + call restartvar(ncid=ncid, flag=flag, varname='plantCN', xtype=ncd_double, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%plantCN_patch) + + call restartvar(ncid=ncid, flag=flag, varname='annsum_counter', xtype=ncd_double, & + dim1name='column', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%annsum_counter_col) + + call restartvar(ncid=ncid, flag=flag, varname='burndate', xtype=ncd_int, & + dim1name='pft', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%burndate_patch) + + call restartvar(ncid=ncid, flag=flag, varname='lfc', xtype=ncd_double, & + dim1name='column', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%lfc_col) + + call restartvar(ncid=ncid, flag=flag, varname='cannavg_t2m', xtype=ncd_double, & + dim1name='column', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%annavg_t2m_col) + + if (use_crop) then + + call restartvar(ncid=ncid, flag=flag, varname='htmx', xtype=ncd_double, & + dim1name='pft', long_name='max height attained by a crop during year', units='m', & + interpinic_flag='interp', readvar=readvar, data=this%htmx_patch) + + call restartvar(ncid=ncid, flag=flag, varname='peaklai', xtype=ncd_int, & + dim1name='pft', long_name='Flag if at max allowed LAI or not', & + flag_values=(/0,1/), nvalid_range=(/0,1/), & + flag_meanings=(/'NOT-at-peak', 'AT_peak-LAI' /) , & + interpinic_flag='interp', readvar=readvar, data=this%peaklai_patch) + + call restartvar(ncid=ncid, flag=flag, varname='idop', xtype=ncd_int, & + dim1name='pft', long_name='Date of planting', units='jday', nvalid_range=(/1,366/), & + interpinic_flag='interp', readvar=readvar, data=this%idop_patch) + + call restartvar(ncid=ncid, flag=flag, varname='aleaf', xtype=ncd_double, & + dim1name='pft', long_name='leaf allocation coefficient', units='', & + interpinic_flag='interp', readvar=readvar, data=this%aleaf_patch) + + call restartvar(ncid=ncid, flag=flag, varname='aleafi', xtype=ncd_double, & + dim1name='pft', long_name='Saved leaf allocation coefficient from phase 2', units='', & + interpinic_flag='interp', readvar=readvar, data=this%aleafi_patch) + + call restartvar(ncid=ncid, flag=flag, varname='astem', xtype=ncd_double, & + dim1name='pft', long_name='stem allocation coefficient', units='', & + interpinic_flag='interp', readvar=readvar, data=this%astem_patch) + + call restartvar(ncid=ncid, flag=flag, varname='astemi', xtype=ncd_double, & + dim1name='pft', long_name='Saved stem allocation coefficient from phase 2', units='', & + interpinic_flag='interp', readvar=readvar, data=this%astemi_patch) + + call restartvar(ncid=ncid, flag=flag, varname='hdidx', xtype=ncd_double, & + dim1name='pft', long_name='cold hardening index', units='', & + interpinic_flag='interp', readvar=readvar, data=this%hdidx_patch) + + call restartvar(ncid=ncid, flag=flag, varname='cumvd', xtype=ncd_double, & + dim1name='pft', long_name='cumulative vernalization d', units='', & + interpinic_flag='interp', readvar=readvar, data=this%cumvd_patch) + + call restartvar(ncid=ncid, flag=flag, varname='gddmaturity', xtype=ncd_double, & + dim1name='pft', long_name='Growing degree days needed to harvest', units='ddays', & + interpinic_flag='interp', readvar=readvar, data=this%gddmaturity_patch) + + call restartvar(ncid=ncid, flag=flag, varname='huileaf', xtype=ncd_double, & + dim1name='pft', long_name='heat unit index needed from planting to leaf emergence', units='', & + interpinic_flag='interp', readvar=readvar, data=this%huileaf_patch) + + call restartvar(ncid=ncid, flag=flag, varname='huigrain', xtype=ncd_double, & + dim1name='pft', long_name='heat unit index needed to reach vegetative maturity', units='', & + interpinic_flag='interp', readvar=readvar, data=this%huigrain_patch) + + call restartvar(ncid=ncid, flag=flag, varname='grain_flag', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%grain_flag_patch) + end if + if ( flag == 'read' .and. num_reseed_patch > 0 )then + if ( masterproc ) write(iulog, *) 'Reseed dead plants for CNVegState' + do i = 1, num_reseed_patch + p = filter_reseed_patch(i) + ! phenology variables + this%dormant_flag_patch(p) = 1._r8 + this%days_active_patch(p) = 0._r8 + this%onset_flag_patch(p) = 0._r8 + this%onset_counter_patch(p) = 0._r8 + this%onset_gddflag_patch(p) = 0._r8 + this%onset_fdd_patch(p) = 0._r8 + this%onset_gdd_patch(p) = 0._r8 + this%onset_swi_patch(p) = 0._r8 + this%offset_flag_patch(p) = 0._r8 + this%offset_counter_patch(p) = 0._r8 + this%offset_fdd_patch(p) = 0._r8 + this%offset_swi_patch(p) = 0._r8 + this%lgsf_patch(p) = 0._r8 + this%bglfr_patch(p) = 0._r8 + this%bgtr_patch(p) = 0._r8 + this%annavg_t2m_patch(p) = 280._r8 + this%tempavg_t2m_patch(p) = 0._r8 + this%grain_flag_patch(p) = 0._r8 + + this%c_allometry_patch(p) = 0._r8 + this%n_allometry_patch(p) = 0._r8 + this%tempsum_potential_gpp_patch(p) = 0._r8 + this%annsum_potential_gpp_patch(p) = 0._r8 + this%tempmax_retransn_patch(p) = 0._r8 + this%annmax_retransn_patch(p) = 0._r8 + this%downreg_patch(p) = 0._r8 + this%leafcn_offset_patch(p) = spval + this%plantCN_patch(p) = spval + end do + end if + + end subroutine Restart + +end module CNVegStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegStructUpdateMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegStructUpdateMod.F90 new file mode 100644 index 000000000..b9fdfe6f8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/CNVegetationFacade.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegetationFacade.F90 new file mode 100644 index 000000000..9b701efb9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CNVegetationFacade.F90 @@ -0,0 +1,1600 @@ +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 shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + 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, get_ref_date + use clm_time_manager , only : get_nstep, is_end_curr_year, 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 + use SoilWaterRetentionCurveMod , only : soil_water_retention_curve_type + ! + 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 + + ! !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, 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, & + soil_water_retention_curve, 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 + class(soil_water_retention_curve_type) , intent(in) :: soil_water_retention_curve + 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, & + soil_water_retention_curve, 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: + use clm_time_manager , only : get_nstep_since_startup_or_lastDA_restart_or_pause + ! + ! !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: + integer :: DA_nstep ! time step number + + character(len=*), parameter :: subname = 'BalanceCheck' + !----------------------------------------------------------------------- + + DA_nstep = get_nstep_since_startup_or_lastDA_restart_or_pause() + if (DA_nstep <= skip_steps )then + if (masterproc) then + write(iulog,*) '--WARNING-- skipping CN balance check for first timesteps after startup or data assimilation' + end if + else + + 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 if + + 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_orig_files/CanopyStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CanopyStateType.F90 new file mode 100644 index 000000000..abb32c9ac --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CanopyStateType.F90 @@ -0,0 +1,600 @@ +module CanopyStateType + + !------------------------------------------------------------------------------ + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, shr_infnan_isnan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use decompMod , only : bounds_type + use landunit_varcon , only : istsoil, istcrop + use clm_varpar , only : nlevcan, nvegwcs + use clm_varcon , only : spval + use clm_varctl , only : iulog, use_cn, use_fates, use_hydrstress + use LandunitType , only : lun + use PatchType , only : patch + ! + implicit none + save + private + ! + ! !PUBLIC TYPES: + 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, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, public :: ReadNML + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: UpdateAccVars + procedure, public :: Restart + + end type CanopyState_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(canopystate_type) :: this + type(bounds_type), intent(in) :: bounds + + call this%InitAllocate(bounds) + call this%InitHistory(bounds) + call this%InitCold(bounds) + + if ( this%leaf_mr_vcm == spval ) then + call endrun(msg="ERROR canopystate Init called before ReadNML"//errmsg(sourcefile, __LINE__)) + end if + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !USES: + ! + ! !ARGUMENTS: + class(canopystate_type) :: 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%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 (:) = nan + allocate(this%tsai_patch (begp:endp)) ; this%tsai_patch (:) = nan + allocate(this%elai_patch (begp:endp)) ; this%elai_patch (:) = nan + allocate(this%elai240_patch (begp:endp)) ; this%elai240_patch (:) = nan + allocate(this%esai_patch (begp:endp)) ; this%esai_patch (:) = nan + allocate(this%laisun_patch (begp:endp)) ; this%laisun_patch (:) = nan + allocate(this%laisha_patch (begp:endp)) ; this%laisha_patch (:) = nan + allocate(this%laisun_z_patch (begp:endp,1:nlevcan)) ; this%laisun_z_patch (:,:) = nan + allocate(this%laisha_z_patch (begp:endp,1:nlevcan)) ; this%laisha_z_patch (:,:) = nan + allocate(this%mlaidiff_patch (begp:endp)) ; this%mlaidiff_patch (:) = nan + allocate(this%annlai_patch (12,begp:endp)) ; this%annlai_patch (:,:) = nan + allocate(this%stem_biomass_patch (begp:endp)) ; this%stem_biomass_patch (:) = nan + allocate(this%leaf_biomass_patch (begp:endp)) ; this%leaf_biomass_patch (:) = nan + allocate(this%htop_patch (begp:endp)) ; this%htop_patch (:) = nan + allocate(this%hbot_patch (begp:endp)) ; this%hbot_patch (:) = nan + 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 (:) = nan + 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 + end subroutine InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! !USES: + use histFileMod , only: hist_addfld1d, hist_addfld2d + ! + ! !ARGUMENTS: + class(canopystate_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: begp, endp + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !--------------------------------------------------------------------- + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + this%elai_patch(begp:endp) = spval + call hist_addfld1d (fname='ELAI', units='m^2/m^2', & + avgflag='A', long_name='exposed one-sided leaf area index', & + ptr_patch=this%elai_patch) + + this%esai_patch(begp:endp) = spval + call hist_addfld1d (fname='ESAI', units='m^2/m^2', & + avgflag='A', long_name='exposed one-sided stem area index', & + ptr_patch=this%esai_patch) + + this%tlai_patch(begp:endp) = spval + call hist_addfld1d (fname='TLAI', units='m^2/m^2', & + avgflag='A', long_name='total projected leaf area index', & + ptr_patch=this%tlai_patch) + + this%tsai_patch(begp:endp) = spval + call hist_addfld1d (fname='TSAI', units='m^2/m^2', & + avgflag='A', long_name='total projected stem area index', & + ptr_patch=this%tsai_patch) + + this%laisun_patch(begp:endp) = spval + call hist_addfld1d (fname='LAISUN', units='m^2/m^2', & + avgflag='A', long_name='sunlit projected leaf area index', & + ptr_patch=this%laisun_patch, set_urb=0._r8) + + this%laisha_patch(begp:endp) = spval + call hist_addfld1d (fname='LAISHA', units='m^2/m^2', & + avgflag='A', long_name='shaded projected leaf area index', & + ptr_patch=this%laisha_patch, set_urb=0._r8) + + this%stem_biomass_patch(begp:endp) = spval + call hist_addfld1d (fname='AGSB', units='kg/m^2', & + avgflag='A', long_name='Aboveground stem biomass', & + ptr_patch=this%stem_biomass_patch, default='inactive') + + this%leaf_biomass_patch(begp:endp) = spval + call hist_addfld1d (fname='AGLB', units='kg/m^2', & + avgflag='A', long_name='Aboveground leaf biomass', & + ptr_patch=this%leaf_biomass_patch, default='inactive') + + if (use_cn .or. use_fates) then + this%fsun_patch(begp:endp) = spval + call hist_addfld1d (fname='FSUN', units='proportion', & + avgflag='A', long_name='sunlit fraction of canopy', & + ptr_patch=this%fsun_patch, default='inactive') + + this%htop_patch(begp:endp) = spval + call hist_addfld1d (fname='HTOP', units='m', & + avgflag='A', long_name='canopy top', & + ptr_patch=this%htop_patch) + + this%hbot_patch(begp:endp) = spval + call hist_addfld1d (fname='HBOT', units='m', & + avgflag='A', long_name='canopy bottom', & + ptr_patch=this%hbot_patch, default='inactive') + + this%displa_patch(begp:endp) = spval + call hist_addfld1d (fname='DISPLA', units='m', & + avgflag='A', long_name='displacement height', & + ptr_patch=this%displa_patch, default='inactive') + end if + + this%z0m_patch(begp:endp) = spval + call hist_addfld1d (fname='Z0M', units='m', & + avgflag='A', long_name='momentum roughness length', & + ptr_patch=this%z0m_patch, default='inactive') + + ! Accumulated fields + this%fsun24_patch(begp:endp) = spval + call hist_addfld1d (fname='FSUN24', units='K', & + avgflag='A', long_name='fraction sunlit (last 24hrs)', & + ptr_patch=this%fsun24_patch, default='inactive') + + this%fsun240_patch(begp:endp) = spval + call hist_addfld1d (fname='FSUN240', units='K', & + avgflag='A', long_name='fraction sunlit (last 240hrs)', & + ptr_patch=this%fsun240_patch, default='inactive') + + this%elai240_patch(begp:endp) = spval + call hist_addfld1d (fname='LAI240', units='m^2/m^2', & + avgflag='A', long_name='240hr average of leaf area index', & + ptr_patch=this%elai240_patch, default='inactive') + + ! Ed specific field + if ( use_fates ) then + this%rscanopy_patch(begp:endp) = spval + call hist_addfld1d (fname='RSCANOPY', units=' s m-1', & + avgflag='A', long_name='canopy resistance', & + ptr_patch=this%rscanopy_patch, set_lake=0._r8, set_urb=0._r8) + end if + +! call hist_addfld1d (fname='GCCANOPY', units='none', & +! avgflag='A', long_name='Canopy Conductance: mmol m-2 s-1', & +! ptr_patch=this%GCcanopy_patch, set_lake=0._r8, set_urb=0._r8) + + if ( use_hydrstress ) then + this%vegwp_patch(begp:endp,:) = spval + call hist_addfld2d (fname='VEGWP', units='mm', type2d='nvegwcs', & + avgflag='A', long_name='vegetation water matric potential for sun/sha canopy,xyl,root segments', & + ptr_patch=this%vegwp_patch) + this%vegwp_ln_patch(begp:endp,:) = spval + call hist_addfld2d (fname='VEGWPLN', units='mm', type2d='nvegwcs', & + avgflag='A', long_name='vegetation water matric potential for sun/sha canopy,xyl,root at local noon', & + ptr_patch=this%vegwp_ln_patch, default='active') + this%vegwp_pd_patch(begp:endp,:) = spval + call hist_addfld2d (fname='VEGWPPD', units='mm', type2d='nvegwcs', avgflag='A', & + long_name='predawn vegetation water matric potential for sun/sha canopy,xyl,root', & + ptr_patch=this%vegwp_pd_patch, default='active') + end if + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! + ! !USES + use accumulMod , only : init_accum_field + ! + ! !ARGUMENTS: + class(canopystate_type) :: this + type(bounds_type), intent(in) :: bounds + !--------------------------------------------------------------------- + + this%fsun24_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='FSUN24', units='fraction', & + desc='24hr average of diffuse solar radiation', accum_type='runmean', accum_period=-1, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + this%fsun240_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='FSUN240', units='fraction', & + desc='240hr average of diffuse solar radiation', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + this%elai240_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='LAI240', units='m2/m2', & + desc='240hr average of leaf area index', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + subroutine InitAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES + use accumulMod , only : extract_accum_field + use clm_time_manager , only : get_nstep + ! + ! !ARGUMENTS: + class(canopystate_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: nstep + integer :: ier + real(r8), pointer :: rbufslp(:) ! temporary + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)' in ' + call endrun(msg="extract_accum_hist allocation error for rbufslp"//& + errMsg(sourcefile, __LINE__)) + endif + + ! Determine time step + nstep = get_nstep() + + call extract_accum_field ('FSUN24', rbufslp, nstep) + this%fsun24_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('FSUN240', rbufslp, nstep) + this%fsun240_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('LAI240', rbufslp, nstep) + this%elai240_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('FSUN24', rbufslp, nstep) + this%fsun24_patch(begp:endp) = rbufslp(begp:endp) + + deallocate(rbufslp) + + end subroutine InitAccVars + + !----------------------------------------------------------------------- + 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 + + !----------------------------------------------------------------------- + subroutine UpdateAccVars (this, bounds) + ! + ! USES + use clm_time_manager, only : get_nstep + use accumulMod , only : update_accum_field, extract_accum_field + use abortutils , only : endrun + ! + ! !ARGUMENTS: + class(canopystate_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g,p ! indices + integer :: dtime ! timestep size [seconds] + integer :: nstep ! timestep number + integer :: ier ! error status + integer :: begp, endp + real(r8), pointer :: rbufslp(:) ! temporary single level - patch level + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + nstep = get_nstep() + + ! Allocate needed dynamic memory for single level patch field + + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)'update_accum_hist allocation error for rbuf1dp' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + ! Accumulate and extract fsun24 & fsun240 + do p = begp,endp + rbufslp(p) = this%fsun_patch(p) + end do + call update_accum_field ('FSUN24' , rbufslp , nstep) + call extract_accum_field ('FSUN24' , this%fsun24_patch , nstep) + call update_accum_field ('FSUN240', rbufslp , nstep) + call extract_accum_field ('FSUN240', this%fsun240_patch , nstep) + + ! Accumulate and extract elai240 + do p = begp,endp + rbufslp(p) = this%elai_patch(p) + end do + call update_accum_field ('LAI240', rbufslp , nstep) + call extract_accum_field ('LAI240', this%elai240_patch , nstep) + + deallocate(rbufslp) + + end subroutine UpdateAccVars + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !ARGUMENTS: + class(canopystate_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p,l,c,g + !----------------------------------------------------------------------- + + do p = bounds%begp, bounds%endp + l = patch%landunit(p) + + this%tlai_patch(p) = 0._r8 + this%tsai_patch(p) = 0._r8 + this%elai_patch(p) = 0._r8 + this%esai_patch(p) = 0._r8 + this%stem_biomass_patch(p)= 0._r8 + this%leaf_biomass_patch(p)= 0._r8 + this%htop_patch(p) = 0._r8 + this%hbot_patch(p) = 0._r8 + this%vegwp_patch(p,:) = -2.5e4_r8 + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%laisun_patch(p) = 0._r8 + this%laisha_patch(p) = 0._r8 + end if + + ! needs to be initialized to spval to avoid problems when averaging for the accum + ! field + this%fsun_patch(p) = spval + end do + + end subroutine InitCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_double, ncd_int + use restUtilMod + ! + ! !ARGUMENTS: + class(canopystate_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,p,c,iv ! indices + logical :: readvar ! determine if variable is on initial file + integer :: begp, endp + !----------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + call restartvar(ncid=ncid, flag=flag, varname='FRAC_VEG_NOSNO_ALB', xtype=ncd_int, & + dim1name='pft', long_name='fraction of vegetation not covered by snow (0 or 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%frac_veg_nosno_alb_patch) + + call restartvar(ncid=ncid, flag=flag, varname='tlai', xtype=ncd_double, & + dim1name='pft', long_name='one-sided leaf area index, no burying by snow', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tlai_patch) + + call restartvar(ncid=ncid, flag=flag, varname='tsai', xtype=ncd_double, & + dim1name='pft', long_name='one-sided stem area index, no burying by snow', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tsai_patch) + + call restartvar(ncid=ncid, flag=flag, varname='elai', xtype=ncd_double, & + dim1name='pft', long_name='one-sided leaf area index, with burying by snow', units='', & + interpinic_flag='interp', readvar=readvar, data=this%elai_patch) + + call restartvar(ncid=ncid, flag=flag, varname='esai', xtype=ncd_double, & + dim1name='pft', long_name='one-sided stem area index, with burying by snow', units='', & + interpinic_flag='interp', readvar=readvar, data=this%esai_patch) + + call restartvar(ncid=ncid, flag=flag, varname='stem_biomass', xtype=ncd_double, & + dim1name='pft', long_name='stem biomass', units='kg/m^2', & + interpinic_flag='interp', readvar=readvar, data=this%stem_biomass_patch) + + call restartvar(ncid=ncid, flag=flag, varname='leaf_biomass', xtype=ncd_double, & + dim1name='pft', long_name='leaf biomass', units='kg/m^2', & + interpinic_flag='interp', readvar=readvar, data=this%leaf_biomass_patch) + + call restartvar(ncid=ncid, flag=flag, varname='htop', xtype=ncd_double, & + dim1name='pft', long_name='canopy top', units='m', & + interpinic_flag='interp', readvar=readvar, data=this%htop_patch) + + call restartvar(ncid=ncid, flag=flag, varname='hbot', xtype=ncd_double, & + dim1name='pft', long_name='canopy botton', units='m', & + interpinic_flag='interp', readvar=readvar, data=this%hbot_patch) + + call restartvar(ncid=ncid, flag=flag, varname='mlaidiff', xtype=ncd_double, & + dim1name='pft', long_name='difference between lai month one and month two', units='', & + interpinic_flag='interp', readvar=readvar, data=this%mlaidiff_patch) + + call restartvar(ncid=ncid, flag=flag, varname='fsun', xtype=ncd_double, & + dim1name='pft', long_name='sunlit fraction of canopy', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fsun_patch) + + + + if (flag=='read' )then + do p = bounds%begp,bounds%endp + if (shr_infnan_isnan(this%fsun_patch(p)) ) then + this%fsun_patch(p) = spval + end if + end do + end if + + if ( use_hydrstress ) then + call restartvar(ncid=ncid, flag=flag, varname='vegwp', xtype=ncd_double, & + dim1name='pft', dim2name='vegwcs', switchdim=.true., & + long_name='vegetation water matric potential', units='mm', & + interpinic_flag='interp', readvar=readvar, data=this%vegwp_patch) + + call restartvar(ncid=ncid, flag=flag, varname='VEGWPLN', xtype=ncd_double, & + dim1name='pft', dim2name='vegwcs', & + long_name='vegetation water matric potential for sun/sha canopy,xyl,root at local noon', units='mm', & + interpinic_flag='skip', readvar=readvar, data=this%vegwp_ln_patch) + + call restartvar(ncid=ncid, flag=flag, varname='VEGWPPD', xtype=ncd_double, & + dim1name='pft', dim2name='vegwcs', & + long_name='predawn vegetation water matric potential for sun/sha canopy,xyl,root', units='mm', & + interpinic_flag='skip', readvar=readvar, data=this%vegwp_pd_patch) + + end if + + end subroutine Restart + +end module CanopyStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ColumnType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ColumnType.F90 new file mode 100644 index 000000000..181be48a0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ColumnType.F90 @@ -0,0 +1,213 @@ +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 shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varpar , only : nlevsno, nlevgrnd, nlevlak, nlevmaxurbgrnd + use clm_varcon , only : spval, ispval + use shr_sys_mod , only : shr_sys_abort + use clm_varctl , only : iulog + use column_varcon , only : is_hydrologically_active + use LandunitType , only : lun + ! + ! !PUBLIC TYPES: + implicit none + save + private + ! + 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 + procedure, public :: Clean + + ! Update the column type for one column. Any updates to col%itype after + ! initialization should be made via this routine. + procedure, public :: update_itype + + end type column_type + + type(column_type), public, target :: col !column data structure (soil/snow/canopy columns) + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, begc, endc) + ! + ! !ARGUMENTS: + class(column_type) :: this + integer, intent(in) :: begc,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. + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine Clean(this) + ! + ! !ARGUMENTS: + class(column_type) :: this + !------------------------------------------------------------------------ + + deallocate(this%gridcell ) + deallocate(this%wtgcell ) + deallocate(this%landunit ) + deallocate(this%wtlunit ) + deallocate(this%patchi ) + deallocate(this%patchf ) + deallocate(this%npatches ) + deallocate(this%itype ) + deallocate(this%lun_itype ) + deallocate(this%active ) + deallocate(this%type_is_dynamic) + deallocate(this%snl ) + deallocate(this%dz ) + deallocate(this%z ) + deallocate(this%zi ) + deallocate(this%zii ) + deallocate(this%lakedepth ) + deallocate(this%dz_lake ) + deallocate(this%z_lake ) + deallocate(this%micro_sigma) + deallocate(this%topo_slope ) + deallocate(this%topo_std ) + deallocate(this%nbedrock ) + deallocate(this%levgrnd_class) + deallocate(this%hydrologically_active) + deallocate(this%urbpoi) + + end subroutine Clean + + !----------------------------------------------------------------------- + subroutine update_itype(this, c, itype) + ! + ! !DESCRIPTION: + ! Update the column type for one column. Any updates to col%itype after + ! initialization should be made via this routine. + ! + ! This can NOT be used to change the landunit type: it can only be used to change the + ! column type within a fixed landunit. + ! + ! !ARGUMENTS: + class(column_type), intent(inout) :: this + integer, intent(in) :: c + integer, intent(in) :: itype + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'update_itype' + !----------------------------------------------------------------------- + + if (col%type_is_dynamic(c)) then + col%itype(c) = itype + col%hydrologically_active(c) = is_hydrologically_active( & + col_itype = itype, & + lun_itype = col%lun_itype(c)) + ! Properties that are tied to the landunit's properties (like urbpoi) are assumed + ! not to change here. + else + write(iulog,*) subname//' ERROR: attempt to update itype when type_is_dynamic is false' + write(iulog,*) 'c, col%itype(c), itype = ', c, col%itype(c), itype + ! Need to use shr_sys_abort rather than endrun, because using endrun would cause + ! circular dependencies + call shr_sys_abort(subname//' ERROR: attempt to update itype when type_is_dynamic is false') + end if + end subroutine update_itype + + + +end module ColumnType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CropType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CropType.F90 new file mode 100644 index 000000000..afa2008f1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/CropType.F90 @@ -0,0 +1,723 @@ +module CropType + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing variables needed for the crop model + ! + ! TODO(wjs, 2014-08-05) Move more crop-specific variables into here - many are + ! currently in CNVegStateType + ! + ! !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 decompMod , only : bounds_type + use clm_varcon , only : spval + use clm_varctl , only : iulog, use_crop + ! + ! !PUBLIC TYPES: + implicit none + private + ! + ! !PUBLIC DATA TYPES: + ! + ! Crop state variables structure + 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 + ! Public routines + procedure, public :: Init ! Initialize the crop type + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: Restart + procedure, public :: ReadNML ! Read in the crop namelist + + ! NOTE(wjs, 2014-09-29) need to rename this from UpdateAccVars to CropUpdateAccVars + ! to prevent cryptic error messages with pgi (v. 13.9 on yellowstone) + ! This is probably related to this bug + ! , which was fixed in pgi 14.7. + procedure, public :: CropUpdateAccVars + + procedure, public :: CropIncrementYear + + ! Private routines + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, private, nopass :: checkDates + + end type crop_type + + character(len=*), parameter, private :: baset_map_constant = 'constant' + character(len=*), parameter, private :: baset_map_latvary = 'varytropicsbylat' + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + !------------------------------------------------------------------------ + +contains + + !----------------------------------------------------------------------- + subroutine Init(this, bounds) + ! + ! !ARGUMENTS: + class(crop_type) , intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Init' + !----------------------------------------------------------------------- + + call this%InitAllocate(bounds) + + if (use_crop) then + call this%InitHistory(bounds) + call this%InitCold(bounds) + end if + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine ReadNML(this, NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for CropType + ! + ! !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(crop_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 = 'Crop::ReadNML' + character(len=*), parameter :: nmlname = 'crop' + !----------------------------------------------------------------------- + character(len=20) :: baset_mapping + real(r8) :: baset_latvary_intercept + real(r8) :: baset_latvary_slope + namelist /crop/ baset_mapping, baset_latvary_intercept, baset_latvary_slope + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + baset_mapping = 'constant' + baset_latvary_intercept = 12._r8 + baset_latvary_slope = 0.4_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=crop, 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 (baset_mapping , mpicom) + call shr_mpi_bcast (baset_latvary_intercept , mpicom) + call shr_mpi_bcast (baset_latvary_slope , mpicom) + + this%baset_mapping = baset_mapping + this%baset_latvary_intercept = baset_latvary_intercept + this%baset_latvary_slope = baset_latvary_slope + if ( trim(this%baset_mapping) == baset_map_constant ) then + if ( masterproc ) write(iulog,*) 'baset mapping for ALL crops are constant' + else if ( trim(this%baset_mapping) == baset_map_latvary ) then + if ( masterproc ) write(iulog,*) 'baset mapping for crops vary with latitude' + else + call endrun(msg="Bad value for baset_mapping in "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=crop) + write(iulog,*) ' ' + end if + + !----------------------------------------------------------------------- + + end subroutine ReadNML + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! !USES: + ! + ! !ARGUMENTS: + class(crop_type) , intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + + character(len=*), parameter :: subname = 'InitAllocate' + !----------------------------------------------------------------------- + + 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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! !USES: + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + class(crop_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + + character(len=*), parameter :: subname = 'InitHistory' + !----------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + this%fertnitro_patch(begp:endp) = spval + call hist_addfld1d (fname='FERTNITRO', units='gN/m2/yr', & + avgflag='A', long_name='Nitrogen fertilizer for each crop', & + ptr_patch=this%fertnitro_patch, default='inactive') + + this%gddplant_patch(begp:endp) = spval + call hist_addfld1d (fname='GDDPLANT', units='ddays', & + avgflag='A', long_name='Accumulated growing degree days past planting date for crop', & + ptr_patch=this%gddplant_patch, default='inactive') + + this%gddtsoi_patch(begp:endp) = spval + call hist_addfld1d (fname='GDDTSOI', units='ddays', & + avgflag='A', long_name='Growing degree-days from planting (top two soil layers)', & + ptr_patch=this%gddtsoi_patch, default='inactive') + + this%cphase_patch(begp:endp) = spval + call hist_addfld1d (fname='CPHASE', units='0-not planted, 1-planted, 2-leaf emerge, 3-grain fill, 4-harvest', & + avgflag='A', long_name='crop phenology phase', & + ptr_patch=this%cphase_patch, default='active') + + if ( (trim(this%baset_mapping) == baset_map_latvary) )then + this%latbaset_patch(begp:endp) = spval + call hist_addfld1d (fname='LATBASET', units='degree C', & + avgflag='A', long_name='latitude vary base temperature for gddplant', & + ptr_patch=this%latbaset_patch, default='inactive') + end if + + end subroutine InitHistory + + subroutine InitCold(this, bounds) + ! !USES: + use LandunitType, only : lun + use landunit_varcon, only : istcrop + use PatchType, only : patch + use clm_instur, only : fert_cft + use pftconMod , only : pftcon + use GridcellType , only : grc + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! !ARGUMENTS: + class(crop_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: c, l, g, p, m, ivt ! indices + + character(len=*), parameter :: subname = 'InitCold' + !----------------------------------------------------------------------- + +!DLL - added wheat & sugarcane restrictions to base T vary by lat + do p= bounds%begp,bounds%endp + g = patch%gridcell(p) + ivt = patch%itype(p) + + this%nyrs_crop_active_patch(p) = 0 + + if ( grc%latdeg(g) >= 0.0_r8 .and. grc%latdeg(g) <= 30.0_r8) then + this%latbaset_patch(p)=pftcon%baset(ivt)+12._r8-0.4_r8*grc%latdeg(g) + else if (grc%latdeg(g) < 0.0_r8 .and. grc%latdeg(g) >= -30.0_r8) then + this%latbaset_patch(p)=pftcon%baset(ivt)+12._r8+0.4_r8*grc%latdeg(g) + else + this%latbaset_patch(p)=pftcon%baset(ivt) + end if + if ( trim(this%baset_mapping) == baset_map_constant ) then + this%latbaset_patch(p) = nan + end if + end do +!DLL -- end of mods + + if (use_crop) then + do p= bounds%begp,bounds%endp + g = patch%gridcell(p) + l = patch%landunit(p) + c = patch%column(p) + + if (lun%itype(l) == istcrop) then + m = patch%itype(p) + this%fertnitro_patch(p) = fert_cft(g,m) + end if + end do + end if + + end subroutine InitCold + + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! Each interval and accumulation type is unique to each field processed. + ! Routine [initAccBuffer] defines the fields to be processed + ! and the type of accumulation. + ! Routine [updateAccVars] does the actual accumulation for a given field. + ! Fields are accumulated by calls to subroutine [update_accum_field]. + ! To accumulate a field, it must first be defined in subroutine [initAccVars] + ! and then accumulated by calls to [updateAccVars]. + ! + ! Should only be called if use_crop is true + ! + ! !USES + use accumulMod , only : init_accum_field + ! + ! !ARGUMENTS: + class(crop_type) , intent(in) :: this + type(bounds_type), intent(in) :: bounds + + ! + ! !LOCAL VARIABLES: + integer, parameter :: not_used = huge(1) + + !--------------------------------------------------------------------- + + call init_accum_field (name='GDDPLANT', units='K', & + desc='growing degree-days from planting', accum_type='runaccum', accum_period=not_used, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field (name='GDDTSOI', units='K', & + desc='growing degree-days from planting (top two soil layers)', accum_type='runaccum', accum_period=not_used, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + subroutine InitAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES: + use accumulMod , only : extract_accum_field + use clm_time_manager , only : get_nstep + ! + ! !ARGUMENTS: + class(crop_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: nstep + integer :: ier + real(r8), pointer :: rbufslp(:) ! temporary + + character(len=*), parameter :: subname = 'InitAccVars' + !----------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)' in ' + call endrun(msg=" allocation error for rbufslp"//& + errMsg(sourcefile, __LINE__)) + endif + + nstep = get_nstep() + + call extract_accum_field ('GDDPLANT', rbufslp, nstep) + this%gddplant_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('GDDTSOI', rbufslp, nstep) + this%gddtsoi_patch(begp:endp) = rbufslp(begp:endp) + + deallocate(rbufslp) + + end subroutine InitAccVars + + !----------------------------------------------------------------------- + subroutine Restart(this, bounds, ncid, flag) + ! + ! !USES: + use restUtilMod + use ncdio_pio + use PatchType, only : patch + use pftconMod, only : npcropmin, npcropmax + ! + ! !ARGUMENTS: + class(crop_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid + character(len=*) , intent(in) :: flag + ! + ! !LOCAL VARIABLES: + integer, pointer :: temp1d(:) ! temporary + integer :: restyear + integer :: p + logical :: readvar ! determine if variable is on initial file + + character(len=*), parameter :: subname = 'Restart' + !----------------------------------------------------------------------- + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='nyrs_crop_active', xtype=ncd_int, & + dim1name='pft', & + long_name='Number of years this crop patch has been active (0 for non-crop patches)', & + units='years', & + interpinic_flag='interp', readvar=readvar, data=this%nyrs_crop_active_patch) + if (flag == 'read' .and. .not. readvar) then + ! BACKWARDS_COMPATIBILITY(wjs, 2017-02-17) Old restart files did not have this + ! patch-level variable. Instead, they had a single scalar tracking the number + ! of years the crop model ran. Copy this scalar onto all *active* crop patches. + + ! Some arguments in the following restartvar call are irrelevant, because we + ! only call this for 'read'. I'm simply maintaining the old restartvar call. + call restartvar(ncid=ncid, flag=flag, varname='restyear', xtype=ncd_int, & + long_name='Number of years prognostic crop ran', units="years", & + interpinic_flag='copy', readvar=readvar, data=restyear) + if (readvar) then + do p = bounds%begp, bounds%endp + if (patch%itype(p) >= npcropmin .and. patch%itype(p) <= npcropmax .and. & + patch%active(p)) then + this%nyrs_crop_active_patch(p) = restyear + end if + end do + end if + end if + + allocate(temp1d(bounds%begp:bounds%endp)) + if (flag == 'write') then + do p= bounds%begp,bounds%endp + if (this%croplive_patch(p)) then + temp1d(p) = 1 + else + temp1d(p) = 0 + end if + end do + end if + call restartvar(ncid=ncid, flag=flag, varname='croplive', xtype=ncd_log, & + dim1name='pft', & + long_name='Flag that crop is alive, but not harvested', & + interpinic_flag='interp', readvar=readvar, data=temp1d) + if (flag == 'read') then + do p= bounds%begp,bounds%endp + if (temp1d(p) == 1) then + this%croplive_patch(p) = .true. + else + this%croplive_patch(p) = .false. + end if + end do + end if + deallocate(temp1d) + + allocate(temp1d(bounds%begp:bounds%endp)) + if (flag == 'write') then + do p= bounds%begp,bounds%endp + if (this%cropplant_patch(p)) then + temp1d(p) = 1 + else + temp1d(p) = 0 + end if + end do + end if + call restartvar(ncid=ncid, flag=flag, varname='cropplant', xtype=ncd_log, & + dim1name='pft', & + long_name='Flag that crop is planted, but not harvested' , & + interpinic_flag='interp', readvar=readvar, data=temp1d) + if (flag == 'read') then + do p= bounds%begp,bounds%endp + if (temp1d(p) == 1) then + this%cropplant_patch(p) = .true. + else + this%cropplant_patch(p) = .false. + end if + end do + end if + deallocate(temp1d) + + call restartvar(ncid=ncid, flag=flag, varname='harvdate', xtype=ncd_int, & + dim1name='pft', long_name='harvest date', units='jday', nvalid_range=(/1,366/), & + interpinic_flag='interp', readvar=readvar, data=this%harvdate_patch) + + call restartvar(ncid=ncid, flag=flag, varname='vf', xtype=ncd_double, & + dim1name='pft', long_name='vernalization factor', units='', & + interpinic_flag='interp', readvar=readvar, data=this%vf_patch) + + call restartvar(ncid=ncid, flag=flag, varname='cphase',xtype=ncd_double, & + dim1name='pft', long_name='crop phenology phase', & + units='0-not planted, 1-planted, 2-leaf emerge, 3-grain fill, 4-harvest', & + interpinic_flag='interp', readvar=readvar, data=this%cphase_patch) + if (flag=='read' )then + call this%checkDates( ) ! Check that restart date is same calendar date (even if year is different) + ! This is so that it properly goes through + ! the crop phases + end if + end if + + end subroutine Restart + + + !----------------------------------------------------------------------- + subroutine CropUpdateAccVars(this, bounds, t_ref2m_patch, t_soisno_col) + ! + ! !DESCRIPTION: + ! Update accumulated variables. Should be called every time step. + ! Should only be called if use_crop is true. + ! + ! !USES: + use accumulMod , only : update_accum_field, extract_accum_field, accumResetVal + use shr_const_mod , only : SHR_CONST_CDAY, SHR_CONST_TKFRZ + use clm_time_manager , only : get_step_size, get_nstep + use clm_varpar , only : nlevsno, nlevgrnd + use pftconMod , only : nswheat, nirrig_swheat, pftcon + use pftconMod , only : nwwheat, nirrig_wwheat + use pftconMod , only : nsugarcane, nirrig_sugarcane + use ColumnType , only : col + use PatchType , only : patch + ! + ! !ARGUMENTS: + implicit none + class(crop_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: t_ref2m_patch( bounds%begp:) + real(r8) , intent(inout) :: t_soisno_col(bounds%begc:, -nlevsno+1:) + ! + ! !LOCAL VARIABLES: + integer :: p,c,g ! indices + integer :: ivt ! vegetation type + integer :: dtime ! timestep size [seconds] + integer :: nstep ! timestep number + integer :: ier ! error status + integer :: begp, endp + integer :: begc, endc + real(r8), pointer :: rbufslp(:) ! temporary single level - patch level + character(len=*), parameter :: subname = 'CropUpdateAccVars' + !----------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(t_ref2m_patch) == (/endp/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(t_soisno_col) == (/endc,nlevgrnd/)) , sourcefile, __LINE__) + + dtime = get_step_size() + nstep = get_nstep() + + ! Allocate needed dynamic memory for single level patch field + + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)'update_accum_hist allocation error for rbuf1dp' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + ! Accumulate and extract GDDPLANT + + call extract_accum_field ('GDDPLANT', rbufslp, nstep) + do p = begp,endp + rbufslp(p) = max(0.0_r8,this%gddplant_patch(p)-rbufslp(p)) + end do + call update_accum_field ('GDDPLANT', rbufslp, nstep) + do p = begp,endp + if (this%croplive_patch(p)) then ! relative to planting date + ivt = patch%itype(p) + if ( (trim(this%baset_mapping) == baset_map_latvary) .and. & + ((ivt == nswheat) .or. (ivt == nirrig_swheat) .or. & + (ivt == nsugarcane) .or. (ivt == nirrig_sugarcane)) ) then + rbufslp(p) = max(0._r8, min(pftcon%mxtmp(ivt), & + t_ref2m_patch(p)-(SHR_CONST_TKFRZ + this%latbaset_patch(p)))) & + * dtime/SHR_CONST_CDAY + else + rbufslp(p) = max(0._r8, min(pftcon%mxtmp(ivt), & + t_ref2m_patch(p)-(SHR_CONST_TKFRZ + pftcon%baset(ivt)))) & + * dtime/SHR_CONST_CDAY + end if + if (ivt == nwwheat .or. ivt == nirrig_wwheat) then + rbufslp(p) = rbufslp(p) * this%vf_patch(p) + end if + else + rbufslp(p) = accumResetVal + end if + end do + call update_accum_field ('GDDPLANT', rbufslp, nstep) + call extract_accum_field ('GDDPLANT', this%gddplant_patch, nstep) + + ! Accumulate and extract GDDTSOI + ! In agroibis this variable is calculated + ! to 0.05 m, so here we use the top two soil layers + + do p = begp,endp + if (this%croplive_patch(p)) then ! relative to planting date + ivt = patch%itype(p) + c = patch%column(p) + rbufslp(p) = max(0._r8, min(pftcon%mxtmp(ivt), & + ((t_soisno_col(c,1)*col%dz(c,1) + & + t_soisno_col(c,2)*col%dz(c,2))/(col%dz(c,1)+col%dz(c,2))) - & + (SHR_CONST_TKFRZ + pftcon%baset(ivt)))) * dtime/SHR_CONST_CDAY + if (ivt == nwwheat .or. ivt == nwwheat) then + rbufslp(p) = rbufslp(p) * this%vf_patch(p) + end if + else + rbufslp(p) = accumResetVal + end if + end do + call update_accum_field ('GDDTSOI', rbufslp, nstep) + call extract_accum_field ('GDDTSOI', this%gddtsoi_patch, nstep) + + deallocate(rbufslp) + + end subroutine CropUpdateAccVars + + !----------------------------------------------------------------------- + subroutine CropIncrementYear (this, num_pcropp, filter_pcropp) + ! + ! !DESCRIPTION: + ! Increment the crop year, if appropriate + ! + ! This routine should be called every time step + ! + ! !USES: + use clm_time_manager , only : get_curr_date, is_first_step + ! + ! !ARGUMENTS: + class(crop_type) :: this + integer , intent(in) :: num_pcropp ! number of prog. crop patches in filter + integer , intent(in) :: filter_pcropp(:) ! filter for prognostic crop patches + ! + ! !LOCAL VARIABLES: + integer kyr ! current year + integer kmo ! month of year (1, ..., 12) + integer kda ! day of month (1, ..., 31) + integer mcsec ! seconds of day (0, ..., seconds/day) + integer :: fp, p + !----------------------------------------------------------------------- + + call get_curr_date ( kyr, kmo, kda, mcsec) + ! Update nyrs when it's the end of the year (unless it's the very start of the + ! run). This assumes that, if this patch is active at the end of the year, then it was + ! active for the whole year. + if ((kmo == 1 .and. kda == 1 .and. mcsec == 0) .and. .not. is_first_step()) then + do fp = 1, num_pcropp + p = filter_pcropp(fp) + + this%nyrs_crop_active_patch(p) = this%nyrs_crop_active_patch(p) + 1 + end do + end if + + end subroutine CropIncrementYear + + !----------------------------------------------------------------------- + subroutine checkDates( ) + ! + ! !DESCRIPTION: + ! Make sure the dates are compatible. The date given to startup the model + ! and the date on the restart file must be the same although years can be + ! different. The dates need to be checked when the restart file is being + ! read in for a startup or branch case (they are NOT allowed to be different + ! for a restart case). + ! + ! For the prognostic crop model the date of planting is tracked and growing + ! degree days is tracked (with a 20 year mean) -- so shifting the start dates + ! messes up these bits of saved information. + ! + ! !ARGUMENTS: + use clm_time_manager, only : get_driver_start_ymd, get_start_date + use clm_varctl , only : iulog + use clm_varctl , only : nsrest, nsrBranch, nsrStartup + ! + ! !LOCAL VARIABLES: + integer :: stymd ! Start date YYYYMMDD from driver + integer :: styr ! Start year from driver + integer :: stmon_day ! Start date MMDD from driver + integer :: rsmon_day ! Restart date MMDD from restart file + integer :: rsyr ! Restart year from restart file + integer :: rsmon ! Restart month from restart file + integer :: rsday ! Restart day from restart file + integer :: tod ! Restart time of day from restart file + character(len=*), parameter :: formDate = '(A,i4.4,"/",i2.2,"/",i2.2)' ! log output format + character(len=32) :: subname = 'CropRest::checkDates' + !----------------------------------------------------------------------- + ! + ! If branch or startup make sure the startdate is compatible with the date + ! on the restart file. + ! + if ( nsrest == nsrBranch .or. nsrest == nsrStartup )then + stymd = get_driver_start_ymd() + styr = stymd / 10000 + stmon_day = stymd - styr*10000 + call get_start_date( rsyr, rsmon, rsday, tod ) + rsmon_day = rsmon*100 + rsday + if ( masterproc ) & + write(iulog,formDate) 'Date on the restart file is: ', rsyr, rsmon, rsday + if ( stmon_day /= rsmon_day )then + write(iulog,formDate) 'Start date is: ', styr, stmon_day/100, & + (stmon_day - stmon_day/100) + call endrun(msg=' ERROR: For prognostic crop to work correctly, the start date (month and day)'// & + ' and the date on the restart file needs to match (years can be different)'//& + errMsg(sourcefile, __LINE__)) + end if + end if + + end subroutine checkDates + +end module CropType + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/EnergyFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/EnergyFluxType.F90 new file mode 100644 index 000000000..5634d26e5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/EnergyFluxType.F90 @@ -0,0 +1,1037 @@ +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 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 AnnualFluxDribbler, only : annual_flux_dribbler_type, annual_flux_dribbler_gridcell + ! + implicit none + save + private + ! + 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) + + ! Objects that help convert once-per-year dynamic land cover changes into fluxes + ! that are dribbled throughout the year + type(annual_flux_dribbler_type) :: eflx_dynbal_dribbler + + contains + + procedure, public :: Init ! Public initialization method + procedure, private :: InitAllocate ! initialize/allocate + procedure, private :: InitHistory ! setup history fields + procedure, private :: InitCold ! initialize for cold start + procedure, public :: Restart ! setup restart fields + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: UpdateAccVars + + end type energyflux_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, t_grnd_col, is_simple_buildtemp, is_prog_buildtemp ) + ! + ! !DESCRIPTION: + ! Allocate and initialize the data type and setup history, and initialize for cold-start. + ! !USES: + implicit none + ! !ARGUMENTS: + class(energyflux_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: t_grnd_col( bounds%begc: ) + logical , intent(in) :: is_simple_buildtemp ! If using simple building temp method + logical , intent(in) :: is_prog_buildtemp ! If using prognostic building temp method + + SHR_ASSERT_ALL_FL((ubound(t_grnd_col) == (/bounds%endc/)), sourcefile, __LINE__) + + call this%InitAllocate ( bounds ) + call this%InitHistory ( bounds, is_simple_buildtemp ) + call this%InitCold ( bounds, t_grnd_col, is_simple_buildtemp, is_prog_buildtemp ) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize and allocate data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varpar , only : nlevsno, nlevgrnd, nlevlak + implicit none + ! + ! !ARGUMENTS: + class(energyflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + 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 + + this%eflx_dynbal_dribbler = annual_flux_dribbler_gridcell( & + bounds = bounds, & + name = 'eflx_dynbal', & + units = 'J/m**2') + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds, is_simple_buildtemp) + ! + ! !DESCRIPTION: + ! Setup fields that can be output to history files + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varpar , only : nlevsno, nlevgrnd + use clm_varctl , only : use_cn, use_hydrstress + use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal + use ncdio_pio , only : ncd_inqvdlen + implicit none + ! + ! !ARGUMENTS: + class(energyflux_type) :: this + type(bounds_type), intent(in) :: bounds + logical , intent(in) :: is_simple_buildtemp ! If using simple building temp method + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: begl, endl + integer :: begg, endg + integer :: dimlen + integer :: err_code + logical :: do_io + character(10) :: active + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begl = bounds%begl; endl= bounds%endl + begg = bounds%begg; endg= bounds%endg + + + this%eflx_dynbal_grc(begg:endg) = spval + call hist_addfld1d (fname='EFLX_DYNBAL', units='W/m^2', & + avgflag='A', long_name='dynamic land cover change conversion energy flux', & + ptr_lnd=this%eflx_dynbal_grc) + + this%eflx_snomelt_col(begc:endc) = spval + call hist_addfld1d (fname='FSM', units='W/m^2', & + avgflag='A', long_name='snow melt heat flux', & + ptr_col=this%eflx_snomelt_col, c2l_scale_type='urbanf') + + call hist_addfld1d (fname='FSM_ICE', units='W/m^2', & + avgflag='A', long_name='snow melt heat flux (ice landunits only)', & + ptr_col=this%eflx_snomelt_col, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%eflx_snomelt_r_col(begc:endc) = spval + call hist_addfld1d (fname='FSM_R', units='W/m^2', & + avgflag='A', long_name='Rural snow melt heat flux', & + ptr_col=this%eflx_snomelt_r_col, set_spec=spval, default='inactive') + + this%eflx_snomelt_u_col(begc:endc) = spval + call hist_addfld1d (fname='FSM_U', units='W/m^2', & + avgflag='A', long_name='Urban snow melt heat flux', & + ptr_col=this%eflx_snomelt_u_col, c2l_scale_type='urbanf', set_nourb=spval, default='inactive') + + this%eflx_lwrad_net_patch(begp:endp) = spval + call hist_addfld1d (fname='FIRA', units='W/m^2', & + avgflag='A', long_name='net infrared (longwave) radiation', & + ptr_patch=this%eflx_lwrad_net_patch, c2l_scale_type='urbanf') + + call hist_addfld1d (fname='FIRA_ICE', units='W/m^2', & + avgflag='A', long_name='net infrared (longwave) radiation (ice landunits only)', & + ptr_patch=this%eflx_lwrad_net_patch, c2l_scale_type='urbanf', l2g_scale_type='ice',& + default='inactive') + + this%eflx_lwrad_net_r_patch(begp:endp) = spval + call hist_addfld1d (fname='FIRA_R', units='W/m^2', & + avgflag='A', long_name='Rural net infrared (longwave) radiation', & + ptr_patch=this%eflx_lwrad_net_r_patch, set_spec=spval) + + this%eflx_lwrad_out_patch(begp:endp) = spval + call hist_addfld1d (fname='FIRE', units='W/m^2', & + avgflag='A', long_name='emitted infrared (longwave) radiation', & + ptr_patch=this%eflx_lwrad_out_patch, c2l_scale_type='urbanf') + ! Rename of FIRE for Urban intercomparision project + call hist_addfld1d (fname='LWup', units='W/m^2', & + avgflag='A', long_name='upwelling longwave radiation', & + ptr_patch=this%eflx_lwrad_out_patch, c2l_scale_type='urbanf', default='inactive') + + call hist_addfld1d (fname='FIRE_ICE', units='W/m^2', & + avgflag='A', long_name='emitted infrared (longwave) radiation (ice landunits only)', & + ptr_patch=this%eflx_lwrad_out_patch, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%eflx_lwrad_out_r_patch(begp:endp) = spval + call hist_addfld1d (fname='FIRE_R', units='W/m^2', & + avgflag='A', long_name='Rural emitted infrared (longwave) radiation', & + ptr_patch=this%eflx_lwrad_out_r_patch, set_spec=spval) + + this%eflx_lh_vegt_patch(begp:endp) = spval + call hist_addfld1d (fname='FCTR', units='W/m^2', & + avgflag='A', long_name='canopy transpiration', & + ptr_patch=this%eflx_lh_vegt_patch, set_lake=0._r8, c2l_scale_type='urbanf') + + this%eflx_lh_vege_patch(begp:endp) = spval + call hist_addfld1d (fname='FCEV', units='W/m^2', & + avgflag='A', long_name='canopy evaporation', & + ptr_patch=this%eflx_lh_vege_patch, set_lake=0._r8, c2l_scale_type='urbanf') + + this%eflx_lh_grnd_patch(begp:endp) = spval + call hist_addfld1d (fname='FGEV', units='W/m^2', & + avgflag='A', long_name='ground evaporation', & + ptr_patch=this%eflx_lh_grnd_patch, c2l_scale_type='urbanf') + + this%eflx_sh_tot_patch(begp:endp) = spval + call hist_addfld1d (fname='FSH', units='W/m^2', & + avgflag='A', long_name='sensible heat not including correction for land use change and rain/snow conversion', & + ptr_patch=this%eflx_sh_tot_patch, c2l_scale_type='urbanf') + + call hist_addfld1d (fname='FSH_ICE', units='W/m^2', & + avgflag='A', & + long_name='sensible heat not including correction for land use change and rain/snow conversion (ice landunits only)', & + ptr_patch=this%eflx_sh_tot_patch, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%eflx_sh_tot_r_patch(begp:endp) = spval + call hist_addfld1d (fname='FSH_R', units='W/m^2', & + avgflag='A', long_name='Rural sensible heat', & + ptr_patch=this%eflx_sh_tot_r_patch, set_spec=spval) + + this%eflx_sh_tot_patch(begp:endp) = spval + call hist_addfld1d (fname='Qh', units='W/m^2', & + avgflag='A', long_name='sensible heat', & + ptr_patch=this%eflx_sh_tot_patch, c2l_scale_type='urbanf', & + default = 'inactive') + + this%eflx_lh_tot_patch(begp:endp) = spval + call hist_addfld1d (fname='Qle', units='W/m^2', & + avgflag='A', long_name='total evaporation', & + ptr_patch=this%eflx_lh_tot_patch, c2l_scale_type='urbanf', & + default = 'inactive') + + this%eflx_lh_tot_patch(begp:endp) = spval + call hist_addfld1d (fname='EFLX_LH_TOT', units='W/m^2', & + avgflag='A', long_name='total latent heat flux [+ to atm]', & + ptr_patch=this%eflx_lh_tot_patch, c2l_scale_type='urbanf') + + call hist_addfld1d (fname='EFLX_LH_TOT_ICE', units='W/m^2', & + avgflag='A', long_name='total latent heat flux [+ to atm] (ice landunits only)', & + ptr_patch=this%eflx_lh_tot_patch, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%eflx_lh_tot_r_patch(begp:endp) = spval + call hist_addfld1d (fname='EFLX_LH_TOT_R', units='W/m^2', & + avgflag='A', long_name='Rural total evaporation', & + ptr_patch=this%eflx_lh_tot_r_patch, set_spec=spval) + + this%eflx_soil_grnd_patch(begp:endp) = spval + call hist_addfld1d (fname='Qstor', units='W/m^2', & + avgflag='A', long_name='storage heat flux (includes snowmelt)', & + ptr_patch=this%eflx_soil_grnd_patch, c2l_scale_type='urbanf', & + default = 'inactive') + this%eflx_sh_veg_patch(begp:endp) = spval + call hist_addfld1d (fname='FSH_V', units='W/m^2', & + avgflag='A', long_name='sensible heat from veg', & + ptr_patch=this%eflx_sh_veg_patch, set_lake=0._r8, c2l_scale_type='urbanf') + + if (use_biomass_heat_storage) then + this%eflx_sh_stem_patch(begp:endp) = spval + call hist_addfld1d (fname='FSH_STEM', units='W/m^2', & + avgflag='A', long_name='sensible heat from stem', & + ptr_patch=this%eflx_sh_stem_patch, c2l_scale_type='urbanf',default = 'inactive') + + this%dhsdt_canopy_patch(begp:endp) = spval + call hist_addfld1d (fname='DHSDT_CANOPY', units='W/m^2', & + avgflag='A', long_name='change in canopy heat storage', & + ptr_patch=this%dhsdt_canopy_patch, set_lake=0._r8, c2l_scale_type='urbanf',default='active') + endif + + this%eflx_sh_grnd_patch(begp:endp) = spval + call hist_addfld1d (fname='FSH_G', units='W/m^2', & + avgflag='A', long_name='sensible heat from ground', & + ptr_patch=this%eflx_sh_grnd_patch, c2l_scale_type='urbanf') + + this%eflx_soil_grnd_patch(begp:endp) = spval + call hist_addfld1d (fname='FGR', units='W/m^2', & + avgflag='A', long_name='heat flux into soil/snow including snow melt and lake / snow light transmission', & + ptr_patch=this%eflx_soil_grnd_patch, c2l_scale_type='urbanf') + + call hist_addfld1d (fname='FGR_ICE', units='W/m^2', & + avgflag='A', & + long_name='heat flux into soil/snow including snow melt and lake / snow light transmission (ice landunits only)', & + ptr_patch=this%eflx_soil_grnd_patch, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%eflx_soil_grnd_r_patch(begp:endp) = spval + call hist_addfld1d (fname='FGR_R', units='W/m^2', & + avgflag='A', long_name='Rural heat flux into soil/snow including snow melt and snow light transmission', & + ptr_patch=this%eflx_soil_grnd_r_patch, set_spec=spval, default='inactive') + + this%eflx_lwrad_net_u_patch(begp:endp) = spval + call hist_addfld1d (fname='FIRA_U', units='W/m^2', & + avgflag='A', long_name='Urban net infrared (longwave) radiation', & + ptr_patch=this%eflx_lwrad_net_u_patch, c2l_scale_type='urbanf', set_nourb=spval, default='inactive') + + this%eflx_soil_grnd_patch(begp:endp) = spval + call hist_addfld1d (fname='EFLX_SOIL_GRND', units='W/m^2', & + avgflag='A', long_name='soil heat flux [+ into soil]', & + ptr_patch=this%eflx_soil_grnd_patch, default='inactive', c2l_scale_type='urbanf') + + this%eflx_lwrad_out_u_patch(begp:endp) = spval + call hist_addfld1d (fname='FIRE_U', units='W/m^2', & + avgflag='A', long_name='Urban emitted infrared (longwave) radiation', & + ptr_patch=this%eflx_lwrad_out_u_patch, c2l_scale_type='urbanf', set_nourb=spval, default='inactive') + + this%eflx_sh_tot_u_patch(begp:endp) = spval + call hist_addfld1d (fname='FSH_U', units='W/m^2', & + avgflag='A', long_name='Urban sensible heat', & + ptr_patch=this%eflx_sh_tot_u_patch, c2l_scale_type='urbanf', set_nourb=spval, default='inactive') + + this%eflx_sh_precip_conversion_col(begc:endc) = spval + call hist_addfld1d (fname = 'FSH_PRECIP_CONVERSION', units='W/m^2', & + avgflag='A', long_name='Sensible heat flux from conversion of rain/snow atm forcing', & + ptr_col=this%eflx_sh_precip_conversion_col, c2l_scale_type='urbanf') + + this%eflx_lh_tot_u_patch(begp:endp) = spval + call hist_addfld1d (fname='EFLX_LH_TOT_U', units='W/m^2', & + avgflag='A', long_name='Urban total evaporation', & + ptr_patch=this%eflx_lh_tot_u_patch, c2l_scale_type='urbanf', set_nourb=spval, default='inactive') + + this%eflx_soil_grnd_u_patch(begp:endp) = spval + call hist_addfld1d (fname='FGR_U', units='W/m^2', & + avgflag='A', long_name='Urban heat flux into soil/snow including snow melt', & + ptr_patch=this%eflx_soil_grnd_u_patch, c2l_scale_type='urbanf', set_nourb=spval, default='inactive') + + this%netrad_patch(begp:endp) = spval + call hist_addfld1d (fname='Rnet', units='W/m^2', & + avgflag='A', long_name='net radiation', & + ptr_patch=this%netrad_patch, c2l_scale_type='urbanf', & + default='inactive') + + if (use_cn) then + this%dlrad_patch(begp:endp) = spval + call hist_addfld1d (fname='DLRAD', units='W/m^2', & + avgflag='A', long_name='downward longwave radiation below the canopy', & + ptr_patch=this%dlrad_patch, default='inactive', c2l_scale_type='urbanf') + end if + + if (use_cn) then + this%ulrad_patch(begp:endp) = spval + call hist_addfld1d (fname='ULRAD', units='W/m^2', & + avgflag='A', long_name='upward longwave radiation above the canopy', & + ptr_patch=this%ulrad_patch, default='inactive', c2l_scale_type='urbanf') + end if + + if (use_cn) then + this%cgrnd_patch(begp:endp) = spval + call hist_addfld1d (fname='CGRND', units='W/m^2/K', & + avgflag='A', long_name='deriv. of soil energy flux wrt to soil temp', & + ptr_patch=this%cgrnd_patch, default='inactive', c2l_scale_type='urbanf') + end if + + if (use_cn) then + this%cgrndl_patch(begp:endp) = spval + call hist_addfld1d (fname='CGRNDL', units='W/m^2/K', & + avgflag='A', long_name='deriv. of soil latent heat flux wrt soil temp', & + ptr_patch=this%cgrndl_patch, default='inactive', c2l_scale_type='urbanf') + end if + + if (use_cn) then + this%cgrnds_patch(begp:endp) = spval + call hist_addfld1d (fname='CGRNDS', units='W/m^2/K', & + avgflag='A', long_name='deriv. of soil sensible heat flux wrt soil temp', & + ptr_patch=this%cgrnds_patch, default='inactive', c2l_scale_type='urbanf') + end if + + this%eflx_gnet_patch(begp:endp) = spval + call hist_addfld1d (fname='EFLX_GNET', units='W/m^2', & + avgflag='A', long_name='net heat flux into ground', & + ptr_patch=this%eflx_gnet_patch, default='inactive', c2l_scale_type='urbanf') + + this%eflx_grnd_lake_patch(begp:endp) = spval + call hist_addfld1d (fname='EFLX_GRND_LAKE', units='W/m^2', & + avgflag='A', long_name='net heat flux into lake/snow surface, excluding light transmission', & + ptr_patch=this%eflx_grnd_lake_patch, set_nolake=spval) + + if ( is_simple_buildtemp )then + this%eflx_building_heat_errsoi_col(begc:endc) = spval + call hist_addfld1d (fname='BUILDHEAT', units='W/m^2', & + avgflag='A', long_name='heat flux from urban building interior to walls and roof', & + ptr_col=this%eflx_building_heat_errsoi_col, set_nourb=0._r8, c2l_scale_type='urbanf') + + this%eflx_urban_ac_col(begc:endc) = spval + call hist_addfld1d (fname='URBAN_AC', units='W/m^2', & + avgflag='A', long_name='urban air conditioning flux', & + ptr_col=this%eflx_urban_ac_col, set_nourb=0._r8, c2l_scale_type='urbanf') + + this%eflx_urban_heat_col(begc:endc) = spval + call hist_addfld1d (fname='URBAN_HEAT', units='W/m^2', & + avgflag='A', long_name='urban heating flux', & + ptr_col=this%eflx_urban_heat_col, set_nourb=0._r8, c2l_scale_type='urbanf') + else + this%eflx_urban_ac_lun(begl:endl) = spval + call hist_addfld1d (fname='EFLXBUILD', units='W/m^2', & + avgflag='A', long_name='building heat flux from change in interior building air temperature', & + ptr_lunit=this%eflx_building_lun, set_nourb=0._r8, l2g_scale_type='unity') + + this%eflx_urban_ac_lun(begl:endl) = spval + call hist_addfld1d (fname='URBAN_AC', units='W/m^2', & + avgflag='A', long_name='urban air conditioning flux', & + ptr_lunit=this%eflx_urban_ac_lun, set_nourb=0._r8, l2g_scale_type='unity') + + this%eflx_urban_heat_lun(begl:endl) = spval + call hist_addfld1d (fname='URBAN_HEAT', units='W/m^2', & + avgflag='A', long_name='urban heating flux', & + ptr_lunit=this%eflx_urban_heat_lun, set_nourb=0._r8, l2g_scale_type='unity') + end if + + + this%dgnetdT_patch(begp:endp) = spval + call hist_addfld1d (fname='DGNETDT', units='W/m^2/K', & + avgflag='A', long_name='derivative of net ground heat flux wrt soil temp', & + ptr_patch=this%dgnetdT_patch, default='inactive', c2l_scale_type='urbanf') + + this%eflx_fgr12_col(begc:endc) = spval + call hist_addfld1d (fname='FGR12', units='W/m^2', & + avgflag='A', long_name='heat flux between soil layers 1 and 2', & + ptr_col=this%eflx_fgr12_col, set_lake=spval) + + this%eflx_fgr_col(begc:endc,:) = spval + call hist_addfld2d (fname='FGR_SOIL_R', units='watt/m^2', type2d='levgrnd', & + avgflag='A', long_name='Rural downward heat flux at interface below each soil layer', & + ptr_col=this%eflx_fgr_col, set_spec=spval, default='inactive') + + this%eflx_traffic_patch(begp:endp) = spval + call hist_addfld1d (fname='TRAFFICFLUX', units='W/m^2', & + avgflag='A', long_name='sensible heat flux from urban traffic', & + ptr_patch=this%eflx_traffic_patch, set_nourb=0._r8, c2l_scale_type='urbanf', & + default='inactive') + + this%eflx_wasteheat_patch(begp:endp) = spval + call hist_addfld1d (fname='WASTEHEAT', units='W/m^2', & + avgflag='A', long_name='sensible heat flux from heating/cooling sources of urban waste heat', & + ptr_patch=this%eflx_wasteheat_patch, set_nourb=0._r8, c2l_scale_type='urbanf') + + this%eflx_heat_from_ac_patch(begp:endp) = spval + call hist_addfld1d (fname='HEAT_FROM_AC', units='W/m^2', & + avgflag='A', long_name='sensible heat flux put into canyon due to heat removed from air conditioning', & + ptr_patch=this%eflx_heat_from_ac_patch, set_nourb=0._r8, c2l_scale_type='urbanf') + + if ( is_simple_buildtemp )then + this%eflx_anthro_patch(begp:endp) = spval + call hist_addfld1d (fname='Qanth', units='W/m^2', & + avgflag='A', long_name='anthropogenic heat flux', & + ptr_patch=this%eflx_anthro_patch, set_nourb=0._r8, c2l_scale_type='urbanf', & + default='inactive') + end if + + this%taux_patch(begp:endp) = spval + call hist_addfld1d (fname='TAUX', units='kg/m/s^2', & + avgflag='A', long_name='zonal surface stress', & + ptr_patch=this%taux_patch) + ! Rename of TAUX for Urban intercomparision project (when U=V) + call hist_addfld1d (fname='Qtau', units='kg/m/s^2', & + avgflag='A', long_name='momentum flux', & + ptr_patch=this%taux_patch, default='inactive') + + this%tauy_patch(begp:endp) = spval + call hist_addfld1d (fname='TAUY', units='kg/m/s^2', & + avgflag='A', long_name='meridional surface stress', & + ptr_patch=this%tauy_patch) + + this%btran_patch(begp:endp) = spval + if (.not. use_hydrstress) then + call hist_addfld1d (fname='BTRAN', units='unitless', & + avgflag='A', long_name='transpiration beta factor', & + ptr_patch=this%btran_patch, l2g_scale_type='veg') + end if + + this%btran_min_patch(begp:endp) = spval + call hist_addfld1d (fname='BTRANMN', units='unitless', & + avgflag='A', long_name='daily minimum of transpiration beta factor', & + ptr_patch=this%btran_min_patch, l2g_scale_type='veg') + + if (use_cn) then + this%rresis_patch(begp:endp,:) = spval + call hist_addfld2d (fname='RRESIS', units='proportion', type2d='levgrnd', & + avgflag='A', long_name='root resistance in each soil layer', & + ptr_patch=this%rresis_patch, l2g_scale_type='veg', default='inactive') + end if + + this%errsoi_col(begc:endc) = spval + call hist_addfld1d (fname='ERRSOI', units='W/m^2', & + avgflag='A', long_name='soil/lake energy conservation error', & + ptr_col=this%errsoi_col) + + this%errseb_patch(begp:endp) = spval + call hist_addfld1d (fname='ERRSEB', units='W/m^2', & + avgflag='A', long_name='surface energy conservation error', & + ptr_patch=this%errseb_patch) + + this%errsol_patch(begp:endp) = spval + call hist_addfld1d (fname='ERRSOL', units='W/m^2', & + avgflag='A', long_name='solar radiation conservation error', & + ptr_patch=this%errsol_patch, set_urb=spval) + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds, t_grnd_col, is_simple_buildtemp, is_prog_buildtemp) + ! + ! !DESCRIPTION: + ! Initialize cold start conditions for module variables + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_TKFRZ + use clm_varpar , only : nlevsoi, nlevgrnd, nlevsno, nlevlak, nlevurb + use clm_varcon , only : denice, denh2o, sb + use landunit_varcon , only : istwet, istsoil, istdlak + use column_varcon , only : icol_road_imperv, icol_roof, icol_sunwall + use column_varcon , only : icol_shadewall, icol_road_perv + use clm_varctl , only : iulog, use_vancouver, use_mexicocity + implicit none + ! + ! !ARGUMENTS: + class(energyflux_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: t_grnd_col( bounds%begc: ) + logical , intent(in) :: is_simple_buildtemp ! If using simple building temp method + logical , intent(in) :: is_prog_buildtemp ! If using prognostic building temp method + ! + ! !LOCAL VARIABLES: + integer :: j,l,c,p,levs,lev + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(t_grnd_col) == (/bounds%endc/)), sourcefile, __LINE__) + + ! Columns + if ( is_simple_buildtemp )then + do c = bounds%begc, bounds%endc + l = col%landunit(c) + + if (lun%urbpoi(l)) then + this%eflx_building_heat_errsoi_col(c) = 0._r8 + this%eflx_urban_ac_col(c) = 0._r8 + this%eflx_urban_heat_col(c) = 0._r8 + else + this%eflx_building_heat_errsoi_col(c) = 0._r8 + this%eflx_urban_ac_col(c) = 0._r8 + this%eflx_urban_heat_col(c) = 0._r8 + end if + + end do + end if + + ! Patches + do p = bounds%begp, bounds%endp + c = patch%column(p) + l = patch%landunit(p) + + if (.not. lun%urbpoi(l)) then ! non-urban + this%eflx_lwrad_net_u_patch(p) = spval + this%eflx_lwrad_out_u_patch(p) = spval + this%eflx_lh_tot_u_patch(p) = spval + this%eflx_sh_tot_u_patch(p) = spval + this%eflx_soil_grnd_u_patch(p) = spval + end if + + this%eflx_lwrad_out_patch(p) = sb * (t_grnd_col(c))**4 + end do + + ! patches + do p = bounds%begp, bounds%endp + l = patch%landunit(p) + + if (.not. lun%urbpoi(l)) then + this%eflx_traffic_lun(l) = spval + this%eflx_wasteheat_lun(l) = spval + if ( is_prog_buildtemp )then + this%eflx_building_lun(l) = 0._r8 + this%eflx_urban_ac_lun(l) = 0._r8 + this%eflx_urban_heat_lun(l) = 0._r8 + end if + + this%eflx_wasteheat_patch(p) = 0._r8 + this%eflx_heat_from_ac_patch(p) = 0._r8 + this%eflx_traffic_patch(p) = 0._r8 + if ( is_simple_buildtemp) & + this%eflx_anthro_patch(p) = 0._r8 + else + if ( is_prog_buildtemp )then + this%eflx_building_lun(l) = 0._r8 + this%eflx_urban_ac_lun(l) = 0._r8 + this%eflx_urban_heat_lun(l) = 0._r8 + end if + end if + end do + + ! initialize rresis, for use in ecosystemdyn + do p = bounds%begp,bounds%endp + do lev = 1,nlevgrnd + this%rresis_patch(p,lev) = 0._r8 + end do + end do + + end subroutine InitCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag, is_simple_buildtemp, is_prog_buildtemp) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use shr_log_mod, only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc + use abortutils , only : endrun + use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_double, ncd_int, & + ncd_inqvdlen + use restUtilMod + use decompMod , only : get_proc_global + implicit none + ! + ! !ARGUMENTS: + class(energyflux_type) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid + character(len=*) , intent(in) :: flag + logical , intent(in) :: is_simple_buildtemp ! If using simple building temp method + logical , intent(in) :: is_prog_buildtemp ! If using prognostic building temp method + ! + ! !LOCAL VARIABLES: + integer :: j,c ! indices + integer :: dimlen + integer :: err_code + integer :: numl_global + logical :: readvar ! determine if variable is on initial file + logical :: do_io + !----------------------------------------------------------------------- + + call get_proc_global(nl=numl_global) + call restartvar(ncid=ncid, flag=flag, varname='EFLX_LWRAD_OUT', xtype=ncd_double, & + dim1name='pft', & + long_name='emitted infrared (longwave) radiation', units='watt/m^2', & + interpinic_flag='interp', readvar=readvar, data=this%eflx_lwrad_out_patch) + + ! Restart for building air temperature method + if ( is_prog_buildtemp )then + ! landunit urban energy state variable - eflx_urban_ac + do_io = .true. + ! On a read, confirm that this variable has the expected size (landunit-level); if not, + ! don't read it (instead give it a default value). This is needed to support older initial + ! conditions for which this variable had a different size (column-level). + if (flag == 'read') then + call ncd_inqvdlen(ncid, 'URBAN_AC_L', 1, dimlen, err_code) + if (dimlen /= numl_global) then + do_io = .false. + readvar = .false. + end if + end if + if (do_io) then + call restartvar(ncid=ncid, flag=flag, varname='URBAN_AC_L', xtype=ncd_double, & + dim1name='landunit',& + long_name='urban air conditioning flux', units='watt/m^2', & + interpinic_flag='interp', readvar=readvar, data=this%eflx_urban_ac_lun) + else + this%eflx_urban_ac_lun = 0.0_r8 + end if + ! landunit urban energy state variable - eflx_urban_heat + do_io = .true. + ! On a read, confirm that this variable has the expected size (landunit-level); if not, + ! don't read it (instead give it a default value). This is needed to support older initial + ! conditions for which this variable had a different size (column-level). + if (flag == 'read') then + call ncd_inqvdlen(ncid, 'URBAN_HEAT_L', 1, dimlen, err_code) + if (dimlen /= numl_global) then + do_io = .false. + readvar = .false. + end if + end if + if (do_io) then + call restartvar(ncid=ncid, flag=flag, varname='URBAN_HEAT_L', xtype=ncd_double, & + dim1name='landunit',& + long_name='urban heating flux', units='watt/m^2', & + interpinic_flag='interp', readvar=readvar, data=this%eflx_urban_heat_lun) + else + this%eflx_urban_heat_lun = 0.0_r8 + end if + else if ( is_simple_buildtemp )then + call restartvar(ncid=ncid, flag=flag, varname='URBAN_AC', xtype=ncd_double, & + dim1name='column', & + long_name='urban air conditioning flux', units='watt/m^2', & + interpinic_flag='interp', readvar=readvar, data=this%eflx_urban_ac_col) + call restartvar(ncid=ncid, flag=flag, varname='URBAN_HEAT', xtype=ncd_double, & + dim1name='column', & + long_name='urban heating flux', units='watt/m^2', & + interpinic_flag='interp', readvar=readvar, data=this%eflx_urban_heat_col) + end if + + call restartvar(ncid=ncid, flag=flag, varname='BTRAN_MIN', xtype=ncd_double, & + dim1name='pft', & + long_name='daily minimum of transpiration wetness factor', units='', & + interpinic_flag='interp', readvar=readvar, data=this%btran_min_patch) + + call restartvar(ncid=ncid, flag=flag, varname='BTRAN_MIN_INST', xtype=ncd_double, & + dim1name='pft', & + long_name='instantaneous daily minimum of transpiration wetness factor', units='', & + interpinic_flag='interp', readvar=readvar, data=this%btran_min_inst_patch) + + call this%eflx_dynbal_dribbler%Restart(bounds, ncid, flag) + + end subroutine Restart + !----------------------------------------------------------------------- + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! Each interval and accumulation type is unique to each field processed. + ! Routine [initAccBuffer] defines the fields to be processed + ! and the type of accumulation. + ! Routine [updateAccVars] does the actual accumulation for a given field. + ! Fields are accumulated by calls to subroutine [update_accum_field]. + ! To accumulate a field, it must first be defined in subroutine [initAccVars] + ! and then accumulated by calls to [updateAccVars]. + ! Four types of accumulations are possible: + ! o average over time interval + ! o running mean over time interval + ! o running accumulation over time interval + ! Time average fields are only valid at the end of the averaging interval. + ! Running means are valid once the length of the simulation exceeds the + ! averaging interval. Accumulated fields are continuously accumulated. + ! The trigger value "-99999." resets the accumulation to zero. + ! + ! !USES + use accumulMod , only : init_accum_field + use clm_time_manager , only : get_step_size_real + use shr_const_mod , only : SHR_CONST_CDAY, SHR_CONST_TKFRZ + ! + ! !ARGUMENTS: + class(energyflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + real(r8) :: dtime + integer, parameter :: not_used = huge(1) + !--------------------------------------------------------------------- + + dtime = get_step_size_real() + + call init_accum_field(name='BTRANAV', units='-', & + desc='average over an hour of btran', accum_type='timeavg', accum_period=nint(3600._r8/dtime), & + subgrid_type='pft', numlev=1, init_value=0._r8) + + end subroutine InitAccBuffer + !----------------------------------------------------------------------- + subroutine InitAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES + use accumulMod , only : init_accum_field, extract_accum_field + use clm_time_manager , only : get_nstep + use clm_varctl , only : nsrest, nsrStartup + use abortutils , only : endrun + ! + ! !ARGUMENTS: + class(energyflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: nstep + integer :: ier + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + ! Initialize variables that are to be time accumulated + ! Initialize btran min values + if (nsrest == nsrStartup) then + this%btran_min_patch(begp:endp) = spval + + this%btran_min_inst_patch(begp:endp) = spval + end if + + end subroutine InitAccVars + !----------------------------------------------------------------------- + subroutine UpdateAccVars (this, bounds) + ! + ! USES + use shr_const_mod , only : SHR_CONST_CDAY, SHR_CONST_TKFRZ + use clm_time_manager , only : get_step_size, get_nstep, is_end_curr_day, get_curr_date + use accumulMod , only : update_accum_field, extract_accum_field, accumResetVal + use clm_varctl , only : iulog + use abortutils , only : endrun + ! + ! !ARGUMENTS: + class(energyflux_type) :: this + type(bounds_type) , intent(in) :: bounds + + ! + ! !LOCAL VARIABLES: + integer :: m,g,l,c,p ! indices + integer :: ier ! error status + integer :: dtime ! timestep size [seconds] + integer :: nstep ! timestep number + integer :: year ! year (0, ...) for nstep + integer :: month ! month (1, ..., 12) for nstep + integer :: day ! day of month (1, ..., 31) for nstep + integer :: secs ! seconds into current date for nstep + logical :: end_cd ! temporary for is_end_curr_day() value + integer :: begp, endp + real(r8), pointer :: rbufslp(:) ! temporary single level - pft level + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + dtime = get_step_size() + nstep = get_nstep() + call get_curr_date (year, month, day, secs) + + ! Allocate needed dynamic memory for single level pft field + + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)'update_accum_hist allocation error for rbuf1dp' + call endrun(msg=errMsg(__FILE__, __LINE__)) + endif + + ! Accumulate and extract BTRANAV - hourly average btran + ! Used to compute minimum of hourly averaged btran + ! over a day. Note that "spval" is returned by the call to + ! accext if the time step does not correspond to the end of an + ! accumulation interval. First, initialize the necessary values for + ! an initial run at the first time step the accumulator is called + + call update_accum_field ('BTRANAV', this%btran_patch, nstep) + call extract_accum_field ('BTRANAV', rbufslp, nstep) + end_cd = is_end_curr_day() + do p = begp,endp + if (rbufslp(p) /= spval) then + this%btran_min_inst_patch(p) = min(rbufslp(p), this%btran_min_inst_patch(p)) + endif + if (end_cd) then + this%btran_min_patch(p) = this%btran_min_inst_patch(p) + this%btran_min_inst_patch(p) = spval + else if (secs == dtime) then + this%btran_min_patch(p) = spval + endif + end do + + deallocate(rbufslp) + + end subroutine UpdateAccVars + +end module EnergyFluxType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/FireDataBaseType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/FireDataBaseType.F90 new file mode 100644 index 000000000..ac7d28171 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/FireDataBaseType.F90 @@ -0,0 +1,454 @@ +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_strdata_mod , only : shr_strdata_type, shr_strdata_create, shr_strdata_print + use shr_strdata_mod , only : shr_strdata_advance + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : iulog, inst_name + use spmdMod , only : masterproc, mpicom, comp_id + use fileutils , only : getavu, relavu + use decompMod , only : gsmap_lnd_gdc2glo + use domainMod , only : ldomain + use abortutils , only : endrun + use decompMod , only : bounds_type + use mct_mod + 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 + + type(shr_strdata_type) :: sdat_hdm ! Human population density input data stream + type(shr_strdata_type) :: sdat_lnfm ! Lightning input data stream + + + 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, public :: FireInterp ! Interpolate fire data + procedure(need_lightning_and_popdens_interface), public, deferred :: & + need_lightning_and_popdens ! Returns true if need lightning & popdens + ! + ! !PRIVATE MEMBER FUNCTIONS: + procedure, private :: hdm_init ! position datasets for dynamic human population density + procedure, private :: hdm_interp ! interpolates between two years of human pop. density file data + procedure, private :: lnfm_init ! position datasets for Lightning + procedure, private :: lnfm_interp ! interpolates between two years of Lightning file data + 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, NLFilename ) + ! + ! !DESCRIPTION: + ! Initialize CN Fire module + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !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 + + call this%hdm_init(bounds, NLFilename) + call this%hdm_interp(bounds) + call this%lnfm_init(bounds, NLFilename) + call this%lnfm_interp(bounds) + end if + + end subroutine BaseFireInit + + !----------------------------------------------------------------------- + subroutine FireInterp(this,bounds) + ! + ! !DESCRIPTION: + ! Interpolate CN Fire datasets + ! + ! !ARGUMENTS: + class(fire_base_type) :: this + type(bounds_type), intent(in) :: bounds + !----------------------------------------------------------------------- + + if ( this%need_lightning_and_popdens() ) then + call this%hdm_interp(bounds) + call this%lnfm_interp(bounds) + end if + + end subroutine FireInterp + + !----------------------------------------------------------------------- + subroutine hdm_init( this, bounds, NLFilename ) + ! + ! !DESCRIPTION: + ! Initialize data stream information for population density. + ! + ! !USES: + use clm_time_manager , only : get_calendar + use ncdio_pio , only : pio_subsystem + use shr_pio_mod , only : shr_pio_getiotype + use clm_nlUtilsMod , only : find_nlgroup_name + use ndepStreamMod , only : clm_domain_mct + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + implicit none + class(fire_base_type) :: this + type(bounds_type), intent(in) :: bounds + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: stream_year_first_popdens ! first year in pop. dens. stream to use + integer :: stream_year_last_popdens ! last year in pop. dens. stream to use + integer :: model_year_align_popdens ! align stream_year_first_hdm with + integer :: nu_nml ! unit for namelist file + integer :: nml_error ! namelist i/o error flag + type(mct_ggrid) :: dom_clm ! domain information + character(len=CL) :: stream_fldFileName_popdens ! population density streams filename + character(len=CL) :: popdensmapalgo = 'bilinear' ! mapping alogrithm for population density + character(len=CL) :: popdens_tintalgo = 'nearest'! time interpolation alogrithm for population density + character(*), parameter :: subName = "('hdmdyn_init')" + character(*), parameter :: F00 = "('(hdmdyn_init) ',4a)" + !----------------------------------------------------------------------- + + namelist /popd_streams/ & + stream_year_first_popdens, & + stream_year_last_popdens, & + model_year_align_popdens, & + popdensmapalgo, & + stream_fldFileName_popdens, & + popdens_tintalgo + + ! Default values for namelist + stream_year_first_popdens = 1 ! first year in stream to use + stream_year_last_popdens = 1 ! last year in stream to use + model_year_align_popdens = 1 ! align stream_year_first_popdens with this model year + stream_fldFileName_popdens = ' ' + + ! Read popd_streams namelist + if (masterproc) then + nu_nml = getavu() + open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) + call find_nlgroup_name(nu_nml, 'popd_streams', status=nml_error) + if (nml_error == 0) then + read(nu_nml, nml=popd_streams,iostat=nml_error) + if (nml_error /= 0) then + call endrun(msg='ERROR reading popd_streams namelist'//errMsg(sourcefile, __LINE__)) + end if + end if + close(nu_nml) + call relavu( nu_nml ) + endif + + call shr_mpi_bcast(stream_year_first_popdens, mpicom) + call shr_mpi_bcast(stream_year_last_popdens, mpicom) + call shr_mpi_bcast(model_year_align_popdens, mpicom) + call shr_mpi_bcast(stream_fldFileName_popdens, mpicom) + call shr_mpi_bcast(popdens_tintalgo, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) 'popdens_streams settings:' + write(iulog,*) ' stream_year_first_popdens = ',stream_year_first_popdens + write(iulog,*) ' stream_year_last_popdens = ',stream_year_last_popdens + write(iulog,*) ' model_year_align_popdens = ',model_year_align_popdens + write(iulog,*) ' stream_fldFileName_popdens = ',stream_fldFileName_popdens + write(iulog,*) ' popdens_tintalgo = ',popdens_tintalgo + write(iulog,*) ' ' + endif + + call clm_domain_mct (bounds, dom_clm) + + call shr_strdata_create(this%sdat_hdm,name="clmhdm", & + pio_subsystem=pio_subsystem, & + pio_iotype=shr_pio_getiotype(inst_name), & + mpicom=mpicom, compid=comp_id, & + gsmap=gsmap_lnd_gdc2glo, ggrid=dom_clm, & + nxg=ldomain%ni, nyg=ldomain%nj, & + yearFirst=stream_year_first_popdens, & + yearLast=stream_year_last_popdens, & + yearAlign=model_year_align_popdens, & + offset=0, & + domFilePath='', & + domFileName=trim(stream_fldFileName_popdens), & + domTvarName='time', & + domXvarName='lon' , & + domYvarName='lat' , & + domAreaName='area', & + domMaskName='mask', & + filePath='', & + filename=(/trim(stream_fldFileName_popdens)/) , & + fldListFile='hdm', & + fldListModel='hdm', & + fillalgo='none', & + mapalgo=popdensmapalgo, & + calendar=get_calendar(), & + tintalgo=popdens_tintalgo, & + taxmode='extend' ) + + if (masterproc) then + call shr_strdata_print(this%sdat_hdm,'population density data') + endif + + ! Add history fields + call hist_addfld1d (fname='HDM', units='counts/km^2', & + avgflag='A', long_name='human population density', & + ptr_lnd=this%forc_hdm, default='inactive') + + end subroutine hdm_init + + !----------------------------------------------------------------------- + subroutine hdm_interp( this, bounds) + ! + ! !DESCRIPTION: + ! Interpolate data stream information for population density. + ! + ! !USES: + use clm_time_manager, only : get_curr_date + ! + ! !ARGUMENTS: + class(fire_base_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g, ig + 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 :: mcdate ! Current model date (yyyymmdd) + !----------------------------------------------------------------------- + + call get_curr_date(year, mon, day, sec) + mcdate = year*10000 + mon*100 + day + + call shr_strdata_advance(this%sdat_hdm, mcdate, sec, mpicom, 'hdmdyn') + + ig = 0 + do g = bounds%begg,bounds%endg + ig = ig+1 + this%forc_hdm(g) = this%sdat_hdm%avs(1)%rAttr(1,ig) + end do + + end subroutine hdm_interp + + !----------------------------------------------------------------------- + subroutine lnfm_init( this, bounds, NLFilename ) + ! + ! !DESCRIPTION: + ! + ! Initialize data stream information for Lightning. + ! + ! !USES: + use clm_time_manager , only : get_calendar + use ncdio_pio , only : pio_subsystem + use shr_pio_mod , only : shr_pio_getiotype + use clm_nlUtilsMod , only : find_nlgroup_name + use ndepStreamMod , only : clm_domain_mct + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + implicit none + class(fire_base_type) :: this + type(bounds_type), intent(in) :: bounds + character(len=*), intent(in) :: NLFilename + ! + ! !LOCAL VARIABLES: + integer :: stream_year_first_lightng ! first year in Lightning stream to use + integer :: stream_year_last_lightng ! last year in Lightning stream to use + integer :: model_year_align_lightng ! align stream_year_first_lnfm with + integer :: nu_nml ! unit for namelist file + integer :: nml_error ! namelist i/o error flag + type(mct_ggrid) :: dom_clm ! domain information + character(len=CL) :: stream_fldFileName_lightng ! lightning stream filename to read + character(len=CL) :: lightng_tintalgo = 'linear'! time interpolation alogrithm + character(len=CL) :: lightngmapalgo = 'bilinear'! Mapping alogrithm + character(*), parameter :: subName = "('lnfmdyn_init')" + character(*), parameter :: F00 = "('(lnfmdyn_init) ',4a)" + !----------------------------------------------------------------------- + + namelist /light_streams/ & + stream_year_first_lightng, & + stream_year_last_lightng, & + model_year_align_lightng, & + lightngmapalgo, & + stream_fldFileName_lightng, & + lightng_tintalgo + + ! Default values for namelist + stream_year_first_lightng = 1 ! first year in stream to use + stream_year_last_lightng = 1 ! last year in stream to use + model_year_align_lightng = 1 ! align stream_year_first_lnfm with this model year + stream_fldFileName_lightng = ' ' + + ! Read light_streams namelist + if (masterproc) then + nu_nml = getavu() + open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) + call find_nlgroup_name(nu_nml, 'light_streams', status=nml_error) + if (nml_error == 0) then + read(nu_nml, nml=light_streams,iostat=nml_error) + if (nml_error /= 0) then + call endrun(msg='ERROR reading light_streams namelist'//errMsg(sourcefile, __LINE__)) + end if + end if + close(nu_nml) + call relavu( nu_nml ) + endif + + call shr_mpi_bcast(stream_year_first_lightng, mpicom) + call shr_mpi_bcast(stream_year_last_lightng, mpicom) + call shr_mpi_bcast(model_year_align_lightng, mpicom) + call shr_mpi_bcast(stream_fldFileName_lightng, mpicom) + call shr_mpi_bcast(lightng_tintalgo, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) 'light_stream settings:' + write(iulog,*) ' stream_year_first_lightng = ',stream_year_first_lightng + write(iulog,*) ' stream_year_last_lightng = ',stream_year_last_lightng + write(iulog,*) ' model_year_align_lightng = ',model_year_align_lightng + write(iulog,*) ' stream_fldFileName_lightng = ',stream_fldFileName_lightng + write(iulog,*) ' lightng_tintalgo = ',lightng_tintalgo + write(iulog,*) ' ' + endif + + call clm_domain_mct (bounds, dom_clm) + + call shr_strdata_create(this%sdat_lnfm,name="clmlnfm", & + pio_subsystem=pio_subsystem, & + pio_iotype=shr_pio_getiotype(inst_name), & + mpicom=mpicom, compid=comp_id, & + gsmap=gsmap_lnd_gdc2glo, ggrid=dom_clm, & + nxg=ldomain%ni, nyg=ldomain%nj, & + yearFirst=stream_year_first_lightng, & + yearLast=stream_year_last_lightng, & + yearAlign=model_year_align_lightng, & + offset=0, & + domFilePath='', & + domFileName=trim(stream_fldFileName_lightng), & + domTvarName='time', & + domXvarName='lon' , & + domYvarName='lat' , & + domAreaName='area', & + domMaskName='mask', & + filePath='', & + filename=(/trim(stream_fldFileName_lightng)/),& + fldListFile='lnfm', & + fldListModel='lnfm', & + fillalgo='none', & + tintalgo=lightng_tintalgo, & + mapalgo=lightngmapalgo, & + calendar=get_calendar(), & + taxmode='cycle' ) + + if (masterproc) then + call shr_strdata_print(this%sdat_lnfm,'Lightning data') + endif + + ! Add history fields + call hist_addfld1d (fname='LNFM', units='counts/km^2/hr', & + avgflag='A', long_name='Lightning frequency', & + ptr_lnd=this%forc_lnfm, default='inactive') + + end subroutine lnfm_init + + !----------------------------------------------------------------------- + subroutine lnfm_interp(this, bounds ) + ! + ! !DESCRIPTION: + ! Interpolate data stream information for Lightning. + ! + ! !USES: + use clm_time_manager, only : get_curr_date + ! + ! !ARGUMENTS: + class(fire_base_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g, ig + 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 :: mcdate ! Current model date (yyyymmdd) + !----------------------------------------------------------------------- + + call get_curr_date(year, mon, day, sec) + mcdate = year*10000 + mon*100 + day + + call shr_strdata_advance(this%sdat_lnfm, mcdate, sec, mpicom, 'lnfmdyn') + + ig = 0 + do g = bounds%begg,bounds%endg + ig = ig+1 + this%forc_lnfm(g) = this%sdat_lnfm%avs(1)%rAttr(1,ig) + end do + + end subroutine lnfm_interp + +end module FireDataBaseType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/FireMethodType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/FireMethodType.F90 new file mode 100644 index 000000000..63c05821b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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, NLFilename ) + ! + ! !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, soil_water_retention_curve, & + 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_orig_files/FrictionVelocityMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/FrictionVelocityMod.F90 new file mode 100644 index 000000000..9efd16787 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/FrictionVelocityMod.F90 @@ -0,0 +1,1103 @@ +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 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 + + 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 + + ! Public procedures + procedure, public :: Init + procedure, public :: Restart + procedure, public :: SetRoughnessLengthsAndForcHeightsNonLake ! Set roughness lengths and forcing heights for non-lake points + procedure, public :: SetActualRoughnessLengths ! Set roughness lengths actually used in flux calculations + procedure, public :: FrictionVelocity ! Calculate friction velocity + procedure, public :: MoninObukIni ! Initialization of the Monin-Obukhov length + + ! Private procedures + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, private :: ReadNamelist + procedure, private :: ReadParams + procedure, private, nopass :: StabilityFunc1 ! Stability function for rib < 0. + procedure, private, nopass :: StabilityFunc2 ! Stability function for rib < 0. + + end type frictionvel_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, NLFilename, params_ncid) + + class(frictionvel_type) :: this + type(bounds_type), intent(in) :: bounds + character(len=*), intent(in) :: NLFilename ! file name of namelist file + type(file_desc_t),intent(inout) :: params_ncid ! pio netCDF file id + + call this%InitAllocate(bounds) + call this%InitHistory(bounds) + call this%InitCold(bounds) + call this%ReadNamelist(NLFilename) + call this%ReadParams(params_ncid) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(frictionvel_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! History fields initialization + ! + ! !USES: + use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) + use histFileMod , only: hist_addfld1d, hist_addfld2d + ! + ! !ARGUMENTS: + class(frictionvel_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: begp, endp + !--------------------------------------------------------------------- + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + this%z0mg_col(begc:endc) = spval + call hist_addfld1d (fname='Z0MG', units='m', & + avgflag='A', long_name='roughness length over ground, momentum', & + ptr_col=this%z0mg_col, default='inactive') + + this%z0hg_col(begc:endc) = spval + call hist_addfld1d (fname='Z0HG', units='m', & + avgflag='A', long_name='roughness length over ground, sensible heat', & + ptr_col=this%z0hg_col, default='inactive') + + this%z0qg_col(begc:endc) = spval + call hist_addfld1d (fname='Z0QG', units='m', & + avgflag='A', long_name='roughness length over ground, latent heat', & + ptr_col=this%z0qg_col, default='inactive') + + this%va_patch(begp:endp) = spval + call hist_addfld1d (fname='VA', units='m/s', & + avgflag='A', long_name='atmospheric wind speed plus convective velocity', & + ptr_patch=this%va_patch, default='inactive') + + this%u10_clm_patch(begp:endp) = spval + call hist_addfld1d (fname='U10', units='m/s', & + avgflag='A', long_name='10-m wind', & + ptr_patch=this%u10_clm_patch) + + call hist_addfld1d (fname='U10_ICE', units='m/s', & + avgflag='A', long_name='10-m wind (ice landunits only)', & + ptr_patch=this%u10_clm_patch, l2g_scale_type='ice', default='inactive') + + this%u10_patch(begp:endp) = spval + call hist_addfld1d (fname='U10_DUST', units='m/s', & + avgflag='A', long_name='10-m wind for dust model', & + ptr_patch=this%u10_patch) + + if (use_cn) then + this%ram1_patch(begp:endp) = spval + call hist_addfld1d (fname='RAM1', units='s/m', & + avgflag='A', long_name='aerodynamical resistance ', & + ptr_patch=this%ram1_patch, default='inactive') + end if + + if (use_cn) then + this%fv_patch(begp:endp) = spval + call hist_addfld1d (fname='FV', units='m/s', & + avgflag='A', long_name='friction velocity for dust model', & + ptr_patch=this%fv_patch, default='inactive') + end if + + call hist_addfld1d (fname='RAH1', units='s/m', & + avgflag='A', long_name='aerodynamical resistance ', & + ptr_patch=this%rah1_patch, default='inactive') + this%rah2_patch(begp:endp) = spval + call hist_addfld1d (fname='RAH2', units='s/m', & + avgflag='A', long_name='aerodynamical resistance ', & + ptr_patch=this%rah2_patch, default='inactive') + this%raw1_patch(begp:endp) = spval + call hist_addfld1d (fname='RAW1', units='s/m', & + avgflag='A', long_name='aerodynamical resistance ', & + ptr_patch=this%raw1_patch, default='inactive') + this%raw2_patch(begp:endp) = spval + call hist_addfld1d (fname='RAW2', units='s/m', & + avgflag='A', long_name='aerodynamical resistance ', & + ptr_patch=this%raw2_patch, default='inactive') + this%ustar_patch(begp:endp) = spval + call hist_addfld1d (fname='USTAR', units='s/m', & + avgflag='A', long_name='aerodynamical resistance ', & + ptr_patch=this%ustar_patch, default='inactive') + this%um_patch(begp:endp) = spval + call hist_addfld1d (fname='UM', units='m/s', & + avgflag='A', long_name='wind speed plus stability effect', & + ptr_patch=this%um_patch, default='inactive') + this%uaf_patch(begp:endp) = spval + call hist_addfld1d (fname='UAF', units='m/s', & + avgflag='A', long_name='canopy air speed ', & + ptr_patch=this%uaf_patch, default='inactive') + this%taf_patch(begp:endp) = spval + call hist_addfld1d (fname='TAF', units='K', & + avgflag='A', long_name='canopy air temperature', & + ptr_patch=this%taf_patch, default='inactive') + this%qaf_patch(begp:endp) = spval + call hist_addfld1d (fname='QAF', units='kg/kg', & + avgflag='A', long_name='canopy air humidity', & + ptr_patch=this%qaf_patch, default='inactive') + this%obu_patch(begp:endp) = spval + call hist_addfld1d (fname='OBU', units='m', & + avgflag='A', long_name='Monin-Obukhov length', & + ptr_patch=this%obu_patch, default='inactive') + this%zeta_patch(begp:endp) = spval + call hist_addfld1d (fname='ZETA', units='unitless', & + avgflag='A', long_name='dimensionless stability parameter', & + ptr_patch=this%zeta_patch, default='inactive') + this%vpd_patch(begp:endp) = spval + call hist_addfld1d (fname='VPD', units='Pa', & + avgflag='A', long_name='vpd', & + ptr_patch=this%vpd_patch, default='inactive') + this%num_iter_patch(begp:endp) = spval + call hist_addfld1d (fname='num_iter', units='unitless', & + avgflag='A', long_name='number of iterations', & + ptr_patch=this%num_iter_patch, default='inactive') + this%rb1_patch(begp:endp) = spval + call hist_addfld1d (fname='RB', units='s/m', & + avgflag='A', long_name='leaf boundary resistance', & + ptr_patch=this%rb1_patch, default='inactive') + + if (use_cn) then + this%z0hv_patch(begp:endp) = spval + call hist_addfld1d (fname='Z0HV', units='m', & + avgflag='A', long_name='roughness length over vegetation, sensible heat', & + ptr_patch=this%z0hv_patch, default='inactive') + end if + + if (use_cn) then + this%z0mv_patch(begp:endp) = spval + call hist_addfld1d (fname='Z0MV', units='m', & + avgflag='A', long_name='roughness length over vegetation, momentum', & + ptr_patch=this%z0mv_patch, default='inactive') + end if + + if (use_cn) then + this%z0qv_patch(begp:endp) = spval + call hist_addfld1d (fname='Z0QV', units='m', & + avgflag='A', long_name='roughness length over vegetation, latent heat', & + ptr_patch=this%z0qv_patch, default='inactive') + end if + + if (use_luna) then + call hist_addfld1d (fname='RB10', units='s/m', & + avgflag='A', long_name='10 day running mean boundary layer resistance', & + ptr_patch=this%rb10_patch, default='inactive') + end if + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! Initialize module surface albedos to reasonable values + ! + ! !ARGUMENTS: + class(frictionvel_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p, c, l ! indices + !----------------------------------------------------------------------- + + ! Added 5/4/04, PET: initialize forc_hgt_u (gridcell-level), + ! since this is not initialized before first call to CNVegStructUpdate, + ! and it is required to set the upper bound for canopy top height. + ! Changed 3/21/08, KO: still needed but don't have sufficient information + ! to set this properly (e.g., patch-level displacement height and roughness + ! length). So leave at 30m. + + if (use_cn) then + do p = bounds%begp, bounds%endp + this%forc_hgt_u_patch(p) = 30._r8 + end do + end if + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%lakpoi(l)) then !lake + this%z0mg_col(c) = 0.0004_r8 + end if + end do + + end subroutine InitCold + + !------------------------------------------------------------------------------ + subroutine ReadParams( this, params_ncid ) + ! + ! !ARGUMENTS: + class(frictionvel_type), intent(inout) :: this + type(file_desc_t),intent(inout) :: params_ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'ReadParams_FrictionVelocity' + !-------------------------------------------------------------------- + + ! Momentum roughness length for snow (m) + call readNcdioScalar(params_ncid, 'zsno', subname, this%zsno) + ! Momentum roughness length for soil, glacier, wetland (m) + call readNcdioScalar(params_ncid, 'zlnd', subname, this%zlnd) + + end subroutine ReadParams + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use spmdMod , only : masterproc + use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_double, ncd_int, ncd_inqvdlen + use restUtilMod + ! + ! !ARGUMENTS: + class(frictionvel_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 + !----------------------------------------------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='Z0MG', xtype=ncd_double, & + dim1name='column', & + long_name='ground momentum roughness length', units='m', & + interpinic_flag='interp', readvar=readvar, data=this%z0mg_col) + + if(use_luna)then + call restartvar(ncid=ncid, flag=flag, varname='rb10', xtype=ncd_double, & + dim1name='pft', long_name='10-day mean boundary layer resistance at the pacth', units='s/m', & + interpinic_flag='interp', readvar=readvar, data=this%rb10_patch) + endif + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine ReadNamelist( this, NLFilename ) + ! + ! !DESCRIPTION: + ! Read the namelist for Friction Velocity + ! + ! !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: + class(frictionvel_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 = 'FrictionVelocityReadNamelist' + character(len=*), parameter :: nmlname = 'friction_velocity' + !----------------------------------------------------------------------- + real(r8) :: zetamaxstable + namelist /friction_velocity/ zetamaxstable + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + zetamaxstable = 0.5_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=friction_velocity, 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 (zetamaxstable, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=friction_velocity) + write(iulog,*) ' ' + end if + + this%zetamaxstable = zetamaxstable + + end subroutine ReadNamelist + + !----------------------------------------------------------------------- + subroutine SetRoughnessLengthsAndForcHeightsNonLake(this, bounds, & + num_nolakec, filter_nolakec, num_nolakep, filter_nolakep, & + atm2lnd_inst, waterdiagnosticbulk_inst, canopystate_inst) + ! + ! !DESCRIPTION: + ! Set roughness lengths and forcing heights for non-lake points + ! + ! !ARGUMENTS: + class(frictionvel_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points + integer , intent(in) :: num_nolakep ! number of column non-lake points in patch filter + integer , intent(in) :: filter_nolakep(:) ! patch filter for non-lake points + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(canopystate_type) , intent(in) :: canopystate_inst + ! + ! !LOCAL VARIABLES: + integer :: fc, c + integer :: fp, p + integer :: l, g + + character(len=*), parameter :: subname = 'SetRoughnessLengthsAndForcHeightsNonLake' + !----------------------------------------------------------------------- + + associate( & + z0mv => this%z0mv_patch , & ! Output: [real(r8) (:) ] roughness length over vegetation, momentum [m] + z0hv => this%z0hv_patch , & ! Output: [real(r8) (:) ] roughness length over vegetation, sensible heat [m] + z0qv => this%z0qv_patch , & ! Output: [real(r8) (:) ] roughness length over vegetation, latent heat [m] + z0hg => this%z0hg_col , & ! Output: [real(r8) (:) ] roughness length over ground, sensible heat [m] + z0mg => this%z0mg_col , & ! Output: [real(r8) (:) ] roughness length over ground, momentum [m] + z0qg => this%z0qg_col , & ! Output: [real(r8) (:) ] roughness length over ground, latent heat [m] + forc_hgt_t_patch => this%forc_hgt_t_patch , & ! Output: [real(r8) (:) ] observational height of temperature at patch level [m] + forc_hgt_q_patch => this%forc_hgt_q_patch , & ! Output: [real(r8) (:) ] observational height of specific humidity at patch level [m] + forc_hgt_u_patch => this%forc_hgt_u_patch , & ! Output: [real(r8) (:) ] observational height of wind at patch level [m] + z0m => canopystate_inst%z0m_patch , & ! Input: [real(r8) (:) ] momentum roughness length (m) + displa => canopystate_inst%displa_patch , & ! Input: [real(r8) (:) ] displacement height (m) + + frac_veg_nosno => canopystate_inst%frac_veg_nosno_patch , & ! Input: [integer (:) ] fraction of vegetation not covered by snow (0 OR 1) [-] + frac_sno => waterdiagnosticbulk_inst%frac_sno_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + urbpoi => lun%urbpoi , & ! Input: [logical (:) ] true => landunit is an urban point + z_0_town => lun%z_0_town , & ! Input: [real(r8) (:) ] momentum roughness length of urban landunit (m) + z_d_town => lun%z_d_town , & ! Input: [real(r8) (:) ] displacement height of urban landunit (m) + forc_hgt_t => atm2lnd_inst%forc_hgt_t_grc , & ! Input: [real(r8) (:) ] observational height of temperature [m] + forc_hgt_u => atm2lnd_inst%forc_hgt_u_grc , & ! Input: [real(r8) (:) ] observational height of wind [m] + forc_hgt_q => atm2lnd_inst%forc_hgt_q_grc & ! Input: [real(r8) (:) ] observational height of specific humidity [m] + ) + + do fc = 1, num_nolakec + c = filter_nolakec(fc) + + ! Ground roughness lengths over non-lake columns (includes bare ground, ground + ! underneath canopy, wetlands, etc.) + if (frac_sno(c) > 0._r8) then + z0mg(c) = this%zsno + else + z0mg(c) = this%zlnd + end if + z0hg(c) = z0mg(c) ! initial set only + z0qg(c) = z0mg(c) ! initial set only + end do + + do fp = 1,num_nolakep + p = filter_nolakep(fp) + + ! Roughness lengths over vegetation + z0mv(p) = z0m(p) + z0hv(p) = z0mv(p) + z0qv(p) = z0mv(p) + end do + + ! Make forcing height a patch-level quantity that is the atmospheric forcing + ! height plus each patch's z0m+displa + do fp = 1, num_nolakep + p = filter_nolakep(fp) + g = patch%gridcell(p) + l = patch%landunit(p) + c = patch%column(p) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + if (frac_veg_nosno(p) == 0) then + forc_hgt_u_patch(p) = forc_hgt_u(g) + z0mg(c) + displa(p) + forc_hgt_t_patch(p) = forc_hgt_t(g) + z0mg(c) + displa(p) + forc_hgt_q_patch(p) = forc_hgt_q(g) + z0mg(c) + displa(p) + else + forc_hgt_u_patch(p) = forc_hgt_u(g) + z0m(p) + displa(p) + forc_hgt_t_patch(p) = forc_hgt_t(g) + z0m(p) + displa(p) + forc_hgt_q_patch(p) = forc_hgt_q(g) + z0m(p) + displa(p) + end if + else if (lun%itype(l) == istwet .or. lun%itype(l) == istice_mec) then + forc_hgt_u_patch(p) = forc_hgt_u(g) + z0mg(c) + forc_hgt_t_patch(p) = forc_hgt_t(g) + z0mg(c) + forc_hgt_q_patch(p) = forc_hgt_q(g) + z0mg(c) + else if (urbpoi(l)) then + forc_hgt_u_patch(p) = forc_hgt_u(g) + z_0_town(l) + z_d_town(l) + forc_hgt_t_patch(p) = forc_hgt_t(g) + z_0_town(l) + z_d_town(l) + forc_hgt_q_patch(p) = forc_hgt_q(g) + z_0_town(l) + z_d_town(l) + end if + end do + + end associate + + end subroutine SetRoughnessLengthsAndForcHeightsNonLake + + !----------------------------------------------------------------------- + subroutine SetActualRoughnessLengths(this, bounds, & + num_exposedvegp, filter_exposedvegp, & + num_noexposedvegp, filter_noexposedvegp, & + num_urbanp, filter_urbanp, & + num_lakep, filter_lakep) + ! + ! !DESCRIPTION: + ! Set roughness lengths actually used in flux calculations + ! + ! !ARGUMENTS: + class(frictionvel_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + 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 (but does NOT include lake or urban) + integer , intent(in) :: num_urbanp ! number of points in filter_urbanp + integer , intent(in) :: filter_urbanp(:) ! patch filter for urban + integer , intent(in) :: num_lakep ! number of points in filter_lakep + integer , intent(in) :: filter_lakep(:) ! patch filter for lake + ! + ! !LOCAL VARIABLES: + integer :: fp, p, c, l + + character(len=*), parameter :: subname = 'SetActualRoughnessLengths' + !----------------------------------------------------------------------- + + associate( & + z_0_town => lun%z_0_town , & ! Input: [real(r8) (:)] momentum roughness length of urban landunit [m] + + z0mv => this%z0mv_patch , & ! Input: [real(r8) (:)] roughness length over vegetation, momentum [m] + z0mg => this%z0mg_col , & ! Input: [real(r8) (:)] roughness length over ground, momentum [m] + z0m_actual => this%z0m_actual_patch & ! Output: [real(r8) (:)] roughness length actually used in flux calculations, momentum [m] + ) + + do fp = 1, num_exposedvegp + p = filter_exposedvegp(fp) + + z0m_actual(p) = z0mv(p) + end do + + do fp = 1, num_noexposedvegp + p = filter_noexposedvegp(fp) + c = patch%column(p) + + z0m_actual(p) = z0mg(c) + end do + + do fp = 1, num_urbanp + p = filter_urbanp(fp) + l = patch%landunit(p) + + z0m_actual(p) = z_0_town(l) + end do + + do fp = 1, num_lakep + p = filter_lakep(fp) + c = patch%column(p) + + z0m_actual(p) = z0mg(c) + end do + + end associate + end subroutine SetActualRoughnessLengths + + !------------------------------------------------------------------------------ + subroutine FrictionVelocity(this, lbn, ubn, fn, filtern, & + displa, z0m, z0h, z0q, & + obu, iter, ur, um, ustar, & + temp1, temp2, temp12m, temp22m, fm, landunit_index) + ! + ! !DESCRIPTION: + ! Calculation of the friction velocity, relation for potential + ! temperature and humidity profiles of surface boundary layer. + ! The scheme is based on the work of Zeng et al. (1998): + ! Intercomparison of bulk aerodynamic algorithms for the computation + ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, + ! Vol. 11, 2628-2644. + ! + ! !USES: + use clm_varcon, only : vkc + use clm_varctl, only : iulog + ! + ! !ARGUMENTS: + class(frictionvel_type), intent(inout) :: this + integer , intent(in) :: lbn, ubn ! pft/landunit array bounds + integer , intent(in) :: fn ! number of filtered pft/landunit elements + integer , intent(in) :: filtern(fn) ! pft/landunit filter + real(r8) , intent(in) :: displa ( lbn: ) ! displacement height (m) [lbn:ubn] + real(r8) , intent(in) :: z0m ( lbn: ) ! roughness length over vegetation, momentum [m] [lbn:ubn] + real(r8) , intent(in) :: z0h ( lbn: ) ! roughness length over vegetation, sensible heat [m] [lbn:ubn] + real(r8) , intent(in) :: z0q ( lbn: ) ! roughness length over vegetation, latent heat [m] [lbn:ubn] + real(r8) , intent(in) :: obu ( lbn: ) ! monin-obukhov length (m) [lbn:ubn] + integer , intent(in) :: iter ! iteration number + real(r8) , intent(in) :: ur ( lbn: ) ! wind speed at reference height [m/s] [lbn:ubn] + real(r8) , intent(in) :: um ( lbn: ) ! wind speed including the stablity effect [m/s] [lbn:ubn] + real(r8) , intent(out) :: ustar ( lbn: ) ! friction velocity [m/s] [lbn:ubn] + real(r8) , intent(out) :: temp1 ( lbn: ) ! relation for potential temperature profile [lbn:ubn] + real(r8) , intent(out) :: temp12m ( lbn: ) ! relation for potential temperature profile applied at 2-m [lbn:ubn] + real(r8) , intent(out) :: temp2 ( lbn: ) ! relation for specific humidity profile [lbn:ubn] + real(r8) , intent(out) :: temp22m ( lbn: ) ! relation for specific humidity profile applied at 2-m [lbn:ubn] + real(r8) , intent(inout) :: fm ( lbn: ) ! diagnose 10m wind (DUST only) [lbn:ubn] + logical , intent(in), optional :: landunit_index ! optional argument that defines landunit or pft level + ! + ! !LOCAL VARIABLES: + real(r8), parameter :: zetam = 1.574_r8 ! transition point of flux-gradient relation (wind profile) + real(r8), parameter :: zetat = 0.465_r8 ! transition point of flux-gradient relation (temp. profile) + integer :: f ! pft/landunit filter index + integer :: n ! pft/landunit index + integer :: g ! gridcell index + integer :: pp ! pfti,pftf index + real(r8) :: zldis(lbn:ubn) ! reference height "minus" zero displacement heght [m] + real(r8) :: zeta(lbn:ubn) ! dimensionless height used in Monin-Obukhov theory + real(r8) :: tmp1,tmp2,tmp3,tmp4 ! Used to diagnose the 10 meter wind + real(r8) :: fmnew ! Used to diagnose the 10 meter wind + real(r8) :: fm10 ! Used to diagnose the 10 meter wind + real(r8) :: zeta10 ! Used to diagnose the 10 meter wind + real(r8) :: vds_tmp ! Temporary for dry deposition velocity + !------------------------------------------------------------------------------ + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(displa) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(z0m) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(z0h) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(z0q) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(obu) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(ur) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(um) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(ustar) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(temp1) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(temp12m) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(temp2) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(temp22m) == (/ubn/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(fm) == (/ubn/)), sourcefile, __LINE__) + + associate( & + pfti => lun%patchi , & ! Input: [integer (:) ] beginning pfti index for landunit + pftf => lun%patchf , & ! Input: [integer (:) ] final pft index for landunit + + forc_hgt_u_patch => this%forc_hgt_u_patch , & ! Input: [real(r8) (:) ] observational height of wind at pft level [m] + forc_hgt_t_patch => this%forc_hgt_t_patch , & ! Input: [real(r8) (:) ] observational height of temperature at pft level [m] + forc_hgt_q_patch => this%forc_hgt_q_patch , & ! Input: [real(r8) (:) ] observational height of specific humidity at pft level [m] + vds => this%vds_patch , & ! Output: [real(r8) (:) ] dry deposition velocity term (m/s) (for SO4 NH4NO3) + u10 => this%u10_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) (for dust model) + u10_clm => this%u10_clm_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) + va => this%va_patch , & ! Output: [real(r8) (:) ] atmospheric wind speed plus convective velocity (m/s) + fv => this%fv_patch & ! Output: [real(r8) (:) ] friction velocity (m/s) (for dust model) + ) + + ! Adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + + do f = 1, fn + n = filtern(f) + if (present(landunit_index)) then + g = lun%gridcell(n) + else + g = patch%gridcell(n) + end if + + ! Wind profile + + if (present(landunit_index)) then + zldis(n) = forc_hgt_u_patch(pfti(n))-displa(n) + else + zldis(n) = forc_hgt_u_patch(n)-displa(n) + end if + zeta(n) = zldis(n)/obu(n) + if (zeta(n) < -zetam) then + ustar(n) = vkc*um(n)/(log(-zetam*obu(n)/z0m(n))& + - this%StabilityFunc1(-zetam) & + + this%StabilityFunc1(z0m(n)/obu(n)) & + + 1.14_r8*((-zeta(n))**0.333_r8-(zetam)**0.333_r8)) + else if (zeta(n) < 0._r8) then + ustar(n) = vkc*um(n)/(log(zldis(n)/z0m(n))& + - this%StabilityFunc1(zeta(n))& + + this%StabilityFunc1(z0m(n)/obu(n))) + else if (zeta(n) <= 1._r8) then + ustar(n) = vkc*um(n)/(log(zldis(n)/z0m(n)) + 5._r8*zeta(n) -5._r8*z0m(n)/obu(n)) + else + ustar(n) = vkc*um(n)/(log(obu(n)/z0m(n))+5._r8-5._r8*z0m(n)/obu(n) & + +(5._r8*log(zeta(n))+zeta(n)-1._r8)) + end if + + if (zeta(n) < 0._r8) then + vds_tmp = 2.e-3_r8*ustar(n) * ( 1._r8 + (300._r8/(-obu(n)))**0.666_r8) + else + vds_tmp = 2.e-3_r8*ustar(n) + endif + + if (present(landunit_index)) then + do pp = pfti(n),pftf(n) + vds(pp) = vds_tmp + end do + else + vds(n) = vds_tmp + end if + + ! Calculate a 10-m wind (10m + z0m + d) + ! For now, this will not be the same as the 10-m wind calculated for the dust + ! model because the CLM stability functions are used here, not the LSM stability + ! functions used in the dust model. We will eventually change the dust model to be + ! consistent with the following formulation. + ! Note that the 10-m wind calculated this way could actually be larger than the + ! atmospheric forcing wind because 1) this includes the convective velocity, 2) + ! this includes the 1 m/s minimum wind threshold + + ! If forcing height is less than or equal to 10m, then set 10-m wind to um + if (present(landunit_index)) then + do pp = pfti(n),pftf(n) + if (zldis(n)-z0m(n) <= 10._r8) then + u10_clm(pp) = um(n) + else + if (zeta(n) < -zetam) then + u10_clm(pp) = um(n) - ( ustar(n)/vkc*(log(-zetam*obu(n)/(10._r8+z0m(n))) & + - this%StabilityFunc1(-zetam) & + + this%StabilityFunc1((10._r8+z0m(n))/obu(n)) & + + 1.14_r8*((-zeta(n))**0.333_r8-(zetam)**0.333_r8)) ) + else if (zeta(n) < 0._r8) then + u10_clm(pp) = um(n) - ( ustar(n)/vkc*(log(zldis(n)/(10._r8+z0m(n))) & + - this%StabilityFunc1(zeta(n)) & + + this%StabilityFunc1((10._r8+z0m(n))/obu(n))) ) + else if (zeta(n) <= 1._r8) then + u10_clm(pp) = um(n) - ( ustar(n)/vkc*(log(zldis(n)/(10._r8+z0m(n))) & + + 5._r8*zeta(n) - 5._r8*(10._r8+z0m(n))/obu(n)) ) + else + u10_clm(pp) = um(n) - ( ustar(n)/vkc*(log(obu(n)/(10._r8+z0m(n))) & + + 5._r8 - 5._r8*(10._r8+z0m(n))/obu(n) & + + (5._r8*log(zeta(n))+zeta(n)-1._r8)) ) + + end if + end if + va(pp) = um(n) + end do + else + if (zldis(n)-z0m(n) <= 10._r8) then + u10_clm(n) = um(n) + else + if (zeta(n) < -zetam) then + u10_clm(n) = um(n) - ( ustar(n)/vkc*(log(-zetam*obu(n)/(10._r8+z0m(n))) & + - this%StabilityFunc1(-zetam) & + + this%StabilityFunc1((10._r8+z0m(n))/obu(n)) & + + 1.14_r8*((-zeta(n))**0.333_r8-(zetam)**0.333_r8)) ) + else if (zeta(n) < 0._r8) then + u10_clm(n) = um(n) - ( ustar(n)/vkc*(log(zldis(n)/(10._r8+z0m(n))) & + - this%StabilityFunc1(zeta(n)) & + + this%StabilityFunc1((10._r8+z0m(n))/obu(n))) ) + else if (zeta(n) <= 1._r8) then + u10_clm(n) = um(n) - ( ustar(n)/vkc*(log(zldis(n)/(10._r8+z0m(n))) & + + 5._r8*zeta(n) - 5._r8*(10._r8+z0m(n))/obu(n)) ) + else + u10_clm(n) = um(n) - ( ustar(n)/vkc*(log(obu(n)/(10._r8+z0m(n))) & + + 5._r8 - 5._r8*(10._r8+z0m(n))/obu(n) & + + (5._r8*log(zeta(n))+zeta(n)-1._r8)) ) + end if + end if + va(n) = um(n) + end if + + ! Temperature profile + + if (present(landunit_index)) then + zldis(n) = forc_hgt_t_patch(pfti(n))-displa(n) + else + zldis(n) = forc_hgt_t_patch(n)-displa(n) + end if + zeta(n) = zldis(n)/obu(n) + if (zeta(n) < -zetat) then + temp1(n) = vkc/(log(-zetat*obu(n)/z0h(n))& + - this%StabilityFunc2(-zetat) & + + this%StabilityFunc2(z0h(n)/obu(n)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) + else if (zeta(n) < 0._r8) then + temp1(n) = vkc/(log(zldis(n)/z0h(n)) & + - this%StabilityFunc2(zeta(n)) & + + this%StabilityFunc2(z0h(n)/obu(n))) + else if (zeta(n) <= 1._r8) then + temp1(n) = vkc/(log(zldis(n)/z0h(n)) + 5._r8*zeta(n) - 5._r8*z0h(n)/obu(n)) + else + temp1(n) = vkc/(log(obu(n)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(n) & + + (5._r8*log(zeta(n))+zeta(n)-1._r8)) + end if + + ! Humidity profile + + if (present(landunit_index)) then + if (forc_hgt_q_patch(pfti(n)) == forc_hgt_t_patch(pfti(n)) .and. z0q(n) == z0h(n)) then + temp2(n) = temp1(n) + else + zldis(n) = forc_hgt_q_patch(pfti(n))-displa(n) + zeta(n) = zldis(n)/obu(n) + if (zeta(n) < -zetat) then + temp2(n) = vkc/(log(-zetat*obu(n)/z0q(n)) & + - this%StabilityFunc2(-zetat) & + + this%StabilityFunc2(z0q(n)/obu(n)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) + else if (zeta(n) < 0._r8) then + temp2(n) = vkc/(log(zldis(n)/z0q(n)) & + - this%StabilityFunc2(zeta(n)) & + + this%StabilityFunc2(z0q(n)/obu(n))) + else if (zeta(n) <= 1._r8) then + temp2(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n)) + else + temp2(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & + + (5._r8*log(zeta(n))+zeta(n)-1._r8)) + end if + end if + else + if (forc_hgt_q_patch(n) == forc_hgt_t_patch(n) .and. z0q(n) == z0h(n)) then + temp2(n) = temp1(n) + else + zldis(n) = forc_hgt_q_patch(n)-displa(n) + zeta(n) = zldis(n)/obu(n) + if (zeta(n) < -zetat) then + temp2(n) = vkc/(log(-zetat*obu(n)/z0q(n)) & + - this%StabilityFunc2(-zetat) & + + this%StabilityFunc2(z0q(n)/obu(n)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) + else if (zeta(n) < 0._r8) then + temp2(n) = vkc/(log(zldis(n)/z0q(n)) & + - this%StabilityFunc2(zeta(n)) & + + this%StabilityFunc2(z0q(n)/obu(n))) + else if (zeta(n) <= 1._r8) then + temp2(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n)) + else + temp2(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & + + (5._r8*log(zeta(n))+zeta(n)-1._r8)) + end if + endif + endif + + ! Temperature profile applied at 2-m + + zldis(n) = 2.0_r8 + z0h(n) + zeta(n) = zldis(n)/obu(n) + if (zeta(n) < -zetat) then + temp12m(n) = vkc/(log(-zetat*obu(n)/z0h(n))& + - this%StabilityFunc2(-zetat) & + + this%StabilityFunc2(z0h(n)/obu(n)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) + else if (zeta(n) < 0._r8) then + temp12m(n) = vkc/(log(zldis(n)/z0h(n)) & + - this%StabilityFunc2(zeta(n)) & + + this%StabilityFunc2(z0h(n)/obu(n))) + else if (zeta(n) <= 1._r8) then + temp12m(n) = vkc/(log(zldis(n)/z0h(n)) + 5._r8*zeta(n) - 5._r8*z0h(n)/obu(n)) + else + temp12m(n) = vkc/(log(obu(n)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(n) & + + (5._r8*log(zeta(n))+zeta(n)-1._r8)) + end if + + ! Humidity profile applied at 2-m + + if (z0q(n) == z0h(n)) then + temp22m(n) = temp12m(n) + else + zldis(n) = 2.0_r8 + z0q(n) + zeta(n) = zldis(n)/obu(n) + if (zeta(n) < -zetat) then + temp22m(n) = vkc/(log(-zetat*obu(n)/z0q(n)) - & + this%StabilityFunc2(-zetat) + this%StabilityFunc2(z0q(n)/obu(n)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) + else if (zeta(n) < 0._r8) then + temp22m(n) = vkc/(log(zldis(n)/z0q(n)) - & + this%StabilityFunc2(zeta(n))+this%StabilityFunc2(z0q(n)/obu(n))) + else if (zeta(n) <= 1._r8) then + temp22m(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n)) + else + temp22m(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & + + (5._r8*log(zeta(n))+zeta(n)-1._r8)) + end if + end if + + ! diagnose 10-m wind for dust model (dstmbl.F) + ! Notes from C. Zender's dst.F: + ! According to Bon96 p. 62, the displacement height d (here displa) is + ! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees). + ! Therefore d <= 0.034*z1 and may safely be neglected. + ! Code from LSM routine SurfaceTemperature was used to obtain u10 + + if (present(landunit_index)) then + zldis(n) = forc_hgt_u_patch(pfti(n))-displa(n) + else + zldis(n) = forc_hgt_u_patch(n)-displa(n) + end if + zeta(n) = zldis(n)/obu(n) + if (min(zeta(n), 1._r8) < 0._r8) then + tmp1 = (1._r8 - 16._r8*min(zeta(n),1._r8))**0.25_r8 + tmp2 = log((1._r8+tmp1*tmp1)/2._r8) + tmp3 = log((1._r8+tmp1)/2._r8) + fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8 + else + fmnew = -5._r8*min(zeta(n),1._r8) + endif + if (iter == 1) then + fm(n) = fmnew + else + fm(n) = 0.5_r8 * (fm(n)+fmnew) + end if + zeta10 = min(10._r8/obu(n), 1._r8) + if (zeta(n) == 0._r8) zeta10 = 0._r8 + if (zeta10 < 0._r8) then + tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8 + tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8) + tmp3 = log((1.0_r8 + tmp1)/2.0_r8) + fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8 + else ! not stable + fm10 = -5.0_r8 * zeta10 + end if + if (present(landunit_index)) then + tmp4 = log( max( 1.0_r8, forc_hgt_u_patch(pfti(n)) / 10._r8) ) + else + tmp4 = log( max( 1.0_r8, forc_hgt_u_patch(n) / 10._r8) ) + end if + if (present(landunit_index)) then + do pp = pfti(n),pftf(n) + u10(pp) = ur(n) - ustar(n)/vkc * (tmp4 - fm(n) + fm10) + fv(pp) = ustar(n) + end do + else + u10(n) = ur(n) - ustar(n)/vkc * (tmp4 - fm(n) + fm10) + fv(n) = ustar(n) + end if + + end do + + end associate + end subroutine FrictionVelocity + + !------------------------------------------------------------------------------ + real(r8) function StabilityFunc1(zeta) + ! + ! !DESCRIPTION: + ! Stability function for rib < 0. + ! + ! !ARGUMENTS: + real(r8), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory + ! + ! !LOCAL VARIABLES: + real(r8) :: chik, chik2 + !------------------------------------------------------------------------------ + + chik2 = sqrt(1._r8-16._r8*zeta) + chik = sqrt(chik2) + StabilityFunc1 = 2._r8*log((1._r8+chik)*0.5_r8) & + + log((1._r8+chik2)*0.5_r8)-2._r8*atan(chik)+SHR_CONST_PI*0.5_r8 + + end function StabilityFunc1 + + !------------------------------------------------------------------------------ + real(r8) function StabilityFunc2(zeta) + ! + ! !DESCRIPTION: + ! Stability function for rib < 0. + ! + ! !ARGUMENTS: + real(r8), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory + ! + ! !LOCAL VARIABLES: + real(r8) :: chik2 + !------------------------------------------------------------------------------ + + chik2 = sqrt(1._r8-16._r8*zeta) + StabilityFunc2 = 2._r8*log((1._r8+chik2)*0.5_r8) + + end function StabilityFunc2 + + !----------------------------------------------------------------------- + subroutine MoninObukIni (this, ur, thv, dthv, zldis, z0m, um, obu) + ! + ! !DESCRIPTION: + ! Initialization of the Monin-Obukhov length. + ! The scheme is based on the work of Zeng et al. (1998): + ! Intercomparison of bulk aerodynamic algorithms for the computation + ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, + ! Vol. 11, 2628-2644. + ! + ! !USES: + use clm_varcon, only : grav + ! + ! !ARGUMENTS: + class(frictionvel_type), intent(in) :: this + real(r8), intent(in) :: ur ! wind speed at reference height [m/s] + real(r8), intent(in) :: thv ! virtual potential temperature (kelvin) + real(r8), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8), intent(in) :: zldis ! reference height "minus" zero displacement heght [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(out) :: um ! wind speed including the stability effect [m/s] + real(r8), intent(out) :: obu ! monin-obukhov length (m) + ! + ! !LOCAL VARIABLES: + real(r8) :: wc ! convective velocity [m/s] + real(r8) :: rib ! bulk Richardson number + real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) :: ustar ! friction velocity [m/s] + !----------------------------------------------------------------------- + + ! Initial values of u* and convective velocity + + ustar=0.06_r8 + wc=0.5_r8 + if (dthv >= 0._r8) then + um=max(ur,0.1_r8) + else + um=sqrt(ur*ur+wc*wc) + endif + + rib=grav*zldis*dthv/(thv*um*um) + + if (rib >= 0._r8) then ! neutral or stable + zeta = rib*log(zldis/z0m)/(1._r8-5._r8*min(rib,0.19_r8)) + zeta = min(this%zetamaxstable,max(zeta,0.01_r8 )) + else ! unstable + zeta=rib*log(zldis/z0m) + zeta = max(-100._r8,min(zeta,-0.01_r8 )) + endif + + obu=zldis/zeta + + end subroutine MoninObukIni + +end module FrictionVelocityMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/GridcellType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/GridcellType.F90 new file mode 100644 index 000000000..30fe988ef --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/GridcellType.F90 @@ -0,0 +1,106 @@ +module GridcellType + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Gridcell data type allocation + ! -------------------------------------------------------- + ! gridcell types can have values of + ! -------------------------------------------------------- + ! 1 => default + ! + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use landunit_varcon, only : max_lunit + use clm_varcon , only : ispval + ! + ! !PUBLIC TYPES: + implicit none + save + private + ! + 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 + procedure, public :: Clean + + end type gridcell_type + type(gridcell_type), public, target :: grc !gridcell data structure + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, begg, endg) + ! + ! !ARGUMENTS: + class(gridcell_type) :: this + integer, intent(in) :: begg, 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 + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine Clean(this) + ! + ! !ARGUMENTS: + class(gridcell_type) :: this + !------------------------------------------------------------------------ + + deallocate(this%gindex ) + deallocate(this%area ) + deallocate(this%lat ) + deallocate(this%lon ) + deallocate(this%latdeg ) + deallocate(this%londeg ) + deallocate(this%active ) + deallocate(this%nbedrock ) + deallocate(this%max_dayl ) + deallocate(this%dayl ) + deallocate(this%prev_dayl ) + deallocate(this%landunit_indices ) + + end subroutine Clean + +end module GridcellType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/LandunitType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/LandunitType.F90 new file mode 100644 index 000000000..2236ca278 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/LandunitType.F90 @@ -0,0 +1,140 @@ +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 shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varcon , only : ispval + ! + ! !PUBLIC TYPES: + implicit none + save + private + ! + 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 ! Allocate and initialize + procedure, public :: Clean ! Clean up memory + + end type landunit_type + ! Singleton instance of the landunitType + type(landunit_type), public, target :: lun !geomorphological landunits + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, begl, endl) + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Allocate memory and initialize to signalling NaN to require + ! data be properly initialized somewhere else. + ! + ! !ARGUMENTS: + class(landunit_type) :: this + integer, intent(in) :: begl,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 + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine Clean(this) + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Clean up memory use + ! + ! !ARGUMENTS: + class(landunit_type) :: this + !------------------------------------------------------------------------ + + deallocate(this%gridcell ) + deallocate(this%wtgcell ) + deallocate(this%coli ) + deallocate(this%colf ) + deallocate(this%ncolumns ) + deallocate(this%patchi ) + deallocate(this%patchf ) + deallocate(this%npatches ) + deallocate(this%itype ) + deallocate(this%ifspecial ) + deallocate(this%lakpoi ) + deallocate(this%urbpoi ) + deallocate(this%glcmecpoi ) + deallocate(this%active ) + deallocate(this%canyon_hwr ) + deallocate(this%wtroad_perv ) + deallocate(this%ht_roof ) + deallocate(this%wtlunit_roof ) + deallocate(this%z_0_town ) + deallocate(this%z_d_town ) + + end subroutine Clean + +end module LandunitType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/NutrientCompetitionCLM45defaultMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/NutrientCompetitionCLM45defaultMod.F90 new file mode 100644 index 000000000..bb40bb47d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/NutrientCompetitionFactoryMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/NutrientCompetitionFactoryMod.F90 new file mode 100644 index 000000000..99daa738f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/NutrientCompetitionFlexibleCNMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/NutrientCompetitionFlexibleCNMod.F90 new file mode 100644 index 000000000..bd6608bcb --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/NutrientCompetitionFlexibleCNMod.F90 @@ -0,0 +1,1987 @@ +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 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 + ! + 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, assignment(=) + ! !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 + + 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_orig_files/NutrientCompetitionMethodMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/NutrientCompetitionMethodMod.F90 new file mode 100644 index 000000000..56ebcc4f6 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/OzoneBaseMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/OzoneBaseMod.F90 new file mode 100644 index 000000000..c50818f38 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/OzoneBaseMod.F90 @@ -0,0 +1,146 @@ +module OzoneBaseMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Define the interface for ozone_type, which calculates ozone-induced stress. The type + ! defined here is abstract; it will get instantiated as a concrete type that extends + ! this base type (e.g., an ozone-off or ozone-on version). + ! + ! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + + implicit none + save + private + + ! !PUBLIC TYPES: + type, abstract, public :: ozone_base_type + private + + ! 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 + ! The following routines need to be implemented by all type extensions + procedure(Init_interface) , public, deferred :: Init + procedure(Restart_interface) , public, deferred :: Restart + procedure(CalcOzoneStress_interface) , public, deferred :: CalcOzoneStress + + ! The following routines should only be called by extensions of the ozone_base_type + procedure, public :: InitAllocateBase + procedure, public :: InitColdBase + + end type ozone_base_type + + abstract interface + + subroutine Init_interface(this, bounds) + use decompMod, only : bounds_type + import :: ozone_base_type + + class(ozone_base_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + end subroutine Init_interface + + subroutine Restart_interface(this, bounds, ncid, flag) + use decompMod , only : bounds_type + use ncdio_pio , only : file_desc_t + import :: ozone_base_type + + class(ozone_base_type) :: this + type(bounds_type) , intent(in) :: bounds + type(file_desc_t) , intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag ! 'read', 'write' or 'define' + end subroutine Restart_interface + + subroutine CalcOzoneStress_interface(this, bounds, num_exposedvegp, filter_exposedvegp, & + forc_pbot, forc_th, rssun, rssha, rb, ram, tlai) + use decompMod , only : bounds_type + use shr_kind_mod , only : r8 => shr_kind_r8 + import :: ozone_base_type + + class(ozone_base_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + real(r8) , intent(in) :: forc_pbot( bounds%begc: ) ! atmospheric pressure (Pa) + real(r8) , intent(in) :: forc_th( bounds%begc: ) ! atmospheric potential temperature (K) + real(r8) , intent(in) :: rssun( bounds%begp: ) ! leaf stomatal resistance, sunlit leaves (s/m) + real(r8) , intent(in) :: rssha( bounds%begp: ) ! leaf stomatal resistance, shaded leaves (s/m) + real(r8) , intent(in) :: rb( bounds%begp: ) ! boundary layer resistance (s/m) + real(r8) , intent(in) :: ram( bounds%begp: ) ! aerodynamical resistance (s/m) + real(r8) , intent(in) :: tlai( bounds%begp: ) ! one-sided leaf area index, no burying by snow + end subroutine CalcOzoneStress_interface + + end interface + +contains + + !----------------------------------------------------------------------- + subroutine InitAllocateBase(this, bounds) + ! + ! !DESCRIPTION: + ! Allocate variables in the base class + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(ozone_base_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + + character(len=*), parameter :: subname = 'InitAllocateBase' + !----------------------------------------------------------------------- + + 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 + + end subroutine InitAllocateBase + + + !----------------------------------------------------------------------- + subroutine InitColdBase(this, bounds) + ! + ! !DESCRIPTION: + ! Do cold start initialization for variables in the base class. Note that this + ! initialization will be the same for all ozone implementations, including the + ! ozone-off implementation. + ! + ! !USES: + ! + ! !ARGUMENTS: + class(ozone_base_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + + character(len=*), parameter :: subname = 'InitColdBase' + !----------------------------------------------------------------------- + + begp = bounds%begp + endp = bounds%endp + + this%o3coefvsha_patch(begp:endp) = 1._r8 + this%o3coefvsun_patch(begp:endp) = 1._r8 + this%o3coefgsha_patch(begp:endp) = 1._r8 + this%o3coefgsun_patch(begp:endp) = 1._r8 + + end subroutine InitColdBase + +end module OzoneBaseMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/PatchType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/PatchType.F90 new file mode 100644 index 000000000..d00f5588b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/PatchType.F90 @@ -0,0 +1,207 @@ +module PatchType + + !----------------------------------------------------------------------- + ! !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 + ! 16 => c3_irrigated + ! 17 => temperate_corn + ! 18 => irrigated_temperate_corn + ! 19 => spring_wheat + ! 20 => irrigated_spring_wheat + ! 21 => winter_wheat + ! 22 => irrigated_winter_wheat + ! 23 => temperate_soybean + ! 24 => irrigated_temperate_soybean + ! 25 => barley + ! 26 => irrigated_barley + ! 27 => winter_barley + ! 28 => irrigated_winter_barley + ! 29 => rye + ! 30 => irrigated_rye + ! 31 => winter_rye + ! 32 => irrigated_winter_rye + ! 33 => cassava + ! 34 => irrigated_cassava + ! 35 => citrus + ! 36 => irrigated_citrus + ! 37 => cocoa + ! 38 => irrigated_cocoa + ! 39 => coffee + ! 40 => irrigated_coffee + ! 41 => cotton + ! 42 => irrigated_cotton + ! 43 => datepalm + ! 44 => irrigated_datepalm + ! 45 => foddergrass + ! 46 => irrigated_foddergrass + ! 47 => grapes + ! 48 => irrigated_grapes + ! 49 => groundnuts + ! 50 => irrigated_groundnuts + ! 51 => millet + ! 52 => irrigated_millet + ! 53 => oilpalm + ! 54 => irrigated_oilpalm + ! 55 => potatoes + ! 56 => irrigated_potatoes + ! 57 => pulses + ! 58 => irrigated_pulses + ! 59 => rapeseed + ! 60 => irrigated_rapeseed + ! 61 => rice + ! 62 => irrigated_rice + ! 63 => sorghum + ! 64 => irrigated_sorghum + ! 65 => sugarbeet + ! 66 => irrigated_sugarbeet + ! 67 => sugarcane + ! 68 => irrigated_sugarcane + ! 69 => sunflower + ! 70 => irrigated_sunflower + ! 71 => miscanthus + ! 72 => irrigated_miscanthus + ! 73 => switchgrass + ! 74 => irrigated_switchgrass + ! 75 => tropical_corn + ! 76 => irrigated_tropical_corn + ! 77 => tropical_soybean + ! 78 => irrigated_tropical_soybean + ! -------------------------------------------------------- + ! + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varcon , only : ispval + use clm_varctl , only : use_fates + ! + ! !PUBLIC TYPES: + implicit none + save + private + ! + 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 + procedure, public :: Clean + + end type patch_type + type(patch_type), public, target :: patch ! patch type data structure + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, begp, endp) + ! + ! !ARGUMENTS: + class(patch_type) :: this + integer, intent(in) :: begp,endp + ! + ! LOCAL VARAIBLES: + !------------------------------------------------------------------------ + + ! The following is set in InitGridCells + + 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 + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine Clean(this) + ! + ! !ARGUMENTS: + class(patch_type) :: this + !------------------------------------------------------------------------ + + deallocate(this%gridcell) + deallocate(this%wtgcell ) + deallocate(this%landunit) + deallocate(this%wtlunit ) + deallocate(this%column ) + deallocate(this%wtcol ) + deallocate(this%itype ) + deallocate(this%mxy ) + deallocate(this%active ) + deallocate(this%is_fates) + + if (use_fates) then + deallocate(this%is_veg) + deallocate(this%is_bareground) + deallocate(this%wt_ed) + end if + + end subroutine Clean + +end module PatchType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/PhotosynthesisMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/PhotosynthesisMod.F90 new file mode 100644 index 000000000..b9956984f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/PhotosynthesisMod.F90 @@ -0,0 +1,4978 @@ +module PhotosynthesisMod + +#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_sys_mod , only : shr_sys_flush + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + 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_varcon , only : namep, c14ratio, spval, isecspday + use decompMod , only : bounds_type + use QuadraticMod , only : quadratic + use pftconMod , only : pftcon + use CIsoAtmTimeseriesMod, only : C14BombSpike, use_c14_bombspike, C13TimeSeries, use_c13_timeseries, nsectors_c14 + 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 + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: Photosynthesis ! Leaf stomatal resistance and leaf photosynthesis + public :: PhotosynthesisTotal ! Determine of total photosynthesis + public :: Fractionation ! C13 fractionation during 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 :: Restart + procedure, public :: ReadNML + procedure, public :: ReadParams + procedure, public :: TimeStepInit + procedure, public :: NewPatchInit + + ! Private procedures + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type photosyns_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(photosyns_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) + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + 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 + + end subroutine InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! !USES: + use histFileMod , only: hist_addfld1d, hist_addfld2d + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + type(bounds_type), intent(in) :: bounds + real(r8), pointer :: ptr_1d(:) ! pointer to 1d patch array + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + !--------------------------------------------------------------------- + + begp = bounds%begp; endp= bounds%endp + + this%rh_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='RH_LEAF', units='fraction', & + avgflag='A', long_name='fractional humidity at leaf surface', & + ptr_patch=this%rh_leaf_patch, set_spec=spval, default='inactive') + + this%vpd_can_patch(begp:endp) = spval + call hist_addfld1d (fname='VPD_CAN', units='kPa', & + avgflag='A', long_name='canopy vapor pressure deficit', & + ptr_patch=this%vpd_can_patch, set_spec=spval, default='active') + + + + this%lnca_patch(begp:endp) = spval + call hist_addfld1d (fname='LNC', units='gN leaf/m^2', & + avgflag='A', long_name='leaf N concentration', & + ptr_patch=this%lnca_patch, set_spec=spval) + + ! Don't output photosynthesis variables when FATES is on as they aren't calculated + if (.not. use_fates) then + this%fpsn_patch(begp:endp) = spval + call hist_addfld1d (fname='FPSN', units='umol m-2 s-1', & + avgflag='A', long_name='photosynthesis', & + ptr_patch=this%fpsn_patch, set_lake=0._r8, set_urb=0._r8) + + ! Don't by default output this rate limiting step as only makes sense if you are outputing + ! the others each time-step + this%fpsn_wc_patch(begp:endp) = spval + call hist_addfld1d (fname='FPSN_WC', units='umol m-2 s-1', & + avgflag='I', long_name='Rubisco-limited photosynthesis', & + ptr_patch=this%fpsn_wc_patch, set_lake=0._r8, set_urb=0._r8, & + default='inactive') + + ! Don't by default output this rate limiting step as only makes sense if you are outputing + ! the others each time-step + this%fpsn_wj_patch(begp:endp) = spval + call hist_addfld1d (fname='FPSN_WJ', units='umol m-2 s-1', & + avgflag='I', long_name='RuBP-limited photosynthesis', & + ptr_patch=this%fpsn_wj_patch, set_lake=0._r8, set_urb=0._r8, & + default='inactive') + + ! Don't by default output this rate limiting step as only makes sense if you are outputing + ! the others each time-step + this%fpsn_wp_patch(begp:endp) = spval + call hist_addfld1d (fname='FPSN_WP', units='umol m-2 s-1', & + avgflag='I', long_name='Product-limited photosynthesis', & + ptr_patch=this%fpsn_wp_patch, set_lake=0._r8, set_urb=0._r8, & + default='inactive') + end if + + if (use_cn) then + this%psnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='PSNSUN', units='umolCO2/m^2/s', & + avgflag='A', long_name='sunlit leaf photosynthesis', & + ptr_patch=this%psnsun_patch) + + this%psnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='PSNSHA', units='umolCO2/m^2/s', & + avgflag='A', long_name='shaded leaf photosynthesis', & + ptr_patch=this%psnsha_patch) + end if + + if ( use_c13 ) then + this%c13_psnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_PSNSUN', units='umolCO2/m^2/s', & + avgflag='A', long_name='C13 sunlit leaf photosynthesis', & + ptr_patch=this%c13_psnsun_patch, default='inactive') + + this%c13_psnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_PSNSHA', units='umolCO2/m^2/s', & + avgflag='A', long_name='C13 shaded leaf photosynthesis', & + ptr_patch=this%c13_psnsha_patch, default='inactive') + end if + + if ( use_c14 ) then + this%c14_psnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_PSNSUN', units='umolCO2/m^2/s', & + avgflag='A', long_name='C14 sunlit leaf photosynthesis', & + ptr_patch=this%c14_psnsun_patch, default='inactive') + + this%c14_psnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_PSNSHA', units='umolCO2/m^2/s', & + avgflag='A', long_name='C14 shaded leaf photosynthesis', & + ptr_patch=this%c14_psnsha_patch, default='inactive') + end if + + if ( use_c13 ) then + this%rc13_canair_patch(begp:endp) = spval + call hist_addfld1d (fname='RC13_CANAIR', units='proportion', & + avgflag='A', long_name='C13/C(12+13) for canopy air', & + ptr_patch=this%rc13_canair_patch, default='inactive') + + this%rc13_psnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='RC13_PSNSUN', units='proportion', & + avgflag='A', long_name='C13/C(12+13) for sunlit photosynthesis', & + ptr_patch=this%rc13_psnsun_patch, default='inactive') + + this%rc13_psnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='RC13_PSNSHA', units='proportion', & + avgflag='A', long_name='C13/C(12+13) for shaded photosynthesis', & + ptr_patch=this%rc13_psnsha_patch, default='inactive') + endif + + ! Canopy physiology + + if ( use_c13 ) then + this%alphapsnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='ALPHAPSNSUN', units='proportion', & + avgflag='A', long_name='sunlit c13 fractionation', & + ptr_patch=this%alphapsnsun_patch, default='inactive') + + this%alphapsnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='ALPHAPSNSHA', units='proportion', & + avgflag='A', long_name='shaded c13 fractionation', & + ptr_patch=this%alphapsnsha_patch, default='inactive') + endif + + this%rssun_patch(begp:endp) = spval + call hist_addfld1d (fname='RSSUN', units='s/m', & + avgflag='M', long_name='sunlit leaf stomatal resistance', & + ptr_patch=this%rssun_patch, l2g_scale_type='veg') + + this%rssha_patch(begp:endp) = spval + call hist_addfld1d (fname='RSSHA', units='s/m', & + avgflag='M', long_name='shaded leaf stomatal resistance', & + ptr_patch=this%rssha_patch, l2g_scale_type='veg') + + this%gs_mol_sun_patch(begp:endp,:) = spval + this%gs_mol_sha_patch(begp:endp,:) = spval + if (nlevcan>1) then + call hist_addfld2d (fname='GSSUN', units='umol H20/m2/s', type2d='nlevcan', & + avgflag='A', long_name='sunlit leaf stomatal conductance', & + ptr_patch=this%gs_mol_sun_patch, set_lake=spval, set_urb=spval) + + call hist_addfld2d (fname='GSSHA', units='umol H20/m2/s', type2d='nlevcan', & + avgflag='A', long_name='shaded leaf stomatal conductance', & + ptr_patch=this%gs_mol_sha_patch, set_lake=spval, set_urb=spval) + else + ptr_1d => this%gs_mol_sun_patch(begp:endp,1) + call hist_addfld1d (fname='GSSUN', units='umol H20/m2/s', & + avgflag='A', long_name='sunlit leaf stomatal conductance', & + ptr_patch=ptr_1d) + + ptr_1d => this%gs_mol_sha_patch(begp:endp,1) + call hist_addfld1d (fname='GSSHA', units='umol H20/m2/s', & + avgflag='A', long_name='shaded leaf stomatal conductance', & + ptr_patch=ptr_1d) + + endif + this%gs_mol_sun_ln_patch(begp:endp,:) = spval + this%gs_mol_sha_ln_patch(begp:endp,:) = spval + if (nlevcan>1) then + call hist_addfld2d (fname='GSSUNLN', units='umol H20/m2/s', type2d='nlevcan', & + avgflag='A', long_name='sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon', & + ptr_patch=this%gs_mol_sun_ln_patch, set_lake=spval, set_urb=spval) + + call hist_addfld2d (fname='GSSHALN', units='umol H20/m2/s', type2d='nlevcan', & + avgflag='A', long_name='shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon', & + ptr_patch=this%gs_mol_sha_ln_patch, set_lake=spval, set_urb=spval) + else + ptr_1d => this%gs_mol_sun_ln_patch(begp:endp,1) + call hist_addfld1d (fname='GSSUNLN', units='umol H20/m2/s', & + avgflag='A', long_name='sunlit leaf stomatal conductance at local noon', & + ptr_patch=ptr_1d) + + ptr_1d => this%gs_mol_sha_ln_patch(begp:endp,1) + call hist_addfld1d (fname='GSSHALN', units='umol H20/m2/s', & + avgflag='A', long_name='shaded leaf stomatal conductance at local noon', & + ptr_patch=ptr_1d) + + endif + if(use_luna)then + if(nlevcan>1)then + call hist_addfld2d (fname='Vcmx25Z', units='umol/m2/s', type2d='nlevcan', & + avgflag='A', long_name='canopy profile of vcmax25 predicted by LUNA model', & + ptr_patch=this%vcmx25_z_patch) + + call hist_addfld2d (fname='Jmx25Z', units='umol electrons/m2/s', type2d='nlevcan', & + avgflag='A', long_name='maximum rate of electron transport at 25 Celcius for canopy layers', & + ptr_patch=this%jmx25_z_patch) + + call hist_addfld2d (fname='PNLCZ', units='unitless', type2d='nlevcan', & + avgflag='A', long_name='Proportion of nitrogen allocated for light capture', & + ptr_patch=this%pnlc_z_patch,default='inactive') + else + ptr_1d => this%vcmx25_z_patch(:,1) + call hist_addfld1d (fname='Vcmx25Z', units='umol/m2/s',& + avgflag='A', long_name='canopy profile of vcmax25 predicted by LUNA model', & + ptr_patch=ptr_1d) + ptr_1d => this%jmx25_z_patch(:,1) + call hist_addfld1d (fname='Jmx25Z', units='umol electrons/m2/s',& + avgflag='A', long_name='maximum rate of electron transport at 25 Celcius for canopy layers', & + ptr_patch=ptr_1d) + ptr_1d => this%pnlc_z_patch(:,1) + call hist_addfld1d (fname='PNLCZ', units='unitless', & + avgflag='A', long_name='Proportion of nitrogen allocated for light capture', & + ptr_patch=ptr_1d,default='inactive') + + this%luvcmax25top_patch(begp:endp) = spval + call hist_addfld1d (fname='VCMX25T', units='umol/m2/s', & + avgflag='M', long_name='canopy profile of vcmax25', & + ptr_patch=this%luvcmax25top_patch, set_lake=spval, set_urb=spval) + + this%lujmax25top_patch(begp:endp) = spval + call hist_addfld1d (fname='JMX25T', units='umol/m2/s', & + avgflag='M', long_name='canopy profile of jmax', & + ptr_patch=this%lujmax25top_patch, set_lake=spval, set_urb=spval) + + this%lutpu25top_patch(begp:endp) = spval + call hist_addfld1d (fname='TPU25T', units='umol/m2/s', & + avgflag='M', long_name='canopy profile of tpu', & + ptr_patch=this%lutpu25top_patch, set_lake=spval, set_urb=spval) + + endif + this%fpsn24_patch = spval + call hist_addfld1d (fname='FPSN24', units='umol CO2/m^2 ground/day',& + avgflag='A', long_name='24 hour accumulative patch photosynthesis starting from mid-night', & + ptr_patch=this%fpsn24_patch, default='inactive') + + endif + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !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) + + this%alphapsnsun_patch(p) = spval + this%alphapsnsha_patch(p) = spval + + if (lun%ifspecial(l)) then + this%psnsun_patch(p) = 0._r8 + this%psnsha_patch(p) = 0._r8 + if ( use_c13 ) then + 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 + end do + + end subroutine InitCold + + !----------------------------------------------------------------------- + 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 NewPatchInit (this, p) + ! + ! For new run-time pft, modify state and flux variables to maintain + ! carbon and nitrogen balance with dynamic pft-weights. + ! Called from dyn_cnbal_patch + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + integer, intent(in) :: p + !----------------------------------------------------------------------- + + if ( use_c13 ) then + this%alphapsnsun_patch(p) = 0._r8 + this%alphapsnsha_patch(p) = 0._r8 + this%rc13_canair_patch(p) = 0._r8 + this%rc13_psnsun_patch(p) = 0._r8 + this%rc13_psnsha_patch(p) = 0._r8 + endif + + this%psnsun_patch(p) = 0._r8 + this%psnsha_patch(p) = 0._r8 + + if (use_c13) then + this%c13_psnsun_patch(p) = 0._r8 + this%c13_psnsha_patch(p) = 0._r8 + end if + if ( use_c14 ) then + this%c14_psnsun_patch(p) = 0._r8 + this%c14_psnsha_patch(p) = 0._r8 + end if + + end subroutine NewPatchInit + + !------------------------------------------------------------------------------ + !------------------------------------------------------------------------------ + subroutine Photosynthesis ( bounds, fn, filterp, & + esat_tv, eair, oair, cair, rb, btran, & + dayl_factor, leafn, & + atm2lnd_inst, temperature_inst, surfalb_inst, solarabs_inst, & + canopystate_inst, ozone_inst, photosyns_inst, phase) + ! + ! !DESCRIPTION: + ! Leaf photosynthesis and stomatal conductance calculation as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy + ! + ! !USES: + use clm_varcon , only : rgas, tfrz, 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 pftconMod , only : nbrdlf_dcd_tmp_shrub, npcropmin + + ! + ! !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) :: btran( bounds%begp: ) ! transpiration wetness factor (0 to 1) [pft] + real(r8) , intent(in) :: dayl_factor( bounds%begp: ) ! scalar (0-1) for daylength + real(r8) , intent(in) :: leafn( bounds%begp: ) ! leaf N (gN/m2) + 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(in) :: canopystate_inst + class(ozone_base_type) , intent(in) :: ozone_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + character(len=*) , intent(in) :: phase ! 'sun' or 'sha' + + ! + ! !LOCAL VARIABLES: + ! + ! Leaf photosynthesis parameters + real(r8) :: jmax_z(bounds%begp:bounds%endp,nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) + !real(r8) :: lnc(bounds%begp:bounds%endp) ! leaf N concentration (gN leaf/m^2) + 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 ! leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + real(r8) :: 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 ! CO2 partial pressure at 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 ! 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 :: niter ! iteration loop index + real(r8) :: nscaler ! leaf nitrogen scaling coefficient + + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + + real(r8) :: psn_wc_z(bounds%begp:bounds%endp,nlevcan) ! Rubisco-limited contribution to psn_z (umol CO2/m**2/s) + real(r8) :: psn_wj_z(bounds%begp:bounds%endp,nlevcan) ! RuBP-limited contribution to psn_z (umol CO2/m**2/s) + real(r8) :: psn_wp_z(bounds%begp:bounds%endp,nlevcan) ! product-limited contribution to psn_z (umol CO2/m**2/s) + + real(r8) :: psncan ! canopy sum of psn_z + real(r8) :: psncan_wc ! canopy sum of psn_wc_z + real(r8) :: psncan_wj ! canopy sum of psn_wj_z + real(r8) :: psncan_wp ! canopy sum of psn_wp_z + real(r8) :: lmrcan ! canopy sum of lmr_z + real(r8) :: gscan ! canopy sum of leaf conductance + real(r8) :: laican ! canopy sum of lai_z + real(r8) :: rh_can + real(r8) , pointer :: lai_z (:,:) + real(r8) , pointer :: par_z (:,:) + real(r8) , pointer :: vcmaxcint (:) + real(r8) , pointer :: alphapsn (:) + real(r8) , pointer :: psn (:) + real(r8) , pointer :: psn_wc (:) + real(r8) , pointer :: psn_wj (:) + real(r8) , pointer :: psn_wp (:) + real(r8) , pointer :: psn_z (:,:) + real(r8) , pointer :: lmr (:) + real(r8) , pointer :: lmr_z (:,:) + real(r8) , pointer :: rs (:) + real(r8) , pointer :: rs_z (:,:) + real(r8) , pointer :: ci_z (:,:) + real(r8) , pointer :: o3coefv (:) ! o3 coefficient used in photo calculation + real(r8) , pointer :: o3coefg (:) ! o3 coefficient used in rs calculation + real(r8) , pointer :: alphapsnsun (:) + real(r8) , pointer :: alphapsnsha (:) + + real(r8) :: sum_nscaler + real(r8) :: total_lai + integer :: nptreemax + + real(r8) :: dtime ! land model time step (sec) + integer :: g ! index + !------------------------------------------------------------------------------ + + ! 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(btran) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dayl_factor) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(leafn) == (/bounds%endp/)), sourcefile, __LINE__) + + associate( & + 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 , & ! Input: [real(r8) (:) ] Ball-Berry slope of conduct/photosyn (umol H2O/umol CO2) + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + + 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_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) + gb_mol => photosyns_inst%gb_mol_patch , & ! Output: [real(r8) (:) ] leaf boundary layer conductance (umol H2O/m**2/s) + gs_mol => photosyns_inst%gs_mol_patch , & ! Output: [real(r8) (:,:) ] 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) + vcmax_z => photosyns_inst%vcmax_z_patch , & ! Output: [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 + 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.GC.fnlprmsn15_r22845 + leaf_mr_vcm => canopystate_inst%leaf_mr_vcm & ! Input: [real(r8) ] scalar constant of leaf respiration with Vcmax + ) + + if (phase == 'sun') then + par_z => solarabs_inst%parsun_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + lai_z => canopystate_inst%laisun_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + vcmaxcint => surfalb_inst%vcmaxcintsun_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + alphapsn => photosyns_inst%alphapsnsun_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () + o3coefv => ozone_inst%o3coefvsun_patch ! Input: [real(r8) (:) ] O3 coefficient used in photosynthesis calculation + o3coefg => ozone_inst%o3coefgsun_patch ! Input: [real(r8) (:) ] O3 coefficient used in rs calculation + ci_z => photosyns_inst%cisun_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + rs => photosyns_inst%rssun_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + rs_z => photosyns_inst%rssun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + lmr => photosyns_inst%lmrsun_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + lmr_z => photosyns_inst%lmrsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + psn => photosyns_inst%psnsun_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_z => photosyns_inst%psnsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wc => photosyns_inst%psnsun_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wj => photosyns_inst%psnsun_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wp => photosyns_inst%psnsun_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + else if (phase == 'sha') then + par_z => solarabs_inst%parsha_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + lai_z => canopystate_inst%laisha_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + vcmaxcint => surfalb_inst%vcmaxcintsha_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + alphapsn => photosyns_inst%alphapsnsha_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () + o3coefv => ozone_inst%o3coefvsha_patch ! Input: [real(r8) (:) ] O3 coefficient used in photosynthesis calculation + o3coefg => ozone_inst%o3coefgsha_patch ! Input: [real(r8) (:) ] O3 coefficient used in rs calculation + ci_z => photosyns_inst%cisha_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + rs => photosyns_inst%rssha_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + rs_z => photosyns_inst%rssha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + lmr => photosyns_inst%lmrsha_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + lmr_z => photosyns_inst%lmrsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + psn => photosyns_inst%psnsha_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_z => photosyns_inst%psnsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wc => photosyns_inst%psnsha_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wj => photosyns_inst%psnsha_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wp => photosyns_inst%psnsha_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + end if + + !==============================================================================! + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + !==============================================================================! + + ! Determine seconds of 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) + + ! 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 + + ! Soil water stress applied to Ball-Berry parameters + + bbb(p) = max (bbbopt(p)*btran(p), 1._r8) + mbb(p) = mbbopt(patch%itype(p)) + + ! 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) + + if ( (slatop(patch%itype(p)) *leafcn(patch%itype(p))) .le. 0.0_r8)then + call endrun( "ERROR: slatop or leafcn is zero" ) + end if + 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 + + + ! 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 + + ! 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) < 1.0e-12_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 = vcmaxcint(p) + else if (nlevcan > 1) then + nscaler = exp(-kn(p) * laican) + end if + + ! Maintenance respiration + + lmr25 = lmr25top * nscaler + + 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 = leaf_mr_vcm * photosyns_inst%vcmx25_z_patch(p,iv) + endif + endif + + if (c3flag(p)) then + lmr_z(p,iv) = lmr25 * ft(t_veg(p), params_inst%lmrha) * fth(t_veg(p), params_inst%lmrhd, & + params_inst%lmrse, lmrc) + else + lmr_z(p,iv) = lmr25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + lmr_z(p,iv) = lmr_z(p,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) + end if + + if (par_z(p,iv) <= 0._r8) then ! night time + + vcmax_z(p,iv) = 0._r8 + jmax_z(p,iv) = 0._r8 + tpu_z(p,iv) = 0._r8 + kp_z(p,iv) = 0._r8 + + if ( use_c13 ) then + alphapsn(p) = 1._r8 + end if + + else ! day time + + if(use_luna.and.c3flag(p).and.crop(patch%itype(p))== 0)then + vcmax25 = photosyns_inst%vcmx25_z_patch(p,iv) + jmax25 = photosyns_inst%jmx25_z_patch(p,iv) + tpu25 = params_inst%tpu25ratio * vcmax25 + !Implement scaling of Vcmax25 from sunlit average to shaded canopy average value. RF & GBB. 1 July 2016 + if(phase == 'sha'.and.surfalb_inst%vcmaxcintsun_patch(p).gt.0._r8.and.nlevcan==1) then + vcmax25 = vcmax25 * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + jmax25 = jmax25 * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + tpu25 = tpu25 * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + end if + + else + vcmax25 = vcmax25top * nscaler + jmax25 = jmax25top * nscaler + tpu25 = tpu25top * nscaler + endif + kp25 = kp25top * nscaler + + ! Adjust for temperature + + 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 + 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,iv) = vcmax25 * ft(t_veg(p), params_inst%vcmaxha) * fth(t_veg(p), & + params_inst%vcmaxhd, vcmaxse, vcmaxc) + jmax_z(p,iv) = jmax25 * ft(t_veg(p), params_inst%jmaxha) * fth(t_veg(p), & + params_inst%jmaxhd, jmaxse, jmaxc) + tpu_z(p,iv) = tpu25 * ft(t_veg(p), params_inst%tpuha) * fth(t_veg(p), params_inst%tpuhd, tpuse, tpuc) + + if (.not. c3flag(p)) then + vcmax_z(p,iv) = vcmax25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + vcmax_z(p,iv) = vcmax_z(p,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg(p)) )) + vcmax_z(p,iv) = vcmax_z(p,iv) / (1._r8 + exp( 0.3_r8*(t_veg(p)-(tfrz+40._r8)) )) + end if + + kp_z(p,iv) = kp25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + + end if + + ! Adjust for soil water + + vcmax_z(p,iv) = vcmax_z(p,iv) * btran(p) + lmr_z(p,iv) = lmr_z(p,iv) * btran(p) + + ! 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(p,1) > 0._r8) then ! are the lights on? + lmr_z(p,iv) = lmr_z(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(p,iv) <= 0._r8) then ! night time + + ac(p,iv) = 0._r8 + aj(p,iv) = 0._r8 + ap(p,iv) = 0._r8 + ag(p,iv) = 0._r8 + an(p,iv) = ag(p,iv) - lmr_z(p,iv) + psn_z(p,iv) = 0._r8 + psn_wc_z(p,iv) = 0._r8 + psn_wj_z(p,iv) = 0._r8 + psn_wp_z(p,iv) = 0._r8 + rs_z(p,iv) = min(rsmax0, 1._r8/bbb(p) * cf) + ci_z(p,iv) = 0._r8 + rh_leaf(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 + + qabs = 0.5_r8 * (1._r8 - params_inst%fnps) * par_z(p,iv) * 4.6_r8 + aquad = params_inst%theta_psii + bquad = -(qabs + jmax_z(p,iv)) + cquad = qabs * jmax_z(p,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Iterative loop for ci beginning with initial guess + + if (c3flag(p)) then + ci_z(p,iv) = 0.7_r8 * cair(p) + else + ci_z(p,iv) = 0.4_r8 * cair(p) + end if + + niter = 0 + + ! Increment iteration counter. Stop if too many iterations + + niter = niter + 1 + + ! Save old ci + + ciold = ci_z(p,iv) + + !find ci and stomatal conductance + call hybrid(ciold, p, iv, c, gb_mol(p), je, cair(p), oair(p), & + lmr_z(p,iv), par_z(p,iv), rh_can, gs_mol(p,iv), niter, & + atm2lnd_inst, photosyns_inst) + + ! End of ci iteration. Check for an < 0, in which case gs_mol = bbb + + if (an(p,iv) < 0._r8) gs_mol(p,iv) = bbb(p) + + ! 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 + if (phase == 'sun') then + gs_mol_sun_ln(p,iv) = gs_mol(p,iv) + else if (phase == 'sha') then + gs_mol_sha_ln(p,iv) = gs_mol(p,iv) + end if + else + if (phase == 'sun') then + gs_mol_sun_ln(p,iv) = spval + else if (phase == 'sha') then + gs_mol_sha_ln(p,iv) = spval + end if + end if + + ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) + + cs = cair(p) - 1.4_r8/gb_mol(p) * an(p,iv) * forc_pbot(c) + cs = max(cs,1.e-06_r8) + ci_z(p,iv) = cair(p) - an(p,iv) * forc_pbot(c) * (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv)) + + ! Trap for values of ci_z less than 1.e-06. This is needed for + ! Megan (which can crash with negative values) + ci_z(p,iv) = max( ci_z(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(p,iv) / cf + rs_z(p,iv) = min(1._r8/gs, rsmax0) + rs_z(p,iv) = rs_z(p,iv) / o3coefg(p) + + ! Photosynthesis. Save rate-limiting photosynthesis + + psn_z(p,iv) = ag(p,iv) + psn_z(p,iv) = psn_z(p,iv) * o3coefv(p) + + psn_wc_z(p,iv) = 0._r8 + psn_wj_z(p,iv) = 0._r8 + psn_wp_z(p,iv) = 0._r8 + + if (ac(p,iv) <= aj(p,iv) .and. ac(p,iv) <= ap(p,iv)) then + psn_wc_z(p,iv) = psn_z(p,iv) + else if (aj(p,iv) < ac(p,iv) .and. aj(p,iv) <= ap(p,iv)) then + psn_wj_z(p,iv) = psn_z(p,iv) + else if (ap(p,iv) < ac(p,iv) .and. ap(p,iv) < aj(p,iv)) then + psn_wp_z(p,iv) = psn_z(p,iv) + end if + + ! Make sure iterative solution is correct + + if (gs_mol(p,iv) < 0._r8) then + write (iulog,*)'Negative stomatal conductance:' + write (iulog,*)'p,iv,gs_mol= ',p,iv,gs_mol(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(p,iv)*esat_tv(p)) / ((gb_mol(p)+gs_mol(p,iv))*esat_tv(p)) + rh_leaf(p) = hs + gs_mol_err = mbb(p)*max(an(p,iv), 0._r8)*hs/cs*forc_pbot(c) + bbb(p) + + if (abs(gs_mol(p,iv)-gs_mol_err) > 1.e-01_r8) then + write (iulog,*) 'Ball-Berry error check - stomatal conductance error:' + write (iulog,*) gs_mol(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 = 0._r8 + psncan_wc = 0._r8 + psncan_wj = 0._r8 + psncan_wp = 0._r8 + lmrcan = 0._r8 + gscan = 0._r8 + laican = 0._r8 + do iv = 1, nrad(p) + psncan = psncan + psn_z(p,iv) * lai_z(p,iv) + psncan_wc = psncan_wc + psn_wc_z(p,iv) * lai_z(p,iv) + psncan_wj = psncan_wj + psn_wj_z(p,iv) * lai_z(p,iv) + psncan_wp = psncan_wp + psn_wp_z(p,iv) * lai_z(p,iv) + lmrcan = lmrcan + lmr_z(p,iv) * lai_z(p,iv) + gscan = gscan + lai_z(p,iv) / (rb(p)+rs_z(p,iv)) + laican = laican + lai_z(p,iv) + end do + if (laican > 0._r8) then + psn(p) = psncan / laican + psn_wc(p) = psncan_wc / laican + psn_wj(p) = psncan_wj / laican + psn_wp(p) = psncan_wp / laican + lmr(p) = lmrcan / laican + rs(p) = laican / gscan - rb(p) + else + psn(p) = 0._r8 + psn_wc(p) = 0._r8 + psn_wj(p) = 0._r8 + psn_wp(p) = 0._r8 + lmr(p) = 0._r8 + rs(p) = 0._r8 + end if + end do + + end associate + + end subroutine Photosynthesis + + !------------------------------------------------------------------------------ + 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( & + forc_pco2 => atm2lnd_inst%forc_pco2_grc , & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) + forc_pc13o2 => atm2lnd_inst%forc_pc13o2_grc , & ! Input: [real(r8) (:) ] partial pressure c13o2 (Pa) + forc_po2 => atm2lnd_inst%forc_po2_grc , & ! Input: [real(r8) (:) ] partial pressure o2 (Pa) + + 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) + ) + + if ( use_c14 ) then + if (use_c14_bombspike) then + call C14BombSpike(rc14_atm) + else + rc14_atm(:) = c14ratio + end if + end if + + if ( use_c13 ) then + if (use_c13_timeseries) then + call C13TimeSeries(rc13_atm) + end if + end if + + 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 + + if (use_cn) then + if ( use_c13 ) then + if (use_c13_timeseries) then + rc13_canair(p) = rc13_atm + else + rc13_canair(p) = forc_pc13o2(g)/(forc_pco2(g) - forc_pc13o2(g)) + endif + rc13_psnsun(p) = rc13_canair(p)/alphapsnsun(p) + rc13_psnsha(p) = rc13_canair(p)/alphapsnsha(p) + c13_psnsun(p) = psnsun(p) * (rc13_psnsun(p)/(1._r8+rc13_psnsun(p))) + c13_psnsha(p) = psnsha(p) * (rc13_psnsha(p)/(1._r8+rc13_psnsha(p))) + + ! use fixed c13 ratio with del13C of -25 to test the overall c13 structure + ! c13_psnsun(p) = 0.01095627 * psnsun(p) + ! c13_psnsha(p) = 0.01095627 * psnsha(p) + endif + if ( use_c14 ) then + + ! determine latitute sector for radiocarbon bomb spike inputs + if ( grc%latdeg(g) .ge. 30._r8 ) then + sector_c14 = 1 + else if ( grc%latdeg(g) .ge. -30._r8 ) then + sector_c14 = 2 + else + sector_c14 = 3 + endif + + c14_psnsun(p) = rc14_atm(sector_c14) * psnsun(p) + c14_psnsha(p) = rc14_atm(sector_c14) * psnsha(p) + endif + end if + + end do + + end associate + + end subroutine PhotosynthesisTotal + + !------------------------------------------------------------------------------ + subroutine Fractionation(bounds, fn, filterp, downreg, & + atm2lnd_inst, canopystate_inst, solarabs_inst, surfalb_inst, photosyns_inst, & + phase) + ! + ! !DESCRIPTION: + ! C13 fractionation during photosynthesis is calculated here after the nitrogen + ! limitation is taken into account in the CNAllocation module. + ! + ! As of CLM5, nutrient downregulation occurs prior to photosynthesis via leafcn, so we may + ! ignore the downregulation term in this and assume that the Ci/Ca used in the photosynthesis + ! calculation is consistent with that in the isotope calculation + ! + !!USES: + use clm_varctl , only : use_hydrstress + ! + ! !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) :: downreg( bounds%begp: ) ! fractional reduction in GPP due to N limitation (dimensionless) + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(solarabs_type) , intent(in) :: solarabs_inst + type(surfalb_type) , intent(in) :: surfalb_inst + type(photosyns_type) , intent(in) :: photosyns_inst + character(len=*) , intent(in) :: phase ! 'sun' or 'sha' + ! + ! !LOCAL VARIABLES: + real(r8) , pointer :: par_z (:,:) ! needed for backwards compatiblity + real(r8) , pointer :: alphapsn (:) ! needed for backwards compatiblity + real(r8) , pointer :: gs_mol(:,:) ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) , pointer :: an(:,:) ! net leaf photosynthesis (umol CO2/m**2/s) + integer :: f,p,c,g,iv ! indices + real(r8) :: co2(bounds%begp:bounds%endp) ! atmospheric co2 partial pressure (pa) + real(r8) :: ci + !------------------------------------------------------------------------------ + + SHR_ASSERT_ALL_FL((ubound(downreg) == (/bounds%endp/)), sourcefile, __LINE__) + + associate( & + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + forc_pco2 => atm2lnd_inst%forc_pco2_grc , & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) + + c3psn => pftcon%c3psn , & ! Input: photosynthetic pathway: 0. = c4, 1. = c3 + + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] number of canopy layers, above snow for radiative transfer + + gb_mol => photosyns_inst%gb_mol_patch & ! Input: [real(r8) (:) ] leaf boundary layer conductance (umol H2O/m**2/s) + ) + + if (phase == 'sun') then + par_z => solarabs_inst%parsun_z_patch ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) + alphapsn => photosyns_inst%alphapsnsun_patch ! Output: [real(r8) (:)] + if (use_hydrstress) then + gs_mol => photosyns_inst%gs_mol_sun_patch ! Input: [real(r8) (:,:) ] sunlit leaf stomatal conductance (umol H2O/m**2/s) + an => photosyns_inst%an_sun_patch ! Input: [real(r8) (:,:) ] net sunlit leaf photosynthesis (umol CO2/m**2/s) + else + gs_mol => photosyns_inst%gs_mol_patch ! Input: [real(r8) (:,:) ] leaf stomatal conductance (umol H2O/m**2/s) + an => photosyns_inst%an_patch ! Input: [real(r8) (:,:) ] net leaf photosynthesis (umol CO2/m**2/s) + end if + else if (phase == 'sha') then + par_z => solarabs_inst%parsha_z_patch ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) + alphapsn => photosyns_inst%alphapsnsha_patch ! Output: [real(r8) (:)] + if (use_hydrstress) then + gs_mol => photosyns_inst%gs_mol_sha_patch ! Input: [real(r8) (:,:) ] shaded leaf stomatal conductance (umol H2O/m**2/s) + an => photosyns_inst%an_sha_patch ! Input: [real(r8) (:,:) ] net shaded leaf photosynthesis (umol CO2/m**2/s) + else + gs_mol => photosyns_inst%gs_mol_patch ! Input: [real(r8) (:,:) ] leaf stomatal conductance (umol H2O/m**2/s) + an => photosyns_inst%an_patch ! Input: [real(r8) (:,:) ] net leaf photosynthesis (umol CO2/m**2/s) + end if + end if + + do f = 1, fn + p = filterp(f) + c= patch%column(p) + g= patch%gridcell(p) + + co2(p) = forc_pco2(g) + do iv = 1,nrad(p) + if (par_z(p,iv) <= 0._r8) then ! night time + alphapsn(p) = 1._r8 + else ! day time + ci = co2(p) - (an(p,iv) * & + forc_pbot(c) * & + (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv))) + alphapsn(p) = 1._r8 + (((c3psn(patch%itype(p)) * & + (4.4_r8 + (22.6_r8*(ci/co2(p))))) + & + ((1._r8 - c3psn(patch%itype(p))) * 4.4_r8))/1000._r8) + end if + end do + end do + + end associate + + end subroutine Fractionation + + !------------------------------------------------------------------------------- + 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. + 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_orig_files/QSatMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/QSatMod.F90 new file mode 100644 index 000000000..9a17ce700 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/RootBiophysMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/RootBiophysMod.F90 new file mode 100644 index 000000000..6e94ddef4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/RootBiophysMod.F90 @@ -0,0 +1,328 @@ +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 + use spmdMod , only : mpicom, masterproc + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + use clm_nlUtilsMod , only : find_nlgroup_name + + ! !ARGUMENTS: + !------------------------------------------------------------------------------ + implicit none + character(len=*), intent(in) :: NLFilename + + integer :: nu_nml ! unit for namelist file + integer :: nml_error ! 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 + nu_nml = getavu() + open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) + call find_nlgroup_name(nu_nml, 'rooting_profile_inparm', status=nml_error) + if (nml_error == 0) then + read(nu_nml, nml=rooting_profile_inparm,iostat=nml_error) + if (nml_error /= 0) then + call endrun(subname // ':: ERROR reading rooting_profile namelist') + end if + else + call endrun(subname // ':: ERROR finding rooting_profile namelist') + end if + close(nu_nml) + call relavu( nu_nml ) + + 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_orig_files/SaturatedExcessRunoffMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SaturatedExcessRunoffMod.F90 new file mode 100644 index 000000000..309d25146 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SaturatedExcessRunoffMod.F90 @@ -0,0 +1,414 @@ +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_varctl , only : iulog, use_vichydro, crop_fsat_equals_zero + use clm_varcon , only : spval + use LandunitType , only : landunit_type + use landunit_varcon , only : istcrop + use ColumnType , only : column_type + use SoilHydrologyType, only : soilhydrology_type + use SoilStateType, only : soilstate_type + use WaterFluxBulkType, only : waterfluxbulk_type + + 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 + ! Public routines + procedure, public :: Init + + procedure, public :: SaturatedExcessRunoff ! Calculate surface runoff due to saturated surface + + ! Private routines + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + procedure, private, nopass :: ComputeFsatTopmodel + procedure, private, nopass :: ComputeFsatVic + end type saturated_excess_runoff_type + public :: readParams + + 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 + + ! !PRIVATE DATA MEMBERS: + + integer, parameter :: FSAT_METHOD_TOPMODEL = 1 + integer, parameter :: FSAT_METHOD_VIC = 2 + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + ! ======================================================================== + ! Infrastructure routines + ! ======================================================================== + + !----------------------------------------------------------------------- + subroutine Init(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize this saturated_excess_runoff_type object + ! + ! !ARGUMENTS: + class(saturated_excess_runoff_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Init' + !----------------------------------------------------------------------- + + call this%InitAllocate(bounds) + call this%InitHistory(bounds) + call this%InitCold(bounds) + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Allocate memory for this saturated_excess_runoff_type object + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(saturated_excess_runoff_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + + character(len=*), parameter :: subname = 'InitAllocate' + !----------------------------------------------------------------------- + + 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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize saturated_excess_runoff_type history variables + ! + ! !USES: + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + class(saturated_excess_runoff_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + + character(len=*), parameter :: subname = 'InitHistory' + !----------------------------------------------------------------------- + + begc = bounds%begc; endc= bounds%endc + + this%fcov_col(begc:endc) = spval + call hist_addfld1d (fname='FCOV', units='unitless', & + avgflag='A', long_name='fractional impermeable area', & + ptr_col=this%fcov_col, l2g_scale_type='veg') + + this%fsat_col(begc:endc) = spval + call hist_addfld1d (fname='FSAT', units='unitless', & + avgflag='A', long_name='fractional area with water table at surface', & + ptr_col=this%fsat_col, l2g_scale_type='veg') + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !DESCRIPTION: + ! Perform cold-start initialization for saturated_excess_runoff_type + ! + ! !ARGUMENTS: + class(saturated_excess_runoff_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'InitCold' + !----------------------------------------------------------------------- + + ! TODO(wjs, 2017-07-12) We'll read fsat_method from namelist. + if (use_vichydro) then + this%fsat_method = FSAT_METHOD_VIC + else + this%fsat_method = FSAT_METHOD_TOPMODEL + end if + + end subroutine InitCold + + !----------------------------------------------------------------------- + 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_SaturatedExcessRunoff' + !-------------------------------------------------------------------- + + ! Decay factor for fractional saturated area (1/m) + call readNcdioScalar(ncid, 'fff', subname, params_inst%fff) + + end subroutine readParams + + ! ======================================================================== + ! Science routines + ! ======================================================================== + + !----------------------------------------------------------------------- + subroutine SaturatedExcessRunoff (this, bounds, num_hydrologyc, filter_hydrologyc, & + lun, col, soilhydrology_inst, soilstate_inst, waterfluxbulk_inst) + ! + ! !DESCRIPTION: + ! Calculate surface runoff due to saturated surface + ! + ! Sets this%fsat_col and waterfluxbulk_inst%qflx_sat_excess_surf_col + ! + ! !ARGUMENTS: + class(saturated_excess_runoff_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter + integer , intent(in) :: filter_hydrologyc(:) ! column filter for soil points + type(landunit_type) , intent(in) :: lun + type(column_type) , intent(in) :: col + type(soilhydrology_type) , intent(inout) :: soilhydrology_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + ! + ! !LOCAL VARIABLES: + integer :: fc, c, l + + character(len=*), parameter :: subname = 'SaturatedExcessRunoff' + !----------------------------------------------------------------------- + + associate( & + fcov => this%fcov_col , & ! Output: [real(r8) (:) ] fractional impermeable area + fsat => this%fsat_col , & ! Output: [real(r8) (:) ] fractional area with water table at surface + + snl => col%snl , & ! Input: [integer (:) ] minus number of snow layers + + qflx_sat_excess_surf => waterfluxbulk_inst%qflx_sat_excess_surf_col, & ! Output: [real(r8) (:) ] surface runoff due to saturated surface (mm H2O /s) + qflx_floodc => waterfluxbulk_inst%qflx_floodc_col , & ! Input: [real(r8) (:) ] column flux of flood water from RTM + qflx_rain_plus_snomelt => waterfluxbulk_inst%qflx_rain_plus_snomelt_col , & ! Input: [real(r8) (:) ] rain plus snow melt falling on the soil (mm/s) + + origflag => soilhydrology_inst%origflag , & ! Input: logical + fracice => soilhydrology_inst%fracice_col & ! Input: [real(r8) (:,:) ] fractional impermeability (-) + ) + + ! ------------------------------------------------------------------------ + ! Compute fsat + ! ------------------------------------------------------------------------ + + select case (this%fsat_method) + case (FSAT_METHOD_TOPMODEL) + call this%ComputeFsatTopmodel(bounds, num_hydrologyc, filter_hydrologyc, & + soilhydrology_inst, soilstate_inst, & + fsat = fsat(bounds%begc:bounds%endc)) + case (FSAT_METHOD_VIC) + call this%ComputeFsatVic(bounds, num_hydrologyc, filter_hydrologyc, & + soilhydrology_inst, & + fsat = fsat(bounds%begc:bounds%endc)) + case default + write(iulog,*) subname//' ERROR: Unrecognized fsat_method: ', this%fsat_method + call endrun(subname//' ERROR: Unrecognized fsat_method') + end select + + ! ------------------------------------------------------------------------ + ! Set fsat to zero for crop columns + ! ------------------------------------------------------------------------ + if (crop_fsat_equals_zero) then + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + l = col%landunit(c) + if(lun%itype(l) == istcrop) fsat(c) = 0._r8 + end do + endif + + ! ------------------------------------------------------------------------ + ! Compute qflx_sat_excess_surf + ! + ! assume qinmax (maximum infiltration rate) is large relative to + ! qflx_rain_plus_snomelt in control + ! ------------------------------------------------------------------------ + + if (origflag == 1) then + if (this%fsat_method == FSAT_METHOD_VIC) then + ! NOTE(wjs, 2017-07-12) I'm not sure if it's the VIC fsat method per se that + ! is incompatible with origflag, or some other aspect of VIC: The original + ! check was for origflag == 1 and use_vichydro, which also appears in error + ! checks elsewhere. + call endrun(msg="VICHYDRO is not available for origflag=1"//errmsg(sourcefile, __LINE__)) + end if + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + fcov(c) = (1._r8 - fracice(c,1)) * fsat(c) + fracice(c,1) + qflx_sat_excess_surf(c) = fcov(c) * qflx_rain_plus_snomelt(c) + end do + else + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + ! only send fast runoff directly to streams + qflx_sat_excess_surf(c) = fsat(c) * qflx_rain_plus_snomelt(c) + + ! Set fcov just to have it on the history file + fcov(c) = fsat(c) + end do + end if + + ! ------------------------------------------------------------------------ + ! For urban columns, send flood water flux to runoff + ! ------------------------------------------------------------------------ + + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + if (col%urbpoi(c)) then + ! send flood water flux to runoff for all urban columns + qflx_sat_excess_surf(c) = qflx_sat_excess_surf(c) + qflx_floodc(c) + end if + end do + + end associate + + end subroutine SaturatedExcessRunoff + + !----------------------------------------------------------------------- + subroutine ComputeFsatTopmodel(bounds, num_hydrologyc, filter_hydrologyc, & + soilhydrology_inst, soilstate_inst, fsat) + ! + ! !DESCRIPTION: + ! Compute fsat using the TOPModel-based parameterization + ! + ! This is the CLM default parameterization + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: num_hydrologyc ! number of column soil points in column filter + integer, intent(in) :: filter_hydrologyc(:) ! column filter for soil points + type(soilhydrology_type) , intent(in) :: soilhydrology_inst + type(soilstate_type), intent(in) :: soilstate_inst + real(r8), intent(inout) :: fsat( bounds%begc: ) ! fractional area with water table at surface + ! + ! !LOCAL VARIABLES: + integer :: fc, c + real(r8) :: fff ! decay factor (m-1) + + character(len=*), parameter :: subname = 'ComputeFsatTopmodel' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(fsat) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + frost_table => soilhydrology_inst%frost_table_col , & ! Input: [real(r8) (:) ] frost table depth (m) + zwt => soilhydrology_inst%zwt_col , & ! Input: [real(r8) (:) ] water table depth (m) + zwt_perched => soilhydrology_inst%zwt_perched_col , & ! Input: [real(r8) (:) ] perched water table depth (m) + + wtfact => soilstate_inst%wtfact_col & ! Input: [real(r8) (:) ] maximum saturated fraction for a gridcell + ) + + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + if (frost_table(c) > zwt_perched(c) .and. frost_table(c) <= zwt(c)) then + ! use perched water table to determine fsat (if present) + fsat(c) = wtfact(c) * exp(-0.5_r8*params_inst%fff*zwt_perched(c)) + else + fsat(c) = wtfact(c) * exp(-0.5_r8*params_inst%fff*zwt(c)) + end if + end do + + end associate + + end subroutine ComputeFsatTopmodel + + !----------------------------------------------------------------------- + subroutine ComputeFsatVic(bounds, num_hydrologyc, filter_hydrologyc, & + soilhydrology_inst, fsat) + ! + ! !DESCRIPTION: + ! Compute fsat using the VIC-based parameterization + ! + ! Citation: Wood et al. 1992, "A land-surface hydrology parameterization with subgrid + ! variability for general circulation models", JGR 97(D3), 2717-2728. + ! + ! This implementation gives a first-order approximation to saturated excess runoff. + ! For now we're not including the more exact analytical solution, or even a better + ! numerical approximation. + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer, intent(in) :: num_hydrologyc ! number of column soil points in column filter + integer, intent(in) :: filter_hydrologyc(:) ! column filter for soil points + type(soilhydrology_type) , intent(in) :: soilhydrology_inst + real(r8), intent(inout) :: fsat( bounds%begc: ) ! fractional area with water table at surface + ! + ! !LOCAL VARIABLES: + integer :: fc, c + real(r8) :: ex(bounds%begc:bounds%endc) ! exponent + + character(len=*), parameter :: subname = 'ComputeFsatVic' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(fsat) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + b_infil => soilhydrology_inst%b_infil_col , & ! Input: [real(r8) (:) ] VIC b infiltration parameter + top_max_moist => soilhydrology_inst%top_max_moist_col, & ! Input: [real(r8) (:) ] maximum soil moisture in top VIC layers + top_moist_limited => soilhydrology_inst%top_moist_limited_col & ! Input: [real(r8) (:) ] soil moisture in top layers, limited to no greater than top_max_moist + ) + + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + ex(c) = b_infil(c) / (1._r8 + b_infil(c)) + ! fsat is equivalent to A in VIC papers + fsat(c) = 1._r8 - (1._r8 - top_moist_limited(c) / top_max_moist(c))**ex(c) + end do + + end associate + + end subroutine ComputeFsatVic + + +end module SaturatedExcessRunoffMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemCarbonFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemCarbonFluxType.F90 new file mode 100644 index 000000000..94af1b536 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemCarbonFluxType.F90 @@ -0,0 +1,902 @@ +module SoilBiogeochemCarbonFluxType + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use decompMod , only : bounds_type + 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_varcon , only : spval, ispval, dzsoi_decomp + use landunit_varcon , only : istsoil, istcrop, istdlak + use ch4varcon , only : allowlakeprod + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use ColumnType , only : col + use LandunitType , only : lun + use clm_varctl , only : use_fates, use_soil_matrixcn, use_vertsoilc + use SPMMod , only : sparse_matrix_type, diag_matrix_type, vector_type + + ! + ! !PUBLIC TYPES: + implicit none + private + ! + + + 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 :: 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 :: Init + procedure , private :: InitAllocate + procedure , private :: InitHistory + procedure , private :: InitCold + procedure , public :: Restart + procedure , public :: SetValues + procedure , public :: Summary + + end type soilbiogeochem_carbonflux_type + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, carbon_type) + + class(soilbiogeochem_carbonflux_type) :: this + type(bounds_type), intent(in) :: bounds + character(len=3) , intent(in) :: carbon_type ! one of ['c12', c13','c14'] + + call this%InitAllocate ( bounds) + call this%InitHistory ( bounds, carbon_type ) + call this%InitCold (bounds ) + + end subroutine Init + + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !ARGUMENTS: + class (soilbiogeochem_carbonflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !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 (:) =nan + 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%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 InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds, carbon_type) + ! + ! !DESCRIPTION: + ! add history fields for all CN variables, always set as default='inactive' + ! + ! !USES: + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools + use clm_varpar , only : nlevdecomp, nlevdecomp_full + use clm_varctl , only : hist_wrtch4diag + use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + ! + ! !ARGUMENTS: + class(soilbiogeochem_carbonflux_type) :: this + type(bounds_type) , intent(in) :: bounds + character(len=3) , intent(in) :: carbon_type ! one of ['c12', c13','c14'] + ! + ! !LOCAL VARIABLES: + integer :: k,l,ii,jj,c + character(8) :: vr_suffix + character(10) :: active + integer :: begp,endp + integer :: begc,endc + character(24) :: fieldname + character(100) :: longname + real(r8), pointer :: data1dptr(:) ! temp. pointer for slicing larger arrays + real(r8), pointer :: data2dptr(:,:) ! temp. pointer for slicing larger arrays + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + if (nlevdecomp > 1) then + vr_suffix = "_vr" + else + vr_suffix = "" + endif + + !------------------------------- + ! C flux variables - native to column + !------------------------------- + + ! add history fields for all CLAMP CN variables + + if (carbon_type == 'c12') then + + this%hr_col(begc:endc) = spval + call hist_addfld1d (fname='HR', units='gC/m^2/s', & + avgflag='A', long_name='total heterotrophic respiration', & + ptr_col=this%hr_col) + + this%lithr_col(begc:endc) = spval + call hist_addfld1d (fname='LITTERC_HR', units='gC/m^2/s', & + avgflag='A', long_name='litter C heterotrophic respiration', & + ptr_col=this%lithr_col) + + this%somhr_col(begc:endc) = spval + call hist_addfld1d (fname='SOILC_HR', units='gC/m^2/s', & + avgflag='A', long_name='soil C heterotrophic respiration', & + ptr_col=this%somhr_col) + + if (hist_wrtch4diag) then + this%fphr_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld_decomp (fname='FPHR'//trim(vr_suffix), units='unitless', type2d='levdcmp', & + avgflag='A', long_name='fraction of potential HR due to N limitation', & + ptr_col=this%fphr_col) + end if + + this%somc_fire_col(begc:endc) = spval + call hist_addfld1d (fname='SOMC_FIRE', units='gC/m^2/s', & + avgflag='A', long_name='C loss due to peat burning', & + ptr_col=this%somc_fire_col) + + do k = 1, ndecomp_pools + ! decomposition k + data2dptr => this%decomp_k_col(:,:,k) + fieldname = 'K_'//trim(decomp_cascade_con%decomp_pool_name_history(k)) + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' potential loss coefficient' + call hist_addfld_decomp (fname=fieldname, units='1/s', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + end do + + this%decomp_cascade_hr_col(begc:endc,:) = spval + this%decomp_cascade_hr_vr_col(begc:endc,:,:) = spval + this%decomp_cascade_ctransfer_col(begc:endc,:) = spval + this%decomp_cascade_ctransfer_vr_col(begc:endc,:,:) = spval + do l = 1, ndecomp_cascade_transitions + + ! output the vertically integrated fluxes only as default + !-- HR fluxes (none from CWD) + if ( .not. decomp_cascade_con%is_cwd(decomp_cascade_con%cascade_donor_pool(l)) ) then + data1dptr => this%decomp_cascade_hr_col(:,l) + ! check to see if there are multiple pathways that include respiration, and if so, note that in the history file + ii = 0 + do jj = 1, ndecomp_cascade_transitions + if ( decomp_cascade_con%cascade_donor_pool(jj) == decomp_cascade_con%cascade_donor_pool(l) ) ii = ii+1 + end do + if ( ii == 1 ) then + fieldname = & + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//'_HR' + else + fieldname = & + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//'_HR_'//& + trim(decomp_cascade_con%decomp_pool_name_short(decomp_cascade_con%cascade_receiver_pool(l))) + endif + longname = 'Het. Resp. from '//& + trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l))) + call hist_addfld1d (fname=fieldname, units='gC/m^2/s', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + endif + + !-- transfer fluxes (none from terminal pool, if present) + if ( decomp_cascade_con%cascade_receiver_pool(l) /= 0 ) then + data1dptr => this%decomp_cascade_ctransfer_col(:,l) + fieldname = & + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//'C_TO_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l)))//'C' + longname = 'decomp. of '//trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l)))//& + ' C to '//trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_receiver_pool(l)))//' C' + call hist_addfld1d (fname=fieldname, units='gC/m^2/s', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + endif + + ! output the vertically resolved fluxes + if ( nlevdecomp_full > 1 ) then + !-- HR fluxes (none from CWD) + if ( .not. decomp_cascade_con%is_cwd(decomp_cascade_con%cascade_donor_pool(l)) ) then + data2dptr => this%decomp_cascade_hr_vr_col(:,:,l) + ! check to see if there are multiple pathways that include respiration, and if so, note that in the history file + ii = 0 + do jj = 1, ndecomp_cascade_transitions + if ( decomp_cascade_con%cascade_donor_pool(jj) == decomp_cascade_con%cascade_donor_pool(l) ) ii = ii+1 + end do + if ( ii == 1 ) then + fieldname = & + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'_HR'//trim(vr_suffix) + else + fieldname = & + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//'_HR_'//& + trim(decomp_cascade_con%decomp_pool_name_short(decomp_cascade_con%cascade_receiver_pool(l)))& + //trim(vr_suffix) + endif + longname = 'Het. Resp. from '//& + trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l))) + call hist_addfld_decomp (fname=fieldname, units='gC/m^3/s', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + + !-- transfer fluxes (none from terminal pool, if present) + if ( decomp_cascade_con%cascade_receiver_pool(l) /= 0 ) then + data2dptr => this%decomp_cascade_ctransfer_vr_col(:,:,l) + fieldname = & + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//'C_TO_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l)))& + //'C'//trim(vr_suffix) + longname = 'decomp. of '//& + trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l)))//& + ' C to '//& + trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_receiver_pool(l)))//' C' + call hist_addfld_decomp (fname=fieldname, units='gC/m^3/s', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + end if + + end do + + if ( nlevdecomp_full > 1 ) then + data2dptr => this%t_scalar_col(begc:endc,1:nlevsoi) + call hist_addfld_decomp (fname='T_SCALAR', units='unitless', type2d='levsoi', & + avgflag='A', long_name='temperature inhibition of decomposition', & + ptr_col=data2dptr) + + data2dptr => this%w_scalar_col(begc:endc,1:nlevsoi) + call hist_addfld_decomp (fname='W_SCALAR', units='unitless', type2d='levsoi', & + avgflag='A', long_name='Moisture (dryness) inhibition of decomposition', & + ptr_col=data2dptr) + + data2dptr => this%o_scalar_col(begc:endc,1:nlevsoi) + call hist_addfld_decomp (fname='O_SCALAR', units='unitless', type2d='levsoi', & + avgflag='A', long_name='fraction by which decomposition is reduced due to anoxia', & + ptr_col=data2dptr) + end if + + this%som_c_leached_col(begc:endc) = spval + call hist_addfld1d (fname='SOM_C_LEACHED', units='gC/m^2/s', & + avgflag='A', long_name='total flux of C from SOM pools due to leaching', & + ptr_col=this%som_c_leached_col)!, default='inactive') + + this%decomp_cpools_leached_col(begc:endc,:) = spval + this%decomp_cpools_transport_tendency_col(begc:endc,:,:) = spval + do k = 1, ndecomp_pools + if ( .not. decomp_cascade_con%is_cwd(k) ) then + data1dptr => this%decomp_cpools_leached_col(:,k) + fieldname = 'M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'C_TO_LEACHING' + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' C leaching loss' + call hist_addfld1d (fname=fieldname, units='gC/m^2/s', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + + data2dptr => this%decomp_cpools_transport_tendency_col(:,:,k) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(k))//'C_TNDNCY_VERT_TRANSPORT' + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' C tendency due to vertical transport' + call hist_addfld_decomp (fname=fieldname, units='gC/m^3/s', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + end do + + if ( nlevdecomp_full > 1 ) then + data2dptr => this%hr_vr_col(begc:endc,1:nlevsoi) + call hist_addfld2d (fname='HR_vr', units='gC/m^3/s', type2d='levsoi', & + avgflag='A', long_name='total vertically resolved heterotrophic respiration', & + ptr_col=data2dptr) + endif + + end if + + !------------------------------- + ! C13 flux variables - native to column + !------------------------------- + + if ( carbon_type == 'c13' ) then + + this%hr_col(begc:endc) = spval + call hist_addfld1d (fname='C13_HR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 total heterotrophic respiration', & + ptr_col=this%hr_col) + + this%lithr_col(begc:endc) = spval + call hist_addfld1d (fname='C13_LITTERC_HR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 fine root C litterfall to litter 3 C', & + ptr_col=this%lithr_col, default='inactive') + + this%somhr_col(begc:endc) = spval + call hist_addfld1d (fname='C13_SOILC_HR', units='gC13/m^2/s', & + avgflag='A', long_name='C13 soil organic matter heterotrophic respiration', & + ptr_col=this%somhr_col, default='inactive') + + + this%decomp_cascade_hr_col(begc:endc,:) = spval + this%decomp_cascade_hr_vr_col(begc:endc,:,:) = spval + this%decomp_cascade_ctransfer_col(begc:endc,:) = spval + this%decomp_cascade_ctransfer_vr_col(begc:endc,:,:) = spval + do l = 1, ndecomp_cascade_transitions + !-- HR fluxes (none from CWD) + if ( .not. decomp_cascade_con%is_cwd(decomp_cascade_con%cascade_donor_pool(l)) ) then + data2dptr => this%decomp_cascade_hr_vr_col(:,:,l) + ! check to see if there are multiple pathways that include respiration, and if so, note that in the history file + ii = 0 + do jj = 1, ndecomp_cascade_transitions + if ( decomp_cascade_con%cascade_donor_pool(jj) == decomp_cascade_con%cascade_donor_pool(l) ) ii = ii+1 + end do + if ( ii == 1 ) then + fieldname = 'C13_'//trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'_HR'//trim(vr_suffix) + else + fieldname = 'C13_'//trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'_HR_'//& + trim(decomp_cascade_con%decomp_pool_name_short(decomp_cascade_con%cascade_receiver_pool(l)))//& + trim(vr_suffix) + endif + longname = 'C13 Het. Resp. from '& + //trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l))) + call hist_addfld_decomp (fname=fieldname, units='gC13/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + !-- transfer fluxes (none from terminal pool, if present) + if ( decomp_cascade_con%cascade_receiver_pool(l) /= 0 ) then + data2dptr => this%decomp_cascade_ctransfer_vr_col(:,:,l) + fieldname = 'C13_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'C_TO_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l)))& + //'C'//trim(vr_suffix) + longname = 'C13 decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l)))& + //' C to '//& + trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_receiver_pool(l)))//' C' + call hist_addfld_decomp (fname=fieldname, units='gC13/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + end do + + end if + + !------------------------------- + ! C14 flux variables - native to column + !------------------------------- + + if (carbon_type == 'c14') then + + this%hr_col(begc:endc) = spval + call hist_addfld1d (fname='C14_HR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 total heterotrophic respiration', & + ptr_col=this%hr_col) + + this%lithr_col(begc:endc) = spval + call hist_addfld1d (fname='C14_LITTERC_HR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 litter carbon heterotrophic respiration', & + ptr_col=this%lithr_col, default='inactive') + + this%somhr_col(begc:endc) = spval + call hist_addfld1d (fname='C14_SOILC_HR', units='gC14/m^2/s', & + avgflag='A', long_name='C14 soil organic matter heterotrophic respiration', & + ptr_col=this%somhr_col, default='inactive') + + this%decomp_cascade_hr_col(begc:endc,:) = spval + this%decomp_cascade_hr_vr_col(begc:endc,:,:) = spval + this%decomp_cascade_ctransfer_col(begc:endc,:) = spval + this%decomp_cascade_ctransfer_vr_col(begc:endc,:,:) = spval + + do l = 1, ndecomp_cascade_transitions + !-- HR fluxes (none from CWD) + if ( .not. decomp_cascade_con%is_cwd(decomp_cascade_con%cascade_donor_pool(l)) ) then + data2dptr => this%decomp_cascade_hr_vr_col(:,:,l) + + ! check to see if there are multiple pathways that include respiration, and if so, note that in the history file + ii = 0 + do jj = 1, ndecomp_cascade_transitions + if ( decomp_cascade_con%cascade_donor_pool(jj) == decomp_cascade_con%cascade_donor_pool(l) ) ii = ii+1 + end do + if ( ii == 1 ) then + fieldname = 'C14_'//trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'_HR'//trim(vr_suffix) + else + fieldname = 'C14_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'_HR_'//& + trim(decomp_cascade_con%decomp_pool_name_short(decomp_cascade_con%cascade_receiver_pool(l)))& + //trim(vr_suffix) + endif + longname = 'C14 Het. Resp. from '& + //trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l))) + call hist_addfld_decomp (fname=fieldname, units='gC14/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + + !-- transfer fluxes (none from terminal pool, if present) + if ( decomp_cascade_con%cascade_receiver_pool(l) /= 0 ) then + data2dptr => this%decomp_cascade_ctransfer_vr_col(:,:,l) + + fieldname = 'C14_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'C_TO_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l)))& + //'C'//trim(vr_suffix) + longname = 'C14 decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l)))//& + ' C to '//trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_receiver_pool(l)))//' C' + call hist_addfld_decomp (fname=fieldname, units='gC14/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + end do + + end if + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + + this%fphr_col(c,nlevdecomp+1:nlevgrnd) = 0._r8 !used to be in ch4Mod + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%fphr_col(c,nlevdecomp+1:nlevgrnd) = 0._r8 + else if (lun%itype(l) == istdlak .and. allowlakeprod) then + this%fphr_col(c,:) = spval + else ! Inactive CH4 columns + this%fphr_col(c,:) = spval + end if + + end do + + if ( use_fates ) then + + call hist_addfld_decomp(fname='FATES_c_to_litr_lab_c', units='gC/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='litter labile carbon flux from FATES to BGC', & + ptr_col=this%FATES_c_to_litr_lab_c_col) + + call hist_addfld_decomp(fname='FATES_c_to_litr_cel_c', units='gC/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='litter celluluse carbon flux from FATES to BGC', & + ptr_col=this%FATES_c_to_litr_cel_c_col) + + call hist_addfld_decomp(fname='FATES_c_to_litr_lig_c', units='gC/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='litter lignin carbon flux from FATES to BGC', & + ptr_col=this%FATES_c_to_litr_lig_c_col) + + endif + + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !ARGUMENTS: + class(soilbiogeochem_carbonflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: c,l + integer :: num_special_col ! number of good values in special_col filter + integer :: special_col(bounds%endc-bounds%begc+1) ! special landunit filter - columns + !----------------------------------------------------------------------- + + ! Set column filters + + num_special_col = 0 + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + num_special_col = num_special_col + 1 + special_col(num_special_col) = c + end if + end do + + ! initialize fields for special filters + + call this%SetValues (num_column=num_special_col, filter_column=special_col, & + value_column=0._r8) + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart(this, bounds, ncid, flag) + ! + ! !USES: + use restUtilMod + use ncdio_pio + use clm_varctl, only : use_vertsoilc + ! + ! !ARGUMENTS: + class(soilbiogeochem_carbonflux_type) :: this + type(bounds_type) , intent(in) :: bounds + type(file_desc_t) , intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag !'read', 'write', 'define' + ! + ! local vars + real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays + real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays + logical :: readvar + !----------------------------------------------------------------------- + + ! + ! if FATES is enabled, need to restart the variables used to transfer from FATES to CLM as they + ! are persistent between daily FATES dynamics calls and half-hourly CLM timesteps + ! + if ( use_fates ) then + + if (use_vertsoilc) then + ptr2d => this%FATES_c_to_litr_lab_c_col + call restartvar(ncid=ncid, flag=flag, varname='FATES_c_to_litr_lab_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + + ptr2d => this%FATES_c_to_litr_cel_c_col + call restartvar(ncid=ncid, flag=flag, varname='FATES_c_to_litr_cel_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + + ptr2d => this%FATES_c_to_litr_lig_c_col + call restartvar(ncid=ncid, flag=flag, varname='FATES_c_to_litr_lig_c_col', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + + else + ptr1d => this%FATES_c_to_litr_lab_c_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname='FATES_c_to_litr_lab_c_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%FATES_c_to_litr_cel_c_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname='FATES_c_to_litr_cel_c_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + ptr1d => this%FATES_c_to_litr_lig_c_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname='FATES_c_to_litr_lig_c_col', xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + + end if + + end if + + end subroutine Restart + + !----------------------------------------------------------------------- + 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%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 + + ! total heterotrophic respiration (HR) + do fc = 1,num_soilc + c = filter_soilc(fc) + + this%hr_col(c) = & + this%lithr_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_orig_files/SoilBiogeochemCarbonStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemCarbonStateType.F90 new file mode 100644 index 000000000..75a15626c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemCarbonStateType.F90 @@ -0,0 +1,1740 @@ +module SoilBiogeochemCarbonStateType + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevcan + use clm_varpar , only : nlevdecomp_full, nlevdecomp, nlevsoi + use clm_varcon , only : spval, ispval, dzsoi_decomp, zisoi, zsoi, c3_r2 + use clm_varctl , only : iulog, use_vertsoilc, spinup_state, use_fates, use_soil_matrixcn + use landunit_varcon , only : istcrop, istsoil + use abortutils , only : endrun + use spmdMod , only : masterproc + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use LandunitType , only : lun + use ColumnType , only : col + use GridcellType , only : grc + use SoilBiogeochemStateType , only : get_spinup_latitude_term + use SPMMod , only : sparse_matrix_type, vector_type + ! + ! !PUBLIC TYPES: + implicit none + private + ! + 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 :: Init + procedure , public :: SetValues + procedure , public :: Restart + procedure , public :: Summary + procedure , public :: SetTotVgCThresh + procedure , public :: DynamicColumnAdjustments ! adjust state variables when column areas change + procedure , private :: InitAllocate + procedure , private :: InitHistory + procedure , private :: InitCold + + + end type soilbiogeochem_carbonstate_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, carbon_type, ratio, c12_soilbiogeochem_carbonstate_inst) + + class(soilbiogeochem_carbonstate_type) :: this + type(bounds_type) , intent(in) :: bounds + character(len=3) , intent(in) :: carbon_type + real(r8) , intent(in) :: ratio + type(soilbiogeochem_carbonstate_type) , intent(in), optional :: c12_soilbiogeochem_carbonstate_inst + + this%totvegcthresh = nan + call this%InitAllocate ( bounds) + call this%InitHistory ( bounds, carbon_type ) + if (present(c12_soilbiogeochem_carbonstate_inst)) then + call this%InitCold ( bounds, ratio, c12_soilbiogeochem_carbonstate_inst ) + else + call this%InitCold ( bounds, ratio) + end if + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !ARGUMENTS: + class (soilbiogeochem_carbonstate_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc,endc + !------------------------------------------------------------------------ + + 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 + 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) + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds, carbon_type) + ! + ! !USES: + use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + ! + ! !ARGUMENTS: + class (soilbiogeochem_carbonstate_type) :: this + type(bounds_type) , intent(in) :: bounds + character(len=3) , intent(in) :: carbon_type + ! + ! !LOCAL VARIABLES: + integer :: l + integer :: begc ,endc + character(24) :: fieldname + character(100) :: longname + real(r8), pointer :: data1dptr(:) ! temp. pointer for slicing larger arrays + real(r8), pointer :: data2dptr(:,:) ! temp. pointer for slicing larger arrays + !------------------------------------------------------------------------ + + begc = bounds%begc; endc = bounds%endc + + !------------------------------- + ! C12 state variables - column + !------------------------------- + + if (carbon_type == 'c12') then + + if ( nlevdecomp_full > 1 ) then + this%decomp_soilc_vr_col(begc:endc,:) = spval + call hist_addfld2d (fname='SOILC_vr', units='gC/m^3', type2d='levsoi', & + avgflag='A', long_name='SOIL C (vertically resolved)', & + ptr_col=this%decomp_soilc_vr_col) + end if + + this%decomp_cpools_col(begc:endc,:) = spval + do l = 1, ndecomp_pools + if ( nlevdecomp_full > 1 ) then + data2dptr => this%decomp_cpools_vr_col(:,1:nlevsoi,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_vr' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' C (vertically resolved)' + call hist_addfld2d (fname=fieldname, units='gC/m^3', type2d='levsoi', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr) + endif + + data1dptr => this%decomp_cpools_col(:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'C' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' C' + call hist_addfld1d (fname=fieldname, units='gC/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr) + + if ( nlevdecomp_full > 1 ) then + data1dptr => this%decomp_cpools_1m_col(:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_1m' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' C to 1 meter' + call hist_addfld1d (fname=fieldname, units='gC/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + endif + end do + + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_col(begc:endc,:) = spval + do l = 1, ndecomp_pools + if ( nlevdecomp_full > 1 ) then + data2dptr => this%matrix_cap_decomp_cpools_vr_col(:,1:nlevsoi,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_Cap_vr' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' C capacity (vertically resolved)' + call hist_addfld2d (fname=fieldname, units='gC/m^3', type2d='levsoi', & + avgflag='I', long_name=longname, & + ptr_col=data2dptr) + endif + + if ( nlevdecomp_full .eq. 1)then + data1dptr => this%matrix_cap_decomp_cpools_col(:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_Cap' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' C capacity' + call hist_addfld1d (fname=fieldname, units='gC/m^2', & + avgflag='I', long_name=longname, & + ptr_col=data1dptr) + end if + + end do + + end if + + this%totlitc_col(begc:endc) = spval + call hist_addfld1d (fname='TOTLITC', units='gC/m^2', & + avgflag='A', long_name='total litter carbon', & + ptr_col=this%totlitc_col) + + this%totsomc_col(begc:endc) = spval + call hist_addfld1d (fname='TOTSOMC', units='gC/m^2', & + avgflag='A', long_name='total soil organic matter carbon', & + ptr_col=this%totsomc_col) + + if ( nlevdecomp_full > 1 ) then + this%totlitc_1m_col(begc:endc) = spval + call hist_addfld1d (fname='TOTLITC_1m', units='gC/m^2', & + avgflag='A', long_name='total litter carbon to 1 meter depth', & + ptr_col=this%totlitc_1m_col) + end if + + if ( nlevdecomp_full > 1 ) then + this%totsomc_1m_col(begc:endc) = spval + call hist_addfld1d (fname='TOTSOMC_1m', units='gC/m^2', & + avgflag='A', long_name='total soil organic matter carbon to 1 meter depth', & + ptr_col=this%totsomc_1m_col) + end if + + this%ctrunc_col(begc:endc) = spval + call hist_addfld1d (fname='COL_CTRUNC', units='gC/m^2', & + avgflag='A', long_name='column-level sink for C truncation', & + ptr_col=this%ctrunc_col, default='inactive') + + this%dyn_cbal_adjustments_col(begc:endc) = spval + call hist_addfld1d (fname='DYN_COL_SOIL_ADJUSTMENTS_C', units='gC/m^2', & + avgflag='SUM', & + long_name='Adjustments in soil carbon due to dynamic column areas; & + &only makes sense at the column level: should not be averaged to gridcell', & + ptr_col=this%dyn_cbal_adjustments_col, default='inactive') + + end if + + !------------------------------- + ! C13 state variables - column + !------------------------------- + + if ( carbon_type == 'c13' ) then + + if ( nlevdecomp_full > 1 ) then + this%decomp_soilc_vr_col(begc:endc,:) = spval + call hist_addfld2d (fname='C13_SOILC_vr', units='gC13/m^3', type2d='levsoi', & + avgflag='A', long_name='C13 SOIL C (vertically resolved)', & + ptr_col=this%decomp_soilc_vr_col, default='inactive') + end if + + this%decomp_cpools_vr_col(begc:endc,:,:) = spval + do l = 1, ndecomp_pools + if ( nlevdecomp_full > 1 ) then + data2dptr => this%decomp_cpools_vr_col(:,1:nlevsoi,l) + fieldname = 'C13_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_vr' + longname = 'C13 '//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C (vertically resolved)' + call hist_addfld2d (fname=fieldname, units='gC13/m^3', type2d='levsoi', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + + data1dptr => this%decomp_cpools_col(:,l) + fieldname = 'C13_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C' + longname = 'C13 '//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C' + call hist_addfld1d (fname=fieldname, units='gC13/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + end do + + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_vr_col(begc:endc,:,:) = spval + do l = 1, ndecomp_pools + if ( nlevdecomp_full > 1 ) then + data2dptr => this%matrix_cap_decomp_cpools_vr_col(:,1:nlevsoi,l) + fieldname = 'C13_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_Cap_vr' + longname = 'C13 '//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C capacity (vertically resolved)' + call hist_addfld2d (fname=fieldname, units='gC13/m^3', type2d='levsoi', & + avgflag='I', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + + if ( nlevdecomp_full .eq. 1)then + data1dptr => this%matrix_cap_decomp_cpools_col(:,l) + fieldname = 'C13_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_Cap' + longname = 'C13 '//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C capacity' + call hist_addfld1d (fname=fieldname, units='gC13/m^2', & + avgflag='I', long_name=longname, & + ptr_col=data1dptr) + end if + end do + end if + + this%totlitc_col(begc:endc) = spval + call hist_addfld1d (fname='C13_TOTLITC', units='gC13/m^2', & + avgflag='A', long_name='C13 total litter carbon', & + ptr_col=this%totlitc_col) + + this%totsomc_col(begc:endc) = spval + call hist_addfld1d (fname='C13_TOTSOMC', units='gC13/m^2', & + avgflag='A', long_name='C13 total soil organic matter carbon', & + ptr_col=this%totsomc_col) + + if ( nlevdecomp_full > 1 ) then + this%totlitc_1m_col(begc:endc) = spval + call hist_addfld1d (fname='C13_TOTLITC_1m', units='gC13/m^2', & + avgflag='A', long_name='C13 total litter carbon to 1 meter', & + ptr_col=this%totlitc_1m_col, default='inactive') + end if + + if ( nlevdecomp_full > 1 ) then + this%totsomc_1m_col(begc:endc) = spval + call hist_addfld1d (fname='C13_TOTSOMC_1m', units='gC13/m^2', & + avgflag='A', long_name='C13 total soil organic matter carbon to 1 meter', & + ptr_col=this%totsomc_1m_col, default='inactive') + endif + + this%ctrunc_col(begc:endc) = spval + call hist_addfld1d (fname='C13_COL_CTRUNC', units='gC13/m^2', & + avgflag='A', long_name='C13 column-level sink for C truncation', & + ptr_col=this%ctrunc_col, default='inactive') + + this%dyn_cbal_adjustments_col(begc:endc) = spval + call hist_addfld1d (fname='C13_DYN_COL_SOIL_ADJUSTMENTS_C', units='gC13/m^2', & + avgflag='SUM', & + long_name='C13 adjustments in soil carbon due to dynamic column areas; & + &only makes sense at the column level: should not be averaged to gridcell', & + ptr_col=this%dyn_cbal_adjustments_col, default='inactive') + endif + + !------------------------------- + ! C14 state variables - column + !------------------------------- + + if ( carbon_type == 'c14' ) then + + if ( nlevdecomp_full > 1 ) then + this%decomp_soilc_vr_col(begc:endc,:) = spval + call hist_addfld2d (fname='C14_SOILC_vr', units='gC14/m^3', type2d='levsoi', & + avgflag='A', long_name='C14 SOIL C (vertically resolved)', & + ptr_col=this%decomp_soilc_vr_col) + end if + + this%decomp_cpools_vr_col(begc:endc,:,:) = spval + do l = 1, ndecomp_pools + if ( nlevdecomp_full > 1 ) then + data2dptr => this%decomp_cpools_vr_col(:,1:nlevsoi,l) + fieldname = 'C14_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_vr' + longname = 'C14 '//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C (vertically resolved)' + call hist_addfld2d (fname=fieldname, units='gC14/m^3', type2d='levsoi', & + avgflag='A', long_name=longname, ptr_col=data2dptr, default='inactive') + endif + + data1dptr => this%decomp_cpools_col(:,l) + fieldname = 'C14_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C' + longname = 'C14 '//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C' + call hist_addfld1d (fname=fieldname, units='gC14/m^2', & + avgflag='A', long_name=longname, ptr_col=data1dptr, default='inactive') + + if ( nlevdecomp_full > 1 ) then + data1dptr => this%decomp_cpools_1m_col(:,l) + fieldname = 'C14_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_1m' + longname = 'C14_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C to 1 meter' + call hist_addfld1d (fname=fieldname, units='gC/m^2', & + avgflag='A', long_name=longname, ptr_col=data1dptr, default='inactive') + endif + end do + + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_vr_col(begc:endc,:,:) = spval + do l = 1, ndecomp_pools + if ( nlevdecomp_full > 1 ) then + data2dptr => this%matrix_cap_decomp_cpools_vr_col(:,1:nlevsoi,l) + fieldname = 'C14_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_Cap_vr' + longname = 'C14 '//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C capacity (vertically resolved)' + call hist_addfld2d (fname=fieldname, units='gC14/m^3', type2d='levsoi', & + avgflag='I', long_name=longname, ptr_col=data2dptr, default='inactive') + endif + + if ( nlevdecomp_full .eq. 1)then + data1dptr => this%matrix_cap_decomp_cpools_col(:,l) + fieldname = 'C14_'//trim(decomp_cascade_con%decomp_pool_name_history(l))//'C_Cap' + longname = 'C14 '//trim(decomp_cascade_con%decomp_pool_name_history(l))//' C capacity' + call hist_addfld1d (fname=fieldname, units='gC14/m^2', & + avgflag='I', long_name=longname, ptr_col=data1dptr) + end if + end do + end if + + this%totlitc_col(begc:endc) = spval + call hist_addfld1d (fname='C14_TOTLITC', units='gC14/m^2', & + avgflag='A', long_name='C14 total litter carbon', & + ptr_col=this%totlitc_col) + + this%totsomc_col(begc:endc) = spval + call hist_addfld1d (fname='C14_TOTSOMC', units='gC14/m^2', & + avgflag='A', long_name='C14 total soil organic matter carbon', & + ptr_col=this%totsomc_col) + + if ( nlevdecomp_full > 1 ) then + this%totlitc_1m_col(begc:endc) = spval + call hist_addfld1d (fname='C14_TOTLITC_1m', units='gC14/m^2', & + avgflag='A', long_name='C14 total litter carbon to 1 meter', & + ptr_col=this%totlitc_1m_col, default='inactive') + + this%totsomc_1m_col(begc:endc) = spval + call hist_addfld1d (fname='C14_TOTSOMC_1m', units='gC14/m^2', & + avgflag='A', long_name='C14 total soil organic matter carbon to 1 meter', & + ptr_col=this%totsomc_1m_col, default='inactive') + endif + + this%ctrunc_col(begc:endc) = spval + call hist_addfld1d (fname='C14_COL_CTRUNC', units='gC14/m^2', & + avgflag='A', long_name='C14 column-level sink for C truncation', & + ptr_col=this%ctrunc_col, default='inactive') + + this%dyn_cbal_adjustments_col(begc:endc) = spval + call hist_addfld1d (fname='C14_DYN_COL_SOIL_ADJUSTMENTS_C', units='gC14/m^2', & + avgflag='SUM', & + long_name='C14 adjustments in soil carbon due to dynamic column areas; & + &only makes sense at the column level: should not be averaged to gridcell', & + ptr_col=this%dyn_cbal_adjustments_col, default='inactive') + endif + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds, ratio, c12_soilbiogeochem_carbonstate_inst) + ! + ! !DESCRIPTION: + ! Initializes time varying variables used only in coupled carbon-nitrogen mode (CN): + ! + ! !USES: + ! + ! !ARGUMENTS: + class(soilbiogeochem_carbonstate_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: ratio + type(soilbiogeochem_carbonstate_type), intent(in), optional :: c12_soilbiogeochem_carbonstate_inst + ! + ! !LOCAL VARIABLES: + integer :: p,c,l,j,k + integer :: fc ! filter index + integer :: num_special_col ! number of good values in special_col filter + integer :: special_col(bounds%endc-bounds%begc+1) ! special landunit filter - columns + !----------------------------------------------------------------------- + + ! initialize column-level variables + + do c = bounds%begc, bounds%endc + l = col%landunit(c) +!matrix-spinup + if(use_soil_matrixcn)then + this%in_acc(c,:) = 0._r8 +! this%tran_acc(c,:,:) = 0._r8 + this%AKXcacc%M(c,:) = 0._r8 + end if + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + if (.not. present(c12_soilbiogeochem_carbonstate_inst)) then !c12 + + do j = 1, nlevdecomp + do k = 1, ndecomp_pools + if (zsoi(j) < decomp_cascade_con%initial_stock_soildepth ) then !! only initialize upper soil column + this%decomp_cpools_vr_col(c,j,k) = decomp_cascade_con%initial_stock(k) + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_vr_col(c,j,k) = decomp_cascade_con%initial_stock(k) + end if + else + this%decomp_cpools_vr_col(c,j,k) = 0._r8 + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_vr_col(c,j,k) = 0._r8 + end if + endif + end do + this%ctrunc_vr_col(c,j) = 0._r8 + end do + if ( nlevdecomp > 1 ) then + do j = nlevdecomp+1, nlevdecomp_full + do k = 1, ndecomp_pools + this%decomp_cpools_vr_col(c,j,k) = 0._r8 + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_vr_col(c,j,k) = 0._r8 + end if + end do + this%ctrunc_vr_col(c,j) = 0._r8 + end do + end if + this%decomp_cpools_col(c,1:ndecomp_pools) = decomp_cascade_con%initial_stock(1:ndecomp_pools) + this%decomp_cpools_1m_col(c,1:ndecomp_pools) = decomp_cascade_con%initial_stock(1:ndecomp_pools) + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_col(c,1:ndecomp_pools) = decomp_cascade_con%initial_stock(1:ndecomp_pools) + end if + + else + + do j = 1, nlevdecomp + do k = 1, ndecomp_pools + this%decomp_cpools_vr_col(c,j,k) = c12_soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(c,j,k) * ratio + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_vr_col(c,j,k) = c12_soilbiogeochem_carbonstate_inst%matrix_cap_decomp_cpools_vr_col(c,j,k) * ratio + end if + end do + this%ctrunc_vr_col(c,j) = c12_soilbiogeochem_carbonstate_inst%ctrunc_vr_col(c,j) * ratio + end do + if ( nlevdecomp > 1 ) then + do j = nlevdecomp+1, nlevdecomp_full + do k = 1, ndecomp_pools + this%decomp_cpools_vr_col(c,j,k) = 0._r8 + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_vr_col(c,j,k) = 0._r8 + end if + end do + this%ctrunc_vr_col(c,j) = 0._r8 + end do + end if + do k = 1, ndecomp_pools + this%decomp_cpools_col(c,k) = c12_soilbiogeochem_carbonstate_inst%decomp_cpools_col(c,k) * ratio + this%decomp_cpools_1m_col(c,k) = c12_soilbiogeochem_carbonstate_inst%decomp_cpools_1m_col(c,k) * ratio + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_col(c,k) = c12_soilbiogeochem_carbonstate_inst%matrix_cap_decomp_cpools_col(c,k) * ratio + end if + end do + + endif + if(use_soil_matrixcn)then + do j = 1, nlevdecomp_full + do k = 1, ndecomp_pools + this%in_acc_2d(c,j,k) = 0._r8 + this%vert_up_tran_acc(c,j,k) = 0._r8 + this%vert_down_tran_acc(c,j,k) = 0._r8 + this%exit_acc(c,j,k) = 0._r8 + this%decomp0_cpools_vr_col(c,j,k) = max(this%decomp_cpools_vr_col(c,j,k),1.e-30_r8) + this%decomp_cpools_vr_SASUsave_col(c,j,k) = 0._r8 + end do + do k = 1, ndecomp_cascade_transitions + this%hori_tran_acc(c,j,k) = 0._r8 + end do + end do + do j = 1,decomp_cascade_con%n_all_entries + this%AKXcacc%M(c,j) = 0._r8 + end do + end if + end if + + if ( .not. use_fates ) then + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + if (present(c12_soilbiogeochem_carbonstate_inst)) then + this%cwdc_col(c) = c12_soilbiogeochem_carbonstate_inst%cwdc_col(c) * ratio + else + this%cwdc_col(c) = 0._r8 + end if + this%ctrunc_col(c) = 0._r8 + this%totlitc_col(c) = 0._r8 + this%totsomc_col(c) = 0._r8 + this%totlitc_1m_col(c) = 0._r8 + this%totsomc_1m_col(c) = 0._r8 + end if + end if + end do + + ! now loop through special filters and explicitly set the variables that + ! have to be in place for biogeophysics + + ! Set column filters + + num_special_col = 0 + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + num_special_col = num_special_col + 1 + special_col(num_special_col) = c + end if + end do + + ! initialize fields for special filters + call this%SetValues (num_column=num_special_col, filter_column=special_col, value_column=0._r8) + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart ( this, bounds, ncid, flag, carbon_type, totvegc_col, c12_soilbiogeochem_carbonstate_inst ) + ! + ! !DESCRIPTION: + ! Read/write CN restart data for carbon state + ! + ! !USES: + use shr_infnan_mod , only : isnan => shr_infnan_isnan, nan => shr_infnan_nan, assignment(=) + use clm_time_manager , only : is_restart, get_nstep + use shr_const_mod , only : SHR_CONST_PDB + use clm_varcon , only : c14ratio + use restUtilMod + use ncdio_pio + ! + ! !ARGUMENTS: + class (soilbiogeochem_carbonstate_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' + character(len=3) , intent(in) :: carbon_type ! 'c12' or 'c13' or 'c14' + real(r8) , intent(in) :: totvegc_col(bounds%begc:bounds%endc) ! (gC/m2) total + ! vegetation carbon + type(soilbiogeochem_carbonstate_type) , intent(in), optional :: c12_soilbiogeochem_carbonstate_inst + + ! + ! !LOCAL VARIABLES: + integer :: i,j,k,l,c,fc + real(r8) :: m ! multiplier for the exit_spinup code + real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays + real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays + character(len=128) :: varname ! temporary + logical :: readvar + integer :: idata + logical :: exit_spinup = .false. + logical :: enter_spinup = .false. + logical :: found = .false. + ! flags for comparing the model and restart decomposition cascades + integer :: decomp_cascade_state, restart_file_decomp_cascade_state + integer :: i_decomp,j_decomp,i_lev,j_lev + !------------------------------------------------------------------------ + + if (carbon_type == 'c12') then + + do k = 1, ndecomp_pools + varname=trim(decomp_cascade_con%decomp_pool_name_restart(k))//'c' + if (use_vertsoilc) then + ptr2d => this%decomp_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%decomp_cpools_vr_col(:,1,k) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname=varname, xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + if (flag=='read' .and. .not. readvar) then + call endrun(msg='ERROR:: '//trim(varname)//' is required on an initialization dataset'//& + errMsg(sourcefile, __LINE__)) + end if + end do + + if (use_soil_matrixcn)then + do k = 1, ndecomp_pools + varname=trim(decomp_cascade_con%decomp_pool_name_restart(k))//'c' + if (use_vertsoilc) then + ptr2d => this%matrix_cap_decomp_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_Cap_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%decomp0_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"0_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%matrix_cap_decomp_cpools_vr_col(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_Cap", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%decomp0_cpools_vr_col(:,1,k) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"0", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + end do + if(flag=='write')then + do i = 1,ndecomp_pools + do j = 1,nlevdecomp + this%in_acc_2d(:,j,i) = this%in_acc(:,j+(i-1)*nlevdecomp) + end do + end do + do i = 1,decomp_cascade_con%n_all_entries + found = .false. + j_lev = mod(decomp_cascade_con%all_j(i) - 1,nlevdecomp) + 1 + j_decomp = (decomp_cascade_con%all_j(i) - j_lev)/nlevdecomp + 1 + i_lev = mod(decomp_cascade_con%all_i(i) - 1,nlevdecomp) + 1 + i_decomp = (decomp_cascade_con%all_i(i) - i_lev)/nlevdecomp + 1 + if(i_decomp .eq. j_decomp .and. j_lev - i_lev .eq. 1)then + this%vert_up_tran_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev - j_lev .eq. 1)then + this%vert_down_tran_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev .eq. j_lev)then + this%exit_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + do k=1,ndecomp_cascade_transitions + if(i_decomp .ne. j_decomp .and. i_lev .eq. j_lev .and. & + i_decomp .eq. decomp_cascade_con%cascade_receiver_pool(k) .and. & + j_decomp .eq. decomp_cascade_con%cascade_donor_pool(k) .and. .not. found)then + this%hori_tran_acc(:,i_lev,k) = this%AKXcacc%M(:,i) + found = .true. + end if + end do + end if + end if + end if + if(.not. found) write(iulog,*) 'Error in storing matrix restart variables',i + end do + end if + do k = 1, ndecomp_pools + varname=trim(decomp_cascade_con%decomp_pool_name_restart(k))//'c' + if (use_vertsoilc) then + ptr2d => this%in_acc_2d(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_input_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%vert_up_tran_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_up_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%vert_down_tran_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_down_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%exit_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_exit_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%in_acc_2d(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_input_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%vert_up_tran_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_up_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%vert_down_tran_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_down_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%exit_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_exit_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + end do + do i = 1, ndecomp_cascade_transitions + varname=trim(decomp_cascade_con%cascade_step_name(i))//'c' + if(use_vertsoilc) then + ptr2d => this%hori_tran_acc(:,:,i) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_hori_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%hori_tran_acc(:,1,i) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_hori_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + end do + if(flag=='read')then + do i = 1,ndecomp_pools + do j = 1,nlevdecomp + this%in_acc(:,j+(i-1)*nlevdecomp) = this%in_acc_2d(:,j,i) + end do + end do + do i = 1,decomp_cascade_con%n_all_entries + found = .false. + j_lev = mod(decomp_cascade_con%all_j(i) - 1,nlevdecomp) + 1 + j_decomp = (decomp_cascade_con%all_j(i) - j_lev)/nlevdecomp + 1 + i_lev = mod(decomp_cascade_con%all_i(i) - 1,nlevdecomp) + 1 + i_decomp = (decomp_cascade_con%all_i(i) - i_lev)/nlevdecomp + 1 + if(i_decomp .eq. j_decomp .and. j_lev - i_lev .eq. 1)then + this%AKXcacc%M(:,i) = this%vert_up_tran_acc(:,i_lev,i_decomp) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev - j_lev .eq. 1)then + this%AKXcacc%M(:,i) = this%vert_down_tran_acc(:,i_lev,i_decomp) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev .eq. j_lev)then + this%AKXcacc%M(:,i) = this%exit_acc(:,i_lev,i_decomp) + found = .true. + else + do k=1,ndecomp_cascade_transitions + if(i_decomp .ne. j_decomp .and. i_lev .eq. j_lev .and. & + i_decomp .eq. decomp_cascade_con%cascade_receiver_pool(k) .and. & + j_decomp .eq. decomp_cascade_con%cascade_donor_pool(k) .and. .not. found)then + this%AKXcacc%M(:,i) = this%hori_tran_acc(:,i_lev,k) + found = .true. + end if + end do + end if + end if + end if + if(.not. found) write(iulog,*) 'Error in storing matrix restart variables',i + end do + end if + end if + + if (use_vertsoilc) then + ptr2d => this%ctrunc_vr_col + call restartvar(ncid=ncid, flag=flag, varname='col_ctrunc_vr', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%ctrunc_vr_col(:,1) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname='col_ctrunc', xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + if (flag=='read' .and. .not. readvar) then + call endrun(msg='ERROR:: '//trim(varname)//' is required on an initialization dataset'//& + errMsg(sourcefile, __LINE__)) + end if + + end if + + !-------------------------------- + ! C13 column carbon state variables + !-------------------------------- + + if ( carbon_type == 'c13' ) then + + do k = 1, ndecomp_pools + varname = trim(decomp_cascade_con%decomp_pool_name_restart(k))//'c_13' + if (use_vertsoilc) then + ptr2d => this%decomp_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + if(use_soil_matrixcn)then + ptr2d => this%matrix_cap_decomp_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_Cap_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%decomp0_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"0_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + end if + else + ptr1d => this%decomp_cpools_vr_col(:,1,k) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname=varname, xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + if(use_soil_matrixcn)then + ptr1d => this%matrix_cap_decomp_cpools_vr_col(:,1,k) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//'_Cap', xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + ptr1d => this%decomp0_cpools_vr_col(:,1,k) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"0", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + end if + if (flag=='read' .and. .not. readvar) then + write(iulog,*) 'initializing soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col' & + // ' with atmospheric c13 value for: '//trim(varname) + do i = bounds%begc,bounds%endc + do j = 1, nlevdecomp + if (this%decomp_cpools_vr_col(i,j,k) /= spval .and. .not. isnan(this%decomp_cpools_vr_col(i,j,k)) ) then + this%decomp_cpools_vr_col(i,j,k) = c12_soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(i,j,k) * c3_r2 + endif + if(use_soil_matrixcn)then + if (this%matrix_cap_decomp_cpools_vr_col(i,j,k) /= spval .and. .not. isnan(this%matrix_cap_decomp_cpools_vr_col(i,j,k)) ) then + this%matrix_cap_decomp_cpools_vr_col(i,j,k) = c12_soilbiogeochem_carbonstate_inst%matrix_cap_decomp_cpools_vr_col(i,j,k) * c3_r2 + endif + end if + end do + end do + end if + end do + + if (use_soil_matrixcn)then + if(flag=='write')then + do i = 1,ndecomp_pools + do j = 1,nlevdecomp + this%in_acc_2d(:,j,i) = this%in_acc(:,j+(i-1)*nlevdecomp) + end do + end do + do i = 1,decomp_cascade_con%n_all_entries + found = .false. + j_lev = mod(decomp_cascade_con%all_j(i) - 1,nlevdecomp) + 1 + j_decomp = (decomp_cascade_con%all_j(i) - j_lev)/nlevdecomp + 1 + i_lev = mod(decomp_cascade_con%all_i(i) - 1,nlevdecomp) + 1 + i_decomp = (decomp_cascade_con%all_i(i) - i_lev)/nlevdecomp + 1 + if(i_decomp .eq. j_decomp .and. j_lev - i_lev .eq. 1)then + this%vert_up_tran_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev - j_lev .eq. 1)then + this%vert_down_tran_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev .eq. j_lev)then + this%exit_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + do k=1,ndecomp_cascade_transitions + if(i_decomp .ne. j_decomp .and. i_lev .eq. j_lev .and. & + i_decomp .eq. decomp_cascade_con%cascade_receiver_pool(k) .and. & + j_decomp .eq. decomp_cascade_con%cascade_donor_pool(k) .and. .not. found)then + this%hori_tran_acc(:,i_lev,k) = this%AKXcacc%M(:,i) + found = .true. + end if + end do + end if + end if + end if + if(.not. found) write(iulog,*) 'Error in storing matrix restart variables',i + end do + end if + do k = 1, ndecomp_pools + varname=trim(decomp_cascade_con%decomp_pool_name_restart(k))//'c_13' + if (use_vertsoilc) then + ptr2d => this%in_acc_2d(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_input_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%vert_up_tran_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_up_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%vert_down_tran_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_down_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%exit_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_exit_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%in_acc_2d(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_input_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%vert_up_tran_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_up_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%vert_down_tran_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_down_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%exit_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_exit_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + end do + do i = 1, ndecomp_cascade_transitions + varname=trim(decomp_cascade_con%cascade_step_name(i))//'c_13' + if(use_vertsoilc) then + ptr2d => this%hori_tran_acc(:,:,i) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_hori_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%hori_tran_acc(:,1,i) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_hori_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + end do + if(flag=='read')then + do i = 1,ndecomp_pools + do j = 1,nlevdecomp + this%in_acc(:,j+(i-1)*nlevdecomp) = this%in_acc_2d(:,j,i) + end do + end do + do i = 1,decomp_cascade_con%n_all_entries + found = .false. + j_lev = mod(decomp_cascade_con%all_j(i) - 1,nlevdecomp) + 1 + j_decomp = (decomp_cascade_con%all_j(i) - j_lev)/nlevdecomp + 1 + i_lev = mod(decomp_cascade_con%all_i(i) - 1,nlevdecomp) + 1 + i_decomp = (decomp_cascade_con%all_i(i) - i_lev)/nlevdecomp + 1 + if(i_decomp .eq. j_decomp .and. j_lev - i_lev .eq. 1)then + this%AKXcacc%M(:,i) = this%vert_up_tran_acc(:,i_lev,i_decomp) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev - j_lev .eq. 1)then + this%AKXcacc%M(:,i) = this%vert_down_tran_acc(:,i_lev,i_decomp) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev .eq. j_lev)then + this%AKXcacc%M(:,i) = this%exit_acc(:,i_lev,i_decomp) + found = .true. + else + do k=1,ndecomp_cascade_transitions + if(i_decomp .ne. j_decomp .and. i_lev .eq. j_lev .and. & + i_decomp .eq. decomp_cascade_con%cascade_receiver_pool(k) .and. & + j_decomp .eq. decomp_cascade_con%cascade_donor_pool(k) .and. .not. found)then + this%AKXcacc%M(:,i) = this%hori_tran_acc(:,i_lev,k) + found = .true. + end if + end do + end if + end if + end if + if(.not. found) write(iulog,*) 'Error in storing matrix restart variables',i + end do + end if + end if + + if (use_vertsoilc) then + ptr2d => this%ctrunc_vr_col + call restartvar(ncid=ncid, flag=flag, varname="col_ctrunc_c13_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%ctrunc_vr_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname="col_ctrunc_c13", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + end if + + !-------------------------------- + ! C14 column carbon state variables + !-------------------------------- + + if ( carbon_type == 'c14' ) then + + do k = 1, ndecomp_pools + varname = trim(decomp_cascade_con%decomp_pool_name_restart(k))//'c_14' + if (use_vertsoilc) then + ptr2d => this%decomp_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + if(use_soil_matrixcn)then + ptr2d => this%matrix_cap_decomp_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_Cap_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%decomp0_cpools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"0_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + end if + else + ptr1d => this%decomp_cpools_vr_col(:,1,k) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname=varname, xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + if(use_soil_matrixcn)then + ptr1d => this%matrix_cap_decomp_cpools_vr_col(:,1,k) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_Cap", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + ptr1d => this%decomp0_cpools_vr_col(:,1,k) ! nlevdecomp = 1; so treat as 1D variable + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"0", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + end if + if (flag=='read' .and. .not. readvar) then + write(iulog,*) 'initializing soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col with atmospheric c14 value for: '//& + trim(varname) + do i = bounds%begc,bounds%endc + do j = 1, nlevdecomp + if (this%decomp_cpools_vr_col(i,j,k) /= spval .and. .not. isnan(this%decomp_cpools_vr_col(i,j,k)) ) then + this%decomp_cpools_vr_col(i,j,k) = c12_soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(i,j,k) * c3_r2 + endif + if(use_soil_matrixcn)then + if (this%matrix_cap_decomp_cpools_vr_col(i,j,k) /= spval .and. .not. isnan(this%matrix_cap_decomp_cpools_vr_col(i,j,k)) ) then + this%matrix_cap_decomp_cpools_vr_col(i,j,k) = c12_soilbiogeochem_carbonstate_inst%matrix_cap_decomp_cpools_vr_col(i,j,k) * c3_r2 + endif + end if + end do + end do + end if + end do + + if (use_soil_matrixcn)then + if(flag=='write')then + do i = 1,ndecomp_pools + do j = 1,nlevdecomp + this%in_acc_2d(:,j,i) = this%in_acc(:,j+(i-1)*nlevdecomp) + end do + end do + do i = 1,decomp_cascade_con%n_all_entries + found = .false. + j_lev = mod(decomp_cascade_con%all_j(i) - 1,nlevdecomp) + 1 + j_decomp = (decomp_cascade_con%all_j(i) - j_lev)/nlevdecomp + 1 + i_lev = mod(decomp_cascade_con%all_i(i) - 1,nlevdecomp) + 1 + i_decomp = (decomp_cascade_con%all_i(i) - i_lev)/nlevdecomp + 1 + if(i_decomp .eq. j_decomp .and. j_lev - i_lev .eq. 1)then + this%vert_up_tran_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev - j_lev .eq. 1)then + this%vert_down_tran_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev .eq. j_lev)then + this%exit_acc(:,i_lev,i_decomp) = this%AKXcacc%M(:,i) + found = .true. + else + do k=1,ndecomp_cascade_transitions + if(i_decomp .ne. j_decomp .and. i_lev .eq. j_lev .and. & + i_decomp .eq. decomp_cascade_con%cascade_receiver_pool(k) .and. & + j_decomp .eq. decomp_cascade_con%cascade_donor_pool(k) .and. .not. found)then + this%hori_tran_acc(:,i_lev,k) = this%AKXcacc%M(:,i) + found = .true. + end if + end do + end if + end if + end if + if(.not. found) write(iulog,*) 'Error in storing matrix restart variables',i + end do + end if + do k = 1, ndecomp_pools + varname=trim(decomp_cascade_con%decomp_pool_name_restart(k))//'c_14' + if (use_vertsoilc) then + ptr2d => this%in_acc_2d(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_input_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%vert_up_tran_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_up_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%vert_down_tran_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_down_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%exit_acc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_exit_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%in_acc_2d(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_input_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%vert_up_tran_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_up_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%vert_down_tran_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_down_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%exit_acc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_exit_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + end do + do i = 1, ndecomp_cascade_transitions + varname=trim(decomp_cascade_con%cascade_step_name(i))//'c_14' + if(use_vertsoilc) then + ptr2d => this%hori_tran_acc(:,:,i) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_hori_tran_acc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%hori_tran_acc(:,1,i) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_hori_tran_acc", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + end do + if(flag=='read')then + do i = 1,ndecomp_pools + do j = 1,nlevdecomp + this%in_acc(:,j+(i-1)*nlevdecomp) = this%in_acc_2d(:,j,i) + end do + end do + do i = 1,decomp_cascade_con%n_all_entries + found = .false. + j_lev = mod(decomp_cascade_con%all_j(i) - 1,nlevdecomp) + 1 + j_decomp = (decomp_cascade_con%all_j(i) - j_lev)/nlevdecomp + 1 + i_lev = mod(decomp_cascade_con%all_i(i) - 1,nlevdecomp) + 1 + i_decomp = (decomp_cascade_con%all_i(i) - i_lev)/nlevdecomp + 1 + if(i_decomp .eq. j_decomp .and. j_lev - i_lev .eq. 1)then + this%AKXcacc%M(:,i) = this%vert_up_tran_acc(:,i_lev,i_decomp) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev - j_lev .eq. 1)then + this%AKXcacc%M(:,i) = this%vert_down_tran_acc(:,i_lev,i_decomp) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev .eq. j_lev)then + this%AKXcacc%M(:,i) = this%exit_acc(:,i_lev,i_decomp) + found = .true. + else + do k=1,ndecomp_cascade_transitions + if(i_decomp .ne. j_decomp .and. i_lev .eq. j_lev .and. & + i_decomp .eq. decomp_cascade_con%cascade_receiver_pool(k) .and. & + j_decomp .eq. decomp_cascade_con%cascade_donor_pool(k) .and. .not. found)then + this%AKXcacc%M(:,i) = this%hori_tran_acc(:,i_lev,k) + found = .true. + end if + end do + end if + end if + end if + if(.not. found) write(iulog,*) 'Error in storing matrix restart variables',i + end do + end if + end if + + if (use_vertsoilc) then + ptr2d => this%ctrunc_vr_col + call restartvar(ncid=ncid, flag=flag, varname="col_ctrunc_c14_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%ctrunc_vr_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname="col_ctrunc_c14", xtype=ncd_double, & + dim1name='column', long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + + end if + + !-------------------------------- + ! Spinup state + !-------------------------------- + + if (carbon_type == 'c12') then + if (flag == 'write') idata = spinup_state + call restartvar(ncid=ncid, flag=flag, varname='spinup_state', xtype=ncd_int, & + long_name='Spinup state of the model that wrote this restart file: ' & + // ' 0 = normal model mode, 1 = AD spinup', units='', & + interpinic_flag='copy', readvar=readvar, data=idata) + if (flag == 'read') then + if (readvar) then + this%restart_file_spinup_state = idata + else + call endrun(msg=' CNRest: spinup_state was not on the restart file and is required' // & + errMsg(sourcefile, __LINE__)) + end if + end if + else + this%restart_file_spinup_state = c12_soilbiogeochem_carbonstate_inst%restart_file_spinup_state + endif + + ! now compare the model and restart file spinup states, and either take the + ! model into spinup mode or out of it if they are not identical + ! taking model out of spinup mode requires multiplying each decomposing pool + ! by the associated AD factor. + ! putting model into spinup mode requires dividing each decomposing pool + ! by the associated AD factor. + ! only allow this to occur on first timestep of model run. + + if (flag == 'read' .and. spinup_state /= this%restart_file_spinup_state ) then + if (spinup_state == 0 .and. this%restart_file_spinup_state >= 1 ) then + if ( masterproc ) write(iulog,*) ' CNRest: taking ',carbon_type,' SOM pools out of AD spinup mode' + exit_spinup = .true. + else if (spinup_state >= 1 .and. this%restart_file_spinup_state == 0 ) then + if ( masterproc ) write(iulog,*) ' CNRest: taking ',carbon_type,' SOM pools into AD spinup mode' + enter_spinup = .true. + else + call endrun(msg=' CNRest: error in entering/exiting spinup. spinup_state ' & + // ' != restart_file_spinup_state, but do not know what to do'//& + errMsg(sourcefile, __LINE__)) + end if + if (get_nstep() >= 2) then + call endrun(msg=' CNRest: error in entering/exiting spinup - should occur only when nstep = 1'//& + errMsg(sourcefile, __LINE__)) + endif + if ( exit_spinup .and. isnan(this%totvegcthresh) )then + call endrun(msg=' CNRest: error in exit spinup - totvegcthresh was not set with SetTotVgCThresh'//& + errMsg(sourcefile, __LINE__)) + end if + do k = 1, ndecomp_pools + if ( exit_spinup ) then + m = decomp_cascade_con%spinup_factor(k) + else if ( enter_spinup ) then + m = 1. / decomp_cascade_con%spinup_factor(k) + end if + do c = bounds%begc, bounds%endc + l = col%landunit(c) + do j = 1, nlevdecomp_full + if ( abs(m - 1._r8) .gt. 0.000001_r8 .and. exit_spinup) then + this%decomp_cpools_vr_col(c,j,k) = this%decomp_cpools_vr_col(c,j,k) * m * & + get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + ! If there is no vegetation carbon, implying that all vegetation has died, then + ! reset decomp pools to near zero during exit_spinup to avoid very + ! large and inert soil carbon stocks; note that only pools with spinup factor > 1 + ! will be affected, which means that total SOMC and LITC pools will not be set to 0. + if (totvegc_col(c) <= this%totvegcthresh .and. lun%itype(l) /= istcrop) then + this%decomp_cpools_vr_col(c,j,k) = 0.0_r8 + endif + elseif ( abs(m - 1._r8) .gt. 0.000001_r8 .and. enter_spinup) then + this%decomp_cpools_vr_col(c,j,k) = this%decomp_cpools_vr_col(c,j,k) * m / & + get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + else + this%decomp_cpools_vr_col(c,j,k) = this%decomp_cpools_vr_col(c,j,k) * m + endif + end do + end do + end do + end if + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine SetValues ( this, num_column, filter_column, value_column) + ! + ! !DESCRIPTION: + ! Set carbon state variables + ! + ! !ARGUMENTS: + class (soilbiogeochem_carbonstate_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 fi = 1,num_column + i = filter_column(fi) + if ( .not. use_fates ) then + this%cwdc_col(i) = value_column + end if + this%ctrunc_col(i) = value_column + this%totlitc_col(i) = value_column + this%totlitc_1m_col(i) = value_column + this%totsomc_col(i) = value_column + this%totsomc_1m_col(i) = value_column + end do + + do j = 1,nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%ctrunc_vr_col(i,j) = value_column + end do + end do + + do k = 1, ndecomp_pools + do fi = 1,num_column + i = filter_column(fi) + this%decomp_cpools_col(i,k) = value_column + this%decomp_cpools_1m_col(i,k) = value_column + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_col(i,k) = value_column + end if + end do + end do + + do j = 1,nlevdecomp_full + do k = 1, ndecomp_pools + do fi = 1,num_column + i = filter_column(fi) + this%decomp_cpools_vr_col(i,j,k) = value_column + if(use_soil_matrixcn)then + this%matrix_cap_decomp_cpools_vr_col(i,j,k) = value_column + this%decomp0_cpools_vr_col(i,j,k) = value_column + end if + end do + end do + end do + + if(use_soil_matrixcn)then + do j = 1,nlevdecomp + do k = 1, ndecomp_pools + do fi = 1, num_column + i = filter_column(fi) + this%in_acc_2d(i,j,k) = value_column + this%vert_up_tran_acc(i,j,k) = value_column + this%vert_down_tran_acc(i,j,k) = value_column + this%exit_acc(i,j,k) = value_column + end do + end do + do k = 1, ndecomp_cascade_transitions + do fi = 1, num_column + i = filter_column(fi) + this%hori_tran_acc(i,j,k) = value_column + end do + end do + end do + end if + + if(use_soil_matrixcn)then + do j = 1,decomp_cascade_con%n_all_entries + do fi = 1, num_column + i = filter_column(fi) + this%AKXcacc%M(i,j) = value_column + end do + end do + end if + + end subroutine SetValues + + !----------------------------------------------------------------------- + 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 + + 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 + + + !----------------------------------------------------------------------- + subroutine DynamicColumnAdjustments(this, bounds, clump_index, column_state_updater) + ! + ! !DESCRIPTION: + ! Adjust state variables when column areas change due to dynamic landuse + ! + ! !USES: + use dynColumnStateUpdaterMod, only : column_state_updater_type + ! + ! !ARGUMENTS: + class(soilbiogeochem_carbonstate_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 + + type(column_state_updater_type) , intent(in) :: column_state_updater + ! + ! !LOCAL VARIABLES: + integer :: j ! level + integer :: l ! decomp pool + real(r8) :: adjustment_one_level(bounds%begc:bounds%endc) + integer :: begc, endc + + character(len=*), parameter :: subname = 'DynamicColumnAdjustments' + !----------------------------------------------------------------------- + + begc = bounds%begc + endc = bounds%endc + + this%dyn_cbal_adjustments_col(begc:endc) = 0._r8 + + do l = 1, ndecomp_pools + do j = 1, nlevdecomp + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%decomp_cpools_vr_col(begc:endc, j, l), & + adjustment = adjustment_one_level(begc:endc)) + + this%dyn_cbal_adjustments_col(begc:endc) = & + this%dyn_cbal_adjustments_col(begc:endc) + & + adjustment_one_level(begc:endc) * dzsoi_decomp(j) + end do + end do + + do j = 1, nlevdecomp + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%ctrunc_vr_col(begc:endc, j), & + adjustment = adjustment_one_level(begc:endc)) + this%dyn_cbal_adjustments_col(begc:endc) = & + this%dyn_cbal_adjustments_col(begc:endc) + & + adjustment_one_level(begc:endc) * dzsoi_decomp(j) + end do + + end subroutine DynamicColumnAdjustments + + +end module SoilBiogeochemCarbonStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemCompetitionMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemCompetitionMod.F90 new file mode 100644 index 000000000..6f5580bb8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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 shr_infnan_mod , only: nan => shr_infnan_nan, assignment(=) + ! + ! !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_orig_files/SoilBiogeochemDecompCascadeBGCMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemDecompCascadeBGCMod.F90 new file mode 100644 index 000000000..bed9493f7 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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, InitSoilTransfer + 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_orig_files/SoilBiogeochemDecompCascadeCNMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemDecompCascadeCNMod.F90 new file mode 100644 index 000000000..6e8ef1074 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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, InitSoilTransfer + 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_orig_files/SoilBiogeochemDecompCascadeConType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemDecompCascadeConType.F90 new file mode 100644 index 000000000..7218244c0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemDecompCascadeConType.F90 @@ -0,0 +1,259 @@ +module SoilBiogeochemDecompCascadeConType + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Decomposition Cascade Type + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevdecomp, & + ndecomp_cascade_outtransitions + use clm_varctl , only : use_soil_matrixcn, iulog + use SPMMod , only : sparse_matrix_type, diag_matrix_type, vector_type + ! + implicit none + + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: init_decomp_cascade_constants + public :: InitSoilTransfer + ! + type, public :: decomp_cascade_type + !-- properties of each pathway along decomposition cascade + 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 :: 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 + + subroutine InitSoilTransfer() +! Initialize sparse matrix variables and index. Count possible non-zero entries and record their x and y in the matrix. +! Collect those non-zero entry information, and save them into the list. + + use SPMMod , only : sparse_matrix_type, diag_matrix_type, vector_type + + integer i,j,k,m,n + integer,dimension(:) :: ntrans_per_donor(1:ndecomp_pools) + real(r8),dimension(:) :: SM(1:1,1:decomp_cascade_con%Ntrans_setup),TRI(1:1,1:decomp_cascade_con%Ntri_setup) + type(sparse_matrix_type) :: AK, AV, AKfire, AKallsoil!, AKtmp1, AKtmp2 + logical list_ready,init_readyAK + integer num_soilc,filter_c(1:1) + + init_readyAK = .false. + ntrans_per_donor = 0 + + do k = 1,ndecomp_cascade_transitions + ntrans_per_donor(decomp_cascade_con%cascade_donor_pool(k)) & + = ntrans_per_donor(decomp_cascade_con%cascade_donor_pool(k)) + 1 + end do + + k = 0 + n = 1 + do i = 1,ndecomp_pools + do j=1,nlevdecomp + do m=1,ntrans_per_donor(i) + if(decomp_cascade_con%cascade_receiver_pool(m+k) .ne. 0)then + decomp_cascade_con%spm_tranlist_a(j,m+k) = n + decomp_cascade_con%A_i(n) = (decomp_cascade_con%cascade_receiver_pool(m+k)-1)*nlevdecomp+j + decomp_cascade_con%A_j(n) = (decomp_cascade_con%cascade_donor_pool(m+k)-1)*nlevdecomp+j + n = n + 1 + end if + end do + end do + k = k + ntrans_per_donor(i) + end do + + SM = 1._r8 + if(n-1 .ne. decomp_cascade_con%Ntrans_setup)then + write(iulog,*) 'error in InitSoilTransfer: number of transfers is error in count' + end if + + n = 1 + do i = 1,ndecomp_pools + do j = 1, nlevdecomp + if(.not. decomp_cascade_con%is_cwd(i))then + if (j > 1) then ! avoid tranfer from for example,soil1_1st layer to litr3_10th layer + TRI(1,n) = 1._r8 + decomp_cascade_con%tri_j(n) = (i-1)*nlevdecomp + j + decomp_cascade_con%tri_i(n) = (i-1)*nlevdecomp + j - 1 + n = n + 1 + end if + TRI(1,n) = 1._r8 + decomp_cascade_con%tri_j(n) = (i-1)*nlevdecomp + j + decomp_cascade_con%tri_i(n) = (i-1)*nlevdecomp + j + n = n + 1 + if (j < nlevdecomp) then ! avoid tranfer from for example, litr3_10th layer to soil1_1st layer + TRI(1,n) = 1._r8 + decomp_cascade_con%tri_j(n) = (i-1)*nlevdecomp + j + decomp_cascade_con%tri_i(n) = (i-1)*nlevdecomp + j + 1 + n = n + 1 + end if + end if + end do + end do + + if(n-1 .ne. decomp_cascade_con%Ntri_setup)then + write(iulog,*) 'error in InitSoilTransfer: number of vertical-transfers is error in count' + end if + + num_soilc = 1 + filter_c(1:1) = 1 + if ( AK%IsAllocSM() ) call AK%ReleaseSM() + call AK%InitSM(ndecomp_pools*nlevdecomp,1,1) + call AK%SetValueA(1,1,num_soilc,filter_c(1:num_soilc),SM,decomp_cascade_con%A_i,decomp_cascade_con%A_j,decomp_cascade_con%Ntrans_setup,init_readyAK) + allocate(decomp_cascade_con%list_AK_AKVfire(1:AK%NE)) + allocate(decomp_cascade_con%list_AK_AKV (1:AK%NE)) + + if ( AV%IsAllocSM() ) call AV%ReleaseSM() + call AV%InitSM(ndecomp_pools*nlevdecomp,1,1) + call AV%SetValueSM(1,1,num_soilc,filter_c(1:num_soilc),TRI,decomp_cascade_con%tri_i,decomp_cascade_con%tri_j,decomp_cascade_con%Ntri_setup) + allocate(decomp_cascade_con%list_V_AKVfire (1:AV%NE)) + allocate(decomp_cascade_con%list_V_AKV (1:AV%NE)) + + if ( AKfire%IsAllocSM() ) call AKfire%ReleaseSM() + call AKfire%InitSM(ndecomp_pools*nlevdecomp,1,1) + call AKfire%SetValueA_diag(num_soilc,filter_c(1:num_soilc),1._r8) + allocate(decomp_cascade_con%list_fire_AKVfire(1:AKfire%NE)) + + list_ready = .false. + if ( AKallsoil%IsAllocSM() ) call AKallsoil%ReleaseSM() + call AKallsoil%InitSM(ndecomp_pools*nlevdecomp,1,1) + call AKallsoil%SPMP_ABC(num_soilc,filter_c(1:num_soilc),AK,AV,AKfire,list_ready) + + decomp_cascade_con%n_all_entries = AKallsoil%NE + allocate(decomp_cascade_con%all_i(1:decomp_cascade_con%n_all_entries)) + allocate(decomp_cascade_con%all_j(1:decomp_cascade_con%n_all_entries)) + decomp_cascade_con%all_i(:) = AKallsoil%RI(1:decomp_cascade_con%n_all_entries) + decomp_cascade_con%all_j(:) = AKallsoil%CI(1:decomp_cascade_con%n_all_entries) + + allocate(decomp_cascade_con%list_Asoilc (1:(ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp)) + allocate(decomp_cascade_con%list_Asoiln (1:(ndecomp_cascade_transitions-ndecomp_cascade_outtransitions)*nlevdecomp)) + + call AK%ReleaseSM() + call AV%ReleaseSM() + call AKfire%ReleaseSM() + call AKallsoil%ReleaseSM() + end subroutine InitSoilTransfer + +end module SoilBiogeochemDecompCascadeConType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemDecompMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemDecompMod.F90 new file mode 100644 index 000000000..3e7f27ee6 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SoilBiogeochemLittVertTranspMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemLittVertTranspMod.F90 new file mode 100644 index 000000000..c020d4c2e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SoilBiogeochemNLeachingMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemNLeachingMod.F90 new file mode 100644 index 000000000..7e8d847b5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SoilBiogeochemNStateUpdate1Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemNStateUpdate1Mod.F90 new file mode 100644 index 000000000..eab4f40d5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SoilBiogeochemNitrifDenitrifMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemNitrifDenitrifMod.F90 new file mode 100644 index 000000000..784b90719 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SoilBiogeochemNitrogenFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemNitrogenFluxType.F90 new file mode 100644 index 000000000..e57a6a359 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemNitrogenFluxType.F90 @@ -0,0 +1,1240 @@ +module SoilBiogeochemNitrogenFluxType + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, ndecomp_cascade_outtransitions + use clm_varpar , only : nlevdecomp_full, nlevdecomp, ndecomp_pools_vr + use clm_varcon , only : spval, ispval, dzsoi_decomp + use decompMod , only : bounds_type + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_crop, use_soil_matrixcn + use CNSharedParamsMod , only : use_fun + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use abortutils , only : endrun + use LandunitType , only : lun + use ColumnType , only : col + use SPMMod , only : sparse_matrix_type, vector_type + ! + ! !PUBLIC TYPES: + implicit none + private + ! + 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 :: Init + procedure , public :: SetValues + procedure , public :: Summary + procedure , private :: InitAllocate + procedure , private :: InitHistory + procedure , private :: InitCold + + end type SoilBiogeochem_nitrogenflux_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(soilbiogeochem_nitrogenflux_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) + ! + ! !DESCRIPTION: + ! Initialize nitrogen flux + ! + ! !ARGUMENTS: + class(soilbiogeochem_nitrogenflux_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !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 InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use histFileMod , only : hist_addfld1d, hist_addfld_decomp + ! + ! !ARGUMENTS: + class(soilbiogeochem_nitrogenflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: k,l + integer :: begc, endc + character(24) :: fieldname + character(100) :: longname + character(8) :: vr_suffix,default + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begc = bounds%begc; endc= bounds%endc + + ! add suffix if number of soil decomposition depths is greater than 1 + if (nlevdecomp > 1) then + vr_suffix = "_vr" + else + vr_suffix = "" + endif + + !------------------------------- + ! N flux variables - native to column + !------------------------------- + + this%ndep_to_sminn_col(begc:endc) = spval + call hist_addfld1d (fname='NDEP_TO_SMINN', units='gN/m^2/s', & + avgflag='A', long_name='atmospheric N deposition to soil mineral N', & + ptr_col=this%ndep_to_sminn_col) + + if (use_fun) then + default = 'inactive' + else + default = 'active' + end if + this%nfix_to_sminn_col(begc:endc) = spval + call hist_addfld1d (fname='NFIX_TO_SMINN', units='gN/m^2/s', & + avgflag='A', long_name='symbiotic/asymbiotic N fixation to soil mineral N', & + ptr_col=this%nfix_to_sminn_col, default=default) + + if ( use_fun )then + this%ffix_to_sminn_col(begc:endc) = spval + call hist_addfld1d (fname='FFIX_TO_SMINN', units='gN/m^2/s', & + avgflag='A', long_name='free living N fixation to soil mineral N', & + ptr_col=this%ffix_to_sminn_col, default='active') + end if + + do l = 1, ndecomp_cascade_transitions + ! vertically integrated fluxes + !-- mineralization/immobilization fluxes (none from CWD) + if ( .not. decomp_cascade_con%is_cwd(decomp_cascade_con%cascade_donor_pool(l)) ) then + this%decomp_cascade_sminn_flux_col(begc:endc,l) = spval + data1dptr => this%decomp_cascade_sminn_flux_col(:,l) + if ( decomp_cascade_con%cascade_receiver_pool(l) /= 0 ) then + fieldname = 'SMINN_TO_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l)))//'N_'//& + trim(decomp_cascade_con%decomp_pool_name_short(decomp_cascade_con%cascade_donor_pool(l))) + longname = 'mineral N flux for decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//& + 'to '//trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l))) + else + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'N_TO_SMINN' + longname = 'mineral N flux for decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l))) + endif + call hist_addfld1d (fname=fieldname, units='gN/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + end if + + !-- transfer fluxes (none from terminal pool, if present) + if ( decomp_cascade_con%cascade_receiver_pool(l) /= 0 ) then + this%decomp_cascade_ntransfer_col(begc:endc,l) = spval + data1dptr => this%decomp_cascade_ntransfer_col(:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//'N_TO_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l)))//'N' + longname = 'decomp. of '//trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l)))//& + ' N to '//trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_receiver_pool(l)))//' N' + call hist_addfld1d (fname=fieldname, units='gN/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + end if + + ! vertically resolved fluxes + if ( nlevdecomp_full > 1 ) then + !-- mineralization/immobilization fluxes (none from CWD) + if ( .not. decomp_cascade_con%is_cwd(decomp_cascade_con%cascade_donor_pool(l)) ) then + this%decomp_cascade_sminn_flux_vr_col(begc:endc,:,l) = spval + data2dptr => this%decomp_cascade_sminn_flux_vr_col(:,:,l) + if ( decomp_cascade_con%cascade_receiver_pool(l) /= 0 ) then + fieldname = 'SMINN_TO_'& + //trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l)))//'N_'//& + trim(decomp_cascade_con%decomp_pool_name_short(decomp_cascade_con%cascade_donor_pool(l)))//trim(vr_suffix) + longname = 'mineral N flux for decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//& + 'to '//trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l))) + else + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))& + //'N_TO_SMINN'//trim(vr_suffix) + longname = 'mineral N flux for decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l))) + endif + call hist_addfld_decomp (fname=fieldname, units='gN/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + + !-- transfer fluxes (none from terminal pool, if present) + if ( decomp_cascade_con%cascade_receiver_pool(l) /= 0 ) then + this%decomp_cascade_ntransfer_vr_col(begc:endc,:,l) = spval + data2dptr => this%decomp_cascade_ntransfer_vr_col(:,:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_donor_pool(l)))//'N_TO_'//& + trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l)))& + //'N'//trim(vr_suffix) + longname = 'decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l)))//& + ' N to '//trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_receiver_pool(l)))//' N' + call hist_addfld_decomp (fname=fieldname, units='gN/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + + endif + end do + + this%denit_col(begc:endc) = spval + call hist_addfld1d (fname='DENIT', units='gN/m^2/s', & + avgflag='A', long_name='total rate of denitrification', & + ptr_col=this%denit_col) + + this%som_n_leached_col(begc:endc) = spval + call hist_addfld1d (fname='SOM_N_LEACHED', units='gN/m^2/s', & + avgflag='A', long_name='total flux of N from SOM pools due to leaching', & + ptr_col=this%som_n_leached_col, default='inactive') + + do k = 1, ndecomp_pools + if ( .not. decomp_cascade_con%is_cwd(k) ) then + this%decomp_npools_leached_col(begc:endc,k) = spval + data1dptr => this%decomp_npools_leached_col(:,k) + fieldname = 'M_'//trim(decomp_cascade_con%decomp_pool_name_history(k))//'N_TO_LEACHING' + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' N leaching loss' + call hist_addfld1d (fname=fieldname, units='gN/m^2/s', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + + this%decomp_npools_transport_tendency_col(begc:endc,:,k) = spval + data2dptr => this%decomp_npools_transport_tendency_col(:,:,k) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(k))//'N_TNDNCY_VERT_TRANSPORT' + longname = trim(decomp_cascade_con%decomp_pool_name_long(k))//' N tendency due to vertical transport' + call hist_addfld_decomp (fname=fieldname, units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + end if + end do + + if (.not. use_nitrif_denitrif) then + do l = 1, ndecomp_cascade_transitions + !-- denitrification fluxes (none from CWD) + if ( .not. decomp_cascade_con%is_cwd(decomp_cascade_con%cascade_donor_pool(l)) ) then + this%sminn_to_denit_decomp_cascade_col(begc:endc,l) = spval + data1dptr => this%sminn_to_denit_decomp_cascade_col(:,l) + fieldname = 'SMINN_TO_DENIT_'//trim(decomp_cascade_con%cascade_step_name(l)) + longname = 'denitrification for decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l)))//& + 'to '//trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l))) + call hist_addfld1d (fname=fieldname, units='gN/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default='inactive') + endif + + if ( nlevdecomp_full > 1 ) then + !-- denitrification fluxes (none from CWD) + if ( .not. decomp_cascade_con%is_cwd(decomp_cascade_con%cascade_donor_pool(l)) ) then + this%sminn_to_denit_decomp_cascade_vr_col(begc:endc,:,l) = spval + data2dptr => this%sminn_to_denit_decomp_cascade_vr_col(:,:,l) + fieldname = 'SMINN_TO_DENIT_'//trim(decomp_cascade_con%cascade_step_name(l))//trim(vr_suffix) + longname = 'denitrification for decomp. of '& + //trim(decomp_cascade_con%decomp_pool_name_long(decomp_cascade_con%cascade_donor_pool(l)))//& + 'to '//trim(decomp_cascade_con%decomp_pool_name_history(decomp_cascade_con%cascade_receiver_pool(l))) + call hist_addfld_decomp (fname=fieldname, units='gN/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr, default='inactive') + endif + endif + end do + end if + + if (.not. use_nitrif_denitrif) then + this%sminn_to_denit_excess_col(begc:endc) = spval + call hist_addfld1d (fname='SMINN_TO_DENIT_EXCESS', units='gN/m^2/s', & + avgflag='A', long_name='denitrification from excess mineral N pool', & + ptr_col=this%sminn_to_denit_excess_col, default='inactive') + end if + + if (.not. use_nitrif_denitrif) then + this%sminn_leached_col(begc:endc) = spval + call hist_addfld1d (fname='SMINN_LEACHED', units='gN/m^2/s', & + avgflag='A', long_name='soil mineral N pool loss to leaching', & + ptr_col=this%sminn_leached_col) + end if + + if (.not. use_nitrif_denitrif) then + if ( nlevdecomp_full > 1 ) then + this%sminn_to_denit_excess_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SMINN_TO_DENIT_EXCESS'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='denitrification from excess mineral N pool', & + ptr_col=this%sminn_to_denit_excess_vr_col, default='inactive') + + this%sminn_leached_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SMINN_LEACHED'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='soil mineral N pool loss to leaching', & + ptr_col=this%sminn_leached_vr_col, default='inactive') + endif + end if + + if (use_nitrif_denitrif) then + this%f_nit_col(begc:endc) = spval + call hist_addfld1d (fname='F_NIT', units='gN/m^2/s', & + avgflag='A', long_name='nitrification flux', & + ptr_col=this%f_nit_col) + end if + + if (use_nitrif_denitrif) then + this%f_denit_col(begc:endc) = spval + call hist_addfld1d (fname='F_DENIT', units='gN/m^2/s', & + avgflag='A', long_name='denitrification flux', & + ptr_col=this%f_denit_col) + end if + + if (use_nitrif_denitrif) then + this%pot_f_nit_col(begc:endc) = spval + call hist_addfld1d (fname='POT_F_NIT', units='gN/m^2/s', & + avgflag='A', long_name='potential nitrification flux', & + ptr_col=this%pot_f_nit_col) + end if + + if (use_nitrif_denitrif) then + this%pot_f_denit_col(begc:endc) = spval + call hist_addfld1d (fname='POT_F_DENIT', units='gN/m^2/s', & + avgflag='A', long_name='potential denitrification flux', & + ptr_col=this%pot_f_denit_col) + end if + + if (use_nitrif_denitrif) then + this%smin_no3_leached_col(begc:endc) = spval + call hist_addfld1d (fname='SMIN_NO3_LEACHED', units='gN/m^2/s', & + avgflag='A', long_name='soil NO3 pool loss to leaching', & + ptr_col=this%smin_no3_leached_col) + end if + + if (use_nitrif_denitrif) then + this%smin_no3_runoff_col(begc:endc) = spval + call hist_addfld1d (fname='SMIN_NO3_RUNOFF', units='gN/m^2/s', & + avgflag='A', long_name='soil NO3 pool loss to runoff', & + ptr_col=this%smin_no3_runoff_col) + end if + + if (use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%f_nit_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='F_NIT'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='nitrification flux', & + ptr_col=this%f_nit_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%f_denit_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='F_DENIT'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='denitrification flux', & + ptr_col=this%f_denit_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%pot_f_nit_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='POT_F_NIT'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='potential nitrification flux', & + ptr_col=this%pot_f_nit_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%pot_f_denit_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='POT_F_DENIT'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='potential denitrification flux', & + ptr_col=this%pot_f_denit_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%smin_no3_leached_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SMIN_NO3_LEACHED'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='soil NO3 pool loss to leaching', & + ptr_col=this%smin_no3_leached_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%smin_no3_runoff_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SMIN_NO3_RUNOFF'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='soil NO3 pool loss to runoff', & + ptr_col=this%smin_no3_runoff_vr_col, default='inactive') + endif + + if (use_nitrif_denitrif) then + this%n2_n2o_ratio_denit_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='n2_n2o_ratio_denit', units='gN/gN', type2d='levdcmp', & + avgflag='A', long_name='n2_n2o_ratio_denit', & + ptr_col=this%n2_n2o_ratio_denit_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%actual_immob_no3_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='ACTUAL_IMMOB_NO3', units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='immobilization of NO3', & + ptr_col=this%actual_immob_no3_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%actual_immob_nh4_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='ACTUAL_IMMOB_NH4', units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='immobilization of NH4', & + ptr_col=this%actual_immob_nh4_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%smin_no3_to_plant_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SMIN_NO3_TO_PLANT', units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='plant uptake of NO3', & + ptr_col=this%smin_no3_to_plant_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%smin_nh4_to_plant_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SMIN_NH4_TO_PLANT', units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='plant uptake of NH4', & + ptr_col=this%smin_nh4_to_plant_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%smin_no3_massdens_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SMIN_NO3_MASSDENS', units='ugN/cm^3 soil', type2d='levdcmp', & + avgflag='A', long_name='SMIN_NO3_MASSDENS', & + ptr_col=this%smin_no3_massdens_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%k_nitr_t_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='K_NITR_T', units='unitless', type2d='levdcmp', & + avgflag='A', long_name='K_NITR_T', & + ptr_col=this%k_nitr_t_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%k_nitr_ph_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='K_NITR_PH', units='unitless', type2d='levdcmp', & + avgflag='A', long_name='K_NITR_PH', & + ptr_col=this%k_nitr_ph_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%k_nitr_h2o_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='K_NITR_H2O', units='unitless', type2d='levdcmp', & + avgflag='A', long_name='K_NITR_H2O', & + ptr_col=this%k_nitr_h2o_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%k_nitr_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='K_NITR', units='1/s', type2d='levdcmp', & + avgflag='A', long_name='K_NITR', & + ptr_col=this%k_nitr_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%wfps_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='WFPS', units='percent', type2d='levdcmp', & + avgflag='A', long_name='WFPS', & + ptr_col=this%wfps_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%fmax_denit_carbonsubstrate_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='FMAX_DENIT_CARBONSUBSTRATE', units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='FMAX_DENIT_CARBONSUBSTRATE', & + ptr_col=this%fmax_denit_carbonsubstrate_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%fmax_denit_nitrate_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='FMAX_DENIT_NITRATE', units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='FMAX_DENIT_NITRATE', & + ptr_col=this%fmax_denit_nitrate_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%f_denit_base_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='F_DENIT_BASE', units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='F_DENIT_BASE', & + ptr_col=this%f_denit_base_vr_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%diffus_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='diffus', units='m^2/s', type2d='levdcmp', & + avgflag='A', long_name='diffusivity', & + ptr_col=this%diffus_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%ratio_k1_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='ratio_k1', units='none', type2d='levdcmp', & + avgflag='A', long_name='ratio_k1', & + ptr_col=this%ratio_k1_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%ratio_no3_co2_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='ratio_no3_co2', units='ratio', type2d='levdcmp', & + avgflag='A', long_name='ratio_no3_co2', & + ptr_col=this%ratio_no3_co2_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%soil_co2_prod_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='soil_co2_prod', units='ug C / g soil / day', type2d='levdcmp', & + avgflag='A', long_name='soil_co2_prod', & + ptr_col=this%soil_co2_prod_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%fr_WFPS_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='fr_WFPS', units='fraction', type2d='levdcmp', & + avgflag='A', long_name='fr_WFPS', & + ptr_col=this%fr_WFPS_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%soil_bulkdensity_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='soil_bulkdensity', units='kg/m3', type2d='levdcmp', & + avgflag='A', long_name='soil_bulkdensity', & + ptr_col=this%soil_bulkdensity_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%anaerobic_frac_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='anaerobic_frac', units='m3/m3', type2d='levdcmp', & + avgflag='A', long_name='anaerobic_frac', & + ptr_col=this%anaerobic_frac_col, default='inactive') + end if + + if (use_nitrif_denitrif) then + this%r_psi_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='r_psi', units='m', type2d='levdcmp', & + avgflag='A', long_name='r_psi', & + ptr_col=this%r_psi_col, default='inactive') + end if + + + if ( use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%potential_immob_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='POTENTIAL_IMMOB'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='potential N immobilization', & + ptr_col=this%potential_immob_vr_col, default='inactive') + end if + + if ( use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%actual_immob_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='ACTUAL_IMMOB'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='actual N immobilization', & + ptr_col=this%actual_immob_vr_col, default='inactive') + end if + + if ( use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%sminn_to_plant_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SMINN_TO_PLANT'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='plant uptake of soil mineral N', & + ptr_col=this%sminn_to_plant_vr_col, default='inactive') + end if + + if ( use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%supplement_to_sminn_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SUPPLEMENT_TO_SMINN'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='supplemental N supply', & + ptr_col=this%supplement_to_sminn_vr_col, default='inactive') + end if + + if ( use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%gross_nmin_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='GROSS_NMIN'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='gross rate of N mineralization', & + ptr_col=this%gross_nmin_vr_col, default='inactive') + end if + + if ( use_nitrif_denitrif .and. nlevdecomp_full > 1 ) then + this%net_nmin_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='NET_NMIN'//trim(vr_suffix), units='gN/m^3/s', type2d='levdcmp', & + avgflag='A', long_name='net rate of N mineralization', & + ptr_col=this%net_nmin_vr_col, default='inactive') + end if + + this%potential_immob_col(begc:endc) = spval + call hist_addfld1d (fname='POTENTIAL_IMMOB', units='gN/m^2/s', & + avgflag='A', long_name='potential N immobilization', & + ptr_col=this%potential_immob_col) + + this%actual_immob_col(begc:endc) = spval + call hist_addfld1d (fname='ACTUAL_IMMOB', units='gN/m^2/s', & + avgflag='A', long_name='actual N immobilization', & + ptr_col=this%actual_immob_col) + + this%sminn_to_plant_col(begc:endc) = spval + call hist_addfld1d (fname='SMINN_TO_PLANT', units='gN/m^2/s', & + avgflag='A', long_name='plant uptake of soil mineral N', & + ptr_col=this%sminn_to_plant_col) + + this%supplement_to_sminn_col(begc:endc) = spval + call hist_addfld1d (fname='SUPPLEMENT_TO_SMINN', units='gN/m^2/s', & + avgflag='A', long_name='supplemental N supply', & + ptr_col=this%supplement_to_sminn_col) + + this%gross_nmin_col(begc:endc) = spval + call hist_addfld1d (fname='GROSS_NMIN', units='gN/m^2/s', & + avgflag='A', long_name='gross rate of N mineralization', & + ptr_col=this%gross_nmin_col) + + this%net_nmin_col(begc:endc) = spval + call hist_addfld1d (fname='NET_NMIN', units='gN/m^2/s', & + avgflag='A', long_name='net rate of N mineralization', & + ptr_col=this%net_nmin_col) + + if (use_nitrif_denitrif) then + this%f_n2o_nit_col(begc:endc) = spval + call hist_addfld1d (fname='F_N2O_NIT', units='gN/m^2/s', & + avgflag='A', long_name='nitrification N2O flux', & + ptr_col=this%f_n2o_nit_col) + + this%f_n2o_denit_col(begc:endc) = spval + call hist_addfld1d (fname='F_N2O_DENIT', units='gN/m^2/s', & + avgflag='A', long_name='denitrification N2O flux', & + ptr_col=this%f_n2o_denit_col) + end if + + if (use_crop) then + this%fert_to_sminn_col(begc:endc) = spval + call hist_addfld1d (fname='FERT_TO_SMINN', units='gN/m^2/s', & + avgflag='A', long_name='fertilizer to soil mineral N', & + ptr_col=this%fert_to_sminn_col, default='inactive') + end if + + if (use_crop .and. .not. use_fun) then + this%soyfixn_to_sminn_col(begc:endc) = spval + call hist_addfld1d (fname='SOYFIXN_TO_SMINN', units='gN/m^2/s', & + avgflag='A', long_name='Soybean fixation to soil mineral N', & + ptr_col=this%soyfixn_to_sminn_col, default='inactive') + end if + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !DESCRIPTION: + ! Initializes time varying variables used only in coupled carbon-nitrogen mode (CN): + ! + ! !USES: + use landunit_varcon , only : istsoil, istcrop + ! + ! !ARGUMENTS: + class(soilbiogeochem_nitrogenflux_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: c,l + integer :: num_special_col ! number of good values in special_col filter + integer :: special_col(bounds%endc-bounds%begc+1) ! special landunit filter - columns + !--------------------------------------------------------------------- + + ! Set column filters + + num_special_col = 0 + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + num_special_col = num_special_col + 1 + special_col(num_special_col) = c + end if + end do + + !----------------------------------------------- + ! initialize nitrogen flux variables + !----------------------------------------------- + + call this%SetValues (& + num_column=num_special_col, filter_column=special_col, value_column=0._r8) + + end subroutine InitCold + + !----------------------------------------------------------------------- + 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_orig_files/SoilBiogeochemNitrogenStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemNitrogenStateType.F90 new file mode 100644 index 000000000..ee041ecee --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemNitrogenStateType.F90 @@ -0,0 +1,1385 @@ +module SoilBiogeochemNitrogenStateType + +#include "shr_assert.h" + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun + use spmdMod , only : masterproc + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools, nlevcan + use clm_varpar , only : nlevdecomp_full, nlevdecomp, nlevsoi + use clm_varcon , only : spval, dzsoi_decomp, zisoi + use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_century_decomp, use_soil_matrixcn + use clm_varctl , only : iulog, override_bgc_restart_mismatch_dump, spinup_state + use landunit_varcon , only : istcrop, istsoil + use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con + use LandunitType , only : lun + use ColumnType , only : col + use GridcellType , only : grc + use SoilBiogeochemStateType , only : get_spinup_latitude_term + use SPMMOD , only : sparse_matrix_type, vector_type + ! + ! !PUBLIC TYPES: + implicit none + private + + 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 :: Init + procedure , public :: Restart + procedure , public :: SetValues + procedure , public :: Summary + procedure , public :: DynamicColumnAdjustments ! adjust state variables when column areas change + procedure , public :: SetTotVgCThresh ! Set value for totvegcthresh needed in Restart + procedure , private :: InitAllocate + procedure , private :: InitHistory + procedure , private :: InitCold + + end type soilbiogeochem_nitrogenstate_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, & + decomp_cpools_vr_col, decomp_cpools_col, decomp_cpools_1m_col) + + class(soilbiogeochem_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: decomp_cpools_vr_col (bounds%begc:, 1:, 1:) + real(r8) , intent(in) :: decomp_cpools_col (bounds%begc:, 1:) + real(r8) , intent(in) :: decomp_cpools_1m_col (bounds%begc:, 1:) + + this%totvegcthresh = nan + call this%InitAllocate (bounds ) + + call this%InitHistory (bounds) + + call this%InitCold ( bounds, & + decomp_cpools_vr_col, decomp_cpools_col, decomp_cpools_1m_col) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !ARGUMENTS: + class (soilbiogeochem_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc,endc + !------------------------------------------------------------------------ + + 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 + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! add history fields for all CN variables, always set as default='inactive' + ! + ! !USES: + use clm_varpar , only : ndecomp_cascade_transitions, ndecomp_pools + use clm_varpar , only : nlevdecomp, nlevdecomp_full, nlevgrnd + use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + use decompMod , only : bounds_type + ! + ! !ARGUMENTS: + class(soilbiogeochem_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: k,l,ii,jj + character(10) :: active + character(8) :: vr_suffix + integer :: begc,endc + character(24) :: fieldname + character(100) :: longname + real(r8), pointer :: data1dptr(:) ! temp. pointer for slicing larger arrays + real(r8), pointer :: data2dptr(:,:) ! temp. pointer for slicing larger arrays + !--------------------------------------------------------------------- + + begc = bounds%begc; endc = bounds%endc + + if ( nlevdecomp_full > 1 ) then + this%decomp_soiln_vr_col(begc:endc,:) = spval + call hist_addfld2d (fname='SOILN_vr', units='gN/m^3', type2d='levdcmp', & + avgflag='A', long_name='SOIL N (vertically resolved)', & + ptr_col=this%decomp_soiln_vr_col) + end if + + if ( nlevdecomp_full > 1 ) then + this%decomp_npools_vr_col(begc:endc,:,:) = spval + this%decomp_npools_1m_col(begc:endc,:) = spval + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_vr_col(begc:endc,:,:) = spval + end if + end if + this%decomp_npools_col(begc:endc,:) = spval + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_col(begc:endc,:) = spval + end if + do l = 1, ndecomp_pools + if ( nlevdecomp_full > 1 ) then + data2dptr => this%decomp_npools_vr_col(:,:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'N_vr' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' N (vertically resolved)' + call hist_addfld2d (fname=fieldname, units='gN/m^3', type2d='levdcmp', & + avgflag='A', long_name=longname, & + ptr_col=data2dptr) + if(use_soil_matrixcn)then + data2dptr => this%matrix_cap_decomp_npools_vr_col(:,:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'N_Cap_vr' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' N capacity (vertically resolved)' + call hist_addfld2d (fname=fieldname, units='gN/m^3', type2d='levdcmp', & + avgflag='I', long_name=longname, & + ptr_col=data2dptr) + end if + endif + + data1dptr => this%decomp_npools_col(:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'N' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' N' + call hist_addfld1d (fname=fieldname, units='gN/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr) + if(nlevdecomp_full .eq. 1)then + if(use_soil_matrixcn)then + data1dptr => this%matrix_cap_decomp_npools_col(:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'N_Cap' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' N capacity' + call hist_addfld1d (fname=fieldname, units='gN/m^2', & + avgflag='I', long_name=longname, & + ptr_col=data1dptr) + end if + end if + + if ( nlevdecomp_full > 1 ) then + data1dptr => this%decomp_npools_1m_col(:,l) + fieldname = trim(decomp_cascade_con%decomp_pool_name_history(l))//'N_1m' + longname = trim(decomp_cascade_con%decomp_pool_name_history(l))//' N to 1 meter' + call hist_addfld1d (fname=fieldname, units='gN/m^2', & + avgflag='A', long_name=longname, & + ptr_col=data1dptr, default = 'inactive') + endif + end do + + + if ( nlevdecomp_full > 1 ) then + + this%sminn_col(begc:endc) = spval + call hist_addfld1d (fname='SMINN', units='gN/m^2', & + avgflag='A', long_name='soil mineral N', & + ptr_col=this%sminn_col) + + this%totlitn_1m_col(begc:endc) = spval + call hist_addfld1d (fname='TOTLITN_1m', units='gN/m^2', & + avgflag='A', long_name='total litter N to 1 meter', & + ptr_col=this%totlitn_1m_col) + + this%totsomn_1m_col(begc:endc) = spval + call hist_addfld1d (fname='TOTSOMN_1m', units='gN/m^2', & + avgflag='A', long_name='total soil organic matter N to 1 meter', & + ptr_col=this%totsomn_1m_col) + endif + + this%ntrunc_col(begc:endc) = spval + call hist_addfld1d (fname='COL_NTRUNC', units='gN/m^2', & + avgflag='A', long_name='column-level sink for N truncation', & + ptr_col=this%ntrunc_col, default='inactive') + + ! add suffix if number of soil decomposition depths is greater than 1 + if (nlevdecomp > 1) then + vr_suffix = "_vr" + else + vr_suffix = "" + endif + + if (use_nitrif_denitrif) then + if ( nlevdecomp_full > 1 ) then + data2dptr => this%smin_no3_vr_col(begc:endc,1:nlevsoi) + call hist_addfld_decomp (fname='SMIN_NO3'//trim(vr_suffix), units='gN/m^3', type2d='levsoi', & + avgflag='A', long_name='soil mineral NO3 (vert. res.)', & + ptr_col=data2dptr) + + data2dptr => this%smin_nh4_vr_col(begc:endc,1:nlevsoi) + call hist_addfld_decomp (fname='SMIN_NH4'//trim(vr_suffix), units='gN/m^3', type2d='levsoi', & + avgflag='A', long_name='soil mineral NH4 (vert. res.)', & + ptr_col=data2dptr) + + data2dptr => this%sminn_vr_col(begc:endc,1:nlevsoi) + call hist_addfld_decomp (fname='SMINN'//trim(vr_suffix), units='gN/m^3', type2d='levsoi', & + avgflag='A', long_name='soil mineral N', & + ptr_col=data2dptr) + + this%smin_no3_col(begc:endc) = spval + call hist_addfld1d (fname='SMIN_NO3', units='gN/m^2', & + avgflag='A', long_name='soil mineral NO3', & + ptr_col=this%smin_no3_col) + + this%smin_nh4_col(begc:endc) = spval + call hist_addfld1d (fname='SMIN_NH4', units='gN/m^2', & + avgflag='A', long_name='soil mineral NH4', & + ptr_col=this%smin_nh4_col) + endif + else + if ( nlevdecomp_full > 1 ) then + data2dptr => this%sminn_vr_col(begc:endc,1:nlevsoi) + call hist_addfld_decomp (fname='SMINN'//trim(vr_suffix), units='gN/m^3', type2d='levsoi', & + avgflag='A', long_name='soil mineral N', & + ptr_col=data2dptr) + end if + + end if + + this%totlitn_col(begc:endc) = spval + call hist_addfld1d (fname='TOTLITN', units='gN/m^2', & + avgflag='A', long_name='total litter N', & + ptr_col=this%totlitn_col) + + this%totsomn_col(begc:endc) = spval + call hist_addfld1d (fname='TOTSOMN', units='gN/m^2', & + avgflag='A', long_name='total soil organic matter N', & + ptr_col=this%totsomn_col) + + this%dyn_nbal_adjustments_col(begc:endc) = spval + call hist_addfld1d (fname='DYN_COL_SOIL_ADJUSTMENTS_N', units='gN/m^2', & + avgflag='SUM', & + long_name='Adjustments in soil nitrogen due to dynamic column areas; & + &only makes sense at the column level: should not be averaged to gridcell', & + ptr_col=this%dyn_nbal_adjustments_col, default='inactive') + + if (use_nitrif_denitrif) then + call hist_addfld1d (fname='DYN_COL_SOIL_ADJUSTMENTS_NO3', units='gN/m^2', & + avgflag='SUM', & + long_name='Adjustments in soil NO3 due to dynamic column areas; & + &only makes sense at the column level: should not be averaged to gridcell', & + ptr_col=this%dyn_no3bal_adjustments_col, default='inactive') + + call hist_addfld1d (fname='DYN_COL_SOIL_ADJUSTMENTS_NH4', units='gN/m^2', & + avgflag='SUM', & + long_name='Adjustments in soil NH4 due to dynamic column areas; & + &only makes sense at the column level: should not be averaged to gridcell', & + ptr_col=this%dyn_nh4bal_adjustments_col, default='inactive') + end if + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds, & + decomp_cpools_vr_col, decomp_cpools_col, decomp_cpools_1m_col) + ! + ! !DESCRIPTION: + ! Initializes time varying variables used only in coupled carbon-nitrogen mode (CN): + ! + ! !USES: + use decompMod , only : bounds_type + ! + ! !ARGUMENTS: + class(soilbiogeochem_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: decomp_cpools_vr_col(bounds%begc:,:,:) + real(r8) , intent(in) :: decomp_cpools_col(bounds%begc:,:) + real(r8) , intent(in) :: decomp_cpools_1m_col(bounds%begc:,:) + ! + ! !LOCAL VARIABLES: + integer :: fc,g,l,c,j,k ! indices + integer :: num_special_col ! number of good values in special_col filter + integer :: special_col (bounds%endc-bounds%begc+1) ! special landunit filter - columns + !------------------------------------------------------------------------ + + SHR_ASSERT_ALL_FL((ubound(decomp_cpools_col) == (/bounds%endc,ndecomp_pools/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_cpools_1m_col) == (/bounds%endc,ndecomp_pools/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(decomp_cpools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)), sourcefile, __LINE__) + + do c = bounds%begc, bounds%endc + l = col%landunit(c) +!matrix-spinup + if(use_soil_matrixcn)then + this%in_nacc(c,:) = 0._r8 +! this%tran_nacc(c,:,:) = 0._r8 + end if + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + + ! column nitrogen state variables + this%ntrunc_col(c) = 0._r8 + this%sminn_col(c) = 0._r8 + do j = 1, nlevdecomp + do k = 1, ndecomp_pools + this%decomp_npools_vr_col(c,j,k) = decomp_cpools_vr_col(c,j,k) / decomp_cascade_con%initial_cn_ratio(k) + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_vr_col(c,j,k) = decomp_cpools_vr_col(c,j,k) / decomp_cascade_con%initial_cn_ratio(k) + this%in_nacc_2d(c,j,k) = 0._r8 + this%vert_up_tran_nacc(c,j,k) = 0._r8 + this%vert_down_tran_nacc(c,j,k) = 0._r8 + this%exit_nacc(c,j,k) = 0._r8 + this%decomp0_npools_vr_col(c,j,k) = max(this%decomp_npools_vr_col(c,j,k),1.e-30_r8) + this%decomp_npools_vr_SASUsave_col(c,j,k) = 0._r8 + end if + end do + if(use_soil_matrixcn)then + do k = 1, ndecomp_cascade_transitions + this%hori_tran_nacc(c,j,k) = 0._r8 + end do + end if + + this%sminn_vr_col(c,j) = 0._r8 + this%ntrunc_vr_col(c,j) = 0._r8 + end do + + if(use_soil_matrixcn)then + do j = 1,decomp_cascade_con%n_all_entries + this%AKXnacc%M(c,j) = 0._r8 + end do + end if + + if ( nlevdecomp > 1 ) then + do j = nlevdecomp+1, nlevdecomp_full + do k = 1, ndecomp_pools + this%decomp_npools_vr_col(c,j,k) = 0._r8 + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_vr_col(c,j,k) = 0._r8 + this%in_nacc_2d(c,j,k) = 0._r8 + this%vert_up_tran_nacc(c,j,k) = 0._r8 + this%vert_down_tran_nacc(c,j,k) = 0._r8 + this%exit_nacc(c,j,k) = 0._r8 + this%decomp0_npools_vr_col(c,j,k) = this%decomp_npools_vr_col(c,j,k) + end if + end do + if(use_soil_matrixcn)then + do k = 1, ndecomp_cascade_transitions + this%hori_tran_nacc(c,j,k) = 0._r8 + end do + end if + this%sminn_vr_col(c,j) = 0._r8 + this%ntrunc_vr_col(c,j) = 0._r8 + end do + end if + do k = 1, ndecomp_pools + this%decomp_npools_col(c,k) = decomp_cpools_col(c,k) / decomp_cascade_con%initial_cn_ratio(k) + this%decomp_npools_1m_col(c,k) = decomp_cpools_1m_col(c,k) / decomp_cascade_con%initial_cn_ratio(k) + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_col(c,k) = decomp_cpools_col(c,k) / decomp_cascade_con%initial_cn_ratio(k) + end if + end do + + if (use_nitrif_denitrif) then + do j = 1, nlevdecomp_full + this%smin_nh4_vr_col(c,j) = 0._r8 + this%smin_no3_vr_col(c,j) = 0._r8 + end do + this%smin_nh4_col(c) = 0._r8 + this%smin_no3_col(c) = 0._r8 + end if + 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 + + ! initialize fields for special filters + + num_special_col = 0 + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + num_special_col = num_special_col + 1 + special_col(num_special_col) = c + end if + end do + + call this%SetValues (num_column=num_special_col, filter_column=special_col, value_column=0._r8) + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart ( this, bounds, ncid, flag, totvegc_col ) + ! + ! !DESCRIPTION: + ! Read/write CN restart data for nitrogen state + ! + ! !USES: + use shr_infnan_mod , only : isnan => shr_infnan_isnan, nan => shr_infnan_nan, assignment(=) + use clm_time_manager , only : is_restart, get_nstep + use restUtilMod + use ncdio_pio + ! + ! !ARGUMENTS: + class (soilbiogeochem_nitrogenstate_type) :: this + type(bounds_type) , intent(in) :: bounds + type(file_desc_t) , intent(inout) :: ncid + character(len=*) , intent(in) :: flag !'read' or 'write' or 'define' + real(r8) , intent(in) :: totvegc_col(bounds%begc:bounds%endc) ! (gC/m2) total vegetation carbon + + ! + ! !LOCAL VARIABLES: + integer :: i,j,k,l,c,fc + logical :: readvar + integer :: idata + logical :: exit_spinup = .false. + logical :: enter_spinup = .false. + logical :: found = .false. + real(r8) :: m ! multiplier for the exit_spinup code + real(r8), pointer :: ptr2d(:,:) ! temp. pointers for slicing larger arrays + real(r8), pointer :: ptr1d(:) ! temp. pointers for slicing larger arrays + character(len=128) :: varname ! temporary + integer :: itemp ! temporary + integer , pointer :: iptemp(:) ! pointer to memory to be allocated + ! spinup state as read from restart file, for determining whether to enter or exit spinup mode. + integer :: restart_file_spinup_state + ! flags for comparing the model and restart decomposition cascades + integer :: decomp_cascade_state, restart_file_decomp_cascade_state + integer :: i_decomp,j_decomp,i_lev,j_lev + !------------------------------------------------------------------------ + + ! sminn + if (use_vertsoilc) then + ptr2d => this%sminn_vr_col + call restartvar(ncid=ncid, flag=flag, varname="sminn_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%sminn_vr_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname="sminn", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + if (flag=='read' .and. .not. readvar) then + call endrun(msg='ERROR::'//trim(varname)//' is required on an initialization dataset'//& + errMsg(sourcefile, __LINE__)) + end if + + ! decomposing N pools + do k = 1, ndecomp_pools + varname=trim(decomp_cascade_con%decomp_pool_name_restart(k))//'n' + if (use_vertsoilc) then + ptr2d => this%decomp_npools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%decomp_npools_vr_col(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=varname, xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + if (flag=='read' .and. .not. readvar) then + call endrun(msg='ERROR:: '//trim(varname)//' is required on an initialization dataset'//& + errMsg(sourcefile, __LINE__)) + end if + end do + if(flag=='write')then + if(use_soil_matrixcn)then + do i = 1,ndecomp_pools + do j = 1,nlevdecomp + this%in_nacc_2d(:,j,i) = this%in_nacc(:,j+(i-1)*nlevdecomp) + end do + end do + do i = 1,decomp_cascade_con%n_all_entries + found = .false. + j_lev = mod(decomp_cascade_con%all_j(i) - 1,nlevdecomp) + 1 + j_decomp = (decomp_cascade_con%all_j(i) - j_lev)/nlevdecomp + 1 + i_lev = mod(decomp_cascade_con%all_i(i) - 1,nlevdecomp) + 1 + i_decomp = (decomp_cascade_con%all_i(i) - i_lev)/nlevdecomp + 1 + if(i_decomp .eq. j_decomp .and. j_lev - i_lev .eq. 1)then + this%vert_up_tran_nacc(:,i_lev,i_decomp) = this%AKXnacc%M(:,i) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev - j_lev .eq. 1)then + this%vert_down_tran_nacc(:,i_lev,i_decomp) = this%AKXnacc%M(:,i) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev .eq. j_lev)then + this%exit_nacc(:,i_lev,i_decomp) = this%AKXnacc%M(:,i) + found = .true. + else + do k=1,ndecomp_cascade_transitions + if(i_decomp .ne. j_decomp .and. i_lev .eq. j_lev .and. & + i_decomp .eq. decomp_cascade_con%cascade_receiver_pool(k) .and. & + j_decomp .eq. decomp_cascade_con%cascade_donor_pool(k) .and. .not. found)then + this%hori_tran_nacc(:,i_lev,k) = this%AKXnacc%M(:,i) + found = .true. + end if + end do + end if + end if + end if + if(.not. found) write(iulog,*) 'Error in storing matrix restart variables',i,i_decomp,j_decomp,i_lev,j_lev + end do + end if + end if + if(use_soil_matrixcn)then + do k = 1, ndecomp_pools + varname=trim(decomp_cascade_con%decomp_pool_name_restart(k))//'n' + if (use_vertsoilc) then + ptr2d => this%matrix_cap_decomp_npools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_Cap_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%decomp0_npools_vr_col(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"0_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%matrix_cap_decomp_npools_vr_col(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_Cap", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval,& + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%decomp0_npools_vr_col(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"0", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + if(use_vertsoilc)then + ptr2d => this%in_nacc_2d(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_input_nacc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%vert_up_tran_nacc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_up_tran_nacc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%vert_down_tran_nacc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_down_tran_nacc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + ptr2d => this%exit_nacc(:,:,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_exit_nacc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%in_nacc_2d(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_input_nacc", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval,& + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%vert_up_tran_nacc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_up_tran_nacc", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval,& + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%vert_down_tran_nacc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_vert_down_tran_nacc", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval,& + interpinic_flag='interp', readvar=readvar, data=ptr1d) + ptr1d => this%exit_nacc(:,1,k) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_exit_nacc", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval,& + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + end do + end if + + if(use_soil_matrixcn)then + do i = 1, ndecomp_cascade_transitions + varname=trim(decomp_cascade_con%cascade_step_name(i))//'n' + if(use_vertsoilc)then + ptr2d => this%hori_tran_nacc(:,:,i) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_hori_tran_nacc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%hori_tran_nacc(:,1,i) + call restartvar(ncid=ncid, flag=flag, varname=trim(varname)//"_hori_tran_nacc", xtype=ncd_double, & + dim1name='column', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + end do + end if + + if(use_soil_matrixcn)then + if(flag=='read')then + do i = 1,ndecomp_pools + do j = 1,nlevdecomp + this%in_nacc(:,j+(i-1)*nlevdecomp) = this%in_nacc_2d(:,j,i) + end do + end do + do i = 1,decomp_cascade_con%n_all_entries + found = .false. + j_lev = mod(decomp_cascade_con%all_j(i) - 1,nlevdecomp) + 1 + j_decomp = (decomp_cascade_con%all_j(i) - j_lev)/nlevdecomp + 1 + i_lev = mod(decomp_cascade_con%all_i(i) - 1,nlevdecomp) + 1 + i_decomp = (decomp_cascade_con%all_i(i) - i_lev)/nlevdecomp + 1 + if(i_decomp .eq. j_decomp .and. j_lev - i_lev .eq. 1)then + this%AKXnacc%M(:,i) = this%vert_up_tran_nacc(:,i_lev,i_decomp) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev - j_lev .eq. 1)then + this%AKXnacc%M(:,i) = this%vert_down_tran_nacc(:,i_lev,i_decomp) + found = .true. + else + if(i_decomp .eq. j_decomp .and. i_lev .eq. j_lev)then + this%AKXnacc%M(:,i) = this%exit_nacc(:,i_lev,i_decomp) + found = .true. + else + do k=1,ndecomp_cascade_transitions + if(i_decomp .ne. j_decomp .and. i_lev .eq. j_lev .and. & + i_decomp .eq. decomp_cascade_con%cascade_receiver_pool(k) .and. & + j_decomp .eq. decomp_cascade_con%cascade_donor_pool(k) .and. .not. found)then + this%AKXnacc%M(:,i) = this%hori_tran_nacc(:,i_lev,k) + found = .true. + end if + end do + end if + end if + end if + if(.not. found) write(iulog,*) 'Error in storing matrix restart variables',i + end do + end if + end if + + if (use_vertsoilc) then + ptr2d => this%ntrunc_vr_col + call restartvar(ncid=ncid, flag=flag, varname="col_ntrunc_vr", xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%ntrunc_vr_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname="col_ntrunc", xtype=ncd_double, & + dim1name='column', & + long_name='', units='', fill_value=spval, & + interpinic_flag='interp' , readvar=readvar, data=ptr1d) + end if + + if (use_nitrif_denitrif) then + ! smin_no3_vr + if (use_vertsoilc) then + ptr2d => this%smin_no3_vr_col(:,:) + call restartvar(ncid=ncid, flag=flag, varname='smin_no3_vr', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%smin_no3_vr_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname='smin_no3', xtype=ncd_double, & + dim1name='column', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + if (flag=='read' .and. .not. readvar) then + call endrun(msg= 'ERROR:: smin_no3_vr'//' is required on an initialization dataset' ) + end if + end if + + if (use_nitrif_denitrif) then + ! smin_nh4 + if (use_vertsoilc) then + ptr2d => this%smin_nh4_vr_col(:,:) + call restartvar(ncid=ncid, flag=flag, varname='smin_nh4_vr', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr2d) + else + ptr1d => this%smin_nh4_vr_col(:,1) + call restartvar(ncid=ncid, flag=flag, varname='smin_nh4', xtype=ncd_double, & + dim1name='column', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=ptr1d) + end if + if (flag=='read' .and. .not. readvar) then + call endrun(msg= 'ERROR:: smin_nh4_vr'//' is required on an initialization dataset' ) + end if + end if + + ! decomp_cascade_state - the purpose of this is to check to make sure the bgc used + ! matches what the restart file was generated with. + ! add info about the SOM decomposition cascade + + if (use_century_decomp) then + decomp_cascade_state = 1 + else + decomp_cascade_state = 0 + end if + ! add info about the nitrification / denitrification state + if (use_nitrif_denitrif) then + decomp_cascade_state = decomp_cascade_state + 10 + end if + if (flag == 'write') itemp = decomp_cascade_state + call restartvar(ncid=ncid, flag=flag, varname='decomp_cascade_state', xtype=ncd_int, & + long_name='BGC of the model that wrote this restart file:' & + // ' 1s column: 0 = CLM-CN cascade, 1 = Century cascade;' & + // ' 10s column: 0 = CLM-CN denitrification, 10 = Century denitrification', units='', & + interpinic_flag='skip', readvar=readvar, data=itemp) + if (flag=='read') then + if (.not. readvar) then + ! assume, for sake of backwards compatibility, that if decomp_cascade_state + ! is not in the restart file, then the current model state is the same as + ! the prior model state + restart_file_decomp_cascade_state = decomp_cascade_state + if ( masterproc ) write(iulog,*) ' CNRest: WARNING! Restart file does not ' & + // ' contain info on decomp_cascade_state used to generate the restart file. ' + if ( masterproc ) write(iulog,*) ' Assuming the same as current setting: ', decomp_cascade_state + else + restart_file_decomp_cascade_state = itemp + if (decomp_cascade_state /= restart_file_decomp_cascade_state ) then + if ( masterproc ) then + write(iulog,*) 'CNRest: ERROR--the decomposition cascade differs between the current ' & + // ' model state and the model that wrote the restart file. ' + write(iulog,*) 'The model will be horribly out of equilibrium until after a lengthy spinup. ' + write(iulog,*) 'Stopping here since this is probably an error in configuring the run. ' + write(iulog,*) 'If you really wish to proceed, then override by setting ' + write(iulog,*) 'override_bgc_restart_mismatch_dump to .true. in the namelist' + if ( .not. override_bgc_restart_mismatch_dump ) then + call endrun(msg= ' CNRest: Stopping. Decomposition cascade mismatch error.'//& + errMsg(sourcefile, __LINE__)) + endif + endif + endif + end if + end if + + !-------------------------------- + ! Spinup state + !-------------------------------- + + ! Do nothing for write + ! Note that the call to write spinup_state out was done in soilbiogeochem_carbonstate_inst and + ! cannot be called again because it will try to define the variable twice + ! when the flag below is set to define + if (flag == 'read') then + call restartvar(ncid=ncid, flag=flag, varname='spinup_state', xtype=ncd_int, & + long_name='Spinup state of the model that wrote this restart file: ' & + // ' 0 = normal model mode, 1 = AD spinup', units='', & + interpinic_flag='copy', readvar=readvar, data=idata) + if (readvar) then + restart_file_spinup_state = idata + else + ! assume, for sake of backwards compatibility, that if spinup_state is not in + ! the restart file then current model state is the same as prior model state + restart_file_spinup_state = spinup_state + if ( masterproc ) then + write(iulog,*) ' WARNING! Restart file does not contain info ' & + // ' on spinup state used to generate the restart file. ' + write(iulog,*) ' Assuming the same as current setting: ', spinup_state + end if + end if + end if + + ! now compare the model and restart file spinup states, and either take the + ! model into spinup mode or out of it if they are not identical + ! taking model out of spinup mode requires multiplying each decomposing pool + ! by the associated AD factor. + ! putting model into spinup mode requires dividing each decomposing pool + ! by the associated AD factor. + ! only allow this to occur on first timestep of model run. + + if (flag == 'read' .and. spinup_state /= restart_file_spinup_state ) then + if (spinup_state == 0 .and. restart_file_spinup_state >= 1 ) then + if ( masterproc ) write(iulog,*) ' NitrogenStateType Restart: taking SOM pools out of AD spinup mode' + exit_spinup = .true. + else if (spinup_state >= 1 .and. restart_file_spinup_state == 0 ) then + if ( masterproc ) write(iulog,*) ' NitrogenStateType Restart: taking SOM pools into AD spinup mode' + enter_spinup = .true. + else + call endrun(msg=' Error in entering/exiting spinup. spinup_state ' & + // ' != restart_file_spinup_state, but do not know what to do'//& + errMsg(sourcefile, __LINE__)) + end if + if (get_nstep() >= 2) then + call endrun(msg=' Error in entering/exiting spinup - should occur only when nstep = 1'//& + errMsg(sourcefile, __LINE__)) + endif + if ( exit_spinup .and. isnan(this%totvegcthresh) )then + call endrun(msg=' Error in exit spinup - totvegcthresh was not set with SetTotVgCThresh'//& + errMsg(sourcefile, __LINE__)) + end if + do k = 1, ndecomp_pools + if ( exit_spinup ) then + m = decomp_cascade_con%spinup_factor(k) + else if ( enter_spinup ) then + m = 1. / decomp_cascade_con%spinup_factor(k) + end if + do c = bounds%begc, bounds%endc + l = col%landunit(c) + do j = 1, nlevdecomp + if ( abs(m - 1._r8) .gt. 0.000001_r8 .and. exit_spinup) then + this%decomp_npools_vr_col(c,j,k) = this%decomp_npools_vr_col(c,j,k) * m * & + get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + ! If there is no vegetation nitrogen, + ! implying that all vegetation has + ! died, then + ! reset decomp pools to near zero during exit_spinup to + ! avoid very + ! large and inert soil carbon stocks; note that only + ! pools with spinup factor > 1 + ! will be affected, which means that total SOMN and LITN + ! pools will not be set to 0. + if (totvegc_col(c) <= this%totvegcthresh .and. lun%itype(l) /= istcrop) then + this%decomp_npools_vr_col(c,j,k) = 0._r8 + endif + elseif ( abs(m - 1._r8) .gt. 0.000001_r8 .and. enter_spinup) then + this%decomp_npools_vr_col(c,j,k) = this%decomp_npools_vr_col(c,j,k) * m / & + get_spinup_latitude_term(grc%latdeg(col%gridcell(c))) + else + this%decomp_npools_vr_col(c,j,k) = this%decomp_npools_vr_col(c,j,k) * m + endif + end do + end do + end do + end if + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine SetValues ( this, num_column, filter_column, value_column ) + ! + ! !DESCRIPTION: + ! Set nitrogen state variables + ! + ! !ARGUMENTS: + class (soilbiogeochem_nitrogenstate_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 ! indices + !------------------------------------------------------------------------ + + do fi = 1,num_column + i = filter_column(fi) + + this%sminn_col(i) = value_column + this%ntrunc_col(i) = value_column + this%cwdn_col(i) = value_column + if (use_nitrif_denitrif) then + this%smin_no3_col(i) = value_column + this%smin_nh4_col(i) = value_column + end if + this%totlitn_col(i) = value_column + this%totsomn_col(i) = value_column + this%totsomn_1m_col(i) = value_column + this%totlitn_1m_col(i) = value_column + end do + + do j = 1,nlevdecomp_full + do fi = 1,num_column + i = filter_column(fi) + this%sminn_vr_col(i,j) = value_column + this%ntrunc_vr_col(i,j) = value_column + if (use_nitrif_denitrif) then + this%smin_no3_vr_col(i,j) = value_column + this%smin_nh4_vr_col(i,j) = value_column + end if + end do + end do + + ! column and decomp_pools + do k = 1, ndecomp_pools + do fi = 1,num_column + i = filter_column(fi) + this%decomp_npools_col(i,k) = value_column + this%decomp_npools_1m_col(i,k) = value_column + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_col(i,k) = value_column + end if + end do + end do + + ! column levdecomp, and decomp_pools + do j = 1,nlevdecomp_full + do k = 1, ndecomp_pools + do fi = 1,num_column + i = filter_column(fi) + this%decomp_npools_vr_col(i,j,k) = value_column + if(use_soil_matrixcn)then + this%matrix_cap_decomp_npools_vr_col(i,j,k) = value_column + this%decomp0_npools_vr_col(i,j,k) = value_column + end if + end do + end do + end do + + if(use_soil_matrixcn)then + do j = 1,nlevdecomp + do k = 1, ndecomp_pools + do fi = 1, num_column + i = filter_column(fi) + this%in_nacc_2d(i,j,k) = value_column + this%vert_up_tran_nacc(i,j,k) = value_column + this%vert_down_tran_nacc(i,j,k) = value_column + this%exit_nacc(i,j,k) = value_column + end do + end do + do k = 1, ndecomp_cascade_transitions + do fi = 1, num_column + i = filter_column(fi) + this%hori_tran_nacc(i,j,k) = value_column + end do + end do + end do + end if + + if(use_soil_matrixcn)then + do j = 1,decomp_cascade_con%n_all_entries + do fi = 1, num_column + i = filter_column(fi) + this%AKXnacc%M(i,j) = value_column + end do + end do + end if + + end subroutine SetValues + + !----------------------------------------------------------------------- + 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 DynamicColumnAdjustments(this, bounds, clump_index, column_state_updater) + ! + ! !DESCRIPTION: + ! Adjust state variables when column areas change due to dynamic landuse + ! + ! !USES: + use dynColumnStateUpdaterMod, only : column_state_updater_type + ! + ! !ARGUMENTS: + class(soilbiogeochem_nitrogenstate_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 + + type(column_state_updater_type) , intent(in) :: column_state_updater + ! + ! !LOCAL VARIABLES: + integer :: j ! level + integer :: l ! decomp pool + real(r8) :: adjustment_one_level(bounds%begc:bounds%endc) + integer :: begc, endc + + character(len=*), parameter :: subname = 'DynamicColumnAdjustments' + !----------------------------------------------------------------------- + + begc = bounds%begc + endc = bounds%endc + + this%dyn_nbal_adjustments_col(begc:endc) = 0._r8 + + do l = 1, ndecomp_pools + do j = 1, nlevdecomp + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%decomp_npools_vr_col(begc:endc, j, l), & + adjustment = adjustment_one_level(begc:endc)) + this%dyn_nbal_adjustments_col(begc:endc) = & + this%dyn_nbal_adjustments_col(begc:endc) + & + adjustment_one_level(begc:endc) * dzsoi_decomp(j) + end do + end do + + do j = 1, nlevdecomp + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%ntrunc_vr_col(begc:endc, j), & + adjustment = adjustment_one_level(begc:endc)) + this%dyn_nbal_adjustments_col(begc:endc) = & + this%dyn_nbal_adjustments_col(begc:endc) + & + adjustment_one_level(begc:endc) * dzsoi_decomp(j) + + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%sminn_vr_col(begc:endc, j), & + adjustment = adjustment_one_level(begc:endc)) + this%dyn_nbal_adjustments_col(begc:endc) = & + this%dyn_nbal_adjustments_col(begc:endc) + & + adjustment_one_level(begc:endc) * dzsoi_decomp(j) + end do + + if (use_nitrif_denitrif) then + + do j = 1, nlevdecomp + ! Separately track adjustments made to no3 and nh4 pools, since those aren't included + ! in the overall N balance (totn) + this%dyn_no3bal_adjustments_col(begc:endc) = 0._r8 + this%dyn_nh4bal_adjustments_col(begc:endc) = 0._r8 + + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%smin_no3_vr_col(begc:endc, j), & + adjustment = adjustment_one_level(begc:endc)) + this%dyn_no3bal_adjustments_col(begc:endc) = & + this%dyn_no3bal_adjustments_col(begc:endc) + & + adjustment_one_level(begc:endc) * dzsoi_decomp(j) + + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%smin_nh4_vr_col(begc:endc, j), & + adjustment = adjustment_one_level(begc:endc)) + this%dyn_nh4bal_adjustments_col(begc:endc) = & + this%dyn_nh4bal_adjustments_col(begc:endc) + & + adjustment_one_level(begc:endc) * dzsoi_decomp(j) + end do + + end if + + end subroutine DynamicColumnAdjustments + + !------------------------------------------------------------------------ + subroutine SetTotVgCThresh(this, totvegcthresh) + + class(soilbiogeochem_nitrogenstate_type) :: this + real(r8) , intent(in) :: totvegcthresh + + 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_orig_files/SoilBiogeochemPotentialMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemPotentialMod.F90 new file mode 100644 index 000000000..b9b9afad0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SoilBiogeochemPrecisionControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemPrecisionControlMod.F90 new file mode 100644 index 000000000..3740700ab --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SoilBiogeochemStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemStateType.F90 new file mode 100644 index 000000000..118c42d3a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemStateType.F90 @@ -0,0 +1,300 @@ +module SoilBiogeochemStateType + + use shr_kind_mod , only : r8 => shr_kind_r8 + 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 clm_varpar , only : nlevsno, nlevgrnd, nlevlak, nlevsoifl, nlevsoi + use clm_varpar , only : ndecomp_cascade_transitions, nlevdecomp, nlevdecomp_full + use clm_varcon , only : spval, ispval, c14ratio, grlnd + use landunit_varcon, only : istsoil, istcrop + use clm_varpar , only : nlevsno, nlevgrnd, nlevlak + use clm_varctl , only : use_vertsoilc, use_cn + use clm_varctl , only : iulog + use LandunitType , only : lun + use ColumnType , only : col + ! + ! !PUBLIC TYPES: + implicit none + private + ! + ! !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 + procedure, public :: Restart + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type soilbiogeochem_state_type + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(soilbiogeochem_state_type) :: this + type(bounds_type), intent(in) :: bounds + + call this%InitAllocate ( bounds ) + if (use_cn) then + call this%InitHistory ( bounds ) + end if + call this%InitCold ( bounds ) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(soilbiogeochem_state_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + !------------------------------------------------------------------------ + + 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 + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use histFileMod , only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp, no_snow_normal + use CNSharedParamsMod , only : use_fun + ! + ! !ARGUMENTS: + class(soilbiogeochem_state_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + character(8) :: vr_suffix + character(10) :: active + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + this%croot_prof_patch(begp:endp,:) = spval + call hist_addfld_decomp (fname='CROOT_PROF', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='profile for litter C and N inputs from coarse roots', & + ptr_patch=this%croot_prof_patch, default='inactive') + + this%froot_prof_patch(begp:endp,:) = spval + call hist_addfld_decomp (fname='FROOT_PROF', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='profile for litter C and N inputs from fine roots', & + ptr_patch=this%froot_prof_patch, default='inactive') + + this%leaf_prof_patch(begp:endp,:) = spval + call hist_addfld_decomp (fname='LEAF_PROF', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='profile for litter C and N inputs from leaves', & + ptr_patch=this%leaf_prof_patch, default='inactive') + + this%stem_prof_patch(begp:endp,:) = spval + call hist_addfld_decomp (fname='STEM_PROF', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='profile for litter C and N inputs from stems', & + ptr_patch=this%stem_prof_patch, default='inactive') + + this%nfixation_prof_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='NFIXATION_PROF', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='profile for biological N fixation', & + ptr_col=this%nfixation_prof_col, default='inactive') + + this%ndep_prof_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='NDEP_PROF', units='1/m', type2d='levdcmp', & + avgflag='A', long_name='profile for atmospheric N deposition', & + ptr_col=this%ndep_prof_col, default='inactive') + + this%som_adv_coef_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SOM_ADV_COEF', units='m/s', type2d='levdcmp', & + avgflag='A', long_name='advection term for vertical SOM translocation', & + ptr_col=this%som_adv_coef_col, default='inactive') + + this%som_diffus_coef_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='SOM_DIFFUS_COEF', units='m^2/s', type2d='levdcmp', & + avgflag='A', long_name='diffusion coefficient for vertical SOM translocation', & + ptr_col=this%som_diffus_coef_col, default='inactive') + + if ( nlevdecomp_full > 1 ) then + this%fpi_col(begc:endc) = spval + call hist_addfld1d (fname='FPI', units='proportion', & + avgflag='A', long_name='fraction of potential immobilization', & + ptr_col=this%fpi_col) + endif + + if (.not. use_fun) then + this%fpg_col(begc:endc) = spval + call hist_addfld1d (fname='FPG', units='proportion', & + avgflag='A', long_name='fraction of potential gpp', & + ptr_col=this%fpg_col) + end if + + if (nlevdecomp > 1) then + vr_suffix = "_vr" + else + vr_suffix = "" + endif + this%fpi_vr_col(begc:endc,:) = spval + call hist_addfld_decomp (fname='FPI'//trim(vr_suffix), units='proportion', type2d='levdcmp', & + avgflag='A', long_name='fraction of potential immobilization', & + ptr_col=this%fpi_vr_col, default='inactive') + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine initCold(this, bounds) + ! + ! !USES: + use spmdMod , only : masterproc + use fileutils , only : getfil + use ncdio_pio + ! + ! !ARGUMENTS: + class(soilbiogeochem_state_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g,l,c,p,n,j,m ! indices + integer :: dimid ! dimension id + integer :: ier ! error status + logical :: readvar + integer :: begc, endc + !----------------------------------------------------------------------- + + begc = bounds%begc; endc= bounds%endc + + ! -------------------------------------------------------------------- + ! Initialize terms needed for dust model + ! -------------------------------------------------------------------- + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%ifspecial(l)) then + this%fpi_col (c) = spval + this%fpg_col (c) = spval + do j = 1,nlevdecomp_full + this%fpi_vr_col(c,j) = spval + end do + end if + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + ! initialize fpi_vr so that levels below nlevsoi are not nans + this%fpi_vr_col(c,1:nlevdecomp_full) = 0._r8 + this%som_adv_coef_col(c,1:nlevdecomp_full) = 0._r8 + this%som_diffus_coef_col(c,1:nlevdecomp_full) = 0._r8 + + ! initialize the profiles for converting to vertically resolved carbon pools + this%nfixation_prof_col(c,1:nlevdecomp_full) = 0._r8 + this%ndep_prof_col(c,1:nlevdecomp_full) = 0._r8 + end if + end do + + end subroutine initCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !USES: + use shr_log_mod, only : errMsg => shr_log_errMsg + use restUtilMod + use ncdio_pio + ! + ! !ARGUMENTS: + class(soilbiogeochem_state_type) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid + character(len=*) , intent(in) :: flag + ! + ! !LOCAL VARIABLES: + logical :: readvar ! determine if variable is on initial file + !----------------------------------------------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='fpg', xtype=ncd_double, & + dim1name='column', & + long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fpg_col) + + end subroutine Restart + + + 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_orig_files/SoilBiogeochemVerticalProfileMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilBiogeochemVerticalProfileMod.F90 new file mode 100644 index 000000000..fe689d975 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SoilStateInitTimeConstMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilStateInitTimeConstMod.F90 new file mode 100644 index 000000000..3dfc7e0aa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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 clm_nlUtilsMod , only : find_nlgroup_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 find_nlgroup_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, ncd_double, ncd_int, ncd_inqvdlen + use ncdio_pio , only : ncd_pio_openfile, ncd_pio_closefile, ncd_inqdlen + use clm_varpar , only : numrad + use clm_varpar , only : nlevsoi, nlevgrnd, nlevlak, nlevsoifl, nlayer, nlayert, nlevmaxurbgrnd, nlevsno + use clm_varcon , only : zsoi, dzsoi, zisoi, spval + use clm_varcon , only : secspday, pc, mu, denh2o, denice, grlnd + use clm_varctl , only : use_cn, use_lch4, use_fates + use clm_varctl , only : iulog, fsurdat, paramfile, soil_layerstruct_predefined + 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_orig_files/SoilStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilStateType.F90 new file mode 100644 index 000000000..f5b75324c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilStateType.F90 @@ -0,0 +1,415 @@ +module SoilStateType + + !------------------------------------------------------------------------------ + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + 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 clm_varpar , only : nlevsoi, nlevgrnd, nlevlak, nlayer, nlevsno, nlevmaxurbgrnd + use clm_varcon , only : spval + use clm_varctl , only : use_hydrstress, use_cn, use_lch4, use_dynroot, use_fates + use clm_varctl , only : iulog, hist_wrtch4diag + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + ! + implicit none + save + private + ! + ! !PUBLIC TYPES: + 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 :: 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 + procedure, public :: Restart + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type soilstate_type + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(soilstate_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) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !ARGUMENTS: + class(soilstate_type) :: 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%mss_frc_cly_vld_col (begc:endc)) ; this%mss_frc_cly_vld_col (:) = nan + allocate(this%sandfrac_patch (begp:endp)) ; this%sandfrac_patch (:) = nan + allocate(this%clayfrac_patch (begp:endp)) ; this%clayfrac_patch (:) = nan + allocate(this%cellorg_col (begc:endc,nlevsoi)) ; this%cellorg_col (:,:) = nan + allocate(this%cellsand_col (begc:endc,nlevsoi)) ; this%cellsand_col (:,:) = nan + allocate(this%cellclay_col (begc:endc,nlevsoi)) ; this%cellclay_col (:,:) = nan + 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%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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! History fields initialization + ! + ! !USES: + use histFileMod , only: hist_addfld1d, hist_addfld2d, no_snow_normal + ! + ! !ARGUMENTS: + class(soilstate_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: begp, endp + character(10) :: active + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !--------------------------------------------------------------------- + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + + if (use_lch4) then + if (hist_wrtch4diag) then + active = "active" + else + active = "inactive" + end if + else + active = "inactive" + end if + + call hist_addfld2d (fname='SMP', units='mm', type2d='levgrnd', & + avgflag='A', long_name='soil matric potential (natural vegetated and crop landunits only)', & + ptr_col=this%smp_l_col, set_spec=spval, l2g_scale_type='veg') + + this%root_conductance_patch(begp:endp,:) = spval + call hist_addfld2d (fname='KROOT', units='1/s', type2d='levsoi', & + avgflag='A', long_name='root conductance each soil layer', & + ptr_patch=this%root_conductance_patch, default='inactive') + + this%soil_conductance_patch(begp:endp,:) = spval + call hist_addfld2d (fname='KSOIL', units='1/s', type2d='levsoi', & + avgflag='A', long_name='soil conductance in each soil layer', & + ptr_patch=this%soil_conductance_patch, default='inactive') + + if (use_cn) then + this%bsw_col(begc:endc,:) = spval + call hist_addfld2d (fname='bsw', units='unitless', type2d='levgrnd', & + avgflag='A', long_name='clap and hornberger B', & + ptr_col=this%bsw_col, default='inactive') + end if + + if (use_dynroot) then + this%rootfr_patch(begp:endp,:) = spval + call hist_addfld2d (fname='ROOTFR', units='proportion', type2d='levgrnd', & + avgflag='A', long_name='fraction of roots in each soil layer', & + ptr_patch=this%rootfr_patch, default='active') + end if + + if ( use_dynroot ) then + this%root_depth_patch(begp:endp) = spval + call hist_addfld1d (fname='ROOT_DEPTH', units="m", & + avgflag='A', long_name='rooting depth', & + ptr_patch=this%root_depth_patch ) + end if + + if (use_cn) then + this%rootr_patch(begp:endp,:) = spval + call hist_addfld2d (fname='ROOTR', units='proportion', type2d='levgrnd', & + avgflag='A', long_name='effective fraction of roots in each soil layer (SMS method)', & + ptr_patch=this%rootr_patch, l2g_scale_type='veg', default='inactive') + end if + + if (use_cn .and. .not.(use_hydrstress)) then + ! rootr_col isn't computed for use_hydrstress = .true. (In contrast, rootr_patch is + ! still computed, albeit using the inconsistent Soil Moisture Stress (SMS) method.) + ! (See also https://github.com/ESCOMP/CTSM/issues/812.) + this%rootr_col(begc:endc,:) = spval + call hist_addfld2d (fname='ROOTR_COLUMN', units='proportion', type2d='levgrnd', & + avgflag='A', long_name='effective fraction of roots in each soil layer (SMS method)', & + ptr_col=this%rootr_col, l2g_scale_type='veg', default='inactive') + + end if + + if (use_cn .or. use_fates) then + this%soilpsi_col(begc:endc,:) = spval + call hist_addfld2d (fname='SOILPSI', units='MPa', type2d='levgrnd', & + avgflag='A', long_name='soil water potential in each soil layer', & + ptr_col=this%soilpsi_col, default='inactive') + end if + + this%thk_col(begc:endc,-nlevsno+1:0) = spval + data2dptr => this%thk_col(:,-nlevsno+1:0) + call hist_addfld2d (fname='SNO_TK', units='W/m-K', type2d='levsno', & + avgflag='A', long_name='Thermal conductivity', & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') + + call hist_addfld2d (fname='SNO_TK_ICE', units='W/m-K', type2d='levsno', & + avgflag='A', long_name='Thermal conductivity (ice landunits only)', & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, & + l2g_scale_type='ice', default='inactive') + + this%hk_l_col(begc:endc,:) = spval + call hist_addfld2d (fname='HK', units='mm/s', type2d='levgrnd', & + avgflag='A', long_name='hydraulic conductivity (natural vegetated and crop landunits only)', & + ptr_col=this%hk_l_col, set_spec=spval, l2g_scale_type='veg', default='inactive') + + this%soilalpha_col(begc:endc) = spval + call hist_addfld1d (fname='SoilAlpha', units='unitless', & + avgflag='A', long_name='factor limiting ground evap', & + ptr_col=this%soilalpha_col, set_urb=spval, default='inactive' ) + + this%soilalpha_u_col(begc:endc) = spval + call hist_addfld1d (fname='SoilAlpha_U', units='unitless', & + avgflag='A', long_name='urban factor limiting ground evap', & + ptr_col=this%soilalpha_u_col, set_nourb=spval, default='inactive') + + if (use_cn) then + this%watsat_col(begc:endc,:) = spval + call hist_addfld2d (fname='watsat', units='m^3/m^3', type2d='levgrnd', & + avgflag='A', long_name='water saturated', & + ptr_col=this%watsat_col, default='inactive') + end if + + if (use_cn) then + this%eff_porosity_col(begc:endc,:) = spval + call hist_addfld2d (fname='EFF_POROSITY', units='proportion', type2d='levgrnd', & + avgflag='A', long_name='effective porosity = porosity - vol_ice', & + ptr_col=this%eff_porosity_col, default='inactive') + end if + + if (use_cn) then + this%watfc_col(begc:endc,:) = spval + call hist_addfld2d (fname='watfc', units='m^3/m^3', type2d='levgrnd', & + avgflag='A', long_name='water field capacity', & + ptr_col=this%watfc_col, default='inactive') + end if + + this%soilresis_col(begc:endc) = spval + call hist_addfld1d (fname='SOILRESIS', units='s/m', & + avgflag='A', long_name='soil resistance to evaporation', & + ptr_col=this%soilresis_col) + + this%dsl_col(begc:endc) = spval + call hist_addfld1d (fname='DSL', units='mm', & + avgflag='A', long_name='dry surface layer thickness', & + ptr_col=this%dsl_col) + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! Initialize module soil state variables to reasonable values + ! + ! !USES: + use clm_varpar , only : nlevgrnd + ! + ! !ARGUMENTS: + class(soilstate_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + + this%smp_l_col(bounds%begc:bounds%endc,1:nlevgrnd) = -1000._r8 + this%hk_l_col(bounds%begc:bounds%endc,1:nlevgrnd) = 0._r8 + + end subroutine InitCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_io, ncd_double + use restUtilMod + use spmdMod , only : masterproc + use RootBiophysMod , only : init_vegrootfr + ! + ! !ARGUMENTS: + class(soilstate_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 :: c + logical :: readvar + logical :: readrootfr = .false. + !------------------------------------------------------------------------ + + call restartvar(ncid=ncid, flag=flag, varname='DSL', xtype=ncd_double, & + dim1name='column', long_name='dsl thickness', units='mm', & + interpinic_flag='interp', readvar=readvar, data=this%dsl_col) + + call restartvar(ncid=ncid, flag=flag, varname='SOILRESIS', xtype=ncd_double, & + dim1name='column', long_name='soil resistance', units='s/m', & + interpinic_flag='interp', readvar=readvar, data=this%soilresis_col) + + call restartvar(ncid=ncid, flag=flag, varname='SMP', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='soil matric potential', units='mm', & + interpinic_flag='interp', readvar=readvar, data=this%smp_l_col) + + call restartvar(ncid=ncid, flag=flag, varname='HK', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='hydraulic conductivity', units='mm/s', & + interpinic_flag='interp', readvar=readvar, data=this%hk_l_col) + + if( use_dynroot ) then + call restartvar(ncid=ncid, flag=flag, varname='rootfr', xtype=ncd_double, & + dim1name='pft', dim2name='levgrnd', switchdim=.true., & + long_name='root fraction', units='', & + interpinic_flag='interp', readvar=readrootfr, data=this%rootfr_patch) + else + readrootfr = .false. + end if + if (flag=='read' .and. .not. readrootfr ) then + if (masterproc) then + write(iulog,*) "can't find rootfr in restart (or initial) file..." + write(iulog,*) "Initialize rootfr to default" + end if + call init_vegrootfr(bounds, nlevsoi, nlevgrnd, & + this%rootfr_patch(bounds%begp:bounds%endp,1:nlevgrnd), 'water') + call init_vegrootfr(bounds, nlevsoi, nlevgrnd, & + this%crootfr_patch(bounds%begp:bounds%endp,1:nlevgrnd), 'carbon') + end if + + end subroutine Restart + +end module SoilStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilWaterRetentionCurveMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SoilWaterRetentionCurveMod.F90 new file mode 100644 index 000000000..74f8299d5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/SolarAbsorbedType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SolarAbsorbedType.F90 new file mode 100644 index 000000000..2a9c9a754 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SolarAbsorbedType.F90 @@ -0,0 +1,477 @@ +module SolarAbsorbedType + + !------------------------------------------------------------------------------ + ! !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_varcon , only : spval + use clm_varctl , only : use_luna + ! + ! !PUBLIC TYPES: + implicit none + save + private + ! + ! !PUBLIC DATA MEMBERS: + 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 + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, public :: Restart + + end type solarabs_type + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(solarabs_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) + ! + ! Allocate module variables and data structures + ! + ! !USES: + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use clm_varpar , only : nlevcan, nlevcan, numrad, nlevsno + ! + ! !ARGUMENTS: + class(solarabs_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + 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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! History fields initialization + ! + ! !USES: + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use clm_varctl , only : use_snicar_frc , use_SSRE + use clm_varpar , only : nlevsno + use histFileMod , only : hist_addfld1d, hist_addfld2d + use histFileMod , only : no_snow_normal + ! + ! !ARGUMENTS: + class(solarabs_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 + real(r8), pointer :: ptr_1d(:) ! pointer to 1d patch array + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + this%fsa_patch(begp:endp) = spval + call hist_addfld1d (fname='FSA', units='W/m^2', & + avgflag='A', long_name='absorbed solar radiation', & + ptr_patch=this%fsa_patch, c2l_scale_type='urbanf') + + call hist_addfld1d (fname='FSA_ICE', units='W/m^2', & + avgflag='A', long_name='absorbed solar radiation (ice landunits only)', & + ptr_patch=this%fsa_patch, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%fsa_r_patch(begp:endp) = spval + call hist_addfld1d (fname='FSA_R', units='W/m^2', & + avgflag='A', long_name='Rural absorbed solar radiation', & + ptr_patch=this%fsa_r_patch, set_spec=spval, default='inactive') + + this%fsa_u_patch(begp:endp) = spval + call hist_addfld1d (fname='FSA_U', units='W/m^2', & + avgflag='A', long_name='Urban absorbed solar radiation', & + ptr_patch=this%fsa_u_patch, c2l_scale_type='urbanf', set_nourb=spval, default='inactive') + + this%fsr_patch(begp:endp) = spval + call hist_addfld1d (fname='FSR', units='W/m^2', & + avgflag='A', long_name='reflected solar radiation', & + ptr_patch=this%fsr_patch, c2l_scale_type='urbanf') + ! Rename of FSR for Urban intercomparision project + call hist_addfld1d (fname='SWup', units='W/m^2', & + avgflag='A', long_name='upwelling shortwave radiation', & + ptr_patch=this%fsr_patch, c2l_scale_type='urbanf', default='inactive') + call hist_addfld1d (fname='FSR_ICE', units='W/m^2', & + avgflag='A', long_name='reflected solar radiation (ice landunits only)', & + ptr_patch=this%fsr_patch, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%sabg_lyr_patch(begp:endp,-nlevsno+1:0) = spval + data2dptr => this%sabg_lyr_patch(:,-nlevsno+1:0) + call hist_addfld2d (fname='SNO_ABS', units='W/m^2', type2d='levsno', & + avgflag='A', long_name='Absorbed solar radiation in each snow layer', & + ptr_patch=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') + + call hist_addfld2d (fname='SNO_ABS_ICE', units='W/m^2', type2d='levsno', & + avgflag='A', long_name='Absorbed solar radiation in each snow layer (ice landunits only)', & + ptr_patch=data2dptr, no_snow_behavior=no_snow_normal, & + l2g_scale_type='ice', default='inactive') + + this%sabv_patch(begp:endp) = spval + call hist_addfld1d (fname='SABV', units='W/m^2', & + avgflag='A', long_name='solar rad absorbed by veg', & + ptr_patch=this%sabv_patch, c2l_scale_type='urbanf') + + this%sabg_patch(begp:endp) = spval + call hist_addfld1d (fname='SABG', units='W/m^2', & + avgflag='A', long_name='solar rad absorbed by ground', & + ptr_patch=this%sabg_patch, c2l_scale_type='urbanf') + + this%sabg_pen_patch(begp:endp) = spval + call hist_addfld1d (fname='SABG_PEN', units='watt/m^2', & + avgflag='A', long_name='Rural solar rad penetrating top soil or snow layer', & + ptr_patch=this%sabg_pen_patch, set_spec=spval) + + ! Currently needed by lake code - TODO should not be here + this%fsds_nir_d_patch(begp:endp) = spval + call hist_addfld1d (fname='FSDSND', units='W/m^2', & + avgflag='A', long_name='direct nir incident solar radiation', & + ptr_patch=this%fsds_nir_d_patch) + + this%fsds_nir_i_patch(begp:endp) = spval + call hist_addfld1d (fname='FSDSNI', units='W/m^2', & + avgflag='A', long_name='diffuse nir incident solar radiation', & + ptr_patch=this%fsds_nir_i_patch) + + this%fsds_nir_d_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='FSDSNDLN', units='W/m^2', & + avgflag='A', long_name='direct nir incident solar radiation at local noon', & + ptr_patch=this%fsds_nir_d_ln_patch) + + this%fsr_nir_d_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRND', units='W/m^2', & + avgflag='A', long_name='direct nir reflected solar radiation', & + ptr_patch=this%fsr_nir_d_patch, c2l_scale_type='urbanf') + + this%fsr_nir_i_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRNI', units='W/m^2', & + avgflag='A', long_name='diffuse nir reflected solar radiation', & + ptr_patch=this%fsr_nir_i_patch, c2l_scale_type='urbanf') + + this%fsr_nir_d_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRNDLN', units='W/m^2', & + avgflag='A', long_name='direct nir reflected solar radiation at local noon', & + ptr_patch=this%fsr_nir_d_ln_patch, c2l_scale_type='urbanf') + ! diagnostic fluxes for ESM-SnowMIP + if (use_SSRE) then + this%fsrSF_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRSF', units='W/m^2', & + avgflag='A', long_name='reflected solar radiation', & + ptr_patch=this%fsrSF_patch, c2l_scale_type='urbanf') + + this%ssre_fsr_patch(begp:endp) = spval + call hist_addfld1d (fname='SSRE_FSR', units='W/m^2', & + avgflag='A', long_name='surface snow effect on reflected solar radiation', & + ptr_patch=this%ssre_fsr_patch, c2l_scale_type='urbanf') + this%fsrSF_nir_d_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRSFND', units='W/m^2', & + avgflag='A', long_name='direct nir reflected solar radiation', & + ptr_patch=this%fsrSF_nir_d_patch, c2l_scale_type='urbanf') + + this%fsrSF_nir_i_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRSFNI', units='W/m^2', & + avgflag='A', long_name='diffuse nir reflected solar radiation', & + ptr_patch=this%fsrSF_nir_i_patch, c2l_scale_type='urbanf') + + this%fsrSF_nir_d_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRSFNDLN', units='W/m^2', & + avgflag='A', long_name='direct nir reflected solar radiation at local noon', & + ptr_patch=this%fsrSF_nir_d_ln_patch, c2l_scale_type='urbanf') + + this%ssre_fsr_nir_d_patch(begp:endp) = spval + call hist_addfld1d (fname='SSRE_FSRND', units='W/m^2', & + avgflag='A', long_name='surface snow effect on direct nir reflected solar radiation', & + ptr_patch=this%ssre_fsr_nir_d_patch, c2l_scale_type='urbanf') + + this%ssre_fsr_nir_i_patch(begp:endp) = spval + call hist_addfld1d (fname='SSRE_FSRNI', units='W/m^2', & + avgflag='A', long_name='surface snow effect on diffuse nir reflected solar radiation', & + ptr_patch=this%ssre_fsr_nir_i_patch, c2l_scale_type='urbanf') + + this%ssre_fsr_nir_d_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='SSRE_FSRNDLN', units='W/m^2', & + avgflag='A', long_name='surface snow effect on direct nir reflected solar radiation at local noon', & + ptr_patch=this%ssre_fsr_nir_d_ln_patch, c2l_scale_type='urbanf') + end if + this%sub_surf_abs_SW_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOINTABS', units='-', & + avgflag='A', long_name='Fraction of incoming solar absorbed by lower snow layers', & + ptr_patch=this%sub_surf_abs_SW_patch, set_lake=spval, set_urb=spval) + + if(use_luna)then + ptr_1d => this%par240d_z_patch(:,1) + call hist_addfld1d (fname='PAR240DZ', units='W/m^2', & + avgflag='A', long_name='10-day running mean of daytime patch absorbed PAR for leaves for top canopy layer', & + ptr_patch=ptr_1d, default='inactive') + ptr_1d => this%par240x_z_patch(:,1) + call hist_addfld1d (fname='PAR240XZ', units='W/m^2', & + avgflag='A', long_name='10-day running mean of maximum patch absorbed PAR for leaves for top canopy layer', & + ptr_patch=ptr_1d, default='inactive') + + endif + + end subroutine InitHistory + + !------------------------------------------------------------------------ + subroutine InitCold(this, bounds) + ! + ! Initialize module surface albedos to reasonable values + ! + use landunit_varcon, only : istsoil, istcrop + ! + ! !ARGUMENTS: + class(solarabs_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begl, endl + !----------------------------------------------------------------------- + + begl = bounds%begl; endl = bounds%endl + + this%sabs_roof_dir_lun (begl:endl, :) = 0._r8 + this%sabs_roof_dif_lun (begl:endl, :) = 0._r8 + this%sabs_sunwall_dir_lun (begl:endl, :) = 0._r8 + this%sabs_sunwall_dif_lun (begl:endl, :) = 0._r8 + this%sabs_shadewall_dir_lun (begl:endl, :) = 0._r8 + this%sabs_shadewall_dif_lun (begl:endl, :) = 0._r8 + this%sabs_improad_dir_lun (begl:endl, :) = 0._r8 + this%sabs_improad_dif_lun (begl:endl, :) = 0._r8 + this%sabs_perroad_dir_lun (begl:endl, :) = 0._r8 + this%sabs_perroad_dif_lun (begl:endl, :) = 0._r8 + + end subroutine InitCold + + !--------------------------------------------------------------------- + subroutine Restart(this, bounds, ncid, flag) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use shr_infnan_mod , only : shr_infnan_isnan + use clm_varctl , only : use_snicar_frc, iulog + use spmdMod , only : masterproc + use abortutils , only : endrun + use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_double, ncd_int, ncd_inqvdlen + use restUtilMod + ! + ! !ARGUMENTS: + class(solarabs_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: + logical :: readvar ! determine if variable is on initial file + integer :: p + !--------------------------------------------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='sabs_roof_dir', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='direct solar absorbed by roof per unit ground area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_roof_dir_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_roof_dif', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='diffuse solar absorbed by roof per unit ground area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_roof_dif_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_sunwall_dir', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='direct solar absorbed by sunwall per unit wall area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_sunwall_dir_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_sunwall_dif', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='diffuse solar absorbed by sunwall per unit wall area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_sunwall_dif_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_shadewall_dir', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='direct solar absorbed by shadewall per unit wall area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_shadewall_dir_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_shadewall_dif', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='diffuse solar absorbed by shadewall per unit wall area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_shadewall_dif_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_improad_dir', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='direct solar absorbed by impervious road per unit ground area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_improad_dir_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_improad_dif', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='diffuse solar absorbed by impervious road per unit ground area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_improad_dif_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_perroad_dir', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='direct solar absorbed by pervious road per unit ground area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_perroad_dir_lun) + + call restartvar(ncid=ncid, flag=flag, varname='sabs_perroad_dif', xtype=ncd_double, dim1name='landunit', & + dim2name='numrad', switchdim=.true., & + long_name='diffuse solar absorbed by pervious road per unit ground area per unit incident flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%sabs_perroad_dif_lun) + + if(use_luna)then + call restartvar(ncid=ncid, flag=flag, varname='par240d', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='10-day running mean of daytime absorbed PAR for leaves in canopy layer', units='W/m**2 leaf', & + interpinic_flag='interp', readvar=readvar, data=this%par240d_z_patch ) + call restartvar(ncid=ncid, flag=flag, varname='par24d', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='Accumulative daytime absorbed PAR for leaves in canopy layer for 24 hours', units='J/m**2 leaf', & + interpinic_flag='interp', readvar=readvar, data=this%par24d_z_patch ) + + call restartvar(ncid=ncid, flag=flag, varname='par240x', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='10-day running mean of maximum absorbed PAR for leaves in canopy layers', units='W/m**2 leaf', & + interpinic_flag='interp', readvar=readvar, data=this%par240x_z_patch ) + call restartvar(ncid=ncid, flag=flag, varname='par24x', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='Maximum absorbed PAR for leaves in canopy layer in 24 hours', units='J/m**2 leaf', & + interpinic_flag='interp', readvar=readvar, data=this%par24x_z_patch ) + + call restartvar(ncid=ncid, flag=flag, varname='parsun', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='Instaneous absorbed PAR for sunlit leaves in canopy layer', units='W/m**2 leaf', & + interpinic_flag='interp', readvar=readvar, data=this%parsun_z_patch ) + call restartvar(ncid=ncid, flag=flag, varname='parsha', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='Instaneous absorbed PAR for shaded leaves in canopy layer', units='W/m**2 leaf', & + interpinic_flag='interp', readvar=readvar, data=this%parsha_z_patch ) + + endif + + end subroutine Restart + +end module SolarAbsorbedType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SurfaceAlbedoMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SurfaceAlbedoMod.F90 new file mode 100644 index 000000000..e8f557f9b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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 : fsurdat, iulog, use_snicar_frc, use_SSRE + 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 + private :: 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_orig_files/SurfaceAlbedoType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SurfaceAlbedoType.F90 new file mode 100644 index 000000000..d8cb16398 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SurfaceAlbedoType.F90 @@ -0,0 +1,668 @@ +module SurfaceAlbedoType + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + use shr_kind_mod , only : r8 => shr_kind_r8 + use decompMod , only : bounds_type + use clm_varpar , only : numrad, nlevcan, nlevsno + use abortutils , only : endrun + use clm_varctl , only : use_SSRE + ! + ! !PUBLIC TYPES: + implicit none + save + ! + ! !PUBLIC DATA MEMBERS: + 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 + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, public :: Restart + + end type surfalb_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(surfalb_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) + ! + ! Allocate module variables and data structures + ! + ! !USES: + use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) + use clm_varcon , only: spval, ispval + use clm_varctl , only: use_SSRE + ! + ! !ARGUMENTS: + class(surfalb_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + !--------------------------------------------------------------------- + + 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 + + end subroutine InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! History fields initialization + ! + ! !USES: + use shr_kind_mod , only: cs => shr_kind_CS + use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) + use clm_varcon , only: spval + use histFileMod , only: hist_addfld1d, hist_addfld2d + ! + ! !ARGUMENTS: + class(surfalb_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + character(len=cs) :: defaultoutput + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + this%coszen_col(begc:endc) = spval + call hist_addfld1d (fname='COSZEN', units='none', & + avgflag='A', long_name='cosine of solar zenith angle', & + ptr_col=this%coszen_col, default='inactive') + + this%albgri_col(begc:endc,:) = spval + call hist_addfld2d (fname='ALBGRD', units='proportion', type2d='numrad', & + avgflag='A', long_name='ground albedo (direct)', & + ptr_col=this%albgrd_col, default='inactive') + + this%albgri_col(begc:endc,:) = spval + call hist_addfld2d (fname='ALBGRI', units='proportion', type2d='numrad', & + avgflag='A', long_name='ground albedo (indirect)', & + ptr_col=this%albgri_col, default='inactive') + + if (use_SSRE) then + this%albdSF_patch(begp:endp,:) = spval + call hist_addfld2d (fname='ALBDSF', units='proportion', type2d='numrad', & + avgflag='A', long_name='diagnostic snow-free surface albedo (direct)', & + ptr_patch=this%albdSF_patch, default='active', c2l_scale_type='urbanf') + this%albiSF_patch(begp:endp,:) = spval + call hist_addfld2d (fname='ALBISF', units='proportion', type2d='numrad', & + avgflag='A', long_name='diagnostic snow-free surface albedo (indirect)', & + ptr_patch=this%albiSF_patch, default='active', c2l_scale_type='urbanf') + defaultoutput = "active" + else + defaultoutput = "inactive" + end if + this%albd_patch(begp:endp,:) = spval + call hist_addfld2d (fname='ALBD', units='proportion', type2d='numrad', & + avgflag='A', long_name='surface albedo (direct)', & + ptr_patch=this%albd_patch, default=defaultoutput, c2l_scale_type='urbanf') + + this%albi_patch(begp:endp,:) = spval + call hist_addfld2d (fname='ALBI', units='proportion', type2d='numrad', & + avgflag='A', long_name='surface albedo (indirect)', & + ptr_patch=this%albi_patch, default=defaultoutput, c2l_scale_type='urbanf') + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! Initialize module surface albedos to reasonable values + ! + ! !ARGUMENTS: + class(surfalb_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: begp, endp + !----------------------------------------------------------------------- + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + this%albgrd_col (begc:endc, :) = 0.2_r8 + this%albgri_col (begc:endc, :) = 0.2_r8 + this%albsod_col (begc:endc, :) = 0.2_r8 + this%albsoi_col (begc:endc, :) = 0.2_r8 + this%albsnd_hst_col (begc:endc, :) = 0.6_r8 + this%albsni_hst_col (begc:endc, :) = 0.6_r8 + this%albd_patch (begp:endp, :) = 0.2_r8 + this%albi_patch (begp:endp, :) = 0.2_r8 + if (use_SSRE) then + this%albdSF_patch (begp:endp, :) = 0.2_r8 + this%albiSF_patch (begp:endp, :) = 0.2_r8 + end if + this%albgrd_pur_col (begc:endc, :) = 0.2_r8 + this%albgri_pur_col (begc:endc, :) = 0.2_r8 + this%albgrd_bc_col (begc:endc, :) = 0.2_r8 + this%albgri_bc_col (begc:endc, :) = 0.2_r8 + this%albgrd_oc_col (begc:endc, :) = 0.2_r8 + this%albgri_oc_col (begc:endc, :) = 0.2_r8 + this%albgrd_dst_col (begc:endc, :) = 0.2_r8 + this%albgri_dst_col (begc:endc, :) = 0.2_r8 + + this%fabi_patch (begp:endp, :) = 0.0_r8 + this%fabd_patch (begp:endp, :) = 0.0_r8 + this%fabi_sun_patch (begp:endp, :) = 0.0_r8 + this%fabd_sun_patch (begp:endp, :) = 0.0_r8 + this%fabd_sha_patch (begp:endp, :) = 0.0_r8 + this%fabi_sha_patch (begp:endp, :) = 0.0_r8 + this%ftdd_patch (begp:endp, :) = 1.0_r8 + this%ftid_patch (begp:endp, :) = 0.0_r8 + this%ftii_patch (begp:endp, :) = 1.0_r8 + + end subroutine InitCold + + !--------------------------------------------------------------------- + subroutine Restart(this, bounds, ncid, flag, & + tlai_patch, tsai_patch) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use clm_varctl , only : use_snicar_frc, iulog + use spmdMod , only : masterproc + use decompMod , only : bounds_type + use abortutils , only : endrun + use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_double, ncd_int, ncd_inqvdlen + use restUtilMod + ! + ! !ARGUMENTS: + class(surfalb_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' + real(r8) , intent(in) :: tlai_patch(bounds%begp:) + real(r8) , intent(in) :: tsai_patch(bounds%begp:) + ! + ! !LOCAL VARIABLES: + logical :: readvar ! determine if variable is on initial file + integer :: iv + integer :: begp, endp + integer :: begc, endc + !--------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(tlai_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(tsai_patch) == (/bounds%endp/)), sourcefile, __LINE__) + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + call restartvar(ncid=ncid, flag=flag, varname='coszen', xtype=ncd_double, & + dim1name='column', & + long_name='cosine of solar zenith angle', units='unitless', & + interpinic_flag='interp', readvar=readvar, data=this%coszen_col) + + call restartvar(ncid=ncid, flag=flag, varname='albd', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='surface albedo (direct) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albd_patch) + + call restartvar(ncid=ncid, flag=flag, varname='albi', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='surface albedo (diffuse) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albi_patch) + if (use_SSRE) then + call restartvar(ncid=ncid, flag=flag, varname='albdSF', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='diagnostic snow-free surface albedo (direct) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albdSF_patch) + + call restartvar(ncid=ncid, flag=flag, varname='albiSF', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='diagnostic snow-free surface albedo (diffuse) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albiSF_patch) + end if + call restartvar(ncid=ncid, flag=flag, varname='albgrd', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='ground albedo (direct) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgrd_col) + + call restartvar(ncid=ncid, flag=flag, varname='albgri', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='ground albedo (indirect) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgri_col) + + call restartvar(ncid=ncid, flag=flag, varname='albsod', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='soil albedo (direct) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albsod_col) + + call restartvar(ncid=ncid, flag=flag, varname='albsoi', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='soil albedo (indirect) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albsoi_col) + + call restartvar(ncid=ncid, flag=flag, varname='albsnd_hst', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='snow albedo (direct) (0 to 1)', units='proportion', & + interpinic_flag='interp', readvar=readvar, data=this%albsnd_hst_col) + + call restartvar(ncid=ncid, flag=flag, varname='albsni_hst', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='snow albedo (diffuse) (0 to 1)', units='proportion', & + interpinic_flag='interp', readvar=readvar, data=this%albsni_hst_col) + + call restartvar(ncid=ncid, flag=flag, varname='tlai_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='tlai increment for canopy layer', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tlai_z_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) then + write(iulog,*) "can't find tlai_z in restart (or initial) file..." + write(iulog,*) "Initialize tlai_z to tlai/nlevcan" + end if + do iv=1,nlevcan + this%tlai_z_patch(begp:endp,iv) = tlai_patch(begp:endp) / nlevcan + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='tsai_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='tsai increment for canopy layer', units='', & + interpinic_flag='interp', readvar=readvar, data=this%tsai_z_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) then + write(iulog,*) "can't find tsai_z in restart (or initial) file..." + write(iulog,*) "Initialize tsai_z to tsai/nlevcan" + end if + do iv=1,nlevcan + this%tsai_z_patch(begp:endp,iv) = tsai_patch(begp:endp) / nlevcan + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='ncan', xtype=ncd_int, & + dim1name='pft', long_name='number of canopy layers', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ncan_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find ncan in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize ncan to nlevcan" + this%ncan_patch(begp:endp) = nlevcan + end if + + call restartvar(ncid=ncid, flag=flag, varname='nrad', xtype=ncd_int, & + dim1name='pft', long_name='number of canopy layers, above snow for radiative transfer', units='', & + interpinic_flag='interp', readvar=readvar, data=this%nrad_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find nrad in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize nrad to nlevcan" + this%nrad_patch(begp:endp) = nlevcan + end if + + call restartvar(ncid=ncid, flag=flag, varname='fsun_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='sunlit fraction for canopy layer', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fsun_z_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fsun_z in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fsun_z to 0" + do iv=1,nlevcan + this%fsun_z_patch(begp:endp,iv) = 0._r8 + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='vcmaxcintsun', xtype=ncd_double, & + dim1name='pft', long_name='sunlit canopy scaling coefficient', units='', & + interpinic_flag='interp', readvar=readvar, data=this%vcmaxcintsun_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find vcmaxcintsun in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize vcmaxcintsun to 1" + this%vcmaxcintsun_patch(begp:endp) = 1._r8 + end if + + call restartvar(ncid=ncid, flag=flag, varname='vcmaxcintsha', xtype=ncd_double, & + dim1name='pft', long_name='shaded canopy scaling coefficient', units='', & + interpinic_flag='interp', readvar=readvar, data=this%vcmaxcintsha_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find vcmaxcintsha in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize vcmaxcintsha to 1" + this%vcmaxcintsha_patch(begp:endp) = 1._r8 + end if + + if (use_snicar_frc) then + + call restartvar(ncid=ncid, flag=flag, varname='albgrd_bc', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='ground albedo without BC (direct) (0 to 1)', units='', & + interpinic_flag='interp',readvar=readvar, data=this%albgrd_bc_col) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "SNICAR: can't find albgrd_bc in initial file..." + if (masterproc) write(iulog,*) "Initialize albgrd_bc to albgrd" + this%albgrd_bc_col(begc:endc,:) = this%albgrd_col(begc:endc,:) + end if + + call restartvar(ncid=ncid, flag=flag, varname='albgri_bc', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='ground albedo without BC (diffuse) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgri_bc_col) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "SNICAR: can't find albgri_bc in initial file..." + if (masterproc) write(iulog,*) "Initialize albgri_bc to albgri" + this%albgri_bc_col(begc:endc,:) = this%albgri_col(begc:endc,:) + end if + + call restartvar(ncid=ncid, flag=flag, varname='albgrd_pur', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='pure snow ground albedo (direct) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgrd_pur_col) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "SNICAR: can't find albgrd_pur in initial file..." + if (masterproc) write(iulog,*) "Initialize albgrd_pur to albgrd" + this%albgrd_pur_col(begc:endc,:) = this%albgrd_col(begc:endc,:) + end if + + call restartvar(ncid=ncid, flag=flag, varname='albgri_pur', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='pure snow ground albedo (diffuse) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgri_pur_col) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "SNICAR: can't find albgri_pur in initial file..." + if (masterproc) write(iulog,*) "Initialize albgri_pur to albgri" + this%albgri_pur_col(begc:endc,:) = this%albgri_col(begc:endc,:) + end if + + call restartvar(ncid=ncid, flag=flag, varname='albgrd_oc', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='ground albedo without OC (direct) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgrd_oc_col) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "SNICAR: can't find albgrd_oc in initial file..." + if (masterproc) write(iulog,*) "Initialize albgrd_oc to albgrd" + this%albgrd_oc_col(begc:endc,:) = this%albgrd_col(begc:endc,:) + end if + + call restartvar(ncid=ncid, flag=flag, varname='albgri_oc', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='ground albedo without OC (diffuse) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgri_oc_col) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "SNICAR: can't find albgri_oc in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize albgri_oc to albgri" + this%albgri_oc_col(begc:endc,:) = this%albgri_col(begc:endc,:) + end if + + call restartvar(ncid=ncid, flag=flag, varname='albgrd_dst', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='ground albedo without dust (direct) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgrd_dst_col) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "SNICAR: can't find albgrd_dst in initial file..." + if (masterproc) write(iulog,*) "Initialize albgrd_dst to albgrd" + this%albgrd_dst_col(begc:endc,:) = this%albgrd_col(begc:endc,:) + end if + + call restartvar(ncid=ncid, flag=flag, varname='albgri_dst', xtype=ncd_double, & + dim1name='column', dim2name='numrad', switchdim=.true., & + long_name='ground albedo without dust (diffuse) (0 to 1)', units='', & + interpinic_flag='interp', readvar=readvar, data=this%albgri_dst_col) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "SNICAR: can't find albgri_dst in initial file..." + if (masterproc) write(iulog,*) "Initialize albgri_dst to albgri" + this%albgri_dst_col(begc:endc,:) = this%albgri_col(begc:endc,:) + end if + + end if ! end of if-use_snicar_frc + + ! patch type physical state variable - fabd + call restartvar(ncid=ncid, flag=flag, varname='fabd', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='flux absorbed by veg per unit direct flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabd_patch) + + call restartvar(ncid=ncid, flag=flag, varname='fabi', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='flux absorbed by veg per unit diffuse flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabi_patch) + + call restartvar(ncid=ncid, flag=flag, varname='fabd_sun', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='flux absorbed by sunlit leaf per unit direct flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabd_sun_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fabd_sun in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fabd_sun to fabd/2" + this%fabd_sun_patch(begp:endp,:) = this%fabd_patch(begp:endp,:)/2._r8 + end if + + call restartvar(ncid=ncid, flag=flag, varname='fabd_sha', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='flux absorbed by shaded leaf per unit direct flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabd_sha_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fabd_sha in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fabd_sha to fabd/2" + this%fabd_sha_patch(begp:endp,:) = this%fabd_patch(begp:endp,:)/2._r8 + end if + + call restartvar(ncid=ncid, flag=flag, varname='fabi_sun', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='flux absorbed by sunlit leaf per unit diffuse flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabi_sun_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fabi_sun in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fabi_sun to fabi/2" + this%fabi_sun_patch(begp:endp,:) = this%fabi_patch(begp:endp,:)/2._r8 + end if + + call restartvar(ncid=ncid, flag=flag, varname='fabi_sha', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='flux absorbed by shaded leaf per unit diffuse flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabi_sha_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fabi_sha in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fabi_sha to fabi/2" + this%fabi_sha_patch(begp:endp,:) = this%fabi_patch(begp:endp,:)/2._r8 + end if + + call restartvar(ncid=ncid, flag=flag, varname='fabd_sun_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='absorbed sunlit leaf direct PAR (per unit lai+sai) for canopy layer', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabd_sun_z_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fabd_sun_z in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fabd_sun_z to (fabd/2)/nlevcan" + do iv=1,nlevcan + this%fabd_sun_z_patch(begp:endp,iv) = (this%fabd_patch(begp:endp,1)/2._r8)/nlevcan + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='fabd_sha_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='absorbed shaded leaf direct PAR (per unit lai+sai) for canopy layer', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabd_sha_z_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fabd_sha_z in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fabd_sha_z to (fabd/2)/nlevcan" + do iv=1,nlevcan + this%fabd_sha_z_patch(begp:endp,iv) = (this%fabd_patch(begp:endp,1)/2._r8)/nlevcan + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='fabi_sun_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='absorbed sunlit leaf diffuse PAR (per unit lai+sai) for canopy layer', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabi_sun_z_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fabi_sun_z in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fabi_sun_z to (fabi/2)/nlevcan" + do iv=1,nlevcan + this%fabi_sun_z_patch(begp:endp,iv) = (this%fabi_patch(begp:endp,1)/2._r8)/nlevcan + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='fabi_sha_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='absorbed shaded leaf diffuse PAR (per unit lai+sai) for canopy layer', units='', & + interpinic_flag='interp', readvar=readvar, data=this%fabi_sha_z_patch) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find fabi_sha_z in restart (or initial) file..." + if (masterproc) write(iulog,*) "Initialize fabi_sha_z to (fabi/2)/nlevcan" + do iv=1,nlevcan + this%fabi_sha_z_patch(begp:endp,iv) = & + (this%fabi_patch(begp:endp,1)/2._r8)/nlevcan + end do + end if + + call restartvar(ncid=ncid, flag=flag, varname='ftdd', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='down direct flux below veg per unit direct flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ftdd_patch) + + call restartvar(ncid=ncid, flag=flag, varname='ftid', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='down diffuse flux below veg per unit direct flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ftid_patch) + + call restartvar(ncid=ncid, flag=flag, varname='ftii', xtype=ncd_double, & + dim1name='pft', dim2name='numrad', switchdim=.true., & + long_name='down diffuse flux below veg per unit diffuse flux', units='', & + interpinic_flag='interp', readvar=readvar, data=this%ftii_patch) + + !-------------------------------- + ! variables needed for SNICAR + !-------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='flx_absdv', xtype=ncd_double, & + dim1name='column', dim2name='levsno1', switchdim=.true., lowerb2=-nlevsno+1, upperb2=1, & + long_name='snow layer flux absorption factors (direct, VIS)', units='fraction', & + interpinic_flag='interp', readvar=readvar, data=this%flx_absdv_col) + + call restartvar(ncid=ncid, flag=flag, varname='flx_absdn', xtype=ncd_double, & + dim1name='column', dim2name='levsno1', switchdim=.true., lowerb2=-nlevsno+1, upperb2=1, & + long_name='snow layer flux absorption factors (direct, NIR)', units='fraction', & + interpinic_flag='interp', readvar=readvar, data=this%flx_absdn_col) + + call restartvar(ncid=ncid, flag=flag, varname='flx_absiv', xtype=ncd_double, & + dim1name='column', dim2name='levsno1', switchdim=.true., lowerb2=-nlevsno+1, upperb2=1, & + long_name='snow layer flux absorption factors (diffuse, VIS)', units='fraction', & + interpinic_flag='interp', readvar=readvar, data=this%flx_absiv_col) + + call restartvar(ncid=ncid, flag=flag, varname='flx_absin', xtype=ncd_double, & + dim1name='column', dim2name='levsno1', switchdim=.true., lowerb2=-nlevsno+1, upperb2=1, & + long_name='snow layer flux absorption factors (diffuse, NIR)', units='fraction', & + interpinic_flag='interp', readvar=readvar, data=this%flx_absin_col) + + end subroutine Restart + +end module SurfaceAlbedoType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SurfaceRadiationMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SurfaceRadiationMod.F90 new file mode 100644 index 000000000..e14c31dc6 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/SurfaceRadiationMod.F90 @@ -0,0 +1,1025 @@ +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 + + ! !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, assignment(=) + ! + ! !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_orig_files/TemperatureType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/TemperatureType.F90 new file mode 100644 index 000000000..174db5981 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/TemperatureType.F90 @@ -0,0 +1,1556 @@ +module TemperatureType + +#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_varctl , only : use_cndv, iulog, use_luna, use_crop, use_biomass_heat_storage + use clm_varpar , only : nlevsno, nlevgrnd, nlevlak, nlevurb, nlevmaxurbgrnd + use clm_varcon , only : spval, ispval + use GridcellType , only : grc + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + ! + implicit none + save + private + ! + 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 + procedure, public :: Restart + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: UpdateAccVars + + end type temperature_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, & + em_roof_lun, em_wall_lun, em_improad_lun, em_perroad_lun, & + is_simple_buildtemp, is_prog_buildtemp) + ! + ! !DESCRIPTION: + ! + ! Initialization of the data type. Allocate data, setup variables + ! for history output, and initialize values needed for a cold-start. + ! + class(temperature_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: em_roof_lun(bounds%begl:) + real(r8) , intent(in) :: em_wall_lun(bounds%begl:) + real(r8) , intent(in) :: em_improad_lun(bounds%begl:) + real(r8) , intent(in) :: em_perroad_lun(bounds%begl:) + logical , intent(in) :: is_simple_buildtemp ! Simple building temp is being used + logical , intent(in) :: is_prog_buildtemp ! Prognostic building temp is being used + + call this%InitAllocate ( bounds ) + call this%InitHistory ( bounds, is_simple_buildtemp, is_prog_buildtemp ) + call this%InitCold ( bounds, & + em_roof_lun(bounds%begl:bounds%endl), & + em_wall_lun(bounds%begl:bounds%endl), & + em_improad_lun(bounds%begl:bounds%endl), & + em_perroad_lun(bounds%begl:bounds%endl), & + is_simple_buildtemp, is_prog_buildtemp) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize and allocate data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(temperature_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + 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 + + ! 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 InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds, is_simple_buildtemp, is_prog_buildtemp ) + ! + ! !DESCRIPTION: + ! Setup the fields that can be output on history files. + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varctl , only : use_cn, use_cndv + use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal + ! + ! !ARGUMENTS: + class(temperature_type) :: this + type(bounds_type), intent(in) :: bounds + logical , intent(in) :: is_simple_buildtemp ! Simple building temp is being used + logical , intent(in) :: is_prog_buildtemp ! Prognostic building temp is being used + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: begl, endl + integer :: begg, endg + character(10) :: active + character(100) :: lname + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begl = bounds%begl; endl= bounds%endl + begg = bounds%begg; endg= bounds%endg + + this%t_h2osfc_col(begc:endc) = spval + call hist_addfld1d (fname='TH2OSFC', units='K', & + avgflag='A', long_name='surface water temperature', & + ptr_col=this%t_h2osfc_col) + + this%t_grnd_u_col(begc:endc) = spval + call hist_addfld1d (fname='TG_U', units='K', & + avgflag='A', long_name='Urban ground temperature', & + ptr_col=this%t_grnd_u_col, set_nourb=spval, c2l_scale_type='urbans', default='inactive') + + this%t_lake_col(begc:endc,:) = spval + call hist_addfld2d (fname='TLAKE', units='K', type2d='levlak', & + avgflag='A', long_name='lake temperature', & + ptr_col=this%t_lake_col) + + this%t_soisno_col(begc:endc,-nlevsno+1:0) = spval + data2dptr => this%t_soisno_col(:,-nlevsno+1:0) + call hist_addfld2d (fname='SNO_T', units='K', type2d='levsno', & + avgflag='A', long_name='Snow temperatures', & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') + + call hist_addfld2d (fname='SNO_T_ICE', units='K', type2d='levsno', & + avgflag='A', long_name='Snow temperatures (ice landunits only)', & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, & + l2g_scale_type='ice', default='inactive') + + this%t_ref2m_patch(begp:endp) = spval + call hist_addfld1d (fname='TSA', units='K', & + avgflag='A', long_name='2m air temperature', & + ptr_patch=this%t_ref2m_patch) + + call hist_addfld1d (fname='TSA_ICE', units='K', & + avgflag='A', long_name='2m air temperature (ice landunits only)', & + ptr_patch=this%t_ref2m_patch, l2g_scale_type='ice', default='inactive') + + this%t_ref2m_r_patch(begp:endp) = spval + call hist_addfld1d (fname='TSA_R', units='K', & + avgflag='A', long_name='Rural 2m air temperature', & + ptr_patch=this%t_ref2m_r_patch, set_spec=spval, default='inactive') + + this%t_ref2m_min_patch(begp:endp) = spval + call hist_addfld1d (fname='TREFMNAV', units='K', & + avgflag='A', long_name='daily minimum of average 2-m temperature', & + ptr_patch=this%t_ref2m_min_patch) + + this%t_ref2m_max_patch(begp:endp) = spval + call hist_addfld1d (fname='TREFMXAV', units='K', & + avgflag='A', long_name='daily maximum of average 2-m temperature', & + ptr_patch=this%t_ref2m_max_patch) + + this%t_ref2m_min_r_patch(begp:endp) = spval + call hist_addfld1d (fname='TREFMNAV_R', units='K', & + avgflag='A', long_name='Rural daily minimum of average 2-m temperature', & + ptr_patch=this%t_ref2m_min_r_patch, set_spec=spval, default='inactive') + + this%t_ref2m_max_r_patch(begp:endp) = spval + call hist_addfld1d (fname='TREFMXAV_R', units='K', & + avgflag='A', long_name='Rural daily maximum of average 2-m temperature', & + ptr_patch=this%t_ref2m_max_r_patch, set_spec=spval, default='inactive') + + this%t_ref2m_u_patch(begp:endp) = spval + call hist_addfld1d (fname='TSA_U', units='K', & + avgflag='A', long_name='Urban 2m air temperature', & + ptr_patch=this%t_ref2m_u_patch, set_nourb=spval, default='inactive') + + this%t_ref2m_min_u_patch(begp:endp) = spval + call hist_addfld1d (fname='TREFMNAV_U', units='K', & + avgflag='A', long_name='Urban daily minimum of average 2-m temperature', & + ptr_patch=this%t_ref2m_min_u_patch, set_nourb=spval, default='inactive') + + this%t_ref2m_max_u_patch(begp:endp) = spval + call hist_addfld1d (fname='TREFMXAV_U', units='K', & + avgflag='A', long_name='Urban daily maximum of average 2-m temperature', & + ptr_patch=this%t_ref2m_max_u_patch, set_nourb=spval, default='inactive') + + if (use_biomass_heat_storage) then + this%t_stem_patch(begp:endp) = spval + call hist_addfld1d (fname='TSTEM', units='K', & + avgflag='A', long_name='stem temperature', & + ptr_patch=this%t_stem_patch, default='active') + endif + + this%t_veg_patch(begp:endp) = spval + call hist_addfld1d (fname='TV', units='K', & + avgflag='A', long_name='vegetation temperature', & + ptr_patch=this%t_veg_patch) + + this%t_skin_patch(begp:endp) = spval + call hist_addfld1d(fname='TSKIN', units='K', & + avgflag='A', long_name='skin temperature', & + ptr_patch=this%t_skin_patch, c2l_scale_type='urbans') + + this%t_grnd_col(begc:endc) = spval + call hist_addfld1d (fname='TG', units='K', & + avgflag='A', long_name='ground temperature', & + ptr_col=this%t_grnd_col, c2l_scale_type='urbans') + + call hist_addfld1d (fname='TG_ICE', units='K', & + avgflag='A', long_name='ground temperature (ice landunits only)', & + ptr_col=this%t_grnd_col, c2l_scale_type='urbans', l2g_scale_type='ice', & + default='inactive') + + this%t_grnd_r_col(begc:endc) = spval + call hist_addfld1d (fname='TG_R', units='K', & + avgflag='A', long_name='Rural ground temperature', & + ptr_col=this%t_grnd_r_col, set_spec=spval, default='inactive') + + this%t_soisno_col(begc:endc,:) = spval + call hist_addfld2d (fname='TSOI', units='K', type2d='levgrnd', & + avgflag='A', long_name='soil temperature (natural vegetated and crop landunits only)', & + ptr_col=this%t_soisno_col, l2g_scale_type='veg') + + call hist_addfld2d (fname='TSOI_ICE', units='K', type2d='levgrnd', & + avgflag='A', long_name='soil temperature (ice landunits only)', & + ptr_col=this%t_soisno_col, l2g_scale_type='ice') + + this%t_soi10cm_col(begc:endc) = spval + call hist_addfld1d (fname='TSOI_10CM', units='K', & + avgflag='A', long_name='soil temperature in top 10cm of soil', & + ptr_col=this%t_soi10cm_col, set_urb=spval) + + this%tsl_col(begc:endc) = spval + call hist_addfld1d (fname='TSL', units='K', & + avgflag='A', & + long_name='temperature of near-surface soil layer (natural vegetated and crop landunits only)', & + ptr_col=this%tsl_col, l2g_scale_type='veg') + this%t_sno_mul_mss_col(begc:endc) = spval + call hist_addfld1d (fname='SNOTXMASS', units='K kg/m2', & + avgflag='A', long_name='snow temperature times layer mass, layer sum; '// & + 'to get mass-weighted temperature, divide by (SNOWICE+SNOWLIQ)', & + ptr_col=this%t_sno_mul_mss_col, c2l_scale_type='urbanf') + + call hist_addfld1d (fname='SNOTXMASS_ICE', units='K kg/m2', & + avgflag='A', long_name='snow temperature times layer mass, layer sum (ice landunits only); ' // & + 'to get mass-weighted temperature, divide by (SNOWICE_ICE+SNOWLIQ_ICE)', & + ptr_col=this%t_sno_mul_mss_col, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + if (use_cndv .or. use_crop) then + active = "active" + else + active = "inactive" + end if + this%t_a10_patch(begp:endp) = spval + call hist_addfld1d (fname='T10', units='K', & + avgflag='A', long_name='10-day running mean of 2-m temperature', & + ptr_patch=this%t_a10_patch, default='inactive') + + this%soila10_patch(begp:endp) = spval + call hist_addfld1d (fname='SOIL10', units='K', & + avgflag='A', long_name='10-day running mean of 3rd layer soil', & + ptr_patch=this%soila10_patch, default='inactive') + + this%t_a5min_patch(begp:endp) = spval + call hist_addfld1d (fname='A5TMIN', units='K', & + avgflag='A', long_name='5-day running mean of min 2-m temperature', & + ptr_patch=this%t_a5min_patch, default='inactive') + + if (use_cn .and. use_crop )then + this%t_a10min_patch(begp:endp) = spval + call hist_addfld1d (fname='A10TMIN', units='K', & + avgflag='A', long_name='10-day running mean of min 2-m temperature', & + ptr_patch=this%t_a10min_patch, default='inactive') + end if + + this%t_building_lun(begl:endl) = spval + if ( is_simple_buildtemp )then + lname = 'internal urban building temperature' + else if ( is_prog_buildtemp )then + lname = 'internal urban building air temperature' + end if + call hist_addfld1d(fname='TBUILD', units='K', & + avgflag='A', long_name=lname, & + ptr_lunit=this%t_building_lun, set_nourb=spval, l2g_scale_type='unity') + + if ( is_prog_buildtemp )then + this%t_roof_inner_lun(begl:endl) = spval + call hist_addfld1d(fname='TROOF_INNER', units='K', & + avgflag='A', long_name='roof inside surface temperature', & + ptr_lunit=this%t_roof_inner_lun, set_nourb=spval, l2g_scale_type='unity', & + default='inactive') + + this%t_sunw_inner_lun(begl:endl) = spval + call hist_addfld1d(fname='TSUNW_INNER', units='K', & + avgflag='A', long_name='sunwall inside surface temperature', & + ptr_lunit=this%t_sunw_inner_lun, set_nourb=spval, l2g_scale_type='unity', & + default='inactive') + + this%t_shdw_inner_lun(begl:endl) = spval + call hist_addfld1d(fname='TSHDW_INNER', units='K', & + avgflag='A', long_name='shadewall inside surface temperature', & + ptr_lunit=this%t_shdw_inner_lun, set_nourb=spval, l2g_scale_type='unity', & + default='inactive') + + this%t_floor_lun(begl:endl) = spval + call hist_addfld1d(fname='TFLOOR', units='K', & + avgflag='A', long_name='floor temperature', & + ptr_lunit=this%t_floor_lun, set_nourb=spval, l2g_scale_type='unity', & + default='inactive') + end if + + this%heat1_grc(begg:endg) = spval + call hist_addfld1d (fname='HEAT_CONTENT1', units='J/m^2', & + avgflag='A', long_name='initial gridcell total heat content', & + ptr_lnd=this%heat1_grc) + call hist_addfld1d (fname='HEAT_CONTENT1_VEG', units='J/m^2', & + avgflag='A', & + long_name='initial gridcell total heat content - natural vegetated and crop landunits only', & + ptr_lnd=this%heat1_grc, l2g_scale_type='veg', default='inactive') + + this%heat2_grc(begg:endg) = spval + call hist_addfld1d (fname='HEAT_CONTENT2', units='J/m^2', & + avgflag='A', long_name='post land cover change total heat content', & + ptr_lnd=this%heat2_grc, default='inactive') + + this%liquid_water_temp1_grc(begg:endg) = spval + call hist_addfld1d (fname='LIQUID_WATER_TEMP1', units='K', & + avgflag='A', long_name='initial gridcell weighted average liquid water temperature', & + ptr_lnd=this%liquid_water_temp1_grc, default='inactive') + + this%snot_top_col(begc:endc) = spval + call hist_addfld1d (fname='SNOTTOPL', units='K', & + avgflag='A', long_name='snow temperature (top layer)', & + ptr_col=this%snot_top_col, set_urb=spval, default='inactive') + + call hist_addfld1d (fname='SNOTTOPL_ICE', units='K', & + avgflag='A', long_name='snow temperature (top layer, ice landunits only)', & + ptr_col=this%snot_top_col, set_urb=spval, l2g_scale_type='ice', default='inactive') + + this%dTdz_top_col(begc:endc) = spval + call hist_addfld1d (fname='SNOdTdzL', units='K/m', & + avgflag='A', long_name='top snow layer temperature gradient (land)', & + ptr_col=this%dTdz_top_col, set_urb=spval, default='inactive') + + if (use_cn) then + this%dt_veg_patch(begp:endp) = spval + call hist_addfld1d (fname='DT_VEG', units='K', & + avgflag='A', long_name='change in t_veg, last iteration', & + ptr_patch=this%dt_veg_patch, default='inactive') + end if + + if (use_cn ) then + this%emv_patch(begp:endp) = spval + call hist_addfld1d (fname='EMV', units='proportion', & + avgflag='A', long_name='vegetation emissivity', & + ptr_patch=this%emv_patch, default='inactive') + end if + + if (use_cn) then + this%emg_col(begc:endc) = spval + call hist_addfld1d (fname='EMG', units='proportion', & + avgflag='A', long_name='ground emissivity', & + ptr_col=this%emg_col, default='inactive') + end if + + if (use_cn) then + this%beta_col(begc:endc) = spval + call hist_addfld1d (fname='BETA', units='none', & + avgflag='A', long_name='coefficient of convective velocity', & + ptr_col=this%beta_col, default='inactive') + end if + + ! Accumulated quantities + + this%t_veg24_patch(begp:endp) = spval + call hist_addfld1d (fname='TV24', units='K', & + avgflag='A', long_name='vegetation temperature (last 24hrs)', & + ptr_patch=this%t_veg24_patch, default='inactive') + + this%t_veg240_patch(begp:endp) = spval + call hist_addfld1d (fname='TV240', units='K', & + avgflag='A', long_name='vegetation temperature (last 240hrs)', & + ptr_patch=this%t_veg240_patch, default='inactive') + + if (use_crop) then + this%gdd0_patch(begp:endp) = spval + call hist_addfld1d (fname='GDD0', units='ddays', & + avgflag='A', long_name='Growing degree days base 0C from planting', & + ptr_patch=this%gdd0_patch, default='inactive') + end if + + if (use_crop) then + this%gdd8_patch(begp:endp) = spval + call hist_addfld1d (fname='GDD8', units='ddays', & + avgflag='A', long_name='Growing degree days base 8C from planting', & + ptr_patch=this%gdd8_patch, default='inactive') + + this%gdd10_patch(begp:endp) = spval + call hist_addfld1d (fname='GDD10', units='ddays', & + avgflag='A', long_name='Growing degree days base 10C from planting', & + ptr_patch=this%gdd10_patch, default='inactive') + + this%gdd020_patch(begp:endp) = spval + call hist_addfld1d (fname='GDD020', units='ddays', & + avgflag='A', long_name='Twenty year average of growing degree days base 0C from planting', & + ptr_patch=this%gdd020_patch, default='inactive') + + this%gdd820_patch(begp:endp) = spval + call hist_addfld1d (fname='GDD820', units='ddays', & + avgflag='A', long_name='Twenty year average of growing degree days base 8C from planting', & + ptr_patch=this%gdd820_patch, default='inactive') + + this%gdd1020_patch(begp:endp) = spval + call hist_addfld1d (fname='GDD1020', units='ddays', & + avgflag='A', long_name='Twenty year average of growing degree days base 10C from planting', & + ptr_patch=this%gdd1020_patch, default='inactive') + + end if + if(use_luna)then + call hist_addfld1d (fname='TVEGD10', units='Kelvin', & + avgflag='A', long_name='10 day running mean of patch daytime vegetation temperature', & + ptr_patch=this%t_veg10_day_patch, default='inactive') + call hist_addfld1d (fname='TVEGN10', units='Kelvin', & + avgflag='A', long_name='10 day running mean of patch night-time vegetation temperature', & + ptr_patch=this%t_veg10_night_patch, default='inactive') + endif + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds, & + em_roof_lun, em_wall_lun, em_improad_lun, em_perroad_lun, & + is_simple_buildtemp, is_prog_buildtemp) + ! + ! !DESCRIPTION: + ! Initialize cold start conditions for module variables + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_TKFRZ + use clm_varcon , only : denice, denh2o, sb + use landunit_varcon, only : istwet, istsoil, istdlak, istice_mec + use column_varcon , only : icol_road_imperv, icol_roof, icol_sunwall + use column_varcon , only : icol_shadewall, icol_road_perv + use clm_varctl , only : iulog, use_vancouver, use_mexicocity + ! + ! !ARGUMENTS: + class(temperature_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: em_roof_lun(bounds%begl:) + real(r8) , intent(in) :: em_wall_lun(bounds%begl:) + real(r8) , intent(in) :: em_improad_lun(bounds%begl:) + real(r8) , intent(in) :: em_perroad_lun(bounds%begl:) + logical , intent(in) :: is_simple_buildtemp ! Simple building temp is being used + logical , intent(in) :: is_prog_buildtemp ! Prognostic building temp is being used + ! + ! !LOCAL VARIABLES: + integer :: j,l,c,p ! indices + integer :: nlevs ! number of levels + real(r8) :: snowbd ! temporary calculation of snow bulk density (kg/m3) + real(r8) :: fmelt ! snowbd/100 + integer :: lev + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(em_roof_lun) == (/bounds%endl/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(em_wall_lun) == (/bounds%endl/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(em_improad_lun) == (/bounds%endl/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(em_perroad_lun) == (/bounds%endl/)), sourcefile, __LINE__) + + associate(snl => col%snl) ! Output: [integer (:) ] number of snow layers + + ! Set snow/soil temperature + ! t_lake only has valid values over non-lake + ! t_soisno, t_grnd and t_veg have valid values over all land + + do c = bounds%begc,bounds%endc + l = col%landunit(c) + + this%t_soisno_col(c,-nlevsno+1:nlevmaxurbgrnd) = spval + + ! Snow level temperatures - all land points + if (snl(c) < 0) then + do j = snl(c)+1, 0 + this%t_soisno_col(c,j) = 250._r8 + end do + end if + + ! Below snow temperatures - nonlake points (lake points are set below) + if (.not. lun%lakpoi(l)) then + + if (lun%itype(l)==istice_mec) then + this%t_soisno_col(c,1:nlevgrnd) = 250._r8 + + else if (lun%itype(l) == istwet) then + this%t_soisno_col(c,1:nlevgrnd) = 277._r8 + + else if (lun%urbpoi(l)) then + if (use_vancouver) then + if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + ! Set road top layer to initial air temperature and interpolate other + ! layers down to 20C in bottom layer + do j = 1, nlevgrnd + this%t_soisno_col(c,j) = 297.56 - (j-1) * ((297.56-293.16)/(nlevgrnd-1)) + end do + ! Set wall and roof layers to initial air temperature + else if (col%itype(c) == icol_sunwall .or. col%itype(c) == icol_shadewall .or. col%itype(c) == icol_roof) then + this%t_soisno_col(c,1:nlevurb) = 297.56 + else + this%t_soisno_col(c,1:nlevgrnd) = 283._r8 + end if + else if (use_mexicocity) then + if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + ! Set road top layer to initial air temperature and interpolate other + ! layers down to 22C in bottom layer + do j = 1, nlevgrnd + this%t_soisno_col(c,j) = 289.46 - (j-1) * ((289.46-295.16)/(nlevgrnd-1)) + end do + else if (col%itype(c) == icol_sunwall .or. col%itype(c) == icol_shadewall .or. col%itype(c) == icol_roof) then + ! Set wall and roof layers to initial air temperature + this%t_soisno_col(c,1:nlevurb) = 289.46 + else + this%t_soisno_col(c,1:nlevgrnd) = 283._r8 + end if + else + if (col%itype(c) == icol_road_perv .or. col%itype(c) == icol_road_imperv) then + this%t_soisno_col(c,1:nlevgrnd) = 274._r8 + else if (col%itype(c) == icol_sunwall .or. col%itype(c) == icol_shadewall & + .or. col%itype(c) == icol_roof) then + ! Set sunwall, shadewall, roof to fairly high temperature to avoid initialization + ! shock from large heating/air conditioning flux + this%t_soisno_col(c,1:nlevurb) = 292._r8 + end if + end if + else + this%t_soisno_col(c,1:nlevgrnd) = 274._r8 + + endif + endif + end do + + ! Initialize internal building temperature, inner temperatures of building + ! surfaces, and floor temperature + if ( is_prog_buildtemp )then + do l = bounds%begl, bounds%endl + do c = lun%coli(l),lun%colf(l) + if (col%itype(c) == icol_roof) then + this%t_roof_inner_lun(l) = this%t_soisno_col(c,nlevurb) + this%t_building_lun(l) = this%t_soisno_col(c,nlevurb) ! arbitrarily set to roof temperature + this%t_floor_lun(l) = this%t_soisno_col(c,nlevurb) ! arbitrarily set to roof temperature + else if (col%itype(c) == icol_sunwall) then + this%t_sunw_inner_lun(l) = this%t_soisno_col(c,nlevurb) + else if (col%itype(c) == icol_shadewall) then + this%t_shdw_inner_lun(l) = this%t_soisno_col(c,nlevurb) + end if + end do + end do + end if + + ! Set Ground temperatures + + do c = bounds%begc,bounds%endc + l = col%landunit(c) + + if (lun%lakpoi(l)) then + this%t_grnd_col(c) = 277._r8 + else + this%t_grnd_col(c) = this%t_soisno_col(c,snl(c)+1) + end if + this%t_soi17cm_col(c) = this%t_grnd_col(c) + end do + + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (lun%lakpoi(l)) then ! lake + this%t_lake_col(c,1:nlevlak) = this%t_grnd_col(c) + this%t_soisno_col(c,1:nlevgrnd) = this%t_grnd_col(c) + end if + end do + + ! Set t_h2osfc_col + + this%t_h2osfc_col(bounds%begc:bounds%endc) = 274._r8 + + ! Set t_veg, t_ref2m, t_ref2m_u and tref2m_r + + do p = bounds%begp, bounds%endp + c = patch%column(p) + l = patch%landunit(p) + + if (use_vancouver) then + this%t_veg_patch(p) = 297.56 + else if (use_mexicocity) then + this%t_veg_patch(p) = 289.46 + else + this%t_veg_patch(p) = 283._r8 + end if + + this%t_stem_patch(p) = this%t_veg_patch(p) + + if (use_vancouver) then + this%t_ref2m_patch(p) = 297.56 + else if (use_mexicocity) then + this%t_ref2m_patch(p) = 289.46 + else + this%t_ref2m_patch(p) = 283._r8 + end if + + if (lun%urbpoi(l)) then + if (use_vancouver) then + this%t_ref2m_u_patch(p) = 297.56 + else if (use_mexicocity) then + this%t_ref2m_u_patch(p) = 289.46 + else + this%t_ref2m_u_patch(p) = 283._r8 + end if + else + if (.not. lun%ifspecial(l)) then + if (use_vancouver) then + this%t_ref2m_r_patch(p) = 297.56 + else if (use_mexicocity) then + this%t_ref2m_r_patch(p) = 289.46 + else + this%t_ref2m_r_patch(p) = 283._r8 + end if + else + this%t_ref2m_r_patch(p) = spval + end if + end if + + end do + + end associate + + do l = bounds%begl, bounds%endl + if (lun%urbpoi(l)) then + if (use_vancouver) then + this%taf_lun(l) = 297.56_r8 + else if (use_mexicocity) then + this%taf_lun(l) = 289.46_r8 + else + this%taf_lun(l) = 283._r8 + end if + end if + end do + + do c = bounds%begc,bounds%endc + l = col%landunit(c) + + if (col%itype(c) == icol_roof ) this%emg_col(c) = em_roof_lun(l) + if (col%itype(c) == icol_sunwall ) this%emg_col(c) = em_wall_lun(l) + if (col%itype(c) == icol_shadewall ) this%emg_col(c) = em_wall_lun(l) + if (col%itype(c) == icol_road_imperv) this%emg_col(c) = em_improad_lun(l) + if (col%itype(c) == icol_road_perv ) this%emg_col(c) = em_perroad_lun(l) + end do + + ! Initialize dynbal_baseline_heat_col: for some columns, this is set elsewhere in + ! initialization, but we need it to be 0 for columns for which it is not explicitly + ! set. + this%dynbal_baseline_heat_col(bounds%begc:bounds%endc) = 0._r8 + + end subroutine InitCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag, is_simple_buildtemp, is_prog_buildtemp) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use shr_log_mod , only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc + use abortutils , only : endrun + use ncdio_pio , only : file_desc_t, ncd_double, ncd_int + use restUtilMod + ! + ! !ARGUMENTS: + class(temperature_type) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid + character(len=*) , intent(in) :: flag + logical , intent(in) :: is_simple_buildtemp ! Simple building temp is being used + logical , intent(in) :: is_prog_buildtemp ! Prognostic building temp is being used + ! + ! !LOCAL VARIABLES: + integer :: j,c ! indices + logical :: readvar ! determine if variable is on initial file + !----------------------------------------------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='T_SOISNO', xtype=ncd_double, & + dim1name='column', dim2name='levtot', switchdim=.true., & + long_name='soil-snow temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_soisno_col) + + call restartvar(ncid=ncid, flag=flag, varname='T_VEG', xtype=ncd_double, & + dim1name='pft', & + long_name='vegetation temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_veg_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_STEM', xtype=ncd_double, & + dim1name='pft', & + long_name='stem temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_stem_patch) + + call restartvar(ncid=ncid, flag=flag, varname='TH2OSFC', xtype=ncd_double, & + dim1name='column', & + long_name='surface water temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_h2osfc_col) + if (flag=='read' .and. .not. readvar) then + this%t_h2osfc_col(bounds%begc:bounds%endc) = 274.0_r8 + end if + + call restartvar(ncid=ncid, flag=flag, varname='T_LAKE', xtype=ncd_double, & + dim1name='column', dim2name='levlak', switchdim=.true., & + long_name='lake temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_lake_col) + + call restartvar(ncid=ncid, flag=flag, varname='T_GRND', xtype=ncd_double, & + dim1name='column', & + long_name='ground temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_grnd_col) + + call restartvar(ncid=ncid, flag=flag, varname='T_GRND_R', xtype=ncd_double, & + dim1name='column', & + long_name='rural ground temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_grnd_r_col) + + call restartvar(ncid=ncid, flag=flag, varname='T_GRND_U', xtype=ncd_double, & + dim1name='column', & + long_name='urban ground temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_grnd_u_col) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M', xtype=ncd_double, & + dim1name='pft', & + long_name='2m height surface air temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_patch) + if (flag=='read' .and. .not. readvar) call endrun(msg=errMsg(sourcefile, __LINE__)) + + call restartvar(ncid=ncid, flag=flag, varname="T_REF2M_R", xtype=ncd_double, & + dim1name='pft', & + long_name='Rural 2m height surface air temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_r_patch) + + call restartvar(ncid=ncid, flag=flag, varname="T_REF2M_U", xtype=ncd_double, dim1name='pft', & + long_name='Urban 2m height surface air temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_u_patch) + + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MIN', xtype=ncd_double, & + dim1name='pft', & + long_name='daily minimum of average 2 m height surface air temperature (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_min_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MIN_R', xtype=ncd_double, & + dim1name='pft', & + long_name='rural daily minimum of average 2 m height surface air temperature (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_min_r_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MIN_U', xtype=ncd_double, dim1name='pft', & + long_name='urban daily minimum of average 2 m height surface air temperature (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_min_u_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MAX', xtype=ncd_double, & + dim1name='pft', & + long_name='daily maximum of average 2 m height surface air temperature (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_max_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MAX_R', xtype=ncd_double, & + dim1name='pft', & + long_name='rural daily maximum of average 2 m height surface air temperature (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_max_r_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MAX_U', xtype=ncd_double, dim1name='pft', & + long_name='urban daily maximum of average 2 m height surface air temperature (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_max_u_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MIN_INST', xtype=ncd_double, & + dim1name='pft', & + long_name='instantaneous daily min of average 2 m height surface air temp (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_min_inst_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MIN_INST_R', xtype=ncd_double, & + dim1name='pft', & + long_name='rural instantaneous daily min of average 2 m height surface air temp (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_min_inst_r_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MIN_INST_U', xtype=ncd_double, dim1name='pft', & + long_name='urban instantaneous daily min of average 2 m height surface air temp (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_min_inst_u_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MAX_INST', xtype=ncd_double, & + dim1name='pft', & + long_name='instantaneous daily max of average 2 m height surface air temp (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_max_inst_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MAX_INST_R', xtype=ncd_double, & + dim1name='pft', & + long_name='rural instantaneous daily max of average 2 m height surface air temp (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_max_inst_r_patch) + + call restartvar(ncid=ncid, flag=flag, varname='T_REF2M_MAX_INST_U', xtype=ncd_double, dim1name='pft', & + long_name='urban instantaneous daily max of average 2 m height surface air temp (K)', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_ref2m_max_inst_u_patch) + + call restartvar(ncid=ncid, flag=flag, varname='taf', xtype=ncd_double, dim1name='landunit', & + long_name='urban canopy air temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%taf_lun) + + call restartvar(ncid=ncid, flag=flag, varname='DYNBAL_BASELINE_HEAT', xtype=ncd_double, & + dim1name='column', & + long_name="baseline heat content subtracted from each column's total heat calculation", & + units='J/m2', & + interpinic_flag='interp', readvar=readvar, data=this%dynbal_baseline_heat_col) + + if (use_crop) then + call restartvar(ncid=ncid, flag=flag, varname='gdd1020', xtype=ncd_double, & + dim1name='pft', long_name='20 year average of growing degree-days base 10C from planting', units='ddays', & + interpinic_flag='interp', readvar=readvar, data=this%gdd1020_patch) + + call restartvar(ncid=ncid, flag=flag, varname='gdd820', xtype=ncd_double, & + dim1name='pft', long_name='20 year average of growing degree-days base 8C from planting', units='ddays', & + interpinic_flag='interp', readvar=readvar, data=this%gdd820_patch) + + call restartvar(ncid=ncid, flag=flag, varname='gdd020', xtype=ncd_double, & + dim1name='pft', long_name='20 year average of growing degree-days base 0C from planting', units='ddays', & + interpinic_flag='interp', readvar=readvar, data=this%gdd020_patch) + end if + + if(use_luna)then + call restartvar(ncid=ncid, flag=flag, varname='tvegd10', xtype=ncd_double, & + dim1name='pft', long_name='10-day mean daytime vegetation temperature', units='Kelvin', & + interpinic_flag='interp', readvar=readvar, data=this%t_veg10_day_patch ) + call restartvar(ncid=ncid, flag=flag, varname='tvegd', xtype=ncd_double, & + dim1name='pft', long_name='accumulative daytime vegetation temperature', units='Kelvin*steps', & + interpinic_flag='interp', readvar=readvar, data=this%t_veg_day_patch ) + call restartvar(ncid=ncid, flag=flag, varname='tvegn10', xtype=ncd_double, & + dim1name='pft', long_name='10-day mean nighttime vegetation temperature', units='Kelvin', & + interpinic_flag='interp', readvar=readvar, data=this%t_veg10_night_patch ) + call restartvar(ncid=ncid, flag=flag, varname='tvegn', xtype=ncd_double, & + dim1name='pft', long_name='accumulative nighttime vegetation temperature', units='Kelvin*steps', & + interpinic_flag='interp', readvar=readvar, data=this%t_veg_night_patch ) + call restartvar(ncid=ncid, flag=flag, varname='tair10', xtype=ncd_double, & + dim1name='pft', long_name='10-day mean air temperature', units='Kelvin', & + interpinic_flag='interp', readvar=readvar, data=this%t_a10_patch ) + call restartvar(ncid=ncid, flag=flag, varname='ndaysteps', xtype=ncd_int, & + dim1name='pft', long_name='accumulative daytime steps', units='steps', & + interpinic_flag='interp', readvar=readvar, data=this%ndaysteps_patch ) + call restartvar(ncid=ncid, flag=flag, varname='nnightsteps', xtype=ncd_int, & + dim1name='pft', long_name='accumulative nighttime steps', units='steps', & + interpinic_flag='interp', readvar=readvar, data=this%nnightsteps_patch ) + endif + + if ( is_prog_buildtemp )then + ! landunit type physical state variable - t_building + call restartvar(ncid=ncid, flag=flag, varname='t_building', xtype=ncd_double, & + dim1name='landunit', & + long_name='internal building air temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_building_lun) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find t_building in initial file..." + if (masterproc) write(iulog,*) "Initialize t_building to taf" + this%t_building_lun(bounds%begl:bounds%endl) = this%taf_lun(bounds%begl:bounds%endl) + end if + + ! landunit type physical state variable - t_roof_inner + call restartvar(ncid=ncid, flag=flag, varname='t_roof_inner', xtype=ncd_double, & + dim1name='landunit', & + long_name='roof inside surface temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_roof_inner_lun) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find t_roof_inner in initial file..." + if (masterproc) write(iulog,*) "Initialize t_roof_inner to taf" + this%t_roof_inner_lun(bounds%begl:bounds%endl) = this%taf_lun(bounds%begl:bounds%endl) + end if + + ! landunit type physical state variable - t_sunw_inner + call restartvar(ncid=ncid, flag=flag, varname='t_sunw_inner', xtype=ncd_double, & + dim1name='landunit', & + long_name='sunwall inside surface temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_sunw_inner_lun) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find t_sunw_inner in initial file..." + if (masterproc) write(iulog,*) "Initialize t_sunw_inner to taf" + this%t_sunw_inner_lun(bounds%begl:bounds%endl) = this%taf_lun(bounds%begl:bounds%endl) + end if + + ! landunit type physical state variable - t_shdw_inner + call restartvar(ncid=ncid, flag=flag, varname='t_shdw_inner', xtype=ncd_double, & + dim1name='landunit', & + long_name='shadewall inside surface temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_shdw_inner_lun) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find t_shdw_inner in initial file..." + if (masterproc) write(iulog,*) "Initialize t_shdw_inner to taf" + this%t_shdw_inner_lun(bounds%begl:bounds%endl) = this%taf_lun(bounds%begl:bounds%endl) + end if + + ! landunit type physical state variable - t_floor + call restartvar(ncid=ncid, flag=flag, varname='t_floor', xtype=ncd_double, & + dim1name='landunit', & + long_name='floor temperature', units='K', & + interpinic_flag='interp', readvar=readvar, data=this%t_floor_lun) + if (flag=='read' .and. .not. readvar) then + if (masterproc) write(iulog,*) "can't find t_floor in initial file..." + if (masterproc) write(iulog,*) "Initialize t_floor to taf" + this%t_floor_lun(bounds%begl:bounds%endl) = this%taf_lun(bounds%begl:bounds%endl) + end if + end if + + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! Each interval and accumulation type is unique to each field processed. + ! Routine [initAccBuffer] defines the fields to be processed + ! and the type of accumulation. + ! Routine [updateAccVars] does the actual accumulation for a given field. + ! Fields are accumulated by calls to subroutine [update_accum_field]. + ! To accumulate a field, it must first be defined in subroutine [initAccVars] + ! and then accumulated by calls to [updateAccVars]. + ! Four types of accumulations are possible: + ! o average over time interval + ! o running mean over time interval + ! o running accumulation over time interval + ! Time average fields are only valid at the end of the averaging interval. + ! Running means are valid once the length of the simulation exceeds the + ! averaging interval. Accumulated fields are continuously accumulated. + ! The trigger value "-99999." resets the accumulation to zero. + ! + ! !USES + use accumulMod , only : init_accum_field + use clm_time_manager , only : get_step_size_real + use shr_const_mod , only : SHR_CONST_CDAY, SHR_CONST_TKFRZ + ! + ! !ARGUMENTS: + class(temperature_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + real(r8) :: dtime + integer, parameter :: not_used = huge(1) + !--------------------------------------------------------------------- + + dtime = get_step_size_real() + + this%t_veg24_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='T_VEG24', units='K', & + desc='24hr average of vegetation temperature', accum_type='runmean', accum_period=-1, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + this%t_veg240_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='T_VEG240', units='K', & + desc='240hr average of vegetation temperature', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field(name='TREFAV', units='K', & + desc='average over an hour of 2-m temperature', accum_type='timeavg', accum_period=nint(3600._r8/dtime), & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field(name='TREFAV_U', units='K', & + desc='average over an hour of urban 2-m temperature', accum_type='timeavg', accum_period=nint(3600._r8/dtime), & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field(name='TREFAV_R', units='K', & + desc='average over an hour of rural 2-m temperature', accum_type='timeavg', accum_period=nint(3600._r8/dtime), & + subgrid_type='pft', numlev=1, init_value=0._r8) + + ! The following is a running mean. The accumulation period is set to -10 for a 10-day running mean. + call init_accum_field (name='T10', units='K', & + desc='10-day running mean of 2-m temperature', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1,init_value=SHR_CONST_TKFRZ+20._r8) + call init_accum_field (name='SOIL10', units='K', & + desc='10-day running mean of 3rd layer soil temp.', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1,init_value=SHR_CONST_TKFRZ) + call init_accum_field (name='TDM5', units='K', & + desc='5-day running mean of min 2-m temperature', accum_type='runmean', accum_period=-5, & + subgrid_type='pft', numlev=1, init_value=SHR_CONST_TKFRZ) + + if ( use_crop )then + call init_accum_field (name='TDM10', units='K', & + desc='10-day running mean of min 2-m temperature', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=SHR_CONST_TKFRZ) + + end if + + if ( use_crop )then + + ! All GDD summations are relative to the planting date (Kucharik & Brye 2003) + call init_accum_field (name='GDD0', units='K', & + desc='growing degree-days base 0C from planting', accum_type='runaccum', accum_period=not_used, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field (name='GDD8', units='K', & + desc='growing degree-days base 8C from planting', accum_type='runaccum', accum_period=not_used, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field (name='GDD10', units='K', & + desc='growing degree-days base 10C from planting', accum_type='runaccum', accum_period=not_used, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + end if + + if (use_cndv) then + ! 30-day average of 2m temperature. + call init_accum_field (name='TDA', units='K', & + desc='30-day average of 2-m temperature', accum_type='timeavg', accum_period=-30, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + end if + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + subroutine InitAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES + use accumulMod , only : init_accum_field, extract_accum_field + use clm_time_manager , only : get_nstep + use clm_varctl , only : nsrest, nsrStartup + use abortutils , only : endrun + ! + ! !ARGUMENTS: + class(temperature_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: nstep + integer :: ier + real(r8), pointer :: rbufslp(:) ! temporary + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + ! Allocate needed dynamic memory for single level pft field + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)' in ' + call endrun(msg="extract_accum_hist allocation error for rbufslp"//& + errMsg(sourcefile, __LINE__)) + endif + + ! Determine time step + nstep = get_nstep() + + call extract_accum_field ('T_VEG24', rbufslp, nstep) + this%t_veg24_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('T_VEG240', rbufslp, nstep) + this%t_veg240_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('T10', rbufslp, nstep) + this%t_a10_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('SOIL10', rbufslp, nstep) + this%soila10_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('TDM5', rbufslp, nstep) + this%t_a5min_patch(begp:endp) = rbufslp(begp:endp) + + if (use_crop) then + call extract_accum_field ('TDM10', rbufslp, nstep) + this%t_a10min_patch(begp:endp)= rbufslp(begp:endp) + + end if + + ! Initialize variables that are to be time accumulated + ! Initialize 2m ref temperature max and min values + + if (nsrest == nsrStartup) then + this%t_ref2m_max_patch(begp:endp) = spval + this%t_ref2m_max_r_patch(begp:endp) = spval + this%t_ref2m_max_u_patch(begp:endp) = spval + + this%t_ref2m_min_patch(begp:endp) = spval + this%t_ref2m_min_r_patch(begp:endp) = spval + this%t_ref2m_min_u_patch(begp:endp) = spval + + this%t_ref2m_max_inst_patch(begp:endp) = -spval + this%t_ref2m_max_inst_r_patch(begp:endp) = -spval + this%t_ref2m_max_inst_u_patch(begp:endp) = -spval + + this%t_ref2m_min_inst_patch(begp:endp) = spval + this%t_ref2m_min_inst_r_patch(begp:endp) = spval + this%t_ref2m_min_inst_u_patch(begp:endp) = spval + end if + + if ( use_crop ) then + + call extract_accum_field ('GDD0', rbufslp, nstep) + this%gdd0_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('GDD8', rbufslp, nstep) ; + this%gdd8_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('GDD10', rbufslp, nstep) + this%gdd10_patch(begp:endp) = rbufslp(begp:endp) + + end if + + deallocate(rbufslp) + + end subroutine InitAccVars + + !----------------------------------------------------------------------- + subroutine UpdateAccVars (this, bounds) + ! + ! USES + use shr_const_mod , only : SHR_CONST_CDAY, SHR_CONST_TKFRZ + use clm_time_manager , only : get_step_size, get_nstep, is_end_curr_day, get_curr_date + use accumulMod , only : update_accum_field, extract_accum_field, accumResetVal + ! + ! !ARGUMENTS: + class(temperature_type) :: this + type(bounds_type) , intent(in) :: bounds + + ! + ! !LOCAL VARIABLES: + integer :: m,g,l,c,p ! indices + integer :: ier ! error status + integer :: dtime ! timestep size [seconds] + integer :: nstep ! timestep number + integer :: year ! year (0, ...) for nstep + integer :: month ! month (1, ..., 12) for nstep + integer :: day ! day of month (1, ..., 31) for nstep + integer :: secs ! seconds into current date for nstep + logical :: end_cd ! temporary for is_end_curr_day() value + integer :: begp, endp + real(r8), pointer :: rbufslp(:) ! temporary single level - pft level + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + dtime = get_step_size() + nstep = get_nstep() + call get_curr_date (year, month, day, secs) + + ! Allocate needed dynamic memory for single level pft field + + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)'update_accum_hist allocation error for rbuf1dp' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + ! Accumulate and extract T_VEG24 & T_VEG240 + do p = begp,endp + rbufslp(p) = this%t_veg_patch(p) + end do + call update_accum_field ('T_VEG24' , rbufslp , nstep) + call extract_accum_field ('T_VEG24' , this%t_veg24_patch , nstep) + call update_accum_field ('T_VEG240', rbufslp , nstep) + call extract_accum_field ('T_VEG240', this%t_veg240_patch , nstep) + + ! Accumulate and extract TREFAV - hourly average 2m air temperature + ! Used to compute maximum and minimum of hourly averaged 2m reference + ! temperature over a day. Note that "spval" is returned by the call to + ! accext if the time step does not correspond to the end of an + ! accumulation interval. First, initialize the necessary values for + ! an initial run at the first time step the accumulator is called + + call update_accum_field ('TREFAV', this%t_ref2m_patch, nstep) + call extract_accum_field ('TREFAV', rbufslp, nstep) + end_cd = is_end_curr_day() + do p = begp,endp + if (rbufslp(p) /= spval) then + this%t_ref2m_max_inst_patch(p) = max(rbufslp(p), this%t_ref2m_max_inst_patch(p)) + this%t_ref2m_min_inst_patch(p) = min(rbufslp(p), this%t_ref2m_min_inst_patch(p)) + endif + if (end_cd) then + this%t_ref2m_max_patch(p) = this%t_ref2m_max_inst_patch(p) + this%t_ref2m_min_patch(p) = this%t_ref2m_min_inst_patch(p) + this%t_ref2m_max_inst_patch(p) = -spval + this%t_ref2m_min_inst_patch(p) = spval + else if (secs == dtime) then + this%t_ref2m_max_patch(p) = spval + this%t_ref2m_min_patch(p) = spval + endif + end do + + ! Accumulate and extract TREFAV_U - hourly average urban 2m air temperature + ! Used to compute maximum and minimum of hourly averaged 2m reference + ! temperature over a day. Note that "spval" is returned by the call to + ! accext if the time step does not correspond to the end of an + ! accumulation interval. First, initialize the necessary values for + ! an initial run at the first time step the accumulator is called + + call update_accum_field ('TREFAV_U', this%t_ref2m_u_patch, nstep) + call extract_accum_field ('TREFAV_U', rbufslp, nstep) + do p = begp,endp + l = patch%landunit(p) + if (rbufslp(p) /= spval) then + this%t_ref2m_max_inst_u_patch(p) = max(rbufslp(p), this%t_ref2m_max_inst_u_patch(p)) + this%t_ref2m_min_inst_u_patch(p) = min(rbufslp(p), this%t_ref2m_min_inst_u_patch(p)) + endif + if (end_cd) then + if (lun%urbpoi(l)) then + this%t_ref2m_max_u_patch(p) = this%t_ref2m_max_inst_u_patch(p) + this%t_ref2m_min_u_patch(p) = this%t_ref2m_min_inst_u_patch(p) + this%t_ref2m_max_inst_u_patch(p) = -spval + this%t_ref2m_min_inst_u_patch(p) = spval + end if + else if (secs == dtime) then + this%t_ref2m_max_u_patch(p) = spval + this%t_ref2m_min_u_patch(p) = spval + endif + end do + + ! Accumulate and extract TREFAV_R - hourly average rural 2m air temperature + ! Used to compute maximum and minimum of hourly averaged 2m reference + ! temperature over a day. Note that "spval" is returned by the call to + ! accext if the time step does not correspond to the end of an + ! accumulation interval. First, initialize the necessary values for + ! an initial run at the first time step the accumulator is called + + call update_accum_field ('TREFAV_R', this%t_ref2m_r_patch, nstep) + call extract_accum_field ('TREFAV_R', rbufslp, nstep) + do p = begp,endp + l = patch%landunit(p) + if (rbufslp(p) /= spval) then + this%t_ref2m_max_inst_r_patch(p) = max(rbufslp(p), this%t_ref2m_max_inst_r_patch(p)) + this%t_ref2m_min_inst_r_patch(p) = min(rbufslp(p), this%t_ref2m_min_inst_r_patch(p)) + endif + if (end_cd) then + if (.not.(lun%ifspecial(l))) then + this%t_ref2m_max_r_patch(p) = this%t_ref2m_max_inst_r_patch(p) + this%t_ref2m_min_r_patch(p) = this%t_ref2m_min_inst_r_patch(p) + this%t_ref2m_max_inst_r_patch(p) = -spval + this%t_ref2m_min_inst_r_patch(p) = spval + end if + else if (secs == dtime) then + this%t_ref2m_max_r_patch(p) = spval + this%t_ref2m_min_r_patch(p) = spval + endif + end do + + ! Accumulate and extract T10 + !(acumulates TSA as 10-day running mean) + + call update_accum_field ('T10', this%t_ref2m_patch, nstep) + call extract_accum_field ('T10', this%t_a10_patch, nstep) + + do p = begp,endp + c = patch%column(p) + rbufslp(p) = this%t_soisno_col(c,3) + end do + call update_accum_field ('SOIL10', rbufslp, nstep) + call extract_accum_field ('SOIL10', this%soila10_patch, nstep) + + ! Accumulate and extract TDM5 + + do p = begp,endp + rbufslp(p) = min(this%t_ref2m_min_patch(p),this%t_ref2m_min_inst_patch(p)) !slevis: ok choice? + if (rbufslp(p) > 1.e30_r8) rbufslp(p) = SHR_CONST_TKFRZ !and were 'min'& + end do !'min_inst' not initialized? + call update_accum_field ('TDM5', rbufslp, nstep) + call extract_accum_field ('TDM5', this%t_a5min_patch, nstep) + + if ( use_crop )then + ! Accumulate and extract TDM10 + + do p = begp,endp + rbufslp(p) = min(this%t_ref2m_min_patch(p),this%t_ref2m_min_inst_patch(p)) !slevis: ok choice? + if (rbufslp(p) > 1.e30_r8) rbufslp(p) = SHR_CONST_TKFRZ !and were 'min'& + end do !'min_inst' not initialized? + call update_accum_field ('TDM10', rbufslp, nstep) + call extract_accum_field ('TDM10', this%t_a10min_patch, nstep) + + + + ! Accumulate and extract GDD0 + + do p = begp,endp + ! Avoid unnecessary calculations over inactive points + if (patch%active(p)) then + g = patch%gridcell(p) + if (month==1 .and. day==1 .and. secs==dtime) then + rbufslp(p) = accumResetVal ! reset gdd + else if (( month > 3 .and. month < 10 .and. grc%latdeg(g) >= 0._r8) .or. & + ((month > 9 .or. month < 4) .and. grc%latdeg(g) < 0._r8) ) then + rbufslp(p) = max(0._r8, min(26._r8, this%t_ref2m_patch(p)-SHR_CONST_TKFRZ)) * dtime/SHR_CONST_CDAY + else + rbufslp(p) = 0._r8 ! keeps gdd unchanged at other times (eg, through Dec in NH) + end if + end if + end do + call update_accum_field ('GDD0', rbufslp, nstep) + call extract_accum_field ('GDD0', this%gdd0_patch, nstep) + + ! Accumulate and extract GDD8 + + do p = begp,endp + ! Avoid unnecessary calculations over inactive points + if (patch%active(p)) then + g = patch%gridcell(p) + if (month==1 .and. day==1 .and. secs==dtime) then + rbufslp(p) = accumResetVal ! reset gdd + else if (( month > 3 .and. month < 10 .and. grc%latdeg(g) >= 0._r8) .or. & + ((month > 9 .or. month < 4) .and. grc%latdeg(g) < 0._r8) ) then + rbufslp(p) = max(0._r8, min(30._r8, & + this%t_ref2m_patch(p)-(SHR_CONST_TKFRZ + 8._r8))) * dtime/SHR_CONST_CDAY + else + rbufslp(p) = 0._r8 ! keeps gdd unchanged at other times (eg, through Dec in NH) + end if + end if + end do + call update_accum_field ('GDD8', rbufslp, nstep) + call extract_accum_field ('GDD8', this%gdd8_patch, nstep) + + ! Accumulate and extract GDD10 + + do p = begp,endp + ! Avoid unnecessary calculations over inactive points + if (patch%active(p)) then + g = patch%gridcell(p) + if (month==1 .and. day==1 .and. secs==dtime) then + rbufslp(p) = accumResetVal ! reset gdd + else if (( month > 3 .and. month < 10 .and. grc%latdeg(g) >= 0._r8) .or. & + ((month > 9 .or. month < 4) .and. grc%latdeg(g) < 0._r8) ) then + rbufslp(p) = max(0._r8, min(30._r8, & + this%t_ref2m_patch(p)-(SHR_CONST_TKFRZ + 10._r8))) * dtime/SHR_CONST_CDAY + else + rbufslp(p) = 0._r8 ! keeps gdd unchanged at other times (eg, through Dec in NH) + end if + end if + end do + call update_accum_field ('GDD10', rbufslp, nstep) + call extract_accum_field ('GDD10', this%gdd10_patch, nstep) + + end if + + deallocate(rbufslp) + + end subroutine UpdateAccVars + +end module TemperatureType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/TridiagonalMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/TridiagonalMod.F90 new file mode 100644 index 000000000..46532b0d8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/WaterDiagnosticBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterDiagnosticBulkType.F90 new file mode 100644 index 000000000..2f3c2cace --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterDiagnosticBulkType.F90 @@ -0,0 +1,1112 @@ +module WaterDiagnosticBulkType + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Defines a derived type containing water diagnostic variables that just apply to bulk + ! water. Diagnostic variables are neither fundamental state variables nor fluxes + ! between those fundamental states, but are typically derived from those states and/or + ! fluxes. Note that this type extends the base waterdiagnostic_type, so the full + ! waterdiagnosticbulk_type contains the union of the fields defined here and the fields + ! defined in waterdiagnostic_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 clm_varctl , only : use_cn, iulog, use_luna + use clm_varpar , only : nlevgrnd, nlevsno, nlevcan + use clm_varcon , only : spval + use LandunitType , only : lun + use ColumnType , only : col + use filterColMod , only : filter_col_type, col_filter_from_ltypes + use WaterDiagnosticType, only : waterdiagnostic_type + use WaterInfoBaseType, only : water_info_base_type + use WaterTracerContainerType, only : water_tracer_container_type + use WaterStateType, only : waterstate_type + use WaterStateBulkType, only : waterstatebulk_type + use WaterFluxType, only : waterflux_type + ! + implicit none + save + private + ! + ! !PUBLIC TYPES: + 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 + procedure, public :: RestartBulk + procedure, public :: Summary + procedure, public :: ResetBulkFilter + procedure, public :: ResetBulk + procedure, private :: InitBulkAllocate + procedure, private :: InitBulkHistory + procedure, private :: InitBulkCold + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: UpdateAccVars + procedure, private :: RestartBackcompatIssue783 + + end type waterdiagnosticbulk_type + + ! PUBLIC MEMBER FUNCTIONS + public :: readParams + + type, private :: params_type + real(r8) :: zlnd ! Momentum roughness length for soil, glacier, wetland (m) + end type params_type + type(params_type), private :: params_inst + + ! minimum allowed snow effective radius (also "fresh snow" value) [microns] + real(r8), public, parameter :: snw_rds_min = 54.526_r8 + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + 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_WaterDiagnosticBulk' + !-------------------------------------------------------------------- + + ! Momentum roughness length for soil, glacier, wetland (m) + call readNcdioScalar(ncid, 'zlnd', subname, params_inst%zlnd) + + end subroutine readParams + + !------------------------------------------------------------------------ + subroutine InitBulk(this, bounds, info, vars, & + snow_depth_input_col, h2osno_input_col) + + class(waterdiagnosticbulk_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + type(water_tracer_container_type), intent(inout) :: vars + real(r8) , intent(in) :: snow_depth_input_col(bounds%begc:) + real(r8) , intent(in) :: h2osno_input_col(bounds%begc:) ! Initial total snow water (mm H2O) + + + call this%Init(bounds, info, vars) + + call this%InitBulkAllocate(bounds) + + call this%InitBulkHistory(bounds) + + call this%InitBulkCold(bounds, & + snow_depth_input_col, h2osno_input_col) + + end subroutine InitBulk + + !------------------------------------------------------------------------ + subroutine InitBulkAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + 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%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 InitBulkAllocate + + !------------------------------------------------------------------------ + subroutine InitBulkHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal, no_snow_zero + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + this%h2osno_total_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('H2OSNO'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('snow depth (liquid water)'), & + ptr_col=this%h2osno_total_col, c2l_scale_type='urbanf') + call hist_addfld1d ( & + fname=this%info%fname('H2OSNO_ICE'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('snow depth (liquid water, ice landunits only)'), & + ptr_col=this%h2osno_total_col, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%h2osoi_liq_tot_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('TOTSOILLIQ'), & + units='kg/m2', & + avgflag='A', & + long_name=this%info%lname('vertically summed soil liquid water (veg landunits only)'), & + ptr_col=this%h2osoi_liq_tot_col, l2g_scale_type='veg') + + this%h2osoi_ice_tot_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('TOTSOILICE'), & + units='kg/m2', & + avgflag='A', & + long_name=this%info%lname('vertically summed soil cie (veg landunits only)'), & + ptr_col=this%h2osoi_ice_tot_col, l2g_scale_type='veg') + + this%iwue_ln_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('IWUELN'), & + units='umolCO2/molH2O', & + avgflag='A', & + long_name=this%info%lname('local noon intrinsic water use efficiency'), & + ptr_patch=this%iwue_ln_patch, set_lake=spval, set_urb=spval) + + this%vpd_ref2m_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('VPD2M'), & + units='Pa', & + avgflag='A', & + long_name=this%info%lname('2m vapor pressure deficit'), & + ptr_patch=this%vpd_ref2m_patch) + + this%rh_ref2m_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('RH2M'), & + units='%', & + avgflag='A', & + long_name=this%info%lname('2m relative humidity'), & + ptr_patch=this%rh_ref2m_patch) + + this%rh_ref2m_r_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('RH2M_R'), & + units='%', & + avgflag='A', & + long_name=this%info%lname('Rural 2m specific humidity'), & + ptr_patch=this%rh_ref2m_r_patch, set_spec=spval, default='inactive') + + this%rh_ref2m_u_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('RH2M_U'), & + units='%', & + avgflag='A', & + long_name=this%info%lname('Urban 2m relative humidity'), & + ptr_patch=this%rh_ref2m_u_patch, set_nourb=spval, default='inactive') + + this%rh_af_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('RHAF'), & + units='fraction', & + avgflag='A', & + long_name=this%info%lname('fractional humidity of canopy air'), & + ptr_patch=this%rh_af_patch, set_spec=spval, default='inactive') + + if(use_luna)then + call hist_addfld1d ( & + fname=this%info%fname('RHAF10'), & + units='fraction', & + avgflag='A', & + long_name=this%info%lname('10 day running mean of fractional humidity of canopy air'), & + ptr_patch=this%rh10_af_patch, set_spec=spval, default='inactive') + endif + + ! Fractions + + this%frac_h2osfc_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('FH2OSFC'), & + units='unitless', & + avgflag='A', & + long_name=this%info%lname('fraction of ground covered by surface water'), & + ptr_col=this%frac_h2osfc_col) + + this%frac_h2osfc_nosnow_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('FH2OSFC_NOSNOW'), & + units='unitless', & + avgflag='A', & + long_name=this%info%lname('fraction of ground covered by surface water (if no snow present)'), & + ptr_col=this%frac_h2osfc_nosnow_col, default='inactive') + + this%frac_sno_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('FSNO'), & + units='unitless', & + avgflag='A', & + long_name=this%info%lname('fraction of ground covered by snow'), & + ptr_col=this%frac_sno_col, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('FSNO_ICE'), & + units='unitless', & + avgflag='A', & + long_name=this%info%lname('fraction of ground covered by snow (ice landunits only)'), & + ptr_col=this%frac_sno_col, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%frac_sno_eff_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('FSNO_EFF'), & + units='unitless', & + avgflag='A', & + long_name=this%info%lname('effective fraction of ground covered by snow'), & + ptr_col=this%frac_sno_eff_col, c2l_scale_type='urbanf')!, default='inactive') + + if (use_cn) then + this%fwet_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('FWET'), & + units='proportion', & + avgflag='A', & + long_name=this%info%lname('fraction of canopy that is wet'), & + ptr_patch=this%fwet_patch, default='inactive') + end if + + if (use_cn) then + this%fcansno_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('FCANSNO'), & + units='proportion', & + avgflag='A', & + long_name=this%info%lname('fraction of canopy that is wet'), & + ptr_patch=this%fcansno_patch, default='inactive') + end if + + if (use_cn) then + this%fdry_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('FDRY'), & + units='proportion', & + avgflag='A', & + long_name=this%info%lname('fraction of foliage that is green and dry'), & + ptr_patch=this%fdry_patch, default='inactive') + end if + + if (use_cn)then + this%frac_iceold_col(begc:endc,:) = spval + call hist_addfld2d ( & + fname=this%info%fname('FRAC_ICEOLD'), & + units='proportion', type2d='levgrnd', & + avgflag='A', & + long_name=this%info%lname('fraction of ice relative to the tot water'), & + ptr_col=this%frac_iceold_col, default='inactive') + end if + + ! Snow properties - these will be vertically averaged over the snow profile + + this%snow_depth_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNOW_DEPTH'), & + units='m', & + avgflag='A', & + long_name=this%info%lname('snow height of snow covered area'), & + ptr_col=this%snow_depth_col, c2l_scale_type='urbanf') + this%snow_5day_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNOW_5D'), & + units='m', & + avgflag='A', & + long_name=this%info%lname('5day snow avg'), & + ptr_col=this%snow_5day_col, c2l_scale_type='urbanf', default='inactive') + + call hist_addfld1d ( & + fname=this%info%fname('SNOW_DEPTH_ICE'), & + units='m', & + avgflag='A', & + long_name=this%info%lname('snow height of snow covered area (ice landunits only)'), & + ptr_col=this%snow_depth_col, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%snowdp_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNOWDP'), & + units='m', & + avgflag='A', & + long_name=this%info%lname('gridcell mean snow height'), & + ptr_col=this%snowdp_col, c2l_scale_type='urbanf') + + if (use_cn) then + this%wf_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('WF'), & + units='proportion', & + avgflag='A', & + long_name=this%info%lname('soil water as frac. of whc for top 0.05 m'), & + ptr_col=this%wf_col, default='inactive') + end if + + this%h2osno_top_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('H2OSNO_TOP'), & + units='kg/m2', & + avgflag='A', & + long_name=this%info%lname('mass of snow in top snow layer'), & + ptr_col=this%h2osno_top_col, set_urb=spval) + + this%snw_rds_top_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNORDSL'), & + units='m^-6', & + avgflag='A', & + long_name=this%info%lname('top snow layer effective grain radius'), & + ptr_col=this%snw_rds_top_col, set_urb=spval, default='inactive') + + this%sno_liq_top_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNOLIQFL'), & + units='fraction', & + avgflag='A', & + long_name=this%info%lname('top snow layer liquid water fraction (land)'), & + ptr_col=this%sno_liq_top_col, set_urb=spval, default='inactive') + + ! We determine the fractional time (and fraction of the grid cell) over which each + ! snow layer existed by running the snow averaging routine on a field whose value is 1 + ! everywhere + data2dptr => this%snow_layer_unity_col(:,-nlevsno+1:0) + call hist_addfld2d ( & + fname=this%info%fname('SNO_EXISTENCE'), & + units='unitless', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('Fraction of averaging period for which each snow layer existed'), & + ptr_col=data2dptr, no_snow_behavior=no_snow_zero, default='inactive') + + this%bw_col(begc:endc,-nlevsno+1:0) = spval + data2dptr => this%bw_col(:,-nlevsno+1:0) + call hist_addfld2d ( & + fname=this%info%fname('SNO_BW'), & + units='kg/m3', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('Partial density of water in the snow pack (ice + liquid)'), & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') + + call hist_addfld2d ( & + fname=this%info%fname('SNO_BW_ICE'), & + units='kg/m3', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('Partial density of water in the snow pack (ice + liquid, ice landunits only)'), & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, & + l2g_scale_type='ice', default='inactive') + + this%snw_rds_col(begc:endc,-nlevsno+1:0) = spval + data2dptr => this%snw_rds_col(:,-nlevsno+1:0) + call hist_addfld2d ( & + fname=this%info%fname('SNO_GS'), & + units='Microns', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('Mean snow grain size'), & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') + + call hist_addfld2d ( & + fname=this%info%fname('SNO_GS_ICE'), & + units='Microns', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('Mean snow grain size (ice landunits only)'), & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, & + l2g_scale_type='ice', default='inactive') + + ! Summed fluxes + + this%qflx_prec_intr_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QINTR'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('interception'), & + ptr_patch=this%qflx_prec_intr_patch, set_lake=0._r8) + + end subroutine InitBulkHistory + + !----------------------------------------------------------------------- + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! + ! !USES + use clm_varcon , only : spval + use accumulMod , only : init_accum_field + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_type) :: this + type(bounds_type), intent(in) :: bounds + !--------------------------------------------------------------------- + + this%snow_5day_col(bounds%begc:bounds%endc) = spval + call init_accum_field (name='SNOW_5D', units='m', & + desc='5-day running mean of snowdepth', accum_type='runmean', accum_period=-5, & + subgrid_type='column', numlev=1, init_value=0._r8) + + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + subroutine InitAccVars (this, bounds) + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES + use accumulMod , only : extract_accum_field + use clm_time_manager , only : get_nstep + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: nstep + integer :: ier + real(r8), pointer :: rbufslp(:) ! temporary + !--------------------------------------------------------------------- + begc = bounds%begc; endc = bounds%endc + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begc:endc), stat=ier) + + ! Determine time step + nstep = get_nstep() + call extract_accum_field ('SNOW_5D', rbufslp, nstep) + this%snow_5day_col(begc:endc) = rbufslp(begc:endc) + + deallocate(rbufslp) + + end subroutine InitAccVars + +!----------------------------------------------------------------------- + subroutine UpdateAccVars (this, bounds) + ! + ! USES + use clm_time_manager, only : get_nstep + use accumulMod , only : update_accum_field, extract_accum_field + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: c ! indices + integer :: dtime ! timestep size [seconds] + integer :: nstep ! timestep number + integer :: ier ! error status + !--------------------------------------------------------------------- + + nstep = get_nstep() + + ! Allocate needed dynamic memory for single level patch field + + + ! Accumulate and extract snow 10 day + call update_accum_field ('SNOW_5D', this%snow_depth_col, nstep) + call extract_accum_field ('SNOW_5D', this%snow_5day_col, nstep) + + + + end subroutine UpdateAccVars + + + !----------------------------------------------------------------------- + + subroutine InitBulkCold(this, bounds, & + snow_depth_input_col, h2osno_input_col) + ! + ! !DESCRIPTION: + ! Initialize time constant variables and cold start conditions + ! + ! !USES: + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_type), intent(in) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: snow_depth_input_col(bounds%begc:) + real(r8) , intent(in) :: h2osno_input_col(bounds%begc:) ! Initial total snow water (mm H2O) + ! + ! !LOCAL VARIABLES: + integer :: c,l + real(r8) :: snowbd ! temporary calculation of snow bulk density (kg/m3) + real(r8) :: fmelt ! snowbd/100 + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(snow_depth_input_col) == (/bounds%endc/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(h2osno_input_col) == (/bounds%endc/)), sourcefile, __LINE__) + + do c = bounds%begc,bounds%endc + this%snow_depth_col(c) = snow_depth_input_col(c) + this%snow_layer_unity_col(c,:) = 1._r8 + end do + + do c = bounds%begc,bounds%endc + this%wf_col(c) = spval + this%wf2_col(c) = spval + end do + + + associate(snl => col%snl) + + this%frac_h2osfc_col(bounds%begc:bounds%endc) = 0._r8 + + this%fwet_patch(bounds%begp:bounds%endp) = 0._r8 + this%fdry_patch(bounds%begp:bounds%endp) = 0._r8 + this%fcansno_patch(bounds%begp:bounds%endp) = 0._r8 + + this%qflx_prec_intr_patch(bounds%begp:bounds%endp) = 0._r8 + + !-------------------------------------------- + ! Set snow water + !-------------------------------------------- + + ! Note: Glacier_mec columns are initialized with half the maximum snow cover. + ! This gives more realistic values of qflx_glcice sooner in the simulation + ! for columns with net ablation, at the cost of delaying ice formation + ! in columns with net accumulation. + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (lun%urbpoi(l)) then + ! From Bonan 1996 (LSM technical note) + this%frac_sno_col(c) = min( this%snow_depth_col(c)/0.05_r8, 1._r8) + else + this%frac_sno_col(c) = 0._r8 + ! snow cover fraction as in Niu and Yang 2007 + if(this%snow_depth_col(c) > 0.0) then + snowbd = min(400._r8, h2osno_input_col(c)/this%snow_depth_col(c)) !bulk density of snow (kg/m3) + fmelt = (snowbd/100.)**1. + ! 100 is the assumed fresh snow density; 1 is a melting factor that could be + ! reconsidered, optimal value of 1.5 in Niu et al., 2007 + this%frac_sno_col(c) = tanh( this%snow_depth_col(c) / (2.5 * params_inst%zlnd * fmelt) ) + endif + end if + end do + + do c = bounds%begc,bounds%endc + if (snl(c) < 0) then + this%snw_rds_col(c,snl(c)+1:0) = snw_rds_min + this%snw_rds_col(c,-nlevsno+1:snl(c)) = 0._r8 + this%snw_rds_top_col(c) = snw_rds_min + elseif (h2osno_input_col(c) > 0._r8) then + this%snw_rds_col(c,0) = snw_rds_min + this%snw_rds_col(c,-nlevsno+1:-1) = 0._r8 + this%snw_rds_top_col(c) = spval + this%sno_liq_top_col(c) = spval + else + this%snw_rds_col(c,:) = 0._r8 + this%snw_rds_top_col(c) = spval + this%sno_liq_top_col(c) = spval + endif + end do + + + end associate + + end subroutine InitBulkCold + + !------------------------------------------------------------------------ + subroutine RestartBulk(this, bounds, ncid, flag, writing_finidat_interp_dest_file, waterstatebulk_inst) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use spmdMod , only : masterproc + use clm_varcon , only : pondmx, watmin, spval, nameg + use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall + use clm_varctl , only : bound_h2osoi + use ncdio_pio , only : file_desc_t, ncd_io, ncd_double + use restUtilMod + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_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' + logical, intent(in) :: writing_finidat_interp_dest_file ! true if we are writing a finidat_interp_dest file (ignored for flag=='read') + type(waterstatebulk_type), intent(in) :: waterstatebulk_inst + ! + ! !LOCAL VARIABLES: + logical :: readvar + !------------------------------------------------------------------------ + + + call this%Restart(bounds, ncid, flag=flag) + + if(use_luna)then + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('rh10'), & + xtype=ncd_double, & + dim1name='pft', & + long_name=this%info%lname('10-day mean boundary layer relative humidity'), & + units='unitless', & + interpinic_flag='interp', readvar=readvar, data=this%rh10_af_patch) + endif + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('FH2OSFC'), & + xtype=ncd_double, & + dim1name='column',& + long_name=this%info%lname('fraction of ground covered by h2osfc (0 to 1)'), & + units='', & + interpinic_flag='interp', readvar=readvar, data=this%frac_h2osfc_col) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('SNOW_DEPTH'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('snow depth'), & + units='m', & + interpinic_flag='interp', readvar=readvar, data=this%snow_depth_col) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('frac_sno_eff'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('fraction of ground covered by snow (0 to 1)'),& + units='unitless', & + interpinic_flag='interp', readvar=readvar, data=this%frac_sno_eff_col) + if (flag == 'read' .and. .not. readvar) then + this%frac_sno_eff_col(bounds%begc:bounds%endc) = 0.0_r8 + end if + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('frac_sno'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('fraction of ground covered by snow (0 to 1)'),& + units='unitless',& + interpinic_flag='interp', readvar=readvar, data=this%frac_sno_col) + call this%RestartBackcompatIssue783( & + bounds = bounds, & + ncid = ncid, & + flag = flag, & + writing_finidat_interp_dest_file = writing_finidat_interp_dest_file, & + waterstatebulk_inst = waterstatebulk_inst) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('IWUELN'), & + xtype=ncd_double, & + dim1name='pft', & + long_name=this%info%lname('local noon intrinsic water use efficiency'), & + units='umolCO2/molH2O', & + interpinic_flag='interp', readvar=readvar, data=this%iwue_ln_patch) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('VPD2M'), & + xtype=ncd_double, & + dim1name='pft', & + long_name=this%info%lname('2m vapor pressure deficit'), & + units='Pa', & + interpinic_flag='interp', readvar=readvar, data=this%vpd_ref2m_patch) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('FWET'), & + xtype=ncd_double, & + dim1name='pft', & + long_name=this%info%lname('fraction of canopy that is wet (0 to 1)'), & + units='', & + interpinic_flag='interp', readvar=readvar, data=this%fwet_patch) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('FCANSNO'), & + xtype=ncd_double, & + dim1name='pft', & + long_name=this%info%lname('fraction of canopy that is snow covered (0 to 1)'), & + units='', & + interpinic_flag='interp', readvar=readvar, data=this%fcansno_patch) + + ! column type physical state variable - snw_rds + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('snw_rds'), & + xtype=ncd_double, & + dim1name='column', dim2name='levsno', switchdim=.true., lowerb2=-nlevsno+1, upperb2=0, & + long_name=this%info%lname('snow layer effective radius'), & + units='um', & + interpinic_flag='interp', readvar=readvar, data=this%snw_rds_col) + if (flag == 'read' .and. .not. readvar) then + ! NOTE(wjs, 2018-08-03) There was some code here that looked like it was just for + ! the sake of backwards compatibility, dating back to 2014 or earlier. I was + ! tempted to just remove it, but on the off-chance that this conditional is still + ! ever entered, I'm putting an endrun call here to notify users of this removed + ! code. + if (masterproc) then + write(iulog,*) "SNICAR: This is an initial run (not a restart), and grain size/aerosol " // & + "mass data are not defined in initial condition file. This situation is no longer handled." + endif + call endrun(msg = "Absent snw_rds on initial conditions file no longer handled. "// & + errMsg(sourcefile, __LINE__)) + endif + + if (use_cn) then + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('wf'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname(''), & + units='', & + interpinic_flag='interp', readvar=readvar, data=this%wf_col) + end if + + + + end subroutine RestartBulk + + !----------------------------------------------------------------------- + subroutine RestartBackcompatIssue783(this, bounds, ncid, flag, & + writing_finidat_interp_dest_file, waterstatebulk_inst) + ! + ! !DESCRIPTION: + ! Apply backwards compatibility corrections to address issue ESCOMP/ctsm#783 + ! + ! BACKWARDS_COMPATIBILITY(wjs, 2019-10-15) Due to ESCOMP/ctsm#783, old restart files + ! can have frac_sno == 0 for lake points despite having a snow pack. This can cause + ! other problems, so fix that here. However, it is apparently possible for frac_sno to + ! be 0 legitimately when h2osno_total > 0. So if we apply this correction always, then + ! we sometimes introduce unintentional changes to newer restart files where we don't + ! actually need to apply this correction. We avoid this by writing metadata to the + ! restart file indicating that it's new enough to have this correction already in + ! place, then avoiding doing the correction here if we find we're working with a + ! new-enough restart file. + ! + ! This backwards compatibility code can be removed once we can rely on all restart + ! files being new enough. i.e., we can remove this code once we can rely all restart + ! files having this new piece of metadata (at which point we can also stop writing + ! this metadata, as long as we don't need to use newer restart files with older code + ! versions). + ! + ! !USES: + use ncdio_pio , only : file_desc_t + use IssueFixedMetadataHandler, only : write_issue_fixed_metadata, read_issue_fixed_metadata + use landunit_varcon , only : istdlak + use clm_time_manager , only : is_restart + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_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' + logical, intent(in) :: writing_finidat_interp_dest_file ! true if this is a finidat_interp_dest file + type(waterstatebulk_type), intent(in) :: waterstatebulk_inst + ! + ! !LOCAL VARIABLES: + integer :: fc, c + integer :: attribute_value + logical :: do_correction + real(r8) :: h2osno_total(bounds%begc:bounds%endc) ! total snow water (mm H2O) + type(filter_col_type) :: filter_lakec ! filter for lake columns + + integer, parameter :: issue_num = 783 + + character(len=*), parameter :: subname = 'RestartBackcompatIssue783' + !----------------------------------------------------------------------- + + if (flag == 'define') then + call write_issue_fixed_metadata( & + ncid = ncid, & + writing_finidat_interp_dest_file = writing_finidat_interp_dest_file, & + issue_num = issue_num) + + else if (flag == 'read' .and. .not. is_restart()) then + call read_issue_fixed_metadata( & + ncid = ncid, & + issue_num = issue_num, & + attribute_value = attribute_value) + if (attribute_value == 0) then + do_correction = .true. + else + do_correction = .false. + end if + + if (do_correction) then + filter_lakec = col_filter_from_ltypes( & + bounds = bounds, & + ltypes = [istdlak], & + include_inactive = .true.) + call waterstatebulk_inst%CalculateTotalH2osno( & + bounds = bounds, & + num_c = filter_lakec%num, & + filter_c = filter_lakec%indices, & + caller = 'WaterDiagnosticBulkType_RestartBulk', & + h2osno_total = h2osno_total(bounds%begc:bounds%endc)) + do fc = 1, filter_lakec%num + c = filter_lakec%indices(fc) + if (this%frac_sno_col(c) == 0._r8 .and. h2osno_total(c) > 0._r8) then + ! Often the value should be between 0 and 1 rather than being 1, but 1 is at + ! least better than 0 in this case, and it would be tricky or impossible to + ! figure out the "correct" value. + this%frac_sno_col(c) = 1._r8 + end if + end do + end if + end if + + end subroutine RestartBackcompatIssue783 + + !----------------------------------------------------------------------- + subroutine Summary(this, bounds, & + num_soilp, filter_soilp, & + num_allc, filter_allc, & + num_nolakec, filter_nolakec, & + waterstate_inst, waterflux_inst) + ! + ! !DESCRIPTION: + ! Compute end-of-timestep summaries of water diagnostic terms + ! + ! !USES: + use clm_varpar , only : nlevsoi + ! !ARGUMENTS: + class(waterdiagnosticbulk_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of patches in soilp filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all columns + integer , intent(in) :: num_nolakec ! number of columns in no-lake columnc filter + integer , intent(in) :: filter_nolakec(:) ! filter for no-lake columns + class(waterstate_type) , intent(in) :: waterstate_inst + class(waterflux_type) , intent(in) :: waterflux_inst + ! + ! !LOCAL VARIABLES: + integer :: fp, p, j, l, fc, c ! Indices + real(r8):: fracl ! fraction of soil layer contributing to 10cm total soil water + + character(len=*), parameter :: subname = 'Summary' + !----------------------------------------------------------------------- + associate( & + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness depth (m) + zi => col%zi , & ! Input: [real(r8) (:,:) ] interface depth (m) + + h2osoi_ice => waterstate_inst%h2osoi_ice_col, & ! Output: [real(r8) (:,:) ] ice lens (kg/m2) + h2osoi_liq => waterstate_inst%h2osoi_liq_col, & ! Output: [real(r8) (:,:) ] liquid water (kg/m2) + + h2osoi_ice_tot => this%h2osoi_ice_tot_col , & ! Output: [real(r8) (:) ] vertically summed ice lens (kg/m2) + h2osoi_liq_tot => this%h2osoi_liq_tot_col , & ! Output: [real(r8) (:) ] vertically summed liquid water (kg/m2) + h2osoi_liqice_10cm => this%h2osoi_liqice_10cm_col & ! Output: [real(r8) (:) ] liquid water + ice lens in top 10cm of soil (kg/m2) + ) + + call this%waterdiagnostic_type%Summary(bounds, & + num_soilp, filter_soilp, & + num_allc, filter_allc, & + num_nolakec, filter_nolakec, & + waterstate_inst, waterflux_inst) + + call waterstate_inst%CalculateTotalH2osno(bounds, num_allc, filter_allc, & + caller = 'WaterDiagnosticBulkType:Summary', & + h2osno_total = this%h2osno_total_col(bounds%begc:bounds%endc)) + + do fp = 1, num_soilp + p = filter_soilp(fp) + this%qflx_prec_intr_patch(p) = & + waterflux_inst%qflx_intercepted_liq_patch(p) + & + waterflux_inst%qflx_intercepted_snow_patch(p) + end do + + do fc = 1, num_allc + c = filter_allc(fc) + this%qflx_prec_grnd_col(c) = & + waterflux_inst%qflx_liq_grnd_col(c) + & + waterflux_inst%qflx_snow_grnd_col(c) + end do + do fc = 1, num_nolakec + c = filter_nolakec(fc) + l = col%landunit(c) + if (.not. lun%urbpoi(l)) then + h2osoi_liqice_10cm(c) = 0.0_r8 + h2osoi_liq_tot(c) = 0._r8 + h2osoi_ice_tot(c) = 0._r8 + end if + end do + do j = 1, nlevsoi + do fc = 1, num_nolakec + c = filter_nolakec(fc) + l = col%landunit(c) + if (.not. lun%urbpoi(l)) then + if (zi(c,j) <= 0.1_r8) then + fracl = 1._r8 + h2osoi_liqice_10cm(c) = h2osoi_liqice_10cm(c) + & + (h2osoi_liq(c,j)+h2osoi_ice(c,j))* & + fracl + else + if (zi(c,j) > 0.1_r8 .and. zi(c,j-1) < 0.1_r8) then + fracl = (0.1_r8 - zi(c,j-1))/dz(c,j) + h2osoi_liqice_10cm(c) = h2osoi_liqice_10cm(c) + & + (h2osoi_liq(c,j)+h2osoi_ice(c,j))* & + fracl + end if + end if + h2osoi_liq_tot(c) = h2osoi_liq_tot(c) + h2osoi_liq(c,j) + h2osoi_ice_tot(c) = h2osoi_ice_tot(c) + h2osoi_ice(c,j) + end if + end do + end do + + end associate + + end subroutine Summary + + !----------------------------------------------------------------------- + subroutine ResetBulkFilter(this, num_c, filter_c) + ! + ! !DESCRIPTION: + ! Initialize SNICAR variables for fresh snow columns, for all columns in the given + ! filter + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_type), intent(inout) :: this + integer, intent(in) :: num_c ! number of columns in filter_c + integer, intent(in) :: filter_c(:) ! column filter to operate over + ! + ! !LOCAL VARIABLES: + integer :: fc, c + + character(len=*), parameter :: subname = 'ResetBulkFilter' + !----------------------------------------------------------------------- + + do fc = 1, num_c + c = filter_c(fc) + call this%ResetBulk(c) + end do + + end subroutine ResetBulkFilter + + !----------------------------------------------------------------------- + subroutine ResetBulk(this, column) + ! + ! !DESCRIPTION: + ! Intitialize SNICAR variables for fresh snow column + ! + ! !ARGUMENTS: + class(waterdiagnosticbulk_type), intent(inout) :: this + integer , intent(in) :: column ! column index + !----------------------------------------------------------------------- + + this%snw_rds_col(column,0) = snw_rds_min + + end subroutine ResetBulk + +end module WaterDiagnosticBulkType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterDiagnosticType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterDiagnosticType.F90 new file mode 100644 index 000000000..0006ecc20 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterDiagnosticType.F90 @@ -0,0 +1,370 @@ +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 decompMod , only : BOUNDS_SUBGRID_PATCH, BOUNDS_SUBGRID_COLUMN, BOUNDS_SUBGRID_LANDUNIT, BOUNDS_SUBGRID_GRIDCELL + use clm_varctl , only : use_vancouver, use_mexicocity + use clm_varcon , only : spval + use LandunitType , only : lun + use WaterInfoBaseType, only : water_info_base_type + use WaterTracerContainerType, only : water_tracer_container_type + use WaterTracerUtils, only : AllocateVar1d + use WaterStateType, only : waterstate_type + use WaterFluxType, only : waterflux_type + ! + implicit none + save + private + ! + ! !PUBLIC TYPES: + type, public :: waterdiagnostic_type + + class(water_info_base_type), pointer :: info + + 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 :: Init + procedure :: Restart + procedure :: Summary ! Compute end-of-timestep summaries of water diagnostic terms + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type waterdiagnostic_type + + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, info, tracer_vars) + + class(waterdiagnostic_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + type(water_tracer_container_type), intent(inout) :: tracer_vars + + this%info => info + + call this%InitAllocate(bounds, tracer_vars) + + call this%InitHistory(bounds) + + call this%InitCold(bounds) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds, tracer_vars) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + ! + ! !ARGUMENTS: + class(waterdiagnostic_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + type(water_tracer_container_type), intent(inout) :: tracer_vars + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------ + + call AllocateVar1d(var = this%snowice_col, name = 'snowice_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%snowliq_col, name = 'snowliq_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%h2ocan_patch, name = 'h2ocan_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%total_plant_stored_h2o_col, name = 'total_plant_stored_h2o_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%h2osoi_liqice_10cm_col, name = 'h2osoi_liqice_10cm_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%tws_grc, name = 'tws_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_GRIDCELL) + call AllocateVar1d(var = this%qg_snow_col, name = 'qg_snow_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qg_soil_col, name = 'qg_soil_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qg_h2osfc_col, name = 'qg_h2osfc_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qg_col, name = 'qg_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qaf_lun, name = 'qaf_lun', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_LANDUNIT) + call AllocateVar1d(var = this%q_ref2m_patch, name = 'q_ref2m_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + class(waterdiagnostic_type), intent(in) :: 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 + + this%h2ocan_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('H2OCAN'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('intercepted water'), & + ptr_patch=this%h2ocan_patch) + + this%h2osoi_liqice_10cm_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SOILWATER_10CM'), & + units='kg/m2', & + avgflag='A', & + long_name=this%info%lname('soil liquid water + ice in top 10cm of soil (veg landunits only)'), & + ptr_col=this%h2osoi_liqice_10cm_col, l2g_scale_type='veg') + + this%tws_grc(begg:endg) = spval + call hist_addfld1d ( & + fname=this%info%fname('TWS'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('total water storage'), & + ptr_lnd=this%tws_grc) + + ! (rgk 02-02-2017) There is intentionally no entry here for stored plant water + ! I think that since the value is zero in all cases except + ! for FATES plant hydraulics, it will be confusing for users + ! when they see their plants have no water in output files. + ! So it is not useful diagnostic information. The information + ! can be provided through FATES specific history diagnostics + ! if need be. + + + this%q_ref2m_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('Q2M'), & + units='kg/kg', & + avgflag='A', & + long_name=this%info%lname('2m specific humidity'), & + ptr_patch=this%q_ref2m_patch) + + + + ! Snow properties - these will be vertically averaged over the snow profile + + this%snowliq_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNOWLIQ'), & + units='kg/m2', & + avgflag='A', & + long_name=this%info%lname('snow liquid water'), & + ptr_col=this%snowliq_col, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('SNOWLIQ_ICE'), & + units='kg/m2', & + avgflag='A', & + long_name=this%info%lname('snow liquid water (ice landunits only)'), & + ptr_col=this%snowliq_col, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%snowice_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNOWICE'), & + units='kg/m2', & + avgflag='A', & + long_name=this%info%lname('snow ice'), & + ptr_col=this%snowice_col, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('SNOWICE_ICE'), & + units='kg/m2', & + avgflag='A', & + long_name=this%info%lname('snow ice (ice landunits only)'), & + ptr_col=this%snowice_col, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize time constant variables and cold start conditions + ! + ! !USES: + use ncdio_pio , only : file_desc_t + ! + ! !ARGUMENTS: + class(waterdiagnostic_type), intent(in) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: l + real(r8) :: ratio + !----------------------------------------------------------------------- + + ratio = this%info%get_ratio() + + ! h2ocan_patch is explicitly set for soil patches; this setting ensures that it will + ! be 0 for special landunits + this%h2ocan_patch(bounds%begp:bounds%endp) = 0._r8 + + ! Water Stored in plants is almost always a static entity, with the exception + ! of when FATES-hydraulics is used. As such, this is trivially set to 0.0 (rgk 03-2017) + this%total_plant_stored_h2o_col(bounds%begc:bounds%endc) = 0.0_r8 + + + do l = bounds%begl, bounds%endl + if (lun%urbpoi(l)) then + if (use_vancouver) then + this%qaf_lun(l) = 0.0111_r8 * ratio + else if (use_mexicocity) then + this%qaf_lun(l) = 0.00248_r8 * ratio + else + this%qaf_lun(l) = 1.e-4_r8 * ratio ! Arbitrary set since forc_q is not yet available + end if + end if + end do + + end subroutine InitCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use clm_varcon , only : nameg + use ncdio_pio , only : file_desc_t, ncd_double + use restUtilMod + ! + ! !ARGUMENTS: + class(waterdiagnostic_type), intent(in) :: 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 :: c,l,j + logical :: readvar + !------------------------------------------------------------------------ + + + + ! TWS is needed when methane is on and the TWS_inversion is used to get exact + ! restart. + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('TWS'), & + xtype=ncd_double, & + dim1name=nameg, & + long_name=this%info%lname('Total Water Storage'), & + units='mm', & + interpinic_flag='interp', readvar=readvar, data=this%tws_grc) + + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('qaf'), & + xtype=ncd_double, dim1name='landunit', & + long_name=this%info%lname('urban canopy specific humidity'), & + units='kg/kg', & + interpinic_flag='interp', readvar=readvar, data=this%qaf_lun) + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine Summary(this, bounds, & + num_soilp, filter_soilp, & + num_allc, filter_allc, & + num_nolakec, filter_nolakec, & + waterstate_inst, waterflux_inst) + ! + ! !DESCRIPTION: + ! Compute end-of-timestep summaries of water diagnostic terms + ! + ! !ARGUMENTS: + class(waterdiagnostic_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of patches in soilp filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all columns + integer , intent(in) :: num_nolakec ! number of columns in no-lake filter + integer , intent(in) :: filter_nolakec(:) ! filter for no-lake columns + class(waterstate_type) , intent(in) :: waterstate_inst + class(waterflux_type) , intent(in) :: waterflux_inst + ! + ! !LOCAL VARIABLES: + integer :: fp, p + + character(len=*), parameter :: subname = 'Summary' + !----------------------------------------------------------------------- + + do fp = 1, num_soilp + p = filter_soilp(fp) + this%h2ocan_patch(p) = waterstate_inst%liqcan_patch(p) + waterstate_inst%snocan_patch(p) + end do + + end subroutine Summary + + +end module WaterDiagnosticType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterFluxBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterFluxBulkType.F90 new file mode 100644 index 000000000..eb0a1d330 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterFluxBulkType.F90 @@ -0,0 +1,400 @@ +module WaterFluxBulkType + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Defines a derived type containing water fluxes that just apply to bulk water. Note + ! that this type extends the base waterflux_type, so the full waterfluxbulk_type + ! contains the union of the fields defined here and the fields defined in + ! waterflux_type. + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use clm_varpar , only : nlevsno, nlevsoi + use clm_varcon , only : spval + use decompMod , only : bounds_type + use CNSharedParamsMod , only : use_fun + use WaterFluxType , only : waterflux_type + use WaterInfoBaseType, only : water_info_base_type + use WaterTracerContainerType, only : water_tracer_container_type + ! + implicit none + private + ! + ! !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 + procedure, public :: RestartBulk + procedure, private :: InitBulkAllocate + procedure, private :: InitBulkHistory + procedure, private :: InitBulkCold + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: UpdateAccVars + + end type waterfluxbulk_type + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine InitBulk(this, bounds, info, vars) + + class(waterfluxbulk_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + type(water_tracer_container_type), intent(inout) :: vars + + call this%Init(bounds, info, vars) + call this%InitBulkAllocate(bounds) ! same as "call initAllocate_type(hydro, bounds)" + call this%InitBulkHistory(bounds) + call this%InitBulkCold(bounds) + + end subroutine InitBulk + + !------------------------------------------------------------------------ + subroutine InitBulkAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !ARGUMENTS: + class(waterfluxbulk_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%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 InitBulkAllocate + + !------------------------------------------------------------------------ + subroutine InitBulkHistory(this, bounds) + ! + ! !USES: + use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal + ! + ! !ARGUMENTS: + class(waterfluxbulk_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + this%qflx_snomelt_lyr_col(begc:endc,-nlevsno+1:0) = spval + data2dptr => this%qflx_snomelt_lyr_col(begc:endc,-nlevsno+1:0) + call hist_addfld2d ( & + fname=this%info%fname('SNO_MELT'), & + units='mm/s', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('snow melt rate in each snow layer'), & + ptr_col=data2dptr, c2l_scale_type='urbanf',no_snow_behavior=no_snow_normal, default='inactive') + + call hist_addfld2d ( & + fname=this%info%fname('SNO_MELT_ICE'), & + units='mm/s', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('snow melt rate in each snow layer (ice landunits only)'), & + ptr_col=data2dptr, c2l_scale_type='urbanf',no_snow_behavior=no_snow_normal, & + l2g_scale_type='ice', default='inactive') + + call hist_addfld2d ( & + fname=this%info%fname('QROOTSINK'), & + units='mm/s', type2d='levsoi', & + avgflag='A', & + long_name=this%info%lname('water flux from soil to root in each soil-layer'), & + ptr_col=this%qflx_rootsoi_col, set_spec=spval, l2g_scale_type='veg', default='inactive') + + this%qflx_hydr_redist_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QHR'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('hydraulic redistribution'), & + ptr_patch=this%qflx_hydr_redist_patch, set_spec=spval, l2g_scale_type='veg', default='active') + + this%qflx_snowindunload_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSNO_WINDUNLOAD'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('canopy snow wind unloading'), & + ptr_patch=this%qflx_snowindunload_patch, set_lake=0._r8, c2l_scale_type='urbanf') + + this%qflx_snotempunload_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSNO_TEMPUNLOAD'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('canopy snow temp unloading'), & + ptr_patch=this%qflx_snotempunload_patch, set_lake=0._r8, c2l_scale_type='urbanf') + + ! QSNOEVAP is evaporation from snow but only when snow is present (snl<0), otherwise, it is + ! equivalent to qflx_ev_soil + this%qflx_ev_snow_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSNOEVAP'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('evaporation from snow (only when snl<0, otherwise it is equal to qflx_ev_soil)'), & + ptr_col=this%qflx_ev_snow_col, c2l_scale_type='urbanf') + + this%qflx_h2osfc_surf_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QH2OSFC'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('surface water runoff'), & + ptr_col=this%qflx_h2osfc_surf_col) + + this%qflx_phs_neg_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QPHSNEG'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('net negative hydraulic redistribution flux'), & + ptr_col=this%qflx_phs_neg_col, default='inactive') + + this%AnnET(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('AnnET'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('Annual ET'), & + ptr_col=this%AnnET, c2l_scale_type='urbanf', default='inactive') + + end subroutine InitBulkHistory + + + + + + !----------------------------------------------------------------------- + subroutine InitBulkCold(this, bounds) + ! !ARGUMENTS: + class(waterfluxbulk_type), intent(in) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + + this%qflx_snowindunload_patch(bounds%begp:bounds%endp) = 0.0_r8 + this%qflx_snotempunload_patch(bounds%begp:bounds%endp) = 0.0_r8 + + this%qflx_phs_neg_col(bounds%begc:bounds%endc) = 0.0_r8 + + this%qflx_h2osfc_surf_col(bounds%begc:bounds%endc) = 0._r8 + + end subroutine InitBulkCold + + !----------------------------------------------------------------------- + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! + ! !USES + use accumulMod , only : init_accum_field + ! + ! !ARGUMENTS: + class(waterfluxbulk_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + !--------------------------------------------------------------------- + + if (use_fun) then + + call init_accum_field (name='AnnET', units='MM H2O/S', & + desc='365-day running mean of total ET', accum_type='runmean', accum_period=-365, & + subgrid_type='column', numlev=1, init_value=0._r8) + + end if + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + ! + subroutine InitAccVars (this, bounds) + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES + use accumulMod , only : extract_accum_field + use clm_time_manager , only : get_nstep + ! + ! !ARGUMENTS: + class(waterfluxbulk_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: nstep + integer :: ier + real(r8), pointer :: rbufslp(:) ! temporary + !--------------------------------------------------------------------- + begc = bounds%begc; endc = bounds%endc + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begc:endc), stat=ier) + + ! Determine time step + nstep = get_nstep() + + if (use_fun) then + call extract_accum_field ('AnnET', rbufslp, nstep) + this%AnnEt(begc:endc) = rbufslp(begc:endc) + end if + + deallocate(rbufslp) + + end subroutine InitAccVars + + + !----------------------------------------------------------------------- + subroutine UpdateAccVars (this, bounds) + ! + ! USES + use clm_time_manager, only : get_nstep + use accumulMod , only : update_accum_field, extract_accum_field + ! + ! !ARGUMENTS: + class(waterfluxbulk_type), intent(in):: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g,c,p ! indices + integer :: dtime ! timestep size [seconds] + integer :: nstep ! timestep number + integer :: ier ! error status + integer :: begc, endc + real(r8), pointer :: rbufslp(:) ! temporary single level - patch level + !--------------------------------------------------------------------- + + begc = bounds%begc; endc = bounds%endc + + nstep = get_nstep() + + ! Allocate needed dynamic memory for single level patch field + + allocate(rbufslp(begc:endc), stat=ier) + + do c = begc,endc + rbufslp(c) = this%qflx_evap_tot_col(c) + end do + if (use_fun) then + ! Accumulate and extract AnnET (accumulates total ET as 365-day running mean) + call update_accum_field ('AnnET', rbufslp, nstep) + call extract_accum_field ('AnnET', this%AnnET, nstep) + + end if + + deallocate(rbufslp) + + end subroutine UpdateAccVars + + !------------------------------------------------------------------------ + subroutine RestartBulk(this, bounds, ncid, flag) + ! + ! !USES: + use ncdio_pio, only : file_desc_t, ncd_double + use restUtilMod + ! + ! !ARGUMENTS: + class(waterfluxbulk_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: + !----------------------------------------------------------------------- + + call this%restart ( bounds, ncid, flag=flag ) + + end subroutine RestartBulk +end module WaterFluxBulkType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterFluxType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterFluxType.F90 new file mode 100644 index 000000000..a2d57c1e5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterFluxType.F90 @@ -0,0 +1,904 @@ +module WaterFluxType + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Defines a derived type containing water fluxes that apply to both bulk water and + ! water tracers. + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use clm_varpar , only : nlevsno, nlevsoi + use clm_varcon , only : spval + use decompMod , only : bounds_type + use decompMod , only : BOUNDS_SUBGRID_PATCH, BOUNDS_SUBGRID_COLUMN, BOUNDS_SUBGRID_GRIDCELL + use LandunitType , only : lun + use ColumnType , only : col + use AnnualFluxDribbler, only : annual_flux_dribbler_type, annual_flux_dribbler_gridcell + use WaterInfoBaseType, only : water_info_base_type + use WaterTracerContainerType, only : water_tracer_container_type + use WaterTracerUtils, only : AllocateVar1d, AllocateVar2d + ! + implicit none + private + ! + ! !PUBLIC TYPES: + type, public :: waterflux_type + + class(water_info_base_type), pointer :: info + + ! 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 + procedure, public :: Restart + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type waterflux_type + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, info, tracer_vars) + + class(waterflux_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + type(water_tracer_container_type), intent(inout) :: tracer_vars + + this%info => info + + call this%InitAllocate(bounds, tracer_vars) + call this%InitHistory(bounds) + call this%InitCold(bounds) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds, tracer_vars) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + ! + ! !ARGUMENTS: + class(waterflux_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + type(water_tracer_container_type), intent(inout) :: tracer_vars + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------ + + call AllocateVar1d(var = this%qflx_through_snow_patch, name = 'qflx_through_snow_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_through_liq_patch, name = 'qflx_through_liq_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_intercepted_snow_patch, name = 'qflx_intercepted_snow_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_intercepted_liq_patch, name = 'qflx_intercepted_liq_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_snocanfall_patch, name = 'qflx_snocanfall_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_liqcanfall_patch, name = 'qflx_liqcanfall_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_snow_unload_patch, name = 'qflx_snow_unload_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_solidevap_from_top_layer_patch, name = 'qflx_solidevap_from_top_layer_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH, & + ival = 0.0_r8) + call AllocateVar1d(var = this%qflx_tran_veg_patch, name = 'qflx_tran_veg_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_liqdew_to_top_layer_patch, name = 'qflx_liqdew_to_top_layer_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_soliddew_to_top_layer_patch, name = 'qflx_soliddew_to_top_layer_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + + call AllocateVar1d(var = this%qflx_liq_grnd_col, name = 'qflx_liq_grnd_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_snow_grnd_col, name = 'qflx_snow_grnd_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_rain_plus_snomelt_col, name = 'qflx_rain_plus_snomelt_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_solidevap_from_top_layer_col, name = 'qflx_solidevap_from_top_layer_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + ival = 0.0_r8) + call AllocateVar1d(var = this%qflx_snwcp_liq_col, name = 'qflx_snwcp_liq_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_snwcp_ice_col, name = 'qflx_snwcp_ice_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_snwcp_discarded_liq_col, name = 'qflx_snwcp_discarded_liq_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_snwcp_discarded_ice_col, name = 'qflx_snwcp_discarded_ice_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_glcice_col, name = 'qflx_glcice_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_glcice_frz_col, name = 'qflx_glcice_frz_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_glcice_melt_col, name = 'qflx_glcice_melt_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_glcice_dyn_water_flux_col, name = 'qflx_glcice_dyn_water_flux_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_tran_veg_col, name = 'qflx_tran_veg_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_evap_veg_col, name = 'qflx_evap_veg_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_evap_can_col, name = 'qflx_evap_can_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_evap_soi_col, name = 'qflx_evap_soi_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_evap_tot_col, name = 'qflx_evap_tot_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_liqevap_from_top_layer_col, name = 'qflx_liqevap_from_top_layer_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_liqdew_to_top_layer_col, name = 'qflx_liqdew_to_top_layer_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_soliddew_to_top_layer_col, name = 'qflx_soliddew_to_top_layer_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_evap_veg_patch, name = 'qflx_evap_veg_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_evap_can_patch, name = 'qflx_evap_can_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_evap_soi_patch, name = 'qflx_evap_soi_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_evap_tot_patch, name = 'qflx_evap_tot_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%qflx_liqevap_from_top_layer_patch, name = 'qflx_liqevap_from_top_layer_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + + call AllocateVar1d(var = this%qflx_infl_col, name = 'qflx_infl_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_surf_col, name = 'qflx_surf_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_drain_col, name = 'qflx_drain_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_drain_perched_col, name = 'qflx_drain_perched_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_top_soil_col, name = 'qflx_top_soil_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_snomelt_col, name = 'qflx_snomelt_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_snofrz_col, name = 'qflx_snofrz_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar2d(var = this%qflx_snofrz_lyr_col, name = 'qflx_snofrz_lyr_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + dim2beg = -nlevsno+1, dim2end = 0) + call AllocateVar1d(var = this%qflx_snow_drain_col, name = 'qflx_snow_drain_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_ice_runoff_snwcp_col, name = 'qflx_ice_runoff_snwcp_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_ice_runoff_xs_col, name = 'qflx_ice_runoff_xs_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_qrgwl_col, name = 'qflx_qrgwl_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_floodc_col, name = 'qflx_floodc_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_sl_top_soil_col, name = 'qflx_sl_top_soil_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_runoff_col, name = 'qflx_runoff_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_runoff_r_col, name = 'qflx_runoff_r_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_runoff_u_col, name = 'qflx_runoff_u_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_rsub_sat_col, name = 'qflx_rsub_sat_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + + call AllocateVar1d(var = this%qflx_h2osfc_to_ice_col, name = 'qflx_h2osfc_to_ice_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_snow_h2osfc_col, name = 'qflx_snow_h2osfc_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%qflx_too_small_h2osfc_to_soil_col, name = 'qflx_too_small_h2osfc_to_soil_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + + call AllocateVar2d(var = this%qflx_snow_percolation_col, name = 'qflx_snow_percolation_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + dim2beg = -nlevsno+1, dim2end = 0) + + call AllocateVar1d(var = this%qflx_liq_dynbal_grc, name = 'qflx_liq_dynbal_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_GRIDCELL) + call AllocateVar1d(var = this%qflx_ice_dynbal_grc, name = 'qflx_ice_dynbal_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_GRIDCELL) + + call AllocateVar1d(var = this%qflx_sfc_irrig_col, name = 'qflx_sfc_irrig_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + + call AllocateVar1d(var = this%qflx_gw_uncon_irrig_col, name = 'qflx_gw_uncon_irrig_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + + call AllocateVar2d(var = this%qflx_gw_uncon_irrig_lyr_col, name = 'qflx_gw_uncon_irrig_lyr_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + dim2beg = 1, dim2end = nlevsoi) + + call AllocateVar1d(var = this%qflx_gw_con_irrig_col, name = 'qflx_gw_con_irrig_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + + call AllocateVar1d(var = this%qflx_irrig_drip_patch, name = 'qflx_irrig_drip_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + + call AllocateVar1d(var = this%qflx_irrig_sprinkler_patch, name = 'qflx_irrig_sprinkler_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + + this%qflx_liq_dynbal_dribbler = annual_flux_dribbler_gridcell( & + bounds = bounds, & + name = this%info%fname('qflx_liq_dynbal'), & + units = 'mm H2O') + + this%qflx_ice_dynbal_dribbler = annual_flux_dribbler_gridcell( & + bounds = bounds, & + name = this%info%fname('qflx_ice_dynbal'), & + units = 'mm H2O') + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !USES: + use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal + ! + ! !ARGUMENTS: + class(waterflux_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + this%qflx_through_liq_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QDIRECT_THROUGHFALL'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('direct throughfall of liquid (rain + above-canopy irrigation)'), & + ptr_patch=this%qflx_through_liq_patch, c2l_scale_type='urbanf', default='inactive') + + this%qflx_through_snow_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QDIRECT_THROUGHFALL_SNOW'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('direct throughfall of snow'), & + ptr_patch=this%qflx_through_snow_patch, c2l_scale_type='urbanf', default='inactive') + + this%qflx_liqcanfall_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QDRIP'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('rate of excess canopy liquid falling off canopy'), & + ptr_patch=this%qflx_liqcanfall_patch, c2l_scale_type='urbanf', default='inactive') + + this%qflx_snocanfall_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QDRIP_SNOW'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('rate of excess canopy snow falling off canopy'), & + ptr_patch=this%qflx_snocanfall_patch, c2l_scale_type='urbanf', default='inactive') + + this%qflx_snow_unload_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSNOUNLOAD'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('canopy snow unloading'), & + ptr_patch=this%qflx_snow_unload_patch, c2l_scale_type='urbanf') + + this%qflx_top_soil_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QTOPSOIL'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('water input to surface'), & + ptr_col=this%qflx_top_soil_col, c2l_scale_type='urbanf', default='inactive') + + this%qflx_infl_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QINFL'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('infiltration'), & + ptr_col=this%qflx_infl_col, c2l_scale_type='urbanf') + + this%qflx_surf_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QOVER'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('total surface runoff (includes QH2OSFC)'), & + ptr_col=this%qflx_surf_col, c2l_scale_type='urbanf') + + this%qflx_qrgwl_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QRGWL'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname( & + 'surface runoff at glaciers (liquid only), wetlands, lakes; also includes melted ice runoff from QSNWCPICE'), & + ptr_col=this%qflx_qrgwl_col, c2l_scale_type='urbanf') + + this%qflx_drain_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QDRAI'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('sub-surface drainage'), & + ptr_col=this%qflx_drain_col, c2l_scale_type='urbanf') + + this%qflx_drain_perched_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QDRAI_PERCH'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('perched wt drainage'), & + ptr_col=this%qflx_drain_perched_col, c2l_scale_type='urbanf') + + this%qflx_liq_dynbal_grc(begg:endg) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_LIQ_DYNBAL'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('liq dynamic land cover change conversion runoff flux'), & + ptr_lnd=this%qflx_liq_dynbal_grc) + + this%qflx_ice_dynbal_grc(begg:endg) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_ICE_DYNBAL'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('ice dynamic land cover change conversion runoff flux'), & + ptr_lnd=this%qflx_ice_dynbal_grc) + + this%qflx_runoff_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QRUNOFF'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('total liquid runoff not including correction for land use change'), & + ptr_col=this%qflx_runoff_col, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('QRUNOFF_ICE'), & + units='mm/s', avgflag='A', & + long_name=this%info%lname('total liquid runoff not incl corret for LULCC (ice landunits only)'), & + ptr_col=this%qflx_runoff_col, c2l_scale_type='urbanf', l2g_scale_type='ice') + + this%qflx_runoff_u_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QRUNOFF_U'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('Urban total runoff'), & + ptr_col=this%qflx_runoff_u_col, set_nourb=spval, c2l_scale_type='urbanf', default='inactive') + + this%qflx_runoff_r_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QRUNOFF_R'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('Rural total runoff'), & + ptr_col=this%qflx_runoff_r_col, set_spec=spval, default='inactive') + + this%qflx_snomelt_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSNOMELT'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('snow melt rate'), & + ptr_col=this%qflx_snomelt_col, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('QSNOMELT_ICE'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('snow melt (ice landunits only)'), & + ptr_col=this%qflx_snomelt_col, c2l_scale_type='urbanf', l2g_scale_type='ice') + + + this%qflx_snofrz_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSNOFRZ'), & + units='kg/m2/s', & + avgflag='A', & + long_name=this%info%lname('column-integrated snow freezing rate'), & + ptr_col=this%qflx_snofrz_col, set_lake=spval, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('QSNOFRZ_ICE'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('column-integrated snow freezing rate (ice landunits only)'), & + ptr_col=this%qflx_snofrz_col, c2l_scale_type='urbanf', l2g_scale_type='ice') + + this%qflx_snofrz_lyr_col(begc:endc,-nlevsno+1:0) = spval + data2dptr => this%qflx_snofrz_lyr_col(begc:endc,-nlevsno+1:0) + call hist_addfld2d ( & + fname=this%info%fname('SNO_FRZ'), & + units='kg/m2/s', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('snow freezing rate in each snow layer'), & + ptr_col=data2dptr, c2l_scale_type='urbanf',no_snow_behavior=no_snow_normal, default='inactive') + + call hist_addfld2d ( & + fname=this%info%fname('SNO_FRZ_ICE'), & + units='mm/s', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('snow freezing rate in each snow layer (ice landunits only)'), & + ptr_col=data2dptr, c2l_scale_type='urbanf',no_snow_behavior=no_snow_normal, & + l2g_scale_type='ice', default='inactive') + + this%qflx_snow_drain_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_SNOW_DRAIN'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('drainage from snow pack'), & + ptr_col=this%qflx_snow_drain_col, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('QFLX_SNOW_DRAIN_ICE'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('drainage from snow pack melt (ice landunits only)'), & + ptr_col=this%qflx_snow_drain_col, c2l_scale_type='urbanf', l2g_scale_type='ice') + + this%qflx_evap_soi_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSOIL'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname( 'Ground evaporation (soil/snow evaporation + soil/snow sublimation - dew)'), & + ptr_patch=this%qflx_evap_soi_patch, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('QSOIL_ICE'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('Ground evaporation (ice landunits only)'), & + ptr_patch=this%qflx_evap_soi_patch, c2l_scale_type='urbanf', l2g_scale_type='ice') + + this%qflx_evap_can_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QVEGE'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('canopy evaporation'), & + ptr_patch=this%qflx_evap_can_patch, set_lake=0._r8, c2l_scale_type='urbanf') + + this%qflx_tran_veg_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QVEGT'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('canopy transpiration'), & + ptr_patch=this%qflx_tran_veg_patch, c2l_scale_type='urbanf') + + this%qflx_snwcp_liq_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSNOCPLIQ'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('excess liquid h2o due to snow capping not including correction for land use change'), & + ptr_col=this%qflx_snwcp_liq_col, c2l_scale_type='urbanf') + + this%qflx_snwcp_ice_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QSNWCPICE'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('excess solid h2o due to snow capping not including correction for land use change'), & + ptr_col=this%qflx_snwcp_ice_col, c2l_scale_type='urbanf') + + this%qflx_glcice_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QICE'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('ice growth/melt'), & + ptr_col=this%qflx_glcice_col, l2g_scale_type='ice') + + this%qflx_glcice_frz_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QICE_FRZ'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('ice growth'), & + ptr_col=this%qflx_glcice_frz_col, l2g_scale_type='ice') + + this%qflx_glcice_melt_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QICE_MELT'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('ice melt'), & + ptr_col=this%qflx_glcice_melt_col, l2g_scale_type='ice') + + this%qflx_liq_grnd_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_LIQ_GRND'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('liquid (rain+irrigation) on ground after interception'), & + ptr_col=this%qflx_liq_grnd_col, default='inactive', c2l_scale_type='urbanf') + + this%qflx_snow_grnd_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_SNOW_GRND'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('snow on ground after interception'), & + ptr_col=this%qflx_snow_grnd_col, default='inactive', c2l_scale_type='urbanf') + + this%qflx_liqevap_from_top_layer_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_LIQEVAP_FROM_TOP_LAYER'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('rate of liquid water evaporated from top soil or snow layer'), & + ptr_patch=this%qflx_liqevap_from_top_layer_patch, c2l_scale_type='urbanf') + + this%qflx_evap_veg_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_EVAP_VEG'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('vegetation evaporation'), & + ptr_patch=this%qflx_evap_veg_patch, default='inactive', c2l_scale_type='urbanf') + + this%qflx_evap_tot_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_EVAP_TOT'), & + units='kg m-2 s-1', & + avgflag='A', & + long_name=this%info%lname('qflx_evap_soi + qflx_evap_can + qflx_tran_veg'), & + ptr_patch=this%qflx_evap_tot_patch, c2l_scale_type='urbanf') + + this%qflx_liqdew_to_top_layer_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_LIQDEW_TO_TOP_LAYER'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('rate of liquid water deposited on top soil or snow layer (dew)'), & + ptr_patch=this%qflx_liqdew_to_top_layer_patch, c2l_scale_type='urbanf') + + this%qflx_solidevap_from_top_layer_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_SOLIDEVAP_FROM_TOP_LAYER'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('rate of ice evaporated from top soil or snow layer (sublimation) (also includes bare ice sublimation from glacier columns)'), & + ptr_patch=this%qflx_solidevap_from_top_layer_patch, c2l_scale_type='urbanf') + + call hist_addfld1d ( & + fname=this%info%fname('QFLX_SOLIDEVAP_FROM_TOP_LAYER_ICE'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('rate of ice evaporated from top soil or snow layer (sublimation) (also includes bare ice sublimation from glacier columns) '// & + '(ice landunits only)'), & + ptr_patch=this%qflx_solidevap_from_top_layer_patch, c2l_scale_type='urbanf', l2g_scale_type='ice', & + default='inactive') + + this%qflx_soliddew_to_top_layer_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QFLX_SOLIDDEW_TO_TOP_LAYER'), & + units='mm H2O/s', & + avgflag='A', & + long_name=this%info%lname('rate of solid water deposited on top soil or snow layer (frost)'), & + ptr_patch=this%qflx_soliddew_to_top_layer_patch, c2l_scale_type='urbanf') + + this%qflx_rsub_sat_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QDRAI_XS'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('saturation excess drainage'), & + ptr_col=this%qflx_rsub_sat_col, c2l_scale_type='urbanf') + + this%qflx_h2osfc_to_ice_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QH2OSFC_TO_ICE'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('surface water converted to ice'), & + ptr_col=this%qflx_h2osfc_to_ice_col, default='inactive') + + this%qflx_sfc_irrig_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QIRRIG_FROM_SURFACE'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('water added through surface water irrigation'), & + ptr_col=this%qflx_sfc_irrig_col) + + this%qflx_gw_uncon_irrig_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QIRRIG_FROM_GW_UNCONFINED'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('water added through unconfined groundwater irrigation'), & + ptr_col=this%qflx_gw_uncon_irrig_col) + + this%qflx_gw_con_irrig_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('QIRRIG_FROM_GW_CONFINED'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('water added through confined groundwater irrigation'), & + ptr_col=this%qflx_gw_con_irrig_col) + + this%qflx_irrig_drip_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QIRRIG_DRIP'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('water added via drip irrigation'), & + ptr_patch=this%qflx_irrig_drip_patch, default='inactive') + + this%qflx_irrig_sprinkler_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('QIRRIG_SPRINKLER'), & + units='mm/s', & + avgflag='A', & + long_name=this%info%lname('water added via sprinkler irrigation'), & + ptr_patch=this%qflx_irrig_sprinkler_patch, default='inactive') + + end subroutine InitHistory + + + + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !USES: + use landunit_varcon, only : istsoil, istcrop + ! + ! !ARGUMENTS: + class(waterflux_type), intent(in) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: c,l + !----------------------------------------------------------------------- + + 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 variable only gets set in the hydrology filter; need to initialize it to 0 for + ! the sake of columns outside this filter + this%qflx_ice_runoff_xs_col(bounds%begc:bounds%endc) = 0._r8 + + ! Initialize qflx_glcice_dyn_water_flux_col to 0 for all columns because we want this + ! flux to remain 0 for columns where is is never set, including non-glacier columns. + ! + ! Other qflx_glcice fluxes intentionally remain unset (spval) outside the do_smb + ! filter, so that they are flagged as missing value outside that filter. + this%qflx_glcice_dyn_water_flux_col(bounds%begc:bounds%endc) = 0._r8 + + ! These fluxes are never set for non-vegetated landunits, but we want their values to + ! be 0 there, so initialize the fluxes to 0 everywhere + this%qflx_tran_veg_patch(bounds%begp:bounds%endp) = 0._r8 + this%qflx_evap_veg_patch(bounds%begp:bounds%endp) = 0._r8 + + ! needed for CNNLeaching + 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 InitCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !USES: + use ncdio_pio, only : file_desc_t, ncd_double + use restUtilMod + ! + ! !ARGUMENTS: + class(waterflux_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: + logical :: readvar ! determine if variable is on initial file + !----------------------------------------------------------------------- + + ! needed for SNICAR + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('qflx_snow_drain')//':'//this%info%fname('qflx_snow_melt'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('drainage from snow column'), & + units='mm/s', & + interpinic_flag='interp', readvar=readvar, data=this%qflx_snow_drain_col) + if (flag == 'read' .and. .not. readvar) then + ! initial run, not restart: initialize qflx_snow_drain to zero + this%qflx_snow_drain_col(bounds%begc:bounds%endc) = 0._r8 + endif + + call this%qflx_liq_dynbal_dribbler%Restart(bounds, ncid, flag) + call this%qflx_ice_dynbal_dribbler%Restart(bounds, ncid, flag) + + end subroutine Restart + +end module WaterFluxType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterStateBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterStateBulkType.F90 new file mode 100644 index 000000000..5c0298c8d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterStateBulkType.F90 @@ -0,0 +1,242 @@ +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 WaterInfoBaseType, only : water_info_base_type + use WaterTracerContainerType, only : water_tracer_container_type + ! + implicit none + save + private + ! + ! !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 :: InitBulk + procedure :: RestartBulk + procedure, private :: InitBulkAllocate + procedure, private :: InitBulkHistory + procedure, private :: InitBulkCold + + end type waterstatebulk_type + + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine InitBulk(this, bounds, info, vars, & + h2osno_input_col, watsat_col, t_soisno_col, use_aquifer_layer) + + class(waterstatebulk_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + type(water_tracer_container_type), intent(inout) :: vars + real(r8) , intent(in) :: h2osno_input_col(bounds%begc:) + real(r8) , intent(in) :: watsat_col(bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + real(r8) , intent(in) :: t_soisno_col(bounds%begc:, -nlevsno+1:) ! col soil temperature (Kelvin) + logical , intent(in) :: use_aquifer_layer ! whether an aquifer layer is used in this run + + + call this%Init(bounds = bounds, & + info = info, & + tracer_vars = vars, & + h2osno_input_col = h2osno_input_col, & + watsat_col = watsat_col, & + t_soisno_col = t_soisno_col, & + use_aquifer_layer = use_aquifer_layer) + + call this%InitBulkAllocate(bounds) + + call this%InitBulkHistory(bounds) + + call this%InitBulkCold(bounds, & + h2osno_input_col) + + end subroutine InitBulk + + !------------------------------------------------------------------------ + subroutine InitBulkAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(waterstatebulk_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + 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%snow_persistence_col (begc:endc)) ; this%snow_persistence_col (:) = nan + allocate(this%int_snow_col (begc:endc)) ; this%int_snow_col (:) = nan + + end subroutine InitBulkAllocate + + !------------------------------------------------------------------------ + subroutine InitBulkHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + class(waterstatebulk_type), intent(in) :: 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 + + + ! Snow properties - these will be vertically averaged over the snow profile + + this%int_snow_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('INT_SNOW'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('accumulated swe (natural vegetated and crop landunits only)'), & + ptr_col=this%int_snow_col, l2g_scale_type='veg', & + default='inactive') + + call hist_addfld1d ( & + fname=this%info%fname('INT_SNOW_ICE'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('accumulated swe (ice landunits only)'), & + ptr_col=this%int_snow_col, l2g_scale_type='ice', & + default='inactive') + + this%snow_persistence_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNOW_PERSISTENCE'), & + units='seconds', & + avgflag='I', & + long_name=this%info%lname('Length of time of continuous snow cover (nat. veg. landunits only)'), & + ptr_col=this%snow_persistence_col, l2g_scale_type='natveg') + + + end subroutine InitBulkHistory + + !----------------------------------------------------------------------- + subroutine InitBulkCold(this, bounds, & + h2osno_input_col) + ! + ! !DESCRIPTION: + ! Initialize time constant variables and cold start conditions + ! + ! !ARGUMENTS: + class(waterstatebulk_type), intent(in) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: h2osno_input_col(bounds%begc:) + ! + ! !LOCAL VARIABLES: + integer :: c + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(h2osno_input_col) == (/bounds%endc/)) , sourcefile, __LINE__) + + do c = bounds%begc,bounds%endc + this%int_snow_col(c) = h2osno_input_col(c) + this%snow_persistence_col(c) = 0._r8 + end do + + end subroutine InitBulkCold + + !------------------------------------------------------------------------ + subroutine RestartBulk(this, bounds, ncid, flag, & + watsat_col) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_double + use restUtilMod + ! + ! !ARGUMENTS: + class(waterstatebulk_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + real(r8) , intent(in) :: watsat_col (bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + ! + ! !LOCAL VARIABLES: + integer :: c,l,j + logical :: readvar + !------------------------------------------------------------------------ + + SHR_ASSERT_ALL_FL((ubound(watsat_col) == (/bounds%endc,nlevmaxurbgrnd/)) , sourcefile, __LINE__) + + call this%restart (bounds, ncid, flag=flag, & + watsat_col=watsat_col(bounds%begc:bounds%endc,:)) + + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('INT_SNOW'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('accuumulated snow'), & + units='mm', & + interpinic_flag='interp', readvar=readvar, data=this%int_snow_col) + if (flag=='read' .and. .not. readvar) then + this%int_snow_col(:) = 0.0_r8 + end if + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('SNOW_PERS'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('continuous snow cover time'), & + units='sec', & + interpinic_flag='interp', readvar=readvar, data=this%snow_persistence_col) + if (flag=='read' .and. .not. readvar) then + this%snow_persistence_col(:) = 0.0_r8 + end if + + end subroutine RestartBulk + + +end module WaterStateBulkType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterStateType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterStateType.F90 new file mode 100644 index 000000000..243e93ca4 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterStateType.F90 @@ -0,0 +1,791 @@ +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 decompMod , only : BOUNDS_SUBGRID_PATCH, BOUNDS_SUBGRID_COLUMN, BOUNDS_SUBGRID_GRIDCELL + use clm_varctl , only : use_bedrock, iulog + use clm_varctl , only : use_fates_planthydro + use clm_varpar , only : nlevgrnd, nlevsoi, nlevurb, nlevmaxurbgrnd, nlevsno + use clm_varcon , only : spval, namec + use LandunitType , only : lun + use ColumnType , only : col + use WaterInfoBaseType, only : water_info_base_type + use WaterTracerContainerType, only : water_tracer_container_type + use WaterTracerUtils, only : AllocateVar1d, AllocateVar2d + ! + implicit none + save + private + ! + ! !PUBLIC TYPES: + type, public :: waterstate_type + + class(water_info_base_type), pointer :: info + + 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 + procedure, public :: Restart + procedure, public :: CalculateTotalH2osno + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, private :: CheckSnowConsistency + + end type waterstate_type + + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, info, tracer_vars, & + h2osno_input_col, watsat_col, t_soisno_col, use_aquifer_layer) + + class(waterstate_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + type(water_tracer_container_type), intent(inout) :: tracer_vars + real(r8) , intent(in) :: h2osno_input_col(bounds%begc:) + real(r8) , intent(in) :: watsat_col(bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + real(r8) , intent(in) :: t_soisno_col(bounds%begc:, -nlevsno+1:) ! col soil temperature (Kelvin) + logical , intent(in) :: use_aquifer_layer ! whether an aquifer layer is used in this run + + this%info => info + + call this%InitAllocate(bounds, tracer_vars) + + call this%InitHistory(bounds) + + call this%InitCold(bounds = bounds, & + h2osno_input_col = h2osno_input_col, & + watsat_col = watsat_col, & + t_soisno_col = t_soisno_col, & + use_aquifer_layer = use_aquifer_layer) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds, tracer_vars) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + ! + ! !ARGUMENTS: + class(waterstate_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + type(water_tracer_container_type), intent(inout) :: tracer_vars + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------ + + call AllocateVar1d(var = this%h2osno_no_layers_col, name = 'h2osno_no_layers_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar2d(var = this%h2osoi_vol_col, name = 'h2osoi_vol_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + dim2beg = 1, dim2end = nlevmaxurbgrnd) + call AllocateVar2d(var = this%h2osoi_vol_prs_grc, name = 'h2osoi_vol_prs_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_GRIDCELL, & + dim2beg = 1, dim2end = nlevgrnd) + call AllocateVar2d(var = this%h2osoi_ice_col, name = 'h2osoi_ice_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + dim2beg = -nlevsno+1, dim2end = nlevmaxurbgrnd) + call AllocateVar2d(var = this%h2osoi_liq_col, name = 'h2osoi_liq_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + dim2beg = -nlevsno+1, dim2end = nlevmaxurbgrnd) + call AllocateVar1d(var = this%snocan_patch, name = 'snocan_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%liqcan_patch, name = 'liqcan_patch', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_PATCH) + call AllocateVar1d(var = this%h2osfc_col, name = 'h2osfc_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%wa_col, name = 'wa_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%dynbal_baseline_liq_col, name = 'dynbal_baseline_liq_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%dynbal_baseline_ice_col, name = 'dynbal_baseline_ice_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal + use clm_varctl , only : use_soil_moisture_streams + ! + ! !ARGUMENTS: + class(waterstate_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: begg, endg + real(r8), pointer :: data2dptr(:,:), data1dptr(:) ! temp. pointers for slicing larger arrays + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + data2dptr => this%h2osoi_liq_col(:,-nlevsno+1:0) + call hist_addfld2d ( & + fname=this%info%fname('SNO_LIQH2O'), & + units='kg/m2', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('Snow liquid water content'), & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') + + data2dptr => this%h2osoi_ice_col(:,-nlevsno+1:0) + call hist_addfld2d ( & + fname=this%info%fname('SNO_ICE'), & + units='kg/m2', type2d='levsno', & + avgflag='A', & + long_name=this%info%lname('Snow ice content'), & + ptr_col=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') + + data2dptr => this%h2osoi_vol_col(begc:endc,1:nlevsoi) + call hist_addfld2d ( & + fname=this%info%fname('H2OSOI'), & + units='mm3/mm3', type2d='levsoi', & + avgflag='A', & + long_name=this%info%lname('volumetric soil water (natural vegetated and crop landunits only)'), & + ptr_col=this%h2osoi_vol_col, l2g_scale_type='veg') + + if ( use_soil_moisture_streams )then + call hist_addfld2d ( & + fname=this%info%fname('H2OSOI_PRESCRIBED_GRC'), & + units='mm3/mm3', type2d='levsoi', & + avgflag='A', & + long_name=this%info%lname('volumetric soil water prescribed (vegetated landunits only)'), & + ptr_gcell=this%h2osoi_vol_prs_grc, l2g_scale_type='veg', default='inactive') + end if + + ! this%h2osoi_liq_col(begc:endc,:) = spval + ! call hist_addfld2d ( & + ! fname=this%info%fname('SOILLIQ'), & + ! units='kg/m2', type2d='levgrnd', & + ! avgflag='A', & + ! long_name=this%info%lname('soil liquid water (natural vegetated and crop landunits only)'), & + ! ptr_col=this%h2osoi_liq_col, l2g_scale_type='veg') + + data2dptr => this%h2osoi_liq_col(begc:endc,1:nlevsoi) + call hist_addfld2d ( & + fname=this%info%fname('SOILLIQ'), & + units='kg/m2', type2d='levsoi', & + avgflag='A', & + long_name=this%info%lname('soil liquid water (natural vegetated and crop landunits only)'), & + ptr_col=data2dptr, l2g_scale_type='veg') + + data2dptr => this%h2osoi_ice_col(begc:endc,1:nlevsoi) + call hist_addfld2d ( & + fname=this%info%fname('SOILICE'), & + units='kg/m2', type2d='levsoi', & + avgflag='A', & + long_name=this%info%lname('soil ice (natural vegetated and crop landunits only)'), & + ptr_col=data2dptr, l2g_scale_type='veg') + + this%snocan_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('SNOCAN'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('intercepted snow'), & + ptr_patch=this%snocan_patch, set_lake=0._r8) + + this%liqcan_patch(begp:endp) = spval + call hist_addfld1d ( & + fname=this%info%fname('LIQCAN'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('intercepted liquid water'), & + ptr_patch=this%liqcan_patch, set_lake=0._r8) + + this%h2osfc_col(begc:endc) = spval + call hist_addfld1d ( & + fname=this%info%fname('H2OSFC'), & + units='mm', & + avgflag='A', & + long_name=this%info%lname('surface water depth'), & + ptr_col=this%h2osfc_col) + + this%wa_col(begc:endc) = spval + call hist_addfld1d (fname=this%info%fname('WA'), units='mm', & + avgflag='A', & + long_name=this%info%lname('water in the unconfined aquifer (natural vegetated and crop landunits only)'), & + ptr_col=this%wa_col, l2g_scale_type='veg') + + + + ! (rgk 02-02-2017) There is intentionally no entry here for stored plant water + ! I think that since the value is zero in all cases except + ! for FATES plant hydraulics, it will be confusing for users + ! when they see their plants have no water in output files. + ! So it is not useful diagnostic information. The information + ! can be provided through FATES specific history diagnostics + ! if need be. + + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds, & + h2osno_input_col, watsat_col, t_soisno_col, use_aquifer_layer) + ! + ! !DESCRIPTION: + ! Initialize time constant variables and cold start conditions + ! + ! !USES: + use shr_const_mod , only : SHR_CONST_TKFRZ + use landunit_varcon , only : istwet, istsoil, istcrop, istice_mec + use column_varcon , only : icol_road_perv, icol_road_imperv + use clm_varcon , only : denice, denh2o, bdsno + use clm_varcon , only : tfrz, aquifer_water_baseline + ! + ! !ARGUMENTS: + class(waterstate_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: h2osno_input_col(bounds%begc:) + real(r8) , intent(in) :: watsat_col(bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + real(r8) , intent(in) :: t_soisno_col(bounds%begc:, -nlevsno+1:) ! col soil temperature (Kelvin) + logical , intent(in) :: use_aquifer_layer ! whether an aquifer layer is used in this run + ! + ! !LOCAL VARIABLES: + integer :: c,j,l,nlevs + integer :: nbedrock + real(r8) :: ratio + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(h2osno_input_col) == (/bounds%endc/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(watsat_col) == (/bounds%endc,nlevmaxurbgrnd/)) , sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(t_soisno_col) == (/bounds%endc,nlevmaxurbgrnd/)) , sourcefile, __LINE__) + + ratio = this%info%get_ratio() + + associate(snl => col%snl) + + this%h2osfc_col(bounds%begc:bounds%endc) = 0._r8 + this%snocan_patch(bounds%begp:bounds%endp) = 0._r8 + this%liqcan_patch(bounds%begp:bounds%endp) = 0._r8 + + + !-------------------------------------------- + ! Set soil water + !-------------------------------------------- + + ! volumetric water is set first and liquid content and ice lens are obtained + ! NOTE: h2osoi_vol, h2osoi_liq and h2osoi_ice only have valid values over soil + ! and urban pervious road (other urban columns have zero soil water) + + this%h2osoi_vol_col(bounds%begc:bounds%endc, 1:) = spval + this%h2osoi_vol_prs_grc(bounds%begg:bounds%endg, 1:) = spval + this%h2osoi_liq_col(bounds%begc:bounds%endc,-nlevsno+1:) = spval + this%h2osoi_ice_col(bounds%begc:bounds%endc,-nlevsno+1:) = spval + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (.not. lun%lakpoi(l)) then !not lake + + ! volumetric water + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + nlevs = nlevgrnd + do j = 1, nlevs + if (use_bedrock) then + nbedrock = col%nbedrock(c) + else + nbedrock = nlevsoi + endif + if (j > nbedrock) then + this%h2osoi_vol_col(c,j) = 0.0_r8 + else + if(use_fates_planthydro) then + this%h2osoi_vol_col(c,j) = 0.75_r8*watsat_col(c,j)*ratio + else + this%h2osoi_vol_col(c,j) = 0.15_r8*ratio + end if + endif + end do + else if (lun%urbpoi(l)) then + if (col%itype(c) == icol_road_perv) then + nlevs = nlevgrnd + do j = 1, nlevs + if (j <= nlevsoi) then + this%h2osoi_vol_col(c,j) = 0.3_r8 * ratio + else + this%h2osoi_vol_col(c,j) = 0.0_r8 + end if + end do + else if (col%itype(c) == icol_road_imperv) then + nlevs = nlevgrnd + do j = 1, nlevs + this%h2osoi_vol_col(c,j) = 0.0_r8 + end do + else + nlevs = nlevurb + do j = 1, nlevs + this%h2osoi_vol_col(c,j) = 0.0_r8 + end do + end if + else if (lun%itype(l) == istwet) then + nlevs = nlevgrnd + do j = 1, nlevs + if (j > nlevsoi) then + this%h2osoi_vol_col(c,j) = 0.0_r8 + else + this%h2osoi_vol_col(c,j) = 1.0_r8 * ratio + endif + end do + else if (lun%itype(l) == istice_mec) then + nlevs = nlevgrnd + do j = 1, nlevs + this%h2osoi_vol_col(c,j) = 1.0_r8 * ratio + end do + else + write(iulog,*) 'water_state_type InitCold: unhandled landunit type ', lun%itype(l) + call endrun(msg = 'unhandled landunit type', & + additional_msg = errMsg(sourcefile, __LINE__)) + endif + do j = 1, nlevs + this%h2osoi_vol_col(c,j) = min(this%h2osoi_vol_col(c,j), watsat_col(c,j)*ratio) + if (t_soisno_col(c,j) <= SHR_CONST_TKFRZ) then + this%h2osoi_ice_col(c,j) = col%dz(c,j)*denice*this%h2osoi_vol_col(c,j) ! ratio already applied + this%h2osoi_liq_col(c,j) = 0._r8 + else + this%h2osoi_ice_col(c,j) = 0._r8 + this%h2osoi_liq_col(c,j) = col%dz(c,j)*denh2o*this%h2osoi_vol_col(c,j) ! ratio already applied + endif + end do + if (snl(c) == 0) then + this%h2osno_no_layers_col(c) = h2osno_input_col(c) * ratio + else + this%h2osno_no_layers_col(c) = 0._r8 + end if + do j = -nlevsno+1, 0 + if (j > snl(c)) then + this%h2osoi_ice_col(c,j) = col%dz(c,j)*250._r8 * ratio + this%h2osoi_liq_col(c,j) = 0._r8 + end if + end do + end if + end do + + + !-------------------------------------------- + ! Set Lake water + !-------------------------------------------- + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + + if (lun%lakpoi(l)) then + if (snl(c) == 0) then + this%h2osno_no_layers_col(c) = h2osno_input_col(c) * ratio + else + this%h2osno_no_layers_col(c) = 0._r8 + end if + do j = -nlevsno+1, 0 + if (j > snl(c)) then + this%h2osoi_ice_col(c,j) = col%dz(c,j)*bdsno * ratio + this%h2osoi_liq_col(c,j) = 0._r8 + end if + end do + do j = 1,nlevgrnd + if (j <= nlevsoi) then ! soil + this%h2osoi_vol_col(c,j) = watsat_col(c,j) * ratio + this%h2osoi_liq_col(c,j) = spval + this%h2osoi_ice_col(c,j) = spval + else ! bedrock + this%h2osoi_vol_col(c,j) = 0._r8 + end if + end do + end if + end do + + !-------------------------------------------- + ! For frozen layers !TODO - does the following make sense ???? it seems to overwrite everything + !-------------------------------------------- + + do c = bounds%begc, bounds%endc + do j = 1,nlevmaxurbgrnd + if (this%h2osoi_vol_col(c,j) /= spval) then + if (t_soisno_col(c,j) <= tfrz) then + this%h2osoi_ice_col(c,j) = col%dz(c,j)*denice*this%h2osoi_vol_col(c,j) ! ratio already applied + this%h2osoi_liq_col(c,j) = 0._r8 + else + this%h2osoi_ice_col(c,j) = 0._r8 + this%h2osoi_liq_col(c,j) = col%dz(c,j)*denh2o*this%h2osoi_vol_col(c,j) ! ratio already applied + endif + end if + end do + end do + + + this%aquifer_water_baseline = aquifer_water_baseline * ratio + this%wa_col(bounds%begc:bounds%endc) = this%aquifer_water_baseline + if (use_aquifer_layer) then + ! NOTE(wjs, 2018-11-27) There is no fundamental reason why wa_col should be + ! initialized differently based on use_aquifer_layer, but we (Bill Sacks and Sean + ! Swenson) want to change the cold start initialization of wa_col to be + ! aquifer_water_baseline everywhere for use_aquifer_layer .false., and we aren't + ! sure of the implications of this change for use_aquifer_layer .true., so are + ! maintaining the old cold start initialization in the latter case. + do c = bounds%begc,bounds%endc + l = col%landunit(c) + if (.not. lun%lakpoi(l)) then !not lake + if (lun%urbpoi(l)) then + if (col%itype(c) == icol_road_perv) then + ! Note that the following hard-coded constant (on the next line) + ! seems implicitly related to aquifer_water_baseline + this%wa_col(c) = 4800._r8 * ratio + else + this%wa_col(c) = spval + end if + else + ! Note that the following hard-coded constant (on the next line) seems + ! implicitly related to aquifer_water_baseline + this%wa_col(c) = 4000._r8 * ratio + end if + end if + end do + end if + + ! Initialize dynbal_baseline_liq_col and dynbal_baseline_ice_col: for some columns, + ! these are set elsewhere in initialization, but we need them to be 0 for columns + ! for which they are not explicitly set. + this%dynbal_baseline_liq_col(bounds%begc:bounds%endc) = 0._r8 + this%dynbal_baseline_ice_col(bounds%begc:bounds%endc) = 0._r8 + + end associate + + end subroutine InitCold + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag, & + watsat_col) + ! + ! !DESCRIPTION: + ! Read/Write module information to/from restart file. + ! + ! !USES: + use clm_varcon , only : denice, denh2o, pondmx, watmin + use landunit_varcon , only : istcrop, istdlak, istsoil + use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall + use clm_time_manager , only : is_first_step, is_restart + use clm_varctl , only : bound_h2osoi + use ncdio_pio , only : file_desc_t, ncd_double + use restUtilMod + ! + ! !ARGUMENTS: + class(waterstate_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + real(r8) , intent(in) :: watsat_col (bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + ! + ! !LOCAL VARIABLES: + integer :: p,c,l,j,nlevs + logical :: readvar + real(r8) :: maxwatsat ! maximum porosity + real(r8) :: excess ! excess volumetric soil water + real(r8) :: totwat ! total soil water (mm) + !------------------------------------------------------------------------ + + SHR_ASSERT_ALL_FL((ubound(watsat_col) == (/bounds%endc,nlevmaxurbgrnd/)) , sourcefile, __LINE__) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('H2OSFC'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('surface water'), & + units='kg/m2', & + interpinic_flag='interp', readvar=readvar, data=this%h2osfc_col) + if (flag=='read' .and. .not. readvar) then + this%h2osfc_col(bounds%begc:bounds%endc) = 0.0_r8 + end if + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('H2OSNO_NO_LAYERS:H2OSNO'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('snow that is not resolved into layers'), & + units='kg/m2', & + interpinic_flag='interp', readvar=readvar, data=this%h2osno_no_layers_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2019-06-06) If h2osno_no_layers is read from the old + ! h2osno, then it will be non-zero for an explicit-layered snow pack. We fix that + ! here. We can (and should) remove this backwards compatibility code at the same time + ! as we remove ":H2OSNO" from the restart variable name above. + if (flag == 'read' .and. .not. is_restart()) then + do c = bounds%begc, bounds%endc + if (col%snl(c) < 0) then + this%h2osno_no_layers_col(c) = 0._r8 + end if + end do + end if + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('H2OSOI_LIQ'), & + xtype=ncd_double, & + dim1name='column', dim2name='levtot', switchdim=.true., & + long_name=this%info%lname('liquid water'), & + units='kg/m2', & + interpinic_flag='interp', readvar=readvar, data=this%h2osoi_liq_col) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('H2OSOI_ICE'), & + xtype=ncd_double, & + dim1name='column', dim2name='levtot', switchdim=.true., & + long_name=this%info%lname('ice lens'), & + units='kg/m2', & + interpinic_flag='interp', readvar=readvar, data=this%h2osoi_ice_col) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('SNOCAN'), & + xtype=ncd_double, & + dim1name='pft', & + long_name=this%info%lname('canopy snow water'), & + units='kg/m2', & + interpinic_flag='interp', readvar=readvar, data=this%snocan_patch) + + ! NOTE(wjs, 2015-07-01) In old restart files, there was no LIQCAN variable. However, + ! H2OCAN had similar meaning. So if we can't find LIQCAN, use H2OCAN to initialize + ! liqcan_patch. + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('LIQCAN')//':'//this%info%fname('H2OCAN'), & + xtype=ncd_double, & + dim1name='pft', & + long_name=this%info%lname('canopy liquid water'), & + units='kg/m2', & + interpinic_flag='interp', readvar=readvar, data=this%liqcan_patch) + + call restartvar(ncid=ncid, flag=flag, varname=this%info%fname('WA'), xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname('water in the unconfined aquifer'), units='mm', & + interpinic_flag='interp', readvar=readvar, data=this%wa_col) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('DYNBAL_BASELINE_LIQ'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname("baseline liquid water mass subtracted from each column's total water calculation"), & + units='kg/m2', & + interpinic_flag='interp', readvar=readvar, data=this%dynbal_baseline_liq_col) + + call restartvar(ncid=ncid, flag=flag, & + varname=this%info%fname('DYNBAL_BASELINE_ICE'), & + xtype=ncd_double, & + dim1name='column', & + long_name=this%info%lname("baseline ice mass subtracted from each column's total ice calculation"), & + units='kg/m2', & + interpinic_flag='interp', readvar=readvar, data=this%dynbal_baseline_ice_col) + + ! Determine volumetric soil water (for read only) + if (flag == 'read' ) then + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if ( col%itype(c) == icol_sunwall .or. & + col%itype(c) == icol_shadewall .or. & + col%itype(c) == icol_roof )then + nlevs = nlevurb + else + nlevs = nlevgrnd + end if + if ( lun%itype(l) /= istdlak ) then ! This calculation is now done for lakes in initLake. + do j = 1,nlevs + this%h2osoi_vol_col(c,j) = this%h2osoi_liq_col(c,j)/(col%dz(c,j)*denh2o) & + + this%h2osoi_ice_col(c,j)/(col%dz(c,j)*denice) + end do + end if + end do + end if + + ! If initial run -- ensure that water is properly bounded (read only) + if (flag == 'read' ) then + if ( is_first_step() .and. bound_h2osoi) then + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if ( col%itype(c) == icol_sunwall .or. col%itype(c) == icol_shadewall .or. & + col%itype(c) == icol_roof )then + nlevs = nlevurb + else + nlevs = nlevgrnd + end if + do j = 1,nlevs + l = col%landunit(c) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + this%h2osoi_liq_col(c,j) = max(0._r8,this%h2osoi_liq_col(c,j)) + this%h2osoi_ice_col(c,j) = max(0._r8,this%h2osoi_ice_col(c,j)) + this%h2osoi_vol_col(c,j) = this%h2osoi_liq_col(c,j)/(col%dz(c,j)*denh2o) & + + this%h2osoi_ice_col(c,j)/(col%dz(c,j)*denice) + if (j == 1) then + maxwatsat = (watsat_col(c,j)*col%dz(c,j)*1000.0_r8 + pondmx) / (col%dz(c,j)*1000.0_r8) + else + maxwatsat = watsat_col(c,j) + end if + if (this%h2osoi_vol_col(c,j) > maxwatsat) then + excess = (this%h2osoi_vol_col(c,j) - maxwatsat)*col%dz(c,j)*1000.0_r8 + totwat = this%h2osoi_liq_col(c,j) + this%h2osoi_ice_col(c,j) + this%h2osoi_liq_col(c,j) = this%h2osoi_liq_col(c,j) - & + (this%h2osoi_liq_col(c,j)/totwat) * excess + this%h2osoi_ice_col(c,j) = this%h2osoi_ice_col(c,j) - & + (this%h2osoi_ice_col(c,j)/totwat) * excess + end if + this%h2osoi_liq_col(c,j) = max(watmin,this%h2osoi_liq_col(c,j)) + this%h2osoi_ice_col(c,j) = max(watmin,this%h2osoi_ice_col(c,j)) + this%h2osoi_vol_col(c,j) = this%h2osoi_liq_col(c,j)/(col%dz(c,j)*denh2o) & + + this%h2osoi_ice_col(c,j)/(col%dz(c,j)*denice) + end if + end do + end do + end if + + endif ! end if if-read flag + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine CalculateTotalH2osno(this, & + bounds, num_c, filter_c, caller, & + h2osno_total) + ! + ! !DESCRIPTION: + ! Calculate h2osno_total over the given column filter + ! + ! If running in debug mode, also assert that we don't have any unresolved snow if snl + ! < 0, and that we don't have any resolved snow if snl == 0. + ! + ! !ARGUMENTS: + class(waterstate_type) , intent(in) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_c ! number of columns in filter + integer , intent(in) :: filter_c(:) ! filter for columns to operate over + character(len=*) , intent(in) :: caller ! name of caller (used in error messages) + real(r8) , intent(inout) :: h2osno_total( bounds%begc: ) ! total snow water (mm H2O) + ! + ! !LOCAL VARIABLES: + integer :: fc, c + integer :: j + + character(len=*), parameter :: subname = 'CalculateTotalH2osno' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(h2osno_total, 1) == bounds%endc), sourcefile, __LINE__) + +#ifndef NDEBUG + call this%CheckSnowConsistency(num_c, filter_c, caller) +#endif + + do fc = 1, num_c + c = filter_c(fc) + h2osno_total(c) = this%h2osno_no_layers_col(c) + + do j = col%snl(c)+1, 0 + h2osno_total(c) = & + h2osno_total(c) + & + this%h2osoi_ice_col(c,j) + & + this%h2osoi_liq_col(c,j) + end do + end do + + end subroutine CalculateTotalH2osno + + !----------------------------------------------------------------------- + subroutine CheckSnowConsistency(this, num_c, filter_c, caller) + ! + ! !DESCRIPTION: + ! Make sure we only have unresolved snow where we should, and that we only have + ! resolved snow where we should. + ! + ! !ARGUMENTS: + class(waterstate_type) , intent(in) :: this + integer , intent(in) :: num_c ! number of columns in filter + integer , intent(in) :: filter_c(:) ! filter for columns to operate over + character(len=*) , intent(in) :: caller ! name of caller (used in error messages) + ! + ! !LOCAL VARIABLES: + integer :: fc, c + integer :: j + logical :: ice_bad + logical :: liq_bad + + character(len=*), parameter :: subname = 'CheckSnowConsistency' + !----------------------------------------------------------------------- + + do fc = 1, num_c + c = filter_c(fc) + if (col%snl(c) < 0) then + if (this%h2osno_no_layers_col(c) /= 0._r8) then + write(iulog,*) subname//' ERROR: col has snow layers but non-zero h2osno_no_layers' + write(iulog,*) '(Called from: ', trim(caller), ')' + write(iulog,*) 'c, snl, h2osno_no_layers = ', c, col%snl(c), & + this%h2osno_no_layers_col(c) + call endrun(decomp_index=c, clmlevel=namec, & + msg = subname//' ERROR: col has snow layers but non-zero h2osno_no_layers') + end if + end if + + do j = -nlevsno+1, col%snl(c) + ice_bad = (this%h2osoi_ice_col(c,j) /= 0._r8 .and. this%h2osoi_ice_col(c,j) /= spval) + liq_bad = (this%h2osoi_liq_col(c,j) /= 0._r8 .and. this%h2osoi_liq_col(c,j) /= spval) + if (ice_bad .or. liq_bad) then + write(iulog,*) subname//' ERROR: col has non-zero h2osoi_ice or h2osoi_liq outside resolved snow layers' + write(iulog,*) '(Called from: ', trim(caller), ')' + write(iulog,*) 'c, j, snl, h2osoi_ice, h2osoi_liq = ', c, j, col%snl(c), & + this%h2osoi_ice_col(c,j), this%h2osoi_liq_col(c,j) + call endrun(decomp_index=c, clmlevel=namec, & + msg = subname//' ERROR: col has non-zero h2osoi_ice or h2osoi_liq outside resolved snow layers') + end if + end do + end do + + end subroutine CheckSnowConsistency + +end module WaterStateType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterType.F90 new file mode 100644 index 000000000..3bed3ff19 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/WaterType.F90 @@ -0,0 +1,1056 @@ +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), allocatable, public :: bulk_and_tracers(:) + + ! ------------------------------------------------------------------------ + ! 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 + procedure, public :: InitForTesting ! Init routine just for unit tests + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: UpdateAccVars + procedure, public :: Restart + procedure, public :: GetBulkOrTracerName ! Return name of a given tracer (or bulk) + procedure, public :: IsIsotope ! Return true if a given tracer is an isotope + procedure, public :: GetIsotopeInfo ! Get a pointer to the object storing isotope info for a given tracer + procedure, public :: GetBulkTracerIndex ! Get the index of the tracer that replicates bulk water + procedure, public :: DoConsistencyCheck ! Whether TracerConsistencyCheck should be called in this run + procedure, public :: TracerConsistencyCheck + procedure, public :: ResetCheckedTracers + procedure, public :: Summary ! Calculate end-of-timestep summaries of water diagnostic terms + + ! Private routines + procedure, private :: DoInit + procedure, private :: ReadNamelist + procedure, private :: SetupTracerInfo + procedure, private :: AllocateBulk + procedure, private :: AllocateTracer + end type water_type + + interface water_params_type + module procedure water_params_constructor + end interface water_params_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !----------------------------------------------------------------------- + function water_params_constructor(enable_consistency_checks, enable_isotopes) & + result(params) + ! + ! !DESCRIPTION: + ! Creates a new instance of water_params_type + ! + ! !USES: + ! + ! !ARGUMENTS: + type(water_params_type) :: params ! function result + logical, intent(in) :: enable_consistency_checks + logical, intent(in) :: enable_isotopes + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'water_params_constructor' + !----------------------------------------------------------------------- + + params%enable_consistency_checks = enable_consistency_checks + params%enable_isotopes = enable_isotopes + end function water_params_constructor + + !----------------------------------------------------------------------- + subroutine Init(this, bounds, NLFilename, & + h2osno_col, snow_depth_col, watsat_col, t_soisno_col, use_aquifer_layer) + ! + ! !DESCRIPTION: + ! Initialize all water variables + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: NLFilename ! Namelist filename + real(r8) , intent(in) :: h2osno_col(bounds%begc:) + real(r8) , intent(in) :: snow_depth_col(bounds%begc:) + real(r8) , intent(in) :: watsat_col(bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + real(r8) , intent(in) :: t_soisno_col(bounds%begc:, -nlevsno+1:) ! col soil temperature (Kelvin) + logical , intent(in) :: use_aquifer_layer ! whether an aquifer layer is used in this run + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Init' + !----------------------------------------------------------------------- + + call this%ReadNamelist(NLFilename) + call this%DoInit(bounds = bounds, & + h2osno_col = h2osno_col, & + snow_depth_col = snow_depth_col, & + watsat_col = watsat_col, & + t_soisno_col = t_soisno_col, & + use_aquifer_layer = use_aquifer_layer) + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitForTesting(this, bounds, params, & + h2osno_col, snow_depth_col, watsat_col, t_soisno_col, use_aquifer_layer) + ! + ! !DESCRIPTION: + ! Version of Init routine just for unit tests + ! + ! This version has params passed in directly instead of reading from namelist + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + type(water_params_type), intent(in) :: params + real(r8) , intent(in) :: h2osno_col(bounds%begc:) + real(r8) , intent(in) :: snow_depth_col(bounds%begc:) + real(r8) , intent(in) :: watsat_col(bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + real(r8) , intent(in) :: t_soisno_col(bounds%begc:, -nlevsno+1:) ! col soil temperature (Kelvin) + logical , intent(in), optional :: use_aquifer_layer ! whether an aquifer layer is used in this run (false by default) + ! + ! !LOCAL VARIABLES: + logical :: l_use_aquifer_layer + + character(len=*), parameter :: subname = 'InitForTesting' + !----------------------------------------------------------------------- + + l_use_aquifer_layer = .false. + if (present(use_aquifer_layer)) then + l_use_aquifer_layer = use_aquifer_layer + end if + + this%params = params + call this%DoInit(bounds = bounds, & + h2osno_col = h2osno_col, & + snow_depth_col = snow_depth_col, & + watsat_col = watsat_col, & + t_soisno_col = t_soisno_col, & + use_aquifer_layer = l_use_aquifer_layer) + + end subroutine InitForTesting + + !----------------------------------------------------------------------- + subroutine DoInit(this, bounds, & + h2osno_col, snow_depth_col, watsat_col, t_soisno_col, use_aquifer_layer) + ! + ! !DESCRIPTION: + ! Actually do the initialization (shared between main Init routine and InitForTesting) + ! + ! !USES: + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + real(r8) , intent(in) :: h2osno_col(bounds%begc:) + real(r8) , intent(in) :: snow_depth_col(bounds%begc:) + real(r8) , intent(in) :: watsat_col(bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + real(r8) , intent(in) :: t_soisno_col(bounds%begc:, -nlevsno+1:) ! col soil temperature (Kelvin) + logical , intent(in) :: use_aquifer_layer ! whether an aquifer layer is used in this run + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: i + + character(len=*), parameter :: subname = 'DoInit' + !----------------------------------------------------------------------- + + begc = bounds%begc + endc = bounds%endc + + SHR_ASSERT_ALL_FL((ubound(h2osno_col) == [endc]), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(snow_depth_col) == [endc]), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(watsat_col, 1) == endc), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(t_soisno_col, 1) == endc), sourcefile, __LINE__) + + call this%SetupTracerInfo() + + call this%AllocateBulk() + + associate( & + bulk_info => this%bulk_and_tracers(this%i_bulk)%info, & + bulk_vars => this%bulk_and_tracers(this%i_bulk)%vars & + ) + + call bulk_vars%init() + + call this%waterstatebulk_inst%InitBulk(bounds, & + bulk_info, & + bulk_vars, & + h2osno_input_col = h2osno_col(begc:endc), & + watsat_col = watsat_col(begc:endc, 1:), & + t_soisno_col = t_soisno_col(begc:endc, -nlevsno+1:), & + use_aquifer_layer = use_aquifer_layer) + + call this%waterdiagnosticbulk_inst%InitBulk(bounds, & + bulk_info, & + bulk_vars, & + snow_depth_input_col = snow_depth_col(begc:endc), & + h2osno_input_col = h2osno_col(begc:endc)) + + call this%waterbalancebulk_inst%Init(bounds, & + bulk_info, & + bulk_vars) + + call this%waterfluxbulk_inst%InitBulk(bounds, & + bulk_info, & + bulk_vars) + + call this%waterlnd2atmbulk_inst%InitBulk(bounds, & + bulk_info, & + bulk_vars) + + call this%wateratm2lndbulk_inst%InitBulk(bounds, & + bulk_info, & + bulk_vars) + + call bulk_vars%complete_setup() + + end associate + + do i = this%tracers_beg, this%tracers_end + + call this%AllocateTracer(i) + + call this%bulk_and_tracers(i)%vars%init() + + call this%bulk_and_tracers(i)%waterstate_inst%Init(bounds, & + this%bulk_and_tracers(i)%info, & + this%bulk_and_tracers(i)%vars, & + h2osno_input_col = h2osno_col(begc:endc), & + watsat_col = watsat_col(begc:endc, 1:), & + t_soisno_col = t_soisno_col(begc:endc, -nlevsno+1:), & + use_aquifer_layer = use_aquifer_layer) + + call this%bulk_and_tracers(i)%waterdiagnostic_inst%Init(bounds, & + this%bulk_and_tracers(i)%info, & + this%bulk_and_tracers(i)%vars) + + call this%bulk_and_tracers(i)%waterbalance_inst%Init(bounds, & + this%bulk_and_tracers(i)%info, & + this%bulk_and_tracers(i)%vars) + + call this%bulk_and_tracers(i)%waterflux_inst%Init(bounds, & + this%bulk_and_tracers(i)%info, & + this%bulk_and_tracers(i)%vars) + + call this%bulk_and_tracers(i)%waterlnd2atm_inst%Init(bounds, & + this%bulk_and_tracers(i)%info, & + this%bulk_and_tracers(i)%vars) + + call this%bulk_and_tracers(i)%wateratm2lnd_inst%Init(bounds, & + this%bulk_and_tracers(i)%info, & + this%bulk_and_tracers(i)%vars) + + call this%bulk_and_tracers(i)%vars%complete_setup() + + end do + + end subroutine DoInit + + + !----------------------------------------------------------------------- + subroutine ReadNamelist(this, NLFilename) + ! + ! !DESCRIPTION: + ! Read the water_tracers namelist; set this%params + ! + ! !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 + class(water_type) , intent(inout) :: this + ! + ! !LOCAL VARIABLES: + + ! temporary local variables corresponding to the namelist items + logical :: enable_water_tracer_consistency_checks + logical :: enable_water_isotopes + + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + character(len=*), parameter :: nmlname = 'water_tracers' + + character(len=*), parameter :: subname = 'ReadNamelist' + !----------------------------------------------------------------------- + + namelist /water_tracers_inparm/ & + enable_water_tracer_consistency_checks, enable_water_isotopes + + ! Initialize namelist variables to defaults + enable_water_tracer_consistency_checks = .false. + enable_water_isotopes = .false. + + 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=water_tracers_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(enable_water_tracer_consistency_checks, mpicom) + call shr_mpi_bcast(enable_water_isotopes, mpicom) + + if (masterproc) then + write(iulog,*) + write(iulog,*) nmlname, ' settings' + write(iulog,nml=water_tracers_inparm) + write(iulog,*) + end if + + this%params = water_params_type( & + enable_consistency_checks = enable_water_tracer_consistency_checks, & + enable_isotopes = enable_water_isotopes) + + end subroutine ReadNamelist + + + !----------------------------------------------------------------------- + subroutine SetupTracerInfo(this) + ! + ! !DESCRIPTION: + ! Setup information on each water tracer + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + integer :: num_tracers + integer :: tracer_num + logical :: enable_bulk_tracer + + character(len=*), parameter :: subname = 'SetupTracerInfo' + !----------------------------------------------------------------------- + + this%bulk_tracer_index = -1 + + num_tracers = 0 + if (this%params%enable_consistency_checks .or. this%params%enable_isotopes) then + ! NOTE(wjs, 2018-09-05) From looking at the old water isotope code, it looks like + ! we may need the bulk tracer even if we're not doing consistency checks, in order + ! to do some roundoff-level adjustments. + enable_bulk_tracer = .true. + else + enable_bulk_tracer = .false. + end if + + if (enable_bulk_tracer) then + num_tracers = num_tracers + 1 + end if + if (this%params%enable_isotopes) then + num_tracers = num_tracers + 2 + end if + if (this%params%enable_consistency_checks) then + num_tracers = num_tracers + 3 + end if + + this%bulk_and_tracers_beg = 0 + this%tracers_beg = 1 + this%bulk_and_tracers_end = num_tracers + this%tracers_end = num_tracers + this%i_bulk = 0 + + allocate(this%bulk_and_tracers(this%bulk_and_tracers_beg:this%bulk_and_tracers_end)) + + allocate(this%bulk_and_tracers(this%i_bulk)%info, source = water_info_bulk_type()) + + tracer_num = 1 + if (enable_bulk_tracer) then + allocate(this%bulk_and_tracers(tracer_num)%info, source = water_info_isotope_type( & + tracer_name = 'H2OTR', & + ratio = 1._r8, & + included_in_consistency_check = .true., & + communicated_with_coupler = .false.)) + this%bulk_and_tracers(tracer_num)%is_isotope = .true. + this%bulk_tracer_index = tracer_num + tracer_num = tracer_num + 1 + end if + if (this%params%enable_isotopes) then + allocate(this%bulk_and_tracers(tracer_num)%info, source = water_info_isotope_type( & + tracer_name = 'HDO', & + ratio = 0.9_r8, & + included_in_consistency_check = .false., & + communicated_with_coupler = .false.)) + this%bulk_and_tracers(tracer_num)%is_isotope = .true. + tracer_num = tracer_num + 1 + + allocate(this%bulk_and_tracers(tracer_num)%info, source = water_info_isotope_type( & + tracer_name = 'H218O', & + ratio = 0.5_r8, & + included_in_consistency_check = .false., & + communicated_with_coupler = .false.)) + this%bulk_and_tracers(tracer_num)%is_isotope = .true. + tracer_num = tracer_num + 1 + end if + if (this%params%enable_consistency_checks) then + allocate(this%bulk_and_tracers(tracer_num)%info, source = water_info_isotope_type( & + tracer_name = 'TESTMED', & + ratio = 0.1_r8, & + included_in_consistency_check = .true., & + communicated_with_coupler = .false.)) + this%bulk_and_tracers(tracer_num)%is_isotope = .true. + tracer_num = tracer_num + 1 + + allocate(this%bulk_and_tracers(tracer_num)%info, source = water_info_isotope_type( & + tracer_name = 'TESTSMALL', & + ratio = 1.0e-10_r8, & + included_in_consistency_check = .true., & + communicated_with_coupler = .false.)) + this%bulk_and_tracers(tracer_num)%is_isotope = .true. + tracer_num = tracer_num + 1 + + allocate(this%bulk_and_tracers(tracer_num)%info, source = water_info_isotope_type( & + tracer_name = 'TESTBIG', & + ratio = 10._r8, & + included_in_consistency_check = .true., & + communicated_with_coupler = .false.)) + this%bulk_and_tracers(tracer_num)%is_isotope = .true. + tracer_num = tracer_num + 1 + end if + + + if (tracer_num - 1 /= num_tracers) then + write(iulog,*) subname//' ERROR: tracer_num discrepancy' + write(iulog,*) 'num_tracers = ', num_tracers + write(iulog,*) 'but added ', tracer_num - 1, ' tracers' + call endrun(msg='tracer_num discrepancy '//errMsg(sourcefile, __LINE__)) + end if + + end subroutine SetupTracerInfo + + !----------------------------------------------------------------------- + subroutine AllocateBulk(this) + ! + ! !DESCRIPTION: + ! Allocate each of the bulk objects + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'AllocateBulk' + !----------------------------------------------------------------------- + + associate( & + i_bulk => this%i_bulk & + ) + + allocate(this%waterfluxbulk_inst) + this%bulk_and_tracers(i_bulk)%waterflux_inst => this%waterfluxbulk_inst + + allocate(this%waterstatebulk_inst) + this%bulk_and_tracers(i_bulk)%waterstate_inst => this%waterstatebulk_inst + + allocate(this%waterdiagnosticbulk_inst) + this%bulk_and_tracers(i_bulk)%waterdiagnostic_inst => this%waterdiagnosticbulk_inst + + allocate(this%waterbalancebulk_inst) + this%bulk_and_tracers(i_bulk)%waterbalance_inst => this%waterbalancebulk_inst + + allocate(this%waterlnd2atmbulk_inst) + this%bulk_and_tracers(i_bulk)%waterlnd2atm_inst => this%waterlnd2atmbulk_inst + + allocate(this%wateratm2lndbulk_inst) + this%bulk_and_tracers(i_bulk)%wateratm2lnd_inst => this%wateratm2lndbulk_inst + + end associate + + end subroutine AllocateBulk + + !----------------------------------------------------------------------- + subroutine AllocateTracer(this, i) + ! + ! !DESCRIPTION: + ! Allocate each of the tracer objects for tracer i + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + integer, intent(in) :: i ! tracer number + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'AllocateTracer' + !----------------------------------------------------------------------- + + allocate(waterflux_type :: this%bulk_and_tracers(i)%waterflux_inst) + allocate(waterstate_type :: this%bulk_and_tracers(i)%waterstate_inst) + allocate(waterdiagnostic_type :: this%bulk_and_tracers(i)%waterdiagnostic_inst) + allocate(waterbalance_type :: this%bulk_and_tracers(i)%waterbalance_inst) + allocate(waterlnd2atm_type :: this%bulk_and_tracers(i)%waterlnd2atm_inst) + allocate(wateratm2lnd_type :: this%bulk_and_tracers(i)%wateratm2lnd_inst) + + end subroutine AllocateTracer + + !----------------------------------------------------------------------- + subroutine InitAccBuffer(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all water variables + ! + ! !ARGUMENTS: + ! + ! !LOCAL VARIABLES: + class(water_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + + character(len=*), parameter :: subname = 'InitAccBuffer' + !----------------------------------------------------------------------- + + call this%waterfluxbulk_inst%InitAccBuffer(bounds) + call this%wateratm2lndbulk_inst%InitAccBuffer(bounds) + call this%waterdiagnosticbulk_inst%InitAccBuffer(bounds) + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + subroutine InitAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize variables that are associated with accumulated fields + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'InitAccVars' + !----------------------------------------------------------------------- + + call this%waterfluxbulk_inst%initAccVars(bounds) + call this%wateratm2lndbulk_inst%initAccVars(bounds) + call this%waterdiagnosticbulk_inst%initAccVars(bounds) + + end subroutine InitAccVars + + !----------------------------------------------------------------------- + subroutine UpdateAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Update accumulated variables + ! + ! Should be called every time step + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'UpdateAccVars' + !----------------------------------------------------------------------- + + call this%waterfluxbulk_inst%UpdateAccVars(bounds) + call this%wateratm2lndbulk_inst%UpdateAccVars(bounds) + call this%waterdiagnosticbulk_inst%UpdateAccVars(bounds) + + end subroutine UpdateAccVars + + + !----------------------------------------------------------------------- + subroutine Restart(this, bounds, ncid, flag, writing_finidat_interp_dest_file, & + watsat_col) + ! + ! !DESCRIPTION: + ! Read/write information to/from restart file for all water variables + ! + ! !ARGUMENTS: + class(water_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', 'write' or 'define' + logical , intent(in) :: writing_finidat_interp_dest_file ! true if we are writing a finidat_interp_dest file (ignored for flag=='read') + real(r8) , intent(in) :: watsat_col (bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) + ! + ! !LOCAL VARIABLES: + integer :: i + + character(len=*), parameter :: subname = 'Restart' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(watsat_col, 1) == bounds%endc), sourcefile, __LINE__) + + call this%waterfluxbulk_inst%restartBulk (bounds, ncid, flag=flag) + + call this%waterstatebulk_inst%restartBulk (bounds, ncid, flag=flag, & + watsat_col=watsat_col(bounds%begc:bounds%endc,:)) + + call this%waterdiagnosticbulk_inst%restartBulk (bounds, ncid, flag=flag, & + writing_finidat_interp_dest_file=writing_finidat_interp_dest_file, & + waterstatebulk_inst = this%waterstatebulk_inst) + + do i = this%tracers_beg, this%tracers_end + + call this%bulk_and_tracers(i)%waterflux_inst%Restart(bounds, ncid, flag=flag) + + call this%bulk_and_tracers(i)%waterstate_inst%Restart(bounds, ncid, flag=flag, & + watsat_col=watsat_col(bounds%begc:bounds%endc,:)) + + call this%bulk_and_tracers(i)%waterdiagnostic_inst%Restart(bounds, ncid, flag=flag) + + end do + + end subroutine Restart + + !----------------------------------------------------------------------- + function GetBulkOrTracerName(this, i) result(name) + ! + ! !DESCRIPTION: + ! Get name of the given tracer (or bulk) + ! + ! i must be >= this%bulk_and_tracers_beg and <= this%bulk_and_tracers_end + ! + ! !ARGUMENTS: + character(len=:), allocatable :: name ! function result + class(water_type), intent(in) :: this + integer, intent(in) :: i ! index of tracer (or bulk) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'GetBulkOrTracerName' + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(i >= this%bulk_and_tracers_beg, sourcefile, __LINE__) + SHR_ASSERT_FL(i <= this%bulk_and_tracers_end, sourcefile, __LINE__) + + name = this%bulk_and_tracers(i)%info%get_name() + + end function GetBulkOrTracerName + + + !----------------------------------------------------------------------- + function IsIsotope(this, i) + ! + ! !DESCRIPTION: + ! Returns true if tracer i is an isotope + ! + ! i must be >= this%tracers_beg and <= this%tracers_end + ! + ! !ARGUMENTS: + logical :: IsIsotope ! function result + class(water_type), intent(in) :: this + integer, intent(in) :: i ! index of tracer + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'IsIsotope' + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(i >= this%tracers_beg, sourcefile, __LINE__) + SHR_ASSERT_FL(i <= this%tracers_end, sourcefile, __LINE__) + + IsIsotope = this%bulk_and_tracers(i)%is_isotope + + end function IsIsotope + + !----------------------------------------------------------------------- + subroutine GetIsotopeInfo(this, i, isotope_info) + ! + ! !DESCRIPTION: + ! Get a pointer to the object storing isotope info for a given tracer + ! + ! This provides a mechanism for passing the isotope info to subroutines that need it. + ! + ! i must be >= this%tracers_beg and <= this%tracers_end, and this%IsIsotope(i) must be + ! true + ! + ! Assumes that the 'isotope_info' pointer is not currently allocated. (Otherwise this + ! will result in a memory leak. It is okay for the isotope_info pointer to be + ! previously associated with something else, though, as long as it doesn't require + ! deallocation before being associated with something new.) + ! + ! !ARGUMENTS: + class(water_type), intent(in) :: this + integer, intent(in) :: i ! index of tracer + type(water_info_isotope_type), pointer, intent(out) :: isotope_info + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'GetIsotopeInfo' + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(i >= this%tracers_beg, sourcefile, __LINE__) + SHR_ASSERT_FL(i <= this%tracers_end, sourcefile, __LINE__) + + select type(info => this%bulk_and_tracers(i)%info) + type is(water_info_isotope_type) + isotope_info => info + class default + write(iulog,*) subname, ' ERROR: tracer ', i, ' is not an isotope' + call endrun(subname//' called on a non-isotope tracer') + end select + + end subroutine GetIsotopeInfo + + !----------------------------------------------------------------------- + function GetBulkTracerIndex(this) result(index) + ! + ! !DESCRIPTION: + ! Get the index of the tracer that replicates bulk water + ! + ! Returns -1 if there is no tracer that replicates bulk water in this run + ! + ! !ARGUMENTS: + integer :: index ! function result + class(water_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'GetBulkTracerIndex' + !----------------------------------------------------------------------- + + index = this%bulk_tracer_index + + end function GetBulkTracerIndex + + !----------------------------------------------------------------------- + function DoConsistencyCheck(this) result(do_consistency_check) + ! + ! !DESCRIPTION: + ! Returns a logical saying whether TracerConsistencyCheck should be called in this run + ! + ! !ARGUMENTS: + logical :: do_consistency_check ! function result + class(water_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'DoConsistencyCheck' + !----------------------------------------------------------------------- + + do_consistency_check = this%params%enable_consistency_checks + + end function DoConsistencyCheck + + + !------------------------------------------------------------------------ + subroutine TracerConsistencyCheck(this, bounds, caller_location) + ! + ! !DESCRIPTION: + ! Check consistency of water tracers with that of bulk water + ! + ! This should only be called if this%DoConsistencyCheck() returns .true. + ! + ! !ARGUMENTS: + class(water_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + character(len=*) , intent(in) :: caller_location ! brief description of where this is called from (for error messages) + ! + ! !LOCAL VARIABLES: + integer :: i + integer :: num_vars + integer :: var_num + character(len=:), allocatable :: name + integer :: begi, endi + real(r8), pointer :: bulk(:) + real(r8), pointer :: tracer(:) + character(len=*), parameter :: subname = 'TracerConsistencyCheck' + !----------------------------------------------------------------------- + + do i = this%tracers_beg, this%tracers_end + + associate( & + tracer_vars => this%bulk_and_tracers(i)%vars, & + tracer_info => this%bulk_and_tracers(i)%info, & + bulk_vars => this%bulk_and_tracers(this%i_bulk)%vars & + ) + + + if (tracer_info%is_included_in_consistency_check()) then + num_vars = tracer_vars%get_num_vars() + SHR_ASSERT_FL(num_vars == bulk_vars%get_num_vars(), sourcefile, __LINE__) + + do var_num = 1, num_vars + name = tracer_vars%get_description(var_num) + SHR_ASSERT_FL(name == bulk_vars%get_description(var_num), sourcefile, __LINE__) + + call tracer_vars%get_bounds(var_num, bounds, begi, endi) + + call bulk_vars%get_data(var_num, bulk) + call tracer_vars%get_data(var_num, tracer) + + call CompareBulkToTracer(begi, endi, & + bulk = bulk(begi:endi), & + tracer = tracer(begi:endi), & + ratio = tracer_info%get_ratio(), & + caller_location = caller_location, & + name = name) + + end do + end if + end associate + + end do + + end subroutine TracerConsistencyCheck + + !----------------------------------------------------------------------- + subroutine ResetCheckedTracers(this, bounds) + ! + ! !DESCRIPTION: + ! For tracers set in TracerConsistencyCheck, reset all values to bulk * ratio + ! + ! This is useful if some code has not been tracerized yet, but we want to perform the + ! tracer consistency check on later code: Put a call to TracerConsistencyCheck just + ! before the not-yet-tracerized code, then put a call to ResetCheckedTracers just + ! after the not-yet-tracerized code. + ! + ! !ARGUMENTS: + class(water_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: i + integer :: num_vars + integer :: var_num + integer :: begi, endi + real(r8), pointer :: bulk(:) + real(r8), pointer :: tracer(:) + + character(len=*), parameter :: subname = 'ResetCheckedTracers' + !----------------------------------------------------------------------- + + do i = this%tracers_beg, this%tracers_end + + associate( & + tracer_vars => this%bulk_and_tracers(i)%vars, & + tracer_info => this%bulk_and_tracers(i)%info, & + bulk_vars => this%bulk_and_tracers(this%i_bulk)%vars & + ) + + if (tracer_info%is_included_in_consistency_check()) then + num_vars = tracer_vars%get_num_vars() + SHR_ASSERT_FL(num_vars == bulk_vars%get_num_vars(), sourcefile, __LINE__) + + do var_num = 1, num_vars + SHR_ASSERT_FL(tracer_vars%get_description(var_num) == bulk_vars%get_description(var_num), sourcefile, __LINE__) + + call tracer_vars%get_bounds(var_num, bounds, begi, endi) + + call bulk_vars%get_data(var_num, bulk) + call tracer_vars%get_data(var_num, tracer) + + call SetTracerToBulkTimesRatio(begi, endi, & + bulk = bulk(begi:endi), & + tracer = tracer(begi:endi), & + ratio = tracer_info%get_ratio()) + end do + end if + end associate + + end do + + end subroutine ResetCheckedTracers + + + !----------------------------------------------------------------------- + subroutine Summary(this, bounds, & + num_soilp, filter_soilp, & + num_allc, filter_allc, & + num_nolakec, filter_nolakec) + ! + ! !DESCRIPTION: + ! Compute end-of-timestep summaries of water diagnostic terms + ! + ! !ARGUMENTS: + class(water_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilp ! number of patches in soilp filter + integer , intent(in) :: filter_soilp(:) ! filter for soil patches + integer , intent(in) :: num_allc ! number of columns in allc filter + integer , intent(in) :: filter_allc(:) ! filter for all columns + integer , intent(in) :: num_nolakec ! number of no-lake filter + integer , intent(in) :: filter_nolakec(:) ! filter for no-lake columns + ! + ! !LOCAL VARIABLES: + integer :: i + + character(len=*), parameter :: subname = 'Summary' + !----------------------------------------------------------------------- + + do i = this%bulk_and_tracers_beg, this%bulk_and_tracers_end + associate(bulk_or_tracer => this%bulk_and_tracers(i)) + call bulk_or_tracer%waterdiagnostic_inst%Summary( & + bounds = bounds, & + num_soilp = num_soilp, & + filter_soilp = filter_soilp, & + num_allc = num_allc, & + filter_allc = filter_allc, & + num_nolakec = num_nolakec, & + filter_nolakec = filter_nolakec, & + waterstate_inst = bulk_or_tracer%waterstate_inst, & + waterflux_inst = bulk_or_tracer%waterflux_inst) + end associate + end do + + end subroutine Summary + + +end module WaterType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/Wateratm2lndBulkType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/Wateratm2lndBulkType.F90 new file mode 100644 index 000000000..03ee7522f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/Wateratm2lndBulkType.F90 @@ -0,0 +1,479 @@ +module Wateratm2lndBulkType + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !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 + use WaterInfoBaseType, only : water_info_base_type + use WaterTracerContainerType, only : water_tracer_container_type + ! + implicit none + save + private + ! + ! !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 + procedure, public :: InitForTesting ! Should only be used in unit tests + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: UpdateAccVars + procedure, public :: Clean + procedure, private :: InitBulkAllocate + procedure, private :: InitBulkHistory + procedure, private :: InitBulkCold + + end type wateratm2lndbulk_type + + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine InitBulk(this, bounds, info, vars) + + class(wateratm2lndbulk_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + type(water_tracer_container_type), intent(inout) :: vars + + + call this%Init(bounds, info, vars) + + call this%InitBulkAllocate(bounds) + + call this%InitBulkHistory(bounds) + + call this%InitBulkCold(bounds) + + end subroutine InitBulk + + !------------------------------------------------------------------------ + subroutine InitForTesting(this, bounds, info) + ! Init routine only for unit testing + class(wateratm2lndbulk_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + + type(water_tracer_container_type) :: vars + + ! In unit tests, we don't care about the vars structure, so don't force tests to + ! create it + call vars%init() + call this%InitBulk(bounds, info, vars) + end subroutine InitForTesting + + !------------------------------------------------------------------------ + subroutine InitBulkAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(wateratm2lndbulk_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !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 + + 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(:) = nan + allocate(this%prec10_patch (begp:endp)) ; this%prec10_patch(:) = nan + allocate(this%rh30_patch (begp:endp)) ; this%rh30_patch (:) = nan + 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 InitBulkAllocate + + !------------------------------------------------------------------------ + subroutine InitBulkHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + class(wateratm2lndbulk_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begg, endg + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begg = bounds%begg; endg= bounds%endg + + + this%volr_grc(begg:endg) = spval + call hist_addfld1d (fname=this%info%fname('VOLR'), units='m3', & + avgflag='A', long_name=this%info%lname('river channel total water storage'), & + ptr_lnd=this%volr_grc) + + this%volrmch_grc(begg:endg) = spval + call hist_addfld1d (fname=this%info%fname('VOLRMCH'), units='m3', & + avgflag='A', long_name=this%info%lname('river channel main channel water storage'), & + ptr_lnd=this%volrmch_grc) + + this%forc_rh_grc(begg:endg) = spval + call hist_addfld1d (fname=this%info%fname('RH'), units='%', & + avgflag='A', long_name=this%info%lname('atmospheric relative humidity'), & + ptr_gcell=this%forc_rh_grc, default='inactive') + + if (use_cn) then + this%rh30_patch(begp:endp) = spval + call hist_addfld1d (fname=this%info%fname('RH30'), units='%', & + avgflag='A', long_name=this%info%lname('30-day running mean of relative humidity'), & + ptr_patch=this%rh30_patch, default='inactive') + + this%prec10_patch(begp:endp) = spval + call hist_addfld1d (fname=this%info%fname('PREC10'), units='MM H2O/S', & + avgflag='A', long_name=this%info%lname('10-day running mean of PREC'), & + ptr_patch=this%prec10_patch, default='inactive') + + this%prec60_patch(begp:endp) = spval + call hist_addfld1d (fname=this%info%fname('PREC60'), units='MM H2O/S', & + avgflag='A', long_name=this%info%lname('60-day running mean of PREC'), & + ptr_patch=this%prec60_patch, default='inactive') + end if + + end subroutine InitBulkHistory + + !----------------------------------------------------------------------- + subroutine InitBulkCold(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize cold start conditions + ! + ! !ARGUMENTS: + class(wateratm2lndbulk_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + + ! Nothing to do for now + + end subroutine InitBulkCold + + !------------------------------------------------------------------------ + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! + ! !USES + use clm_varcon , only : spval + use accumulMod , only : init_accum_field + ! + ! !ARGUMENTS: + class(wateratm2lndbulk_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + !--------------------------------------------------------------------- + + if (use_cn) then + call init_accum_field (name='PREC10', units='MM H2O/S', & + desc='10-day running mean of total precipitation', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field (name='PREC60', units='MM H2O/S', & + desc='60-day running mean of total precipitation', accum_type='runmean', accum_period=-60, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + call init_accum_field (name='RH30', units='%', & + desc='30-day running mean of relative humidity', accum_type='runmean', accum_period=-30, & + subgrid_type='pft', numlev=1, init_value=100._r8) + end if + + if (use_cndv) then + ! The following is a running mean with the accumulation period is set to -365 for a 365-day running mean. + call init_accum_field (name='PREC365', units='MM H2O/S', & + desc='365-day running mean of total precipitation', accum_type='runmean', accum_period=-365, & + subgrid_type='column', numlev=1, init_value=0._r8) + end if + + if ( use_fates ) then + call init_accum_field (name='PREC24', units='m', & + desc='24hr sum of precipitation', accum_type='runmean', accum_period=-1, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + ! Fudge - this neds to be initialized from the restat file eventually. + call init_accum_field (name='RH24', units='m', & + desc='24hr average of RH', accum_type='runmean', accum_period=-1, & + subgrid_type='pft', numlev=1, init_value=100._r8) + end if + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + subroutine InitAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES + use accumulMod , only : extract_accum_field + use clm_time_manager , only : get_nstep + ! + ! !ARGUMENTS: + class(wateratm2lndbulk_type), intent(in) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: nstep + integer :: ier + real(r8), pointer :: rbufslp(:) ! temporary + real(r8), pointer :: rbufslc(:) ! temporary + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)' in ' + call endrun(msg="InitAccVars allocation error for rbufslp"//& + errMsg(sourcefile, __LINE__)) + endif + ! Allocate needed dynamic memory for single level col field + allocate(rbufslc(begc:endc), stat=ier) + if (ier/=0) then + write(iulog,*)' in ' + call endrun(msg="InitAccVars allocation error for rbufslc"//& + errMsg(sourcefile, __LINE__)) + endif + + ! Determine time step + nstep = get_nstep() + + if (use_cn) then + call extract_accum_field ('PREC10', rbufslp, nstep) + this%prec10_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('PREC60', rbufslp, nstep) + this%prec60_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('RH30', rbufslp, nstep) + this%rh30_patch(begp:endp) = rbufslp(begp:endp) + end if + + if (use_cndv) then + call extract_accum_field ('PREC365' , rbufslc, nstep) + this%prec365_col(begc:endc) = rbufslc(begc:endc) + end if + + if (use_fates) then + call extract_accum_field ('PREC24', rbufslp, nstep) + this%prec24_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('RH24', rbufslp, nstep) + this%rh24_patch(begp:endp) = rbufslp(begp:endp) + end if + + deallocate(rbufslp) + deallocate(rbufslc) + + end subroutine InitAccVars + + subroutine UpdateAccVars (this, bounds) + ! + ! USES + use clm_time_manager, only : get_nstep + use accumulMod , only : update_accum_field, extract_accum_field + ! + ! !ARGUMENTS: + class(wateratm2lndbulk_type), intent(in) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g,c,p ! indices + integer :: nstep ! timestep number + integer :: ier ! error status + integer :: begp, endp + integer :: begc, endc + real(r8), pointer :: rbufslp(:) ! temporary single level - patch level + real(r8), pointer :: rbufslc(:) ! temporary single level - column level + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + nstep = get_nstep() + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)'UpdateAccVars allocation error for rbufslp' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + ! Allocate needed dynamic memory for single level col field + allocate(rbufslc(begc:endc), stat=ier) + if (ier/=0) then + write(iulog,*)'UpdateAccVars allocation error for rbufslc' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + + ! Precipitation accumulators + ! + ! For CNDV, we use a column-level accumulator. We cannot use a patch-level + ! accumulator for CNDV because this is used for establishment, so must be available + ! for inactive patches. In principle, we could/should switch to column-level for the + ! other precip accumulators, too; we'd just need to be careful about backwards + ! compatibility with old restart files. + + do p = begp,endp + c = patch%column(p) + rbufslp(p) = this%forc_rain_downscaled_col(c) + this%forc_snow_downscaled_col(c) + rbufslc(c) = this%forc_rain_downscaled_col(c) + this%forc_snow_downscaled_col(c) + end do + + if (use_cn) then + ! Accumulate and extract PREC60 (accumulates total precipitation as 60-day running mean) + call update_accum_field ('PREC60', rbufslp, nstep) + call extract_accum_field ('PREC60', this%prec60_patch, nstep) + + ! Accumulate and extract PREC10 (accumulates total precipitation as 10-day running mean) + call update_accum_field ('PREC10', rbufslp, nstep) + call extract_accum_field ('PREC10', this%prec10_patch, nstep) + end if + + if (use_cndv) then + ! Accumulate and extract PREC365 (accumulates total precipitation as 365-day running mean) + ! See above comment regarding why this is at the column-level despite other prec + ! accumulators being at the patch level. + call update_accum_field ('PREC365', rbufslc, nstep) + call extract_accum_field ('PREC365', this%prec365_col, nstep) + + end if + + if (use_fates) then + call update_accum_field ('PREC24', rbufslp, nstep) + call extract_accum_field ('PREC24', this%prec24_patch, nstep) + + do p = bounds%begp,bounds%endp + g = patch%gridcell(p) + rbufslp(p) = this%forc_rh_grc(g) + end do + call update_accum_field ('RH24', rbufslp, nstep) + call extract_accum_field ('RH24', this%rh24_patch, nstep) + end if + + if (use_cn) then + do p = begp,endp + g = patch%gridcell(p) + rbufslp(p) = this%forc_rh_grc(g) + end do + ! Accumulate and extract RH30 (accumulates RH as 30-day running mean) + call update_accum_field ('RH30', rbufslp, nstep) + call extract_accum_field ('RH30', this%rh30_patch, nstep) + endif + + deallocate(rbufslp) + deallocate(rbufslc) + + end subroutine UpdateAccVars + + subroutine Clean(this) + ! + ! !DESCRIPTION: + ! Finalize this instance + ! + ! !USES: + ! + ! !ARGUMENTS: + class(wateratm2lndbulk_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Clean' + !----------------------------------------------------------------------- + + ! atm->lnd + deallocate(this%forc_rh_grc) + + ! atm->lnd not downscaled + deallocate(this%forc_q_not_downscaled_grc) + deallocate(this%forc_rain_not_downscaled_grc) + deallocate(this%forc_snow_not_downscaled_grc) + + ! atm->lnd downscaled + deallocate(this%forc_q_downscaled_col) + deallocate(this%forc_rain_downscaled_col) + deallocate(this%forc_snow_downscaled_col) + + ! rof->lnd + deallocate(this%forc_flood_grc) + deallocate(this%volr_grc) + deallocate(this%volrmch_grc) + + ! anomaly forcing + deallocate(this%prec365_col) + deallocate(this%prec60_patch) + deallocate(this%prec10_patch) + if (use_fates) then + deallocate(this%prec24_patch) + deallocate(this%rh24_patch) + end if + + end subroutine Clean + +end module Wateratm2lndBulkType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/Wateratm2lndType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/Wateratm2lndType.F90 new file mode 100644 index 000000000..cc7358d3c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/Wateratm2lndType.F90 @@ -0,0 +1,447 @@ +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 decompMod , only : BOUNDS_SUBGRID_COLUMN, BOUNDS_SUBGRID_GRIDCELL + use clm_varcon , only : spval + use ColumnType , only : col + use WaterInfoBaseType, only : water_info_base_type + use WaterTracerContainerType, only : water_tracer_container_type + use WaterTracerUtils, only : AllocateVar1d, CalcTracerFromBulk, CalcTracerFromBulkFixedRatio + ! + implicit none + save + private + ! + ! !PUBLIC TYPES: + type, public :: wateratm2lnd_type + + class(water_info_base_type), pointer :: info + + 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 + procedure, public :: IsCommunicatedWithCoupler + procedure, public :: SetNondownscaledTracers + procedure, public :: SetDownscaledTracers + procedure, public :: Clean + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type wateratm2lnd_type + + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, info, tracer_vars) + + class(wateratm2lnd_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + class(water_info_base_type), intent(in), target :: info + type(water_tracer_container_type), intent(inout) :: tracer_vars + + this%info => info + + call this%InitAllocate(bounds, tracer_vars) + + call this%InitHistory(bounds) + + call this%InitCold(bounds) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds, tracer_vars) + ! + ! !DESCRIPTION: + ! Initialize module data structure + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(wateratm2lnd_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + type(water_tracer_container_type), intent(inout) :: tracer_vars + ! + ! !LOCAL VARIABLES: + real(r8) :: ival = 0.0_r8 ! initial value + !------------------------------------------------------------------------ + + call AllocateVar1d(var = this%forc_q_not_downscaled_grc, name = 'forc_q_not_downscaled_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_GRIDCELL, & + ival=ival) + call AllocateVar1d(var = this%forc_rain_not_downscaled_grc, name = 'forc_rain_not_downscaled_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_GRIDCELL, & + ival=ival) + call AllocateVar1d(var = this%forc_snow_not_downscaled_grc, name = 'forc_snow_not_downscaled_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_GRIDCELL, & + ival=ival) + call AllocateVar1d(var = this%forc_q_downscaled_col, name = 'forc_q_downscaled_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + ival=ival) + call AllocateVar1d(var = this%forc_flood_grc, name = 'forc_flood_grc', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_GRIDCELL, & + ival=ival) + call AllocateVar1d(var = this%forc_rain_downscaled_col, name = 'forc_rain_downscaled_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + ival=ival) + call AllocateVar1d(var = this%forc_snow_downscaled_col, name = 'forc_snow_downscaled_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN, & + ival=ival) + call AllocateVar1d(var = this%rain_to_snow_conversion_col, name = 'rain_to_snow_conversion_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + call AllocateVar1d(var = this%snow_to_rain_conversion_col, name = 'snow_to_rain_conversion_col', & + container = tracer_vars, & + bounds = bounds, subgrid_level = BOUNDS_SUBGRID_COLUMN) + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize history vars + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use histFileMod , only : hist_addfld1d + ! + ! !ARGUMENTS: + class(wateratm2lnd_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begc, endc + integer :: begg, endg + !------------------------------------------------------------------------ + + begc = bounds%begc; endc= bounds%endc + begg = bounds%begg; endg= bounds%endg + + + this%forc_rain_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname=this%info%fname('RAIN_FROM_ATM'), units='mm/s', & + avgflag='A', long_name=this%info%lname('atmospheric rain received from atmosphere (pre-repartitioning)'), & + ptr_lnd=this%forc_rain_not_downscaled_grc) + + this%forc_snow_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname=this%info%fname('SNOW_FROM_ATM'), units='mm/s', & + avgflag='A', long_name=this%info%lname('atmospheric snow received from atmosphere (pre-repartitioning)'), & + ptr_lnd=this%forc_snow_not_downscaled_grc) + + this%forc_q_downscaled_col(begc:endc) = spval + call hist_addfld1d (fname=this%info%fname('QBOT'), units='kg/kg', & + avgflag='A', long_name=this%info%lname('atmospheric specific humidity (downscaled to columns in glacier regions)'), & + ptr_col=this%forc_q_downscaled_col) + ! Rename of QBOT for Urban intercomparison project + call hist_addfld1d (fname=this%info%fname('Qair'), units='kg/kg', & + avgflag='A', long_name=this%info%lname('atmospheric specific humidity (downscaled to columns in glacier regions)'), & + ptr_col=this%forc_q_downscaled_col, default='inactive') + + this%forc_flood_grc(begg:endg) = spval + call hist_addfld1d (fname=this%info%fname('QFLOOD'), units='mm/s', & + avgflag='A', long_name=this%info%lname('runoff from river flooding'), & + ptr_lnd=this%forc_flood_grc) + + this%forc_rain_downscaled_col(begc:endc) = spval + call hist_addfld1d (fname=this%info%fname('RAIN'), units='mm/s', & + avgflag='A', long_name=this%info%lname('atmospheric rain, after rain/snow repartitioning based on temperature'), & + ptr_col=this%forc_rain_downscaled_col) + call hist_addfld1d (fname=this%info%fname('Rainf'), units='mm/s', & + avgflag='A', long_name=this%info%lname('atmospheric rain, after rain/snow repartitioning based on temperature'), & + ptr_col=this%forc_rain_downscaled_col, default='inactive') + + call hist_addfld1d (fname=this%info%fname('RAIN_ICE'), units='mm/s', & + avgflag='A', & + long_name=this%info%lname('atmospheric rain, after rain/snow repartitioning based on temperature (ice landunits only)'), & + ptr_col=this%forc_rain_downscaled_col, l2g_scale_type='ice', & + default='inactive') + + this%forc_snow_downscaled_col(begc:endc) = spval + call hist_addfld1d (fname=this%info%fname('SNOW'), units='mm/s', & + avgflag='A', long_name=this%info%lname('atmospheric snow, after rain/snow repartitioning based on temperature'), & + ptr_col=this%forc_snow_downscaled_col) + + call hist_addfld1d (fname=this%info%fname('SNOW_ICE'), units='mm/s', & + avgflag='A', & + long_name=this%info%lname('atmospheric snow, after rain/snow repartitioning based on temperature (ice landunits only)'), & + ptr_col=this%forc_snow_downscaled_col, l2g_scale_type='ice', & + default='inactive') + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize cold start conditions + ! + ! !ARGUMENTS: + class(wateratm2lnd_type), intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + + ! Nothing to do for now + + end subroutine InitCold + + !------------------------------------------------------------------------ + pure function IsCommunicatedWithCoupler(this) result(coupled) + ! + ! !DESCRIPTION: + ! Returns true if this tracer is received from the coupler. Returns false if this + ! tracer is just used internally in CTSM, and should be set to some fixed ratio times + ! the bulk water. + ! + ! !ARGUMENTS: + logical :: coupled ! function result + class(wateratm2lnd_type), intent(in) :: this + !----------------------------------------------------------------------- + + coupled = this%info%is_communicated_with_coupler() + + end function IsCommunicatedWithCoupler + + + !----------------------------------------------------------------------- + subroutine SetNondownscaledTracers(this, bounds, bulk) + ! + ! !DESCRIPTION: + ! Set tracer values for the non-downscaled atm2lnd water quantities from the bulk quantities + ! + ! This should only be called for tracers that are not communicated with the coupler + ! (i.e., for which this%IsCommunicatedWithCoupler() is false). Note that the tracer + ! values are set to a fixed ratio times the bulk (because we don't have any other + ! information to go on for these fields). + ! + ! !ARGUMENTS: + class(wateratm2lnd_type), intent(inout) :: this + type(bounds_type), intent(in) :: bounds + class(wateratm2lnd_type), intent(in) :: bulk + ! + ! !LOCAL VARIABLES: + real(r8) :: ratio + + character(len=*), parameter :: subname = 'SetNondownscaledTracers' + !----------------------------------------------------------------------- + + associate( & + begg => bounds%begg, & + endg => bounds%endg & + ) + + ratio = this%info%get_ratio() + + call CalcTracerFromBulkFixedRatio( & + bulk = bulk%forc_q_not_downscaled_grc(begg:endg), & + ratio = ratio, & + tracer = this%forc_q_not_downscaled_grc(begg:endg)) + + call CalcTracerFromBulkFixedRatio( & + bulk = bulk%forc_rain_not_downscaled_grc(begg:endg), & + ratio = ratio, & + tracer = this%forc_rain_not_downscaled_grc(begg:endg)) + + call CalcTracerFromBulkFixedRatio( & + bulk = bulk%forc_snow_not_downscaled_grc(begg:endg), & + ratio = ratio, & + tracer = this%forc_snow_not_downscaled_grc(begg:endg)) + + call CalcTracerFromBulkFixedRatio( & + bulk = bulk%forc_flood_grc(begg:endg), & + ratio = ratio, & + tracer = this%forc_flood_grc(begg:endg)) + + end associate + + end subroutine SetNondownscaledTracers + + !----------------------------------------------------------------------- + subroutine SetDownscaledTracers(this, bounds, num_allc, filter_allc, & + bulk) + ! + ! !DESCRIPTION: + ! Set tracer values for the downscaled atm2lnd water quantities from the bulk quantities + ! + ! !ARGUMENTS: + class(wateratm2lnd_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_allc ! number of column points in filter_allc + integer , intent(in) :: filter_allc(:) ! column filter for all points + class(wateratm2lnd_type) , intent(in) :: bulk + ! + ! !LOCAL VARIABLES: + integer :: fc, c, g + + character(len=*), parameter :: subname = 'SetDownscaledTracers' + !----------------------------------------------------------------------- + + associate( & + begg => bounds%begg, & + endg => bounds%endg, & + begc => bounds%begc, & + endc => bounds%endc & + ) + + call SetOneDownscaledTracer( & + bulk_not_downscaled = bulk%forc_q_not_downscaled_grc(begg:endg), & + tracer_not_downscaled = this%forc_q_not_downscaled_grc(begg:endg), & + bulk_downscaled = bulk%forc_q_downscaled_col(begc:endc), & + tracer_downscaled = this%forc_q_downscaled_col(begc:endc)) + + call SetOneDownscaledTracer( & + bulk_not_downscaled = bulk%forc_rain_not_downscaled_grc(begg:endg), & + tracer_not_downscaled = this%forc_rain_not_downscaled_grc(begg:endg), & + bulk_downscaled = bulk%rain_to_snow_conversion_col(begc:endc), & + tracer_downscaled = this%rain_to_snow_conversion_col(begc:endc)) + + call SetOneDownscaledTracer( & + bulk_not_downscaled = bulk%forc_snow_not_downscaled_grc(begg:endg), & + tracer_not_downscaled = this%forc_snow_not_downscaled_grc(begg:endg), & + bulk_downscaled = bulk%snow_to_rain_conversion_col(begc:endc), & + tracer_downscaled = this%snow_to_rain_conversion_col(begc:endc)) + + do fc = 1, num_allc + c = filter_allc(fc) + g = col%gridcell(c) + this%forc_rain_downscaled_col(c) = AdjustPrecipTracer( & + not_downscaled = this%forc_rain_not_downscaled_grc(g), & + addition = this%snow_to_rain_conversion_col(c), & + subtraction = this%rain_to_snow_conversion_col(c)) + this%forc_snow_downscaled_col(c) = AdjustPrecipTracer( & + not_downscaled = this%forc_snow_not_downscaled_grc(g), & + addition = this%rain_to_snow_conversion_col(c), & + subtraction = this%snow_to_rain_conversion_col(c)) + end do + + end associate + + contains + subroutine SetOneDownscaledTracer(bulk_not_downscaled, tracer_not_downscaled, & + bulk_downscaled, tracer_downscaled) + real(r8), intent(in) :: bulk_not_downscaled( bounds%begg: ) + real(r8), intent(in) :: tracer_not_downscaled( bounds%begg: ) + real(r8), intent(in) :: bulk_downscaled( bounds%begc: ) + real(r8), intent(inout) :: tracer_downscaled( bounds%begc: ) + + integer :: fc, c, g + real(r8) :: bulk_not_downscaled_col(bounds%begc:bounds%endc) + real(r8) :: tracer_not_downscaled_col(bounds%begc:bounds%endc) + + SHR_ASSERT_ALL_FL((ubound(bulk_not_downscaled) == [bounds%endg]), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(tracer_not_downscaled) == [bounds%endg]), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(bulk_downscaled) == [bounds%endc]), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(tracer_downscaled) == [bounds%endc]), sourcefile, __LINE__) + + associate( & + begc => bounds%begc, & + endc => bounds%endc & + ) + + do fc = 1, num_allc + c = filter_allc(fc) + g = col%gridcell(c) + ! Note that this copying of bulk_not_downscaled to bulk_not_downscaled_col will + ! be repeated for every tracer. At some point we might want to optimize this so + ! that it's just done once and shared for all tracers (probably by doing this + ! copy outside of the loop over tracers that calls SetDownscaledTracers). + bulk_not_downscaled_col(c) = bulk_not_downscaled(g) + tracer_not_downscaled_col(c) = tracer_not_downscaled(g) + end do + + call CalcTracerFromBulk( & + lb = begc, & + num_pts = num_allc, & + filter_pts = filter_allc, & + bulk_source = bulk_not_downscaled_col(begc:endc), & + bulk_val = bulk_downscaled(begc:endc), & + tracer_source = tracer_not_downscaled_col(begc:endc), & + tracer_val = tracer_downscaled(begc:endc)) + + end associate + + end subroutine SetOneDownscaledTracer + + pure function AdjustPrecipTracer(not_downscaled, addition, subtraction) result(downscaled) + real(r8) :: downscaled + real(r8), intent(in) :: not_downscaled + real(r8), intent(in) :: addition + real(r8), intent(in) :: subtraction + + real(r8), parameter :: tolerance = 1.e-13_r8 + + downscaled = not_downscaled + addition - subtraction + if (not_downscaled /= 0._r8) then + if (abs(downscaled / not_downscaled) < tolerance) then + ! Roundoff correction: If it seems that the downscaled quantity is supposed + ! to go to exactly 0, then make sure it is indeed exactly 0 rather than + ! roundoff-level different from 0. + downscaled = 0._r8 + end if + end if + end function AdjustPrecipTracer + + end subroutine SetDownscaledTracers + + !----------------------------------------------------------------------- + subroutine Clean(this) + ! + ! !DESCRIPTION: + ! Deallocate memory associated with this instance + ! + ! !ARGUMENTS: + class(wateratm2lnd_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Clean' + !----------------------------------------------------------------------- + + deallocate(this%forc_q_not_downscaled_grc) + deallocate(this%forc_rain_not_downscaled_grc) + deallocate(this%forc_snow_not_downscaled_grc) + deallocate(this%forc_q_downscaled_col) + deallocate(this%forc_flood_grc) + deallocate(this%forc_rain_downscaled_col) + deallocate(this%forc_snow_downscaled_col) + deallocate(this%rain_to_snow_conversion_col) + deallocate(this%snow_to_rain_conversion_col) + + end subroutine Clean + +end module Wateratm2lndType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/abortutils.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/abortutils.F90 new file mode 100644 index 000000000..eb276ca04 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/atm2lndType.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/atm2lndType.F90 new file mode 100644 index 000000000..a2d09ca85 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/atm2lndType.F90 @@ -0,0 +1,1030 @@ +module atm2lndType + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Handle atm2lnd, lnd2atm mapping + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : numrad, ndst, nlevgrnd !ndst = number of dust bins. + use clm_varcon , only : rair, grav, cpair, hfus, tfrz, spval + use clm_varctl , only : iulog, use_c13, use_cn, use_lch4, use_cndv, use_fates, use_luna + use decompMod , only : bounds_type + use abortutils , only : endrun + use PatchType , only : patch + ! + ! !PUBLIC TYPES: + implicit none + private + save + ! + ! !PUBLIC DATA TYPES: + + type, public :: atm2lnd_params_type + ! true => repartition rain/snow from atm based on temperature + logical :: repartition_rain_snow + + ! true => downscale longwave radiation + logical :: glcmec_downscale_longwave + + ! Surface temperature lapse rate (K m-1) + real(r8) :: lapse_rate + + ! longwave radiation lapse rate (W m-2 m-1) + real(r8) :: lapse_rate_longwave + + ! Relative limit for how much longwave downscaling can be done (unitless) + ! The pre-normalized, downscaled longwave is restricted to be in the range + ! [lwrad*(1-longwave_downscaling_limit), lwrad*(1+longwave_downscaling_limit)] + real(r8) :: longwave_downscaling_limit + + ! Rain-snow ramp for glacier landunits + ! frac_rain = (temp - all_snow_t) * frac_rain_slope + ! (all_snow_t is in K) + real(r8) :: precip_repartition_glc_all_snow_t + real(r8) :: precip_repartition_glc_frac_rain_slope + + ! Rain-snow ramp for non-glacier landunits + ! frac_rain = (temp - all_snow_t) * frac_rain_slope + ! (all_snow_t is in K) + real(r8) :: precip_repartition_nonglc_all_snow_t + real(r8) :: precip_repartition_nonglc_frac_rain_slope + end type atm2lnd_params_type + + !---------------------------------------------------- + ! atmosphere -> land variables structure + ! + ! NOTE: + ! IF there are forcing variables that are downscaled - then the + ! non-downscaled versions SHOULD NOT be used in the code. Currently + ! the non-downscaled versions are only used n a handful of places in + ! the code (and needs to be used in lnd_import_export and the + ! downscaling routines), but in general should NOT be used in new + ! code. Instead use the datatype variables that have a _col suffix + ! which gives the downscaled versions of these fields. + !---------------------------------------------------- + type, public :: atm2lnd_type + type(atm2lnd_params_type) :: params + + ! 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 + procedure, public :: InitForTesting ! version of Init meant for unit testing + procedure, private :: ReadNamelist + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, public :: InitAccBuffer + procedure, public :: InitAccVars + procedure, public :: UpdateAccVars + procedure, public :: Restart + procedure, public :: Clean + + end type atm2lnd_type + + interface atm2lnd_params_type + module procedure atm2lnd_params_constructor + end interface atm2lnd_params_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !---------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + function atm2lnd_params_constructor(repartition_rain_snow, glcmec_downscale_longwave, & + lapse_rate, lapse_rate_longwave, longwave_downscaling_limit, & + precip_repartition_glc_all_snow_t, precip_repartition_glc_all_rain_t, & + precip_repartition_nonglc_all_snow_t, precip_repartition_nonglc_all_rain_t) & + result(params) + ! + ! !DESCRIPTION: + ! Creates a new instance of atm2lnd_params_type + ! + ! !USES: + ! + ! !ARGUMENTS: + type(atm2lnd_params_type) :: params ! function result + logical, intent(in) :: repartition_rain_snow + logical, intent(in) :: glcmec_downscale_longwave + + ! Surface temperature lapse rate (K m-1) + real(r8), intent(in) :: lapse_rate + + ! Longwave radiation lapse rate (W m-2 m-1) + ! Must be present if glcmec_downscale_longwave is true; ignored otherwise + real(r8), intent(in), optional :: lapse_rate_longwave + + ! Relative limit for how much longwave downscaling can be done (unitless) + ! Must be present if glcmec_downscale_longwave is true; ignored otherwise + real(r8), intent(in), optional :: longwave_downscaling_limit + + ! End-points of the rain-snow ramp for glacier landunits (degrees C) + ! Must be present if repartition_rain_snow is true; ignored otherwise + real(r8), intent(in), optional :: precip_repartition_glc_all_snow_t + real(r8), intent(in), optional :: precip_repartition_glc_all_rain_t + + ! End-points of the rain-snow ramp for non-glacier landunits (degrees C) + ! Must be present if repartition_rain_snow is true; ignored otherwise + real(r8), intent(in), optional :: precip_repartition_nonglc_all_snow_t + real(r8), intent(in), optional :: precip_repartition_nonglc_all_rain_t + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'atm2lnd_params_constructor' + !----------------------------------------------------------------------- + + params%repartition_rain_snow = repartition_rain_snow + params%glcmec_downscale_longwave = glcmec_downscale_longwave + + params%lapse_rate = lapse_rate + + if (glcmec_downscale_longwave) then + if (.not. present(lapse_rate_longwave)) then + call endrun(subname // & + ' ERROR: For glcmec_downscale_longwave true, lapse_rate_longwave must be provided') + end if + if (.not. present(longwave_downscaling_limit)) then + call endrun(subname // & + ' ERROR: For glcmec_downscale_longwave true, longwave_downscaling_limit must be provided') + end if + + if (longwave_downscaling_limit < 0._r8 .or. & + longwave_downscaling_limit > 1._r8) then + call endrun(subname // & + ' ERROR: longwave_downscaling_limit must be between 0 and 1') + end if + + params%lapse_rate_longwave = lapse_rate_longwave + params%longwave_downscaling_limit = longwave_downscaling_limit + else + params%lapse_rate_longwave = nan + params%longwave_downscaling_limit = nan + end if + + if (repartition_rain_snow) then + + ! Make sure all of the repartitioning-related parameters are present + + if (.not. present(precip_repartition_glc_all_snow_t)) then + call endrun(subname // & + ' ERROR: For repartition_rain_snow true, precip_repartition_glc_all_snow_t must be provided') + end if + if (.not. present(precip_repartition_glc_all_rain_t)) then + call endrun(subname // & + ' ERROR: For repartition_rain_snow true, precip_repartition_glc_all_rain_t must be provided') + end if + if (.not. present(precip_repartition_nonglc_all_snow_t)) then + call endrun(subname // & + ' ERROR: For repartition_rain_snow true, precip_repartition_nonglc_all_snow_t must be provided') + end if + if (.not. present(precip_repartition_nonglc_all_rain_t)) then + call endrun(subname // & + ' ERROR: For repartition_rain_snow true, precip_repartition_nonglc_all_rain_t must be provided') + end if + + ! Do some other error checking + + if (precip_repartition_glc_all_rain_t <= precip_repartition_glc_all_snow_t) then + call endrun(subname // & + ' ERROR: Must have precip_repartition_glc_all_snow_t < precip_repartition_glc_all_rain_t') + end if + + if (precip_repartition_nonglc_all_rain_t <= precip_repartition_nonglc_all_snow_t) then + call endrun(subname // & + ' ERROR: Must have precip_repartition_nonglc_all_snow_t < precip_repartition_nonglc_all_rain_t') + end if + + ! Convert to the form of the parameters we want for the main code + + call compute_ramp_params( & + all_snow_t_c = precip_repartition_glc_all_snow_t, & + all_rain_t_c = precip_repartition_glc_all_rain_t, & + all_snow_t_k = params%precip_repartition_glc_all_snow_t, & + frac_rain_slope = params%precip_repartition_glc_frac_rain_slope) + + call compute_ramp_params( & + all_snow_t_c = precip_repartition_nonglc_all_snow_t, & + all_rain_t_c = precip_repartition_nonglc_all_rain_t, & + all_snow_t_k = params%precip_repartition_nonglc_all_snow_t, & + frac_rain_slope = params%precip_repartition_nonglc_frac_rain_slope) + + else ! .not. repartition_rain_snow + params%precip_repartition_glc_all_snow_t = nan + params%precip_repartition_glc_frac_rain_slope = nan + params%precip_repartition_nonglc_all_snow_t = nan + params%precip_repartition_nonglc_frac_rain_slope = nan + end if + + contains + subroutine compute_ramp_params(all_snow_t_c, all_rain_t_c, & + all_snow_t_k, frac_rain_slope) + real(r8), intent(in) :: all_snow_t_c ! Temperature at which precip falls entirely as rain (deg C) + real(r8), intent(in) :: all_rain_t_c ! Temperature at which precip falls entirely as snow (deg C) + real(r8), intent(out) :: all_snow_t_k ! Temperature at which precip falls entirely as snow (K) + real(r8), intent(out) :: frac_rain_slope ! Slope of the frac_rain vs. T relationship + + frac_rain_slope = 1._r8 / (all_rain_t_c - all_snow_t_c) + all_snow_t_k = all_snow_t_c + tfrz + end subroutine compute_ramp_params + + end function atm2lnd_params_constructor + + + !------------------------------------------------------------------------ + subroutine Init(this, bounds, NLFilename) + + class(atm2lnd_type) :: this + type(bounds_type), intent(in) :: bounds + character(len=*), intent(in) :: NLFilename ! namelist filename + + call this%InitAllocate(bounds) + call this%ReadNamelist(NLFilename) + call this%InitHistory(bounds) + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitForTesting(this, bounds, params) + ! + ! !DESCRIPTION: + ! Does initialization needed for unit testing. Allows caller to prescribe parameter + ! values (bypassing the namelist read) + ! + ! !USES: + ! + ! !ARGUMENTS: + class(atm2lnd_type) :: this + type(bounds_type), intent(in) :: bounds + + ! If params isn't provided, we use default values + type(atm2lnd_params_type), intent(in), optional :: params + ! + ! !LOCAL VARIABLES: + type(atm2lnd_params_type) :: l_params + + character(len=*), parameter :: subname = 'InitForTesting' + !----------------------------------------------------------------------- + + if (present(params)) then + l_params = params + else + ! Use arbitrary values + l_params = atm2lnd_params_type( & + repartition_rain_snow = .false., & + glcmec_downscale_longwave = .false., & + lapse_rate = 0.01_r8) + end if + + call this%InitAllocate(bounds) + this%params = l_params + + end subroutine InitForTesting + + + !----------------------------------------------------------------------- + subroutine ReadNamelist(this, NLFilename) + ! + ! !DESCRIPTION: + ! Read the atm2lnd 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 + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + class(atm2lnd_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + + ! temporary variables corresponding to the components of atm2lnd_params_type + logical :: repartition_rain_snow + logical :: glcmec_downscale_longwave + real(r8) :: lapse_rate + real(r8) :: lapse_rate_longwave + real(r8) :: longwave_downscaling_limit + real(r8) :: precip_repartition_glc_all_snow_t + real(r8) :: precip_repartition_glc_all_rain_t + real(r8) :: precip_repartition_nonglc_all_snow_t + real(r8) :: precip_repartition_nonglc_all_rain_t + + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + character(len=*), parameter :: nmlname = 'atm2lnd_inparm' + + character(len=*), parameter :: subname = 'ReadNamelist' + !----------------------------------------------------------------------- + + namelist /atm2lnd_inparm/ repartition_rain_snow, glcmec_downscale_longwave, & + lapse_rate, lapse_rate_longwave, longwave_downscaling_limit, & + precip_repartition_glc_all_snow_t, precip_repartition_glc_all_rain_t, & + precip_repartition_nonglc_all_snow_t, precip_repartition_nonglc_all_rain_t + + ! Initialize namelist variables to defaults + repartition_rain_snow = .false. + glcmec_downscale_longwave = .false. + lapse_rate = nan + lapse_rate_longwave = nan + longwave_downscaling_limit = nan + precip_repartition_glc_all_snow_t = nan + precip_repartition_glc_all_rain_t = nan + precip_repartition_nonglc_all_snow_t = nan + precip_repartition_nonglc_all_rain_t = nan + + if (masterproc) then + unitn = getavu() + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=atm2lnd_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(repartition_rain_snow, mpicom) + call shr_mpi_bcast(glcmec_downscale_longwave, mpicom) + call shr_mpi_bcast(lapse_rate, mpicom) + call shr_mpi_bcast(lapse_rate_longwave, mpicom) + call shr_mpi_bcast(longwave_downscaling_limit, mpicom) + call shr_mpi_bcast(precip_repartition_glc_all_snow_t, mpicom) + call shr_mpi_bcast(precip_repartition_glc_all_rain_t, mpicom) + call shr_mpi_bcast(precip_repartition_nonglc_all_snow_t, mpicom) + call shr_mpi_bcast(precip_repartition_nonglc_all_rain_t, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + ! Write settings one-by-one rather than with a nml write because some settings may + ! be NaN if certain options are turned off. + write(iulog,*) 'repartition_rain_snow = ', repartition_rain_snow + write(iulog,*) 'glcmec_downscale_longwave = ', glcmec_downscale_longwave + write(iulog,*) 'lapse_rate = ', lapse_rate + if (glcmec_downscale_longwave) then + write(iulog,*) 'lapse_rate_longwave = ', lapse_rate_longwave + write(iulog,*) 'longwave_downscaling_limit = ', longwave_downscaling_limit + end if + if (repartition_rain_snow) then + write(iulog,*) 'precip_repartition_glc_all_snow_t = ', precip_repartition_glc_all_snow_t + write(iulog,*) 'precip_repartition_glc_all_rain_t = ', precip_repartition_glc_all_rain_t + write(iulog,*) 'precip_repartition_nonglc_all_snow_t = ', precip_repartition_nonglc_all_snow_t + write(iulog,*) 'precip_repartition_nonglc_all_rain_t = ', precip_repartition_nonglc_all_rain_t + end if + write(iulog,*) ' ' + end if + + this%params = atm2lnd_params_type( & + repartition_rain_snow = repartition_rain_snow, & + glcmec_downscale_longwave = glcmec_downscale_longwave, & + lapse_rate = lapse_rate, & + lapse_rate_longwave = lapse_rate_longwave, & + longwave_downscaling_limit = longwave_downscaling_limit, & + precip_repartition_glc_all_snow_t = precip_repartition_glc_all_snow_t, & + precip_repartition_glc_all_rain_t = precip_repartition_glc_all_rain_t, & + precip_repartition_nonglc_all_snow_t = precip_repartition_nonglc_all_snow_t, & + precip_repartition_nonglc_all_rain_t = precip_repartition_nonglc_all_rain_t) + + end subroutine ReadNamelist + + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize atm2lnd derived type + ! + ! !ARGUMENTS: + class(atm2lnd_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + 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 + endif + + ! 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 (:) = spval ! TODO - initialize this elsewhere + + end subroutine InitAllocate + + !------------------------------------------------------------------------ + subroutine InitHistory(this, bounds) + ! + ! !USES: + use histFileMod, only : hist_addfld1d + ! + ! !ARGUMENTS: + class(atm2lnd_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + 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 + + this%forc_wind_grc(begg:endg) = spval + call hist_addfld1d (fname='WIND', units='m/s', & + avgflag='A', long_name='atmospheric wind velocity magnitude', & + ptr_lnd=this%forc_wind_grc) + ! Rename of WIND for Urban intercomparision project + call hist_addfld1d (fname='Wind', units='m/s', & + avgflag='A', long_name='atmospheric wind velocity magnitude', & + ptr_gcell=this%forc_wind_grc, default = 'inactive') + + this%forc_hgt_grc(begg:endg) = spval + call hist_addfld1d (fname='ZBOT', units='m', & + avgflag='A', long_name='atmospheric reference height', & + ptr_lnd=this%forc_hgt_grc) + + this%forc_topo_grc(begg:endg) = spval + call hist_addfld1d (fname='ATM_TOPO', units='m', & + avgflag='A', long_name='atmospheric surface height', & + ptr_lnd=this%forc_topo_grc) + + this%forc_solar_grc(begg:endg) = spval + call hist_addfld1d (fname='FSDS', units='W/m^2', & + avgflag='A', long_name='atmospheric incident solar radiation', & + ptr_lnd=this%forc_solar_grc) + + this%forc_pco2_grc(begg:endg) = spval + call hist_addfld1d (fname='PCO2', units='Pa', & + avgflag='A', long_name='atmospheric partial pressure of CO2', & + ptr_lnd=this%forc_pco2_grc) + + this%forc_solar_grc(begg:endg) = spval + call hist_addfld1d (fname='SWdown', units='W/m^2', & + avgflag='A', long_name='atmospheric incident solar radiation', & + ptr_gcell=this%forc_solar_grc, default='inactive') + + if (use_lch4) then + this%forc_pch4_grc(begg:endg) = spval + call hist_addfld1d (fname='PCH4', units='Pa', & + avgflag='A', long_name='atmospheric partial pressure of CH4', & + ptr_lnd=this%forc_pch4_grc) + end if + + this%forc_t_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname='Tair_from_atm', units='K', & + avgflag='A', long_name='atmospheric air temperature received from atmosphere (pre-downscaling)', & + ptr_gcell=this%forc_t_not_downscaled_grc, default='inactive') + + this%forc_t_downscaled_col(begc:endc) = spval + call hist_addfld1d (fname='TBOT', units='K', & + avgflag='A', long_name='atmospheric air temperature (downscaled to columns in glacier regions)', & + ptr_col=this%forc_t_downscaled_col) + call hist_addfld1d (fname='Tair', units='K', & + avgflag='A', long_name='atmospheric air temperature (downscaled to columns in glacier regions)', & + ptr_col=this%forc_t_downscaled_col, default='inactive') + + this%forc_pbot_downscaled_col(begc:endc) = spval + call hist_addfld1d (fname='PBOT', units='Pa', & + avgflag='A', long_name='atmospheric pressure at surface (downscaled to columns in glacier regions)', & + ptr_col=this%forc_pbot_downscaled_col) + call hist_addfld1d (fname='PSurf', units='Pa', & + avgflag='A', long_name='atmospheric pressure at surface (downscaled to columns in glacier regions)', & + ptr_col=this%forc_pbot_downscaled_col, default='inactive') + + this%forc_lwrad_downscaled_col(begc:endc) = spval + call hist_addfld1d (fname='FLDS', units='W/m^2', & + avgflag='A', long_name='atmospheric longwave radiation (downscaled to columns in glacier regions)', & + ptr_col=this%forc_lwrad_downscaled_col) + call hist_addfld1d (fname='LWdown', units='W/m^2', & + avgflag='A', long_name='atmospheric longwave radiation (downscaled to columns in glacier regions)', & + ptr_col=this%forc_lwrad_downscaled_col, default='inactive') + + call hist_addfld1d (fname='FLDS_ICE', units='W/m^2', & + avgflag='A', & + long_name='atmospheric longwave radiation (downscaled to columns in glacier regions) (ice landunits only)', & + ptr_col=this%forc_lwrad_downscaled_col, l2g_scale_type='ice', & + default='inactive') + + this%forc_th_downscaled_col(begc:endc) = spval + call hist_addfld1d (fname='THBOT', units='K', & + avgflag='A', long_name='atmospheric air potential temperature (downscaled to columns in glacier regions)', & + ptr_col=this%forc_th_downscaled_col) + + + ! Time averaged quantities + this%fsi24_patch(begp:endp) = spval + call hist_addfld1d (fname='FSI24', units='K', & + avgflag='A', long_name='indirect radiation (last 24hrs)', & + ptr_patch=this%fsi24_patch, default='inactive') + + this%fsi240_patch(begp:endp) = spval + call hist_addfld1d (fname='FSI240', units='K', & + avgflag='A', long_name='indirect radiation (last 240hrs)', & + ptr_patch=this%fsi240_patch, default='inactive') + + this%fsd24_patch(begp:endp) = spval + call hist_addfld1d (fname='FSD24', units='K', & + avgflag='A', long_name='direct radiation (last 24hrs)', & + ptr_patch=this%fsd24_patch, default='inactive') + + this%fsd240_patch(begp:endp) = spval + call hist_addfld1d (fname='FSD240', units='K', & + avgflag='A', long_name='direct radiation (last 240hrs)', & + ptr_patch=this%fsd240_patch, default='inactive') + + if (use_cndv) then + call hist_addfld1d (fname='TDA', units='K', & + avgflag='A', long_name='daily average 2-m temperature', & + ptr_patch=this%t_mo_patch) + end if + + if(use_luna)then + this%forc_pco2_240_patch = spval + call hist_addfld1d (fname='PCO2_240', units='Pa', & + avgflag='A', long_name='10 day running mean of CO2 pressure', & + ptr_patch=this%forc_pco2_240_patch, default='inactive') + this%forc_po2_240_patch = spval + call hist_addfld1d (fname='PO2_240', units='Pa', & + avgflag='A', long_name='10 day running mean of O2 pressure', & + ptr_patch=this%forc_po2_240_patch, default='inactive') + this%forc_pbot240_downscaled_patch = spval + call hist_addfld1d (fname='PBOT_240', units='Pa', & + avgflag='A', long_name='10 day running mean of air pressure', & + ptr_patch=this%forc_pbot240_downscaled_patch, default='inactive') + endif + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitAccBuffer (this, bounds) + ! + ! !DESCRIPTION: + ! Initialize accumulation buffer for all required module accumulated fields + ! This routine set defaults values that are then overwritten by the + ! restart file for restart or branch runs + ! + ! !USES + use clm_varcon , only : spval + use accumulMod , only : init_accum_field + ! + ! !ARGUMENTS: + class(atm2lnd_type) :: this + type(bounds_type), intent(in) :: bounds + !--------------------------------------------------------------------- + + this%fsd24_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='FSD24', units='W/m2', & + desc='24hr average of direct solar radiation', accum_type='runmean', accum_period=-1, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + this%fsd240_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='FSD240', units='W/m2', & + desc='240hr average of direct solar radiation', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + this%fsi24_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='FSI24', units='W/m2', & + desc='24hr average of diffuse solar radiation', accum_type='runmean', accum_period=-1, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + this%fsi240_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='FSI240', units='W/m2', & + desc='240hr average of diffuse solar radiation', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=0._r8) + + if ( use_fates ) then + call init_accum_field (name='WIND24', units='m', & + desc='24hr average of wind', accum_type='runmean', accum_period=-1, & + subgrid_type='pft', numlev=1, init_value=0._r8) + end if + + if(use_luna) then + this%forc_po2_240_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='po2_240', units='Pa', & + desc='10-day running mean of parial O2 pressure', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=21223._r8) + + this%forc_pco2_240_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='pco2_240', units='Pa', & + desc='10-day running mean of parial CO2 pressure', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=28._r8) + + this%forc_pbot240_downscaled_patch(bounds%begp:bounds%endp) = spval + call init_accum_field (name='pbot240', units='Pa', & + desc='10-day running mean of air pressure', accum_type='runmean', accum_period=-10, & + subgrid_type='pft', numlev=1, init_value=101325._r8) + + endif + + end subroutine InitAccBuffer + + !----------------------------------------------------------------------- + subroutine InitAccVars(this, bounds) + ! + ! !DESCRIPTION: + ! Initialize module variables that are associated with + ! time accumulated fields. This routine is called for both an initial run + ! and a restart run (and must therefore must be called after the restart file + ! is read in and the accumulation buffer is obtained) + ! + ! !USES + use accumulMod , only : extract_accum_field + use clm_time_manager , only : get_nstep + ! + ! !ARGUMENTS: + class(atm2lnd_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + integer :: nstep + integer :: ier + real(r8), pointer :: rbufslp(:) ! temporary + real(r8), pointer :: rbufslc(:) ! temporary + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)' in ' + call endrun(msg="InitAccVars allocation error for rbufslp"//& + errMsg(sourcefile, __LINE__)) + endif + ! Allocate needed dynamic memory for single level col field + allocate(rbufslc(begc:endc), stat=ier) + if (ier/=0) then + write(iulog,*)' in ' + call endrun(msg="InitAccVars allocation error for rbufslc"//& + errMsg(sourcefile, __LINE__)) + endif + + ! Determine time step + nstep = get_nstep() + + call extract_accum_field ('FSD24', rbufslp, nstep) + this%fsd24_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('FSD240', rbufslp, nstep) + this%fsd240_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('FSI24', rbufslp, nstep) + this%fsi24_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('FSI240', rbufslp, nstep) + this%fsi240_patch(begp:endp) = rbufslp(begp:endp) + + if (use_cndv) then + call extract_accum_field ('TDA', rbufslp, nstep) + this%t_mo_patch(begp:endp) = rbufslp(begp:endp) + end if + + if (use_fates) then + call extract_accum_field ('WIND24', rbufslp, nstep) + this%wind24_patch(begp:endp) = rbufslp(begp:endp) + end if + + if(use_luna) then + call extract_accum_field ('po2_240', rbufslp, nstep) + this%forc_po2_240_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('pco2_240', rbufslp, nstep) + this%forc_pco2_240_patch(begp:endp) = rbufslp(begp:endp) + + call extract_accum_field ('pbot240', rbufslp, nstep) + this%forc_pbot240_downscaled_patch(begp:endp) = rbufslp(begp:endp) + + endif + + deallocate(rbufslp) + deallocate(rbufslc) + + end subroutine InitAccVars + + !----------------------------------------------------------------------- + subroutine UpdateAccVars (this, bounds) + ! + ! USES + use clm_time_manager, only : get_nstep + use accumulMod , only : update_accum_field, extract_accum_field + ! + ! !ARGUMENTS: + class(atm2lnd_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: g,c,p ! indices + integer :: dtime ! timestep size [seconds] + integer :: nstep ! timestep number + integer :: ier ! error status + integer :: begp, endp + integer :: begc, endc + real(r8), pointer :: rbufslp(:) ! temporary single level - patch level + real(r8), pointer :: rbufslc(:) ! temporary single level - column level + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + nstep = get_nstep() + + ! Allocate needed dynamic memory for single level patch field + allocate(rbufslp(begp:endp), stat=ier) + if (ier/=0) then + write(iulog,*)'UpdateAccVars allocation error for rbufslp' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + ! Allocate needed dynamic memory for single level col field + allocate(rbufslc(begc:endc), stat=ier) + if (ier/=0) then + write(iulog,*)'UpdateAccVars allocation error for rbufslc' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + ! Accumulate and extract forc_solad24 & forc_solad240 + do p = begp,endp + g = patch%gridcell(p) + rbufslp(p) = this%forc_solad_grc(g,1) + end do + call update_accum_field ('FSD240', rbufslp , nstep) + call extract_accum_field ('FSD240', this%fsd240_patch , nstep) + call update_accum_field ('FSD24' , rbufslp , nstep) + call extract_accum_field ('FSD24' , this%fsd24_patch , nstep) + + ! Accumulate and extract forc_solai24 & forc_solai240 + do p = begp,endp + g = patch%gridcell(p) + rbufslp(p) = this%forc_solai_grc(g,1) + end do + call update_accum_field ('FSI24' , rbufslp , nstep) + call extract_accum_field ('FSI24' , this%fsi24_patch , nstep) + call update_accum_field ('FSI240', rbufslp , nstep) + call extract_accum_field ('FSI240', this%fsi240_patch , nstep) + + + if (use_cndv) then + + ! Accumulate and extract TDA (accumulates TBOT as 30-day average) and + ! also determines t_mo_min + + do p = begp,endp + c = patch%column(p) + rbufslp(p) = this%forc_t_downscaled_col(c) + end do + call update_accum_field ('TDA', rbufslp, nstep) + call extract_accum_field ('TDA', rbufslp, nstep) + do p = begp,endp + this%t_mo_patch(p) = rbufslp(p) + this%t_mo_min_patch(p) = min(this%t_mo_min_patch(p), rbufslp(p)) + end do + + end if + + if (use_fates) then + do p = bounds%begp,bounds%endp + g = patch%gridcell(p) + rbufslp(p) = this%forc_wind_grc(g) + end do + call update_accum_field ('WIND24', rbufslp, nstep) + call extract_accum_field ('WIND24', this%wind24_patch, nstep) + + end if + + if(use_luna) then + do p = bounds%begp,bounds%endp + g = patch%gridcell(p) + rbufslp(p) = this%forc_pco2_grc(g) + enddo + call update_accum_field ('pco2_240', rbufslp, nstep) + call extract_accum_field ('pco2_240', this%forc_pco2_240_patch, nstep) + + do p = bounds%begp,bounds%endp + g = patch%gridcell(p) + rbufslp(p) = this%forc_po2_grc(g) + enddo + call update_accum_field ('po2_240', rbufslp, nstep) + call extract_accum_field ('po2_240', this%forc_po2_240_patch, nstep) + + do p = bounds%begp,bounds%endp + c = patch%column(p) + rbufslp(p) = this%forc_pbot_downscaled_col(c) + enddo + call update_accum_field ('pbot240', rbufslp, nstep) + call extract_accum_field ('pbot240', this%forc_pbot240_downscaled_patch, nstep) + + endif + + deallocate(rbufslp) + deallocate(rbufslc) + + end subroutine UpdateAccVars + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !USES: + use restUtilMod + use ncdio_pio + ! + ! !ARGUMENTS: + class(atm2lnd_type) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid + character(len=*) , intent(in) :: flag + ! + ! !LOCAL VARIABLES: + logical :: readvar + !------------------------------------------------------------------------ + + if (use_cndv) then + call restartvar(ncid=ncid, flag=flag, varname='T_MO_MIN', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%t_mo_min_patch) + end if + + if(use_luna)then + call restartvar(ncid=ncid, flag=flag, varname='pco2_240', xtype=ncd_double, & + dim1name='pft', long_name='10-day mean CO2 partial pressure', units='Pa', & + interpinic_flag='interp', readvar=readvar, data=this%forc_pco2_240_patch ) + call restartvar(ncid=ncid, flag=flag, varname='po2_240', xtype=ncd_double, & + dim1name='pft', long_name='10-day mean O2 partial pressure', units='Pa', & + interpinic_flag='interp', readvar=readvar, data=this%forc_po2_240_patch ) + call restartvar(ncid=ncid, flag=flag, varname='pbot240', xtype=ncd_double, & + dim1name='pft', long_name='10 day mean atmospheric pressure(Pa)', units='Pa', & + interpinic_flag='interp', readvar=readvar, data=this%forc_pbot240_downscaled_patch ) + endif + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine Clean(this) + ! + ! !DESCRIPTION: + ! Finalize this instance + ! + ! !USES: + ! + ! !ARGUMENTS: + class(atm2lnd_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Clean' + !----------------------------------------------------------------------- + + ! atm->lnd + deallocate(this%forc_u_grc) + deallocate(this%forc_v_grc) + deallocate(this%forc_wind_grc) + deallocate(this%forc_hgt_grc) + deallocate(this%forc_topo_grc) + deallocate(this%forc_hgt_u_grc) + deallocate(this%forc_hgt_t_grc) + deallocate(this%forc_hgt_q_grc) + deallocate(this%forc_vp_grc) + deallocate(this%forc_pco2_grc) + deallocate(this%forc_solad_grc) + deallocate(this%forc_solai_grc) + deallocate(this%forc_solar_grc) + deallocate(this%forc_ndep_grc) + deallocate(this%forc_pc13o2_grc) + deallocate(this%forc_po2_grc) + deallocate(this%forc_aer_grc) + deallocate(this%forc_pch4_grc) + + ! atm->lnd not downscaled + deallocate(this%forc_t_not_downscaled_grc) + deallocate(this%forc_pbot_not_downscaled_grc) + deallocate(this%forc_th_not_downscaled_grc) + deallocate(this%forc_rho_not_downscaled_grc) + deallocate(this%forc_lwrad_not_downscaled_grc) + + ! atm->lnd downscaled + deallocate(this%forc_t_downscaled_col) + deallocate(this%forc_pbot_downscaled_col) + deallocate(this%forc_th_downscaled_col) + deallocate(this%forc_rho_downscaled_col) + deallocate(this%forc_lwrad_downscaled_col) + + deallocate(this%fsd24_patch) + deallocate(this%fsd240_patch) + deallocate(this%fsi24_patch) + deallocate(this%fsi240_patch) + if (use_fates) then + deallocate(this%wind24_patch) + end if + deallocate(this%t_mo_patch) + deallocate(this%t_mo_min_patch) + + end subroutine Clean + + +end module atm2lndType diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ch4Mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ch4Mod.F90 new file mode 100644 index 000000000..0fe591b9e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ch4Mod.F90 @@ -0,0 +1,4247 @@ +module ch4Mod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module holding routines to calculate methane fluxes + ! The driver averages up to gridcell, weighting by finundated, and checks for balance errors. + ! Sources, sinks, "competition" for CH4 & O2, & transport are resolved in ch4_tran. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=), shr_infnan_isnan + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varpar , only : nlevsoi, ngases, nlevsno, nlevdecomp + use clm_varcon , only : denh2o, denice, tfrz, grav, spval, rgas, grlnd + use clm_varcon , only : catomw, s_con, d_con_w, d_con_g, c_h_inv, kh_theta, kh_tbase + use landunit_varcon , only : istsoil, istcrop, istdlak + use clm_time_manager , only : get_step_size_real, get_nstep + use clm_varctl , only : iulog, use_cn, use_nitrif_denitrif, use_lch4 + use abortutils , only : endrun + use decompMod , only : bounds_type + use atm2lndType , only : atm2lnd_type + use CanopyStateType , only : canopystate_type + use CNSharedParamsMod , only : CNParamsShareInst + use SoilBiogeochemCarbonFluxType , only : soilbiogeochem_carbonflux_type + use SoilBiogeochemNitrogenFluxType , only : soilbiogeochem_nitrogenflux_type + use EnergyFluxType , only : energyflux_type + use LakeStateType , only : lakestate_type + use lnd2atmType , only : lnd2atm_type + use SoilHydrologyType , only : soilhydrology_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use WaterFluxBulkType , only : waterfluxbulk_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 + use ch4FInundatedStreamType , only : ch4finundatedstream_type + ! + implicit none + private + + ! Non-tunable constants + real(r8) :: rgasm ! J/mol.K; rgas / 1000; will be set below + real(r8), parameter :: rgasLatm = 0.0821_r8 ! L.atm/mol.K + + ! !PUBLIC MEMBER FUNCTIONS: + public :: readParams + public :: ch4_init_column_balance_check + public :: ch4_init_gridcell_balance_check + public :: ch4 + + ! !PRIVATE MEMBER FUNCTIONS: + private :: ch4_prod + private :: ch4_oxid + private :: ch4_aere + private :: ch4_ebul + private :: ch4_tran + private :: ch4_annualupdate + private :: ch4_totcolch4 + private :: get_jwt + + type, private :: params_type + ! ch4 production constants + real(r8) :: q10ch4 ! additional Q10 for methane production ABOVE the soil decomposition temperature relationship + real(r8) :: q10ch4base ! temperature at which the effective f_ch4 actually equals the constant f_ch4 + real(r8) :: f_ch4 ! ratio of CH4 production to total C mineralization + real(r8) :: rootlitfrac ! Fraction of soil organic matter associated with roots + real(r8) :: cnscalefactor ! scale factor on CN decomposition for assigning methane flux + real(r8) :: redoxlag ! Number of days to lag in the calculation of finundated_lag + real(r8) :: lake_decomp_fact ! Base decomposition rate (1/s) at 25C + real(r8) :: redoxlag_vertical ! time lag (days) to inhibit production for newly unsaturated layers + real(r8) :: pHmax ! maximum pH for methane production(= 9._r8) + real(r8) :: pHmin ! minimum pH for methane production(= 2.2_r8) + real(r8) :: oxinhib ! inhibition of methane production by oxygen (m^3/mol) + + ! ch4 oxidation constants + real(r8) :: vmax_ch4_oxid ! oxidation rate constant (= 45.e-6_r8 * 1000._r8 / 3600._r8) [mol/m3-w/s]; + real(r8) :: k_m ! Michaelis-Menten oxidation rate constant for CH4 concentration + real(r8) :: q10_ch4oxid ! Q10 oxidation constant + real(r8) :: smp_crit ! Critical soil moisture potential + real(r8) :: k_m_o2 ! Michaelis-Menten oxidation rate constant for O2 concentration + real(r8) :: k_m_unsat ! Michaelis-Menten oxidation rate constant for CH4 concentration + real(r8) :: vmax_oxid_unsat ! (= 45.e-6_r8 * 1000._r8 / 3600._r8 / 10._r8) [mol/m3-w/s] + + ! ch4 aerenchyma constants + real(r8) :: aereoxid ! fraction of methane flux entering aerenchyma rhizosphere that will be + + ! oxidized rather than emitted + real(r8) :: scale_factor_aere ! scale factor on the aerenchyma area for sensitivity tests + real(r8) :: nongrassporosratio ! Ratio of root porosity in non-grass to grass, used for aerenchyma transport + real(r8) :: unsat_aere_ratio ! Ratio to multiply upland vegetation aerenchyma porosity by compared to inundated systems (= 0.05_r8 / 0.3_r8) + real(r8) :: porosmin ! minimum aerenchyma porosity (unitless)(= 0.05_r8) + + ! ch4 ebbulition constants + real(r8) :: vgc_max ! ratio of saturation pressure triggering ebullition + + ! ch4 transport constants + real(r8) :: satpow ! exponent on watsat for saturated soil solute diffusion + real(r8) :: scale_factor_gasdiff ! For sensitivity tests; convection would allow this to be > 1 + real(r8) :: scale_factor_liqdiff ! For sensitivity tests; convection would allow this to be > 1 + real(r8) :: capthick ! min thickness before assuming h2osfc is impermeable (mm) (= 100._r8) + + ! additional constants + real(r8) :: f_sat ! volumetric soil water defining top of water table or where production is allowed (=0.95) + real(r8) :: qflxlagd ! days to lag qflx_surf_lag in the tropics (days) ( = 30._r8) + real(r8) :: highlatfact ! multiple of qflxlagd for high latitudes (= 2._r8) + real(r8) :: q10lakebase ! (K) base temperature for lake CH4 production (= 298._r8) + real(r8) :: atmch4 ! Atmospheric CH4 mixing ratio to prescribe if not provided by the atmospheric model (= 1.7e-6_r8) (mol/mol) + real(r8) :: rob ! ratio of root length to vertical depth ("root obliquity") (= 3._r8) + end type params_type + type(params_type), private :: params_inst + + 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 + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + procedure, public :: Restart + procedure, public :: DynamicColumnAdjustments ! adjust state variables when column areas change + + end type ch4_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init( this, bounds, cellorg_col, fsurdat, NLFilename ) + + class(ch4_type) :: this + type(bounds_type), intent(in) :: bounds + real(r8) , intent(in) :: cellorg_col (bounds%begc:, 1:) + character(len=*) , intent(in) :: fsurdat ! surface data file name + character(len=*), intent(in) :: NLFilename ! Namelist filename + + call this%InitAllocate (bounds) + if (use_lch4) then + call this%InitHistory (bounds) + call this%InitCold (bounds, cellorg_col, fsurdat) + call this%ch4findstream%Init( bounds, NLFilename ) + end if + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! + ! !DESCRIPTION: + ! Allocate module variables and data structures + ! + ! !USES: + use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) + use clm_varpar , only: nlevgrnd + ! + ! !ARGUMENTS: + class(ch4_type) :: 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%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 InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! !USES: + use clm_varpar , only : nlevgrnd, nlevdecomp + use clm_varctl , only : hist_wrtch4diag + use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + use ch4varcon , only : allowlakeprod + ! + ! !ARGUMENTS: + class(ch4_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + character(8) :: vr_suffix + character(10) :: active + integer :: begc,endc + integer :: begg,endg + real(r8), pointer :: data2dptr(:,:) ! temp. pointers for slicing larger arrays + !--------------------------------------------------------------------- + + begc = bounds%begc; endc = bounds%endc + begg = bounds%begg; endg = bounds%endg + + if (nlevdecomp > 1) then + vr_suffix = "_vr" + else + vr_suffix = "" + endif + + if (hist_wrtch4diag) then + active = "active" + else + active = "inactive" + end if + + this%finundated_col(begc:endc) = spval + ! Using l2g_scale_type='veg' to exclude values in special landunits, which can change + ! from dynamic column adjustments (also want to exclude lakes here, for which + ! finundated is implicitly 1). + call hist_addfld1d (fname='FINUNDATED', units='unitless', & + avgflag='A', long_name='fractional inundated area of vegetated columns', & + ptr_col=this%finundated_col, l2g_scale_type='veg') + + this%finundated_lag_col(begc:endc) = spval + ! Using l2g_scale_type='veg' to exclude values in special landunits, which can change + ! from dynamic column adjustments (also want to exclude lakes here, for which + ! finundated is implicitly 1). + call hist_addfld1d (fname='FINUNDATED_LAG', units='unitless', & + avgflag='A', long_name='time-lagged inundated fraction of vegetated columns', & + ptr_col=this%finundated_lag_col, l2g_scale_type='veg', default='inactive') + + this%ch4_surf_diff_sat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_SURF_DIFF_SAT', units='mol/m2/s', & + avgflag='A', long_name='diffusive surface CH4 flux for inundated / lake area; (+ to atm)', & + ptr_col=this%ch4_surf_diff_sat_col) + + this%ch4_surf_diff_unsat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_SURF_DIFF_UNSAT', units='mol/m2/s', & + avgflag='A', long_name='diffusive surface CH4 flux for non-inundated area; (+ to atm)', & + ptr_col=this%ch4_surf_diff_unsat_col) + + this%ch4_ebul_total_sat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_EBUL_TOTAL_SAT', units='mol/m2/s', & + avgflag='A', long_name='ebullition surface CH4 flux; (+ to atm)', & + ptr_col=this%ch4_ebul_total_sat_col, default='inactive') + + this%ch4_ebul_total_unsat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_EBUL_TOTAL_UNSAT', units='mol/m2/s', & + avgflag='A', long_name='ebullition surface CH4 flux; (+ to atm)', & + ptr_col=this%ch4_ebul_total_unsat_col, default='inactive') + + this%ch4_surf_ebul_sat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_SURF_EBUL_SAT', units='mol/m2/s', & + avgflag='A', long_name='ebullition surface CH4 flux for inundated / lake area; (+ to atm)', & + ptr_col=this%ch4_surf_ebul_sat_col) + + this%ch4_surf_ebul_unsat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_SURF_EBUL_UNSAT', units='mol/m2/s', & + avgflag='A', long_name='ebullition surface CH4 flux for non-inundated area; (+ to atm)', & + ptr_col=this%ch4_surf_ebul_unsat_col) + + this%ch4_surf_aere_sat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_SURF_AERE_SAT', units='mol/m2/s', & + avgflag='A', long_name='aerenchyma surface CH4 flux for inundated area; (+ to atm)', & + ptr_col=this%ch4_surf_aere_sat_col) + + this%ch4_surf_aere_unsat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_SURF_AERE_UNSAT', units='mol/m2/s', & + avgflag='A', long_name='aerenchyma surface CH4 flux for non-inundated area; (+ to atm)', & + ptr_col=this%ch4_surf_aere_unsat_col) + + this%totcolch4_col(begc:endc) = spval + ! Unlike other ch4 diagnostic fields, TOTCOLCH4 includes all landunits. Values will + ! typically be 0 for non-lake special landunits, but may be non-zero due to the state + ! adjustments from dynamic landunits. + call hist_addfld1d (fname='TOTCOLCH4', units='gC/m2', & + avgflag='A', & + long_name='total belowground CH4 (0 for non-lake special landunits in the absence of dynamic landunits)', & + ptr_col=this%totcolch4_col) + + this%conc_ch4_sat_col(begc:endc,1:nlevgrnd) = spval + ! Using l2g_scale_type='veg_plus_lake' to exclude mass in non-lake special landunits, + ! which can arise from dynamic column adjustments + call hist_addfld2d (fname='CONC_CH4_SAT', units='mol/m3', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil Concentration for inundated / lake area', & + ptr_col=this%conc_ch4_sat_col, l2g_scale_type='veg_plus_lake', default='inactive') + + this%conc_ch4_unsat_col(begc:endc,1:nlevgrnd) = spval + ! Using l2g_scale_type='veg' to exclude mass in special landunits, which can arise + ! from dynamic column adjustments. (We also exclude lakes here, because they don't + ! have any unsaturated area.) + call hist_addfld2d (fname='CONC_CH4_UNSAT', units='mol/m3', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil Concentration for non-inundated area', & + ptr_col=this%conc_ch4_unsat_col, l2g_scale_type='veg', default='inactive') + + if (hist_wrtch4diag) then + this%ch4_prod_depth_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_PROD_DEPTH_SAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil production for inundated / lake area', & + ptr_col=this%ch4_prod_depth_sat_col) + end if + + if (hist_wrtch4diag) then + this%ch4_prod_depth_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_PROD_DEPTH_UNSAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil production for non-inundated area', & + ptr_col=this%ch4_prod_depth_unsat_col) + end if + + if (hist_wrtch4diag) then + this%ch4_oxid_depth_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_OXID_DEPTH_SAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil oxidation for inundated / lake area', & + ptr_col=this%ch4_oxid_depth_sat_col) + end if + + if (hist_wrtch4diag) then + this%ch4_oxid_depth_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_OXID_DEPTH_UNSAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil oxidation for non-inundated area', & + ptr_col=this%ch4_oxid_depth_unsat_col) + end if + + if (hist_wrtch4diag) then + this%ch4_aere_depth_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_AERE_DEPTH_SAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil aerenchyma loss for inundated / lake area '// & + ' (including transpiration flux if activated)', & + ptr_col=this%ch4_aere_depth_sat_col) + end if + + if (hist_wrtch4diag) then + this%ch4_aere_depth_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_AERE_DEPTH_UNSAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil aerenchyma loss for non-inundated area '// & + ' (including transpiration flux if activated)', & + ptr_col=this%ch4_aere_depth_unsat_col) + end if + + if (hist_wrtch4diag) then + this%o2_aere_depth_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='O2_AERE_DEPTH_SAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='O2 aerenchyma diffusion into soil for inundated / lake area', & + ptr_col=this%o2_aere_depth_sat_col) + end if + + if (hist_wrtch4diag) then + this%o2_aere_depth_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='O2_AERE_DEPTH_UNSAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='O2 aerenchyma diffusion into soil for non-inundated area', & + ptr_col=this%o2_aere_depth_unsat_col) + end if + + if (hist_wrtch4diag) then + call hist_addfld2d (fname='O2_DECOMP_DEPTH_SAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='O2 consumption from HR and AR for inundated / lake area', & + ptr_col=this%o2_decomp_depth_sat_col) + end if + + this%o2_decomp_depth_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='O2_DECOMP_DEPTH_UNSAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='O2 consumption from HR and AR for non-inundated area', & + ptr_col=this%o2_decomp_depth_unsat_col, default=active) + + if (hist_wrtch4diag) then + this%ch4_tran_depth_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_TRAN_DEPTH_SAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil loss from transpiration for inundated / lake area', & + ptr_col=this%ch4_tran_depth_sat_col) + end if + + if (hist_wrtch4diag) then + this%ch4_tran_depth_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_TRAN_DEPTH_UNSAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil loss from transpiration for non-inundated area', & + ptr_col=this%ch4_tran_depth_unsat_col) + end if + + if (hist_wrtch4diag) then + this%ch4_ebul_depth_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_EBUL_DEPTH_SAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil ebullition for inundated / lake area', & + ptr_col=this%ch4_ebul_depth_sat_col) + end if + + if (hist_wrtch4diag) then + this%ch4_ebul_depth_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_EBUL_DEPTH_UNSAT', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 soil ebullition for non-inundated area', & + ptr_col=this%ch4_ebul_depth_unsat_col) + end if + + if (hist_wrtch4diag) then + this%o2stress_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='O2STRESS_SAT', units='unitless', type2d='levgrnd', & + avgflag='A', long_name='Ratio of oxygen available to demanded for non-inundated area', & + ptr_col=this%o2stress_sat_col) + end if + + if (hist_wrtch4diag) then + this%o2stress_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='O2STRESS_UNSAT', units='unitless', type2d='levgrnd', & + avgflag='A', long_name='Ratio of oxygen available to demanded for inundated / lake area', & + ptr_col=this%o2stress_unsat_col) + end if + + if (hist_wrtch4diag) then + this%ch4stress_unsat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4STRESS_UNSAT', units='unitless', type2d='levgrnd', & + avgflag='A', long_name='Ratio of methane available to total potential sink for inundated / lake area', & + ptr_col=this%ch4stress_unsat_col) + end if + + if (hist_wrtch4diag) then + this%ch4stress_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4STRESS_SAT', units='unitless', type2d='levgrnd', & + avgflag='A', long_name='Ratio of methane available to total potential sink for non-inundated area', & + ptr_col=this%ch4stress_sat_col) + end if + + if (hist_wrtch4diag .and. allowlakeprod) then + this%ch4_prod_depth_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_PROD_DEPTH_LAKE', units='mol/m3/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 production in each soil layer, lake col. only', & + ptr_col=this%ch4_prod_depth_sat_col) + end if + + if (hist_wrtch4diag .and. allowlakeprod) then + this%conc_ch4_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CONC_CH4_LAKE', units='mol/m3', type2d='levgrnd', & + avgflag='A', long_name='CH4 Concentration each soil layer, lake col. only', & + ptr_col=this%conc_ch4_sat_col) + end if + + if (hist_wrtch4diag .and. allowlakeprod) then + this%conc_o2_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CONC_O2_LAKE', units='mol/m3', type2d='levgrnd', & + avgflag='A', long_name='O2 Concentration each soil layer, lake col. only', & + ptr_col=this%conc_o2_sat_col) + end if + + if (hist_wrtch4diag .and. allowlakeprod) then + this%ch4_surf_diff_sat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_SURF_DIFF_LAKE', units='mol/m2/s', & + avgflag='A', long_name='diffusive surface CH4 flux, lake col. only (+ to atm)', & + ptr_col=this%ch4_surf_diff_sat_col) + end if + + if (hist_wrtch4diag .and. allowlakeprod) then + this%ch4_surf_ebul_sat_col(begc:endc) = spval + call hist_addfld1d (fname='CH4_SURF_EBUL_LAKE', units='mol/m2/s', & + avgflag='A', long_name='ebullition surface CH4 flux, lake col. only (+ to atm)', & + ptr_col=this%ch4_surf_ebul_sat_col) + end if + + if (hist_wrtch4diag .and. allowlakeprod) then + this%ch4_oxid_depth_sat_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='CH4_OXID_DEPTH_LAKE', units='mol/m2/s', type2d='levgrnd', & + avgflag='A', long_name='CH4 oxidation in each soil layer, lake col. only', & + ptr_col=this%ch4_oxid_depth_sat_col) + end if + + if (hist_wrtch4diag) then + this%layer_sat_lag_col(begc:endc,1:nlevgrnd) = spval + ! Using l2g_scale_type='veg' to exclude mass in special landunits, which can arise + ! from dynamic column adjustments. (We also exclude lakes here, because they don't + ! have any unsaturated area.) + call hist_addfld2d (fname='LAYER_SAT_LAG', units='unitless', type2d='levgrnd', & + avgflag='A', long_name='lagged saturation status of layer in unsat. zone', & + ptr_col=this%layer_sat_lag_col, l2g_scale_type='veg') + end if + + if (hist_wrtch4diag) then + this%annavg_finrw_col(begc:endc) = spval + call hist_addfld1d (fname='ANNAVG_FINRW', units='unitless', & + avgflag='A', long_name='annual average respiration-weighted FINUNDATED', & + ptr_col=this%annavg_finrw_col) + end if + + if (hist_wrtch4diag) then + this%sif_col(begc:endc) = spval + call hist_addfld1d (fname='SIF', units='unitless', & + avgflag='A', long_name='seasonal inundation factor calculated for sat. CH4 prod. (non-lake)', & + ptr_col=this%sif_col) + end if + + this%conc_o2_sat_col(begc:endc,1:nlevgrnd) = spval + ! Using l2g_scale_type='veg_plus_lake' to exclude mass in non-lake special landunits, + ! which can arise from dynamic column adjustments + data2dptr => this%conc_o2_sat_col(:,1:nlevsoi) + call hist_addfld2d (fname='CONC_O2_SAT', units='mol/m3', type2d='levsoi', & + avgflag='A', long_name='O2 soil Concentration for inundated / lake area', & + ptr_col=data2dptr, l2g_scale_type='veg_plus_lake') + + this%conc_o2_unsat_col(begc:endc,1:nlevgrnd) = spval + ! Using l2g_scale_type='veg' to exclude mass in special landunits, which can arise + ! from dynamic column adjustments. (We also exclude lakes here, because they don't + ! have any unsaturated area.) + data2dptr => this%conc_o2_unsat_col(:,1:nlevsoi) + call hist_addfld2d (fname='CONC_O2_UNSAT', units='mol/m3', type2d='levsoi', & + avgflag='A', long_name='O2 soil Concentration for non-inundated area', & + ptr_col=data2dptr, l2g_scale_type='veg') + + this%ch4co2f_grc(begg:endg) = spval + call hist_addfld1d (fname='FCH4TOCO2', units='gC/m2/s', & + avgflag='A', long_name='Gridcell oxidation of CH4 to CO2', & + ptr_lnd=this%ch4co2f_grc) + + this%ch4prodg_grc(begg:endg) = spval + call hist_addfld1d (fname='CH4PROD', units='gC/m2/s', & + avgflag='A', long_name='Gridcell total production of CH4', & + ptr_lnd=this%ch4prodg_grc) + + this%ch4_dfsat_flux_col(begc:endc) = spval + call hist_addfld1d (fname='FCH4_DFSAT', units='kgC/m2/s', & + avgflag='A', & + long_name='CH4 additional flux due to changing fsat, natural vegetated and crop landunits only', & + ptr_col=this%ch4_dfsat_flux_col) + + this%zwt_ch4_unsat_col(begc:endc) = spval + call hist_addfld1d (fname='ZWT_CH4_UNSAT', units='m', & + avgflag='A', long_name='depth of water table for methane production used in non-inundated area', & + ptr_col=this%zwt_ch4_unsat_col) + + this%qflx_surf_lag_col(begc:endc) = spval + call hist_addfld1d (fname='QOVER_LAG', units='mm/s', & + avgflag='A', long_name='time-lagged surface runoff for soil columns', & + ptr_col=this%qflx_surf_lag_col, default='inactive') + + if (allowlakeprod) then + this%lake_soilc_col(begc:endc,1:nlevgrnd) = spval + call hist_addfld2d (fname='LAKE_SOILC', units='gC/m3', type2d='levgrnd', & + avgflag='A', long_name='Soil carbon under lakes', & + ptr_col=this%lake_soilc_col) + end if + + this%grnd_ch4_cond_col(begc:endc) = spval + call hist_addfld1d (fname='WTGQ', units='m/s', & + avgflag='A', long_name='surface tracer conductance', & + ptr_col=this%grnd_ch4_cond_col) + + this%dyn_ch4bal_adjustments_col(begc:endc) = spval + call hist_addfld1d (fname='DYN_COL_ADJUSTMENTS_CH4', units='gC/m^2', & + avgflag='SUM', & + long_name='Adjustments in ch4 due to dynamic column areas; & + &only makes sense at the column level: should not be averaged to gridcell', & + ptr_col=this%dyn_ch4bal_adjustments_col, default='inactive') + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds, cellorg_col, fsurdat) + ! + ! !DESCRIPTION: + ! - Sets cold start values for time varying values. + ! Initializes the following time varying variables: + ! conc_ch4_sat, conc_ch4_unsat, conc_o2_sat, conc_o2_unsat, + ! lake_soilc, o2stress, finunduated + ! - Sets variables for ch4 code that will not be input + ! from restart/inic file. + ! - Sets values for inactive CH4 columns to spval so that they will + ! not be averaged in history file. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varpar , only : nlevsoi, nlevgrnd, nlevdecomp + use landunit_varcon , only : istsoil, istdlak, istcrop + use clm_varctl , only : iulog + use ch4varcon , only : allowlakeprod, usephfact, finundation_mtd + use ch4varcon , only : finundation_mtd_ZWT_inversion + use spmdMod , only : masterproc + use fileutils , only : getfil + use ncdio_pio + ! + ! !ARGUMENTS: + class(ch4_type) :: this + type(bounds_type) , intent(in) :: bounds + real(r8) , intent(in) :: cellorg_col (bounds%begc:, 1:) + character(len=*) , intent(in) :: fsurdat ! surface data file name + ! + ! !LOCAL VARIABLES: + integer :: j ,g, l,c,p ! indices + type(file_desc_t) :: ncid ! netcdf id + real(r8) ,pointer :: pH_in (:) ! read in - pH + character(len=256) :: locfn ! local file name + logical :: readvar ! If read variable from file or not + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(cellorg_col) == (/bounds%endc, nlevsoi/)), sourcefile, __LINE__) + + !---------------------------------------- + ! Initialize time constant variables + !---------------------------------------- + + if (usephfact) allocate(ph_in(bounds%begg:bounds%endg)) + + ! Methane code parameters for finundated + + call getfil( fsurdat, locfn, 0 ) + call ncd_pio_openfile (ncid, trim(locfn), 0) + + ! pH factor for methane model + if (usephfact) then + call ncd_io(ncid=ncid, varname='PH', flag='read', data=ph_in, dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + call endrun(msg=' ERROR: CH4 pH production factor activated in ch4par_in'//& + 'but pH is not on surfdata file'//errMsg(sourcefile, __LINE__)) + end if + end if + call ncd_pio_closefile(ncid) + + if ( usephfact )then + do c = bounds%begc, bounds%endc + g = col%gridcell(c) + + this%pH_col(c) = pH_in(g) + end do + end if + + if (usephfact) deallocate(pH_in) + + !---------------------------------------- + ! Initialize time varying variables + !---------------------------------------- + + if ( masterproc ) write (iulog,*) 'Setting initial data to non-spun up values for CH4 Mod' + + do c = bounds%begc,bounds%endc + + ! To detect first year + this%annavg_somhr_col(c) = spval + this%annavg_finrw_col(c) = spval + + ! To detect file input + this%qflx_surf_lag_col (c) = spval + this%o2stress_sat_col (c,:) = spval + this%o2stress_unsat_col (c,:) = spval + this%ch4stress_sat_col (c,:) = spval + this%ch4stress_unsat_col(c,:) = spval + this%lake_soilc_col (c,:) = spval + + ! The following variables need to be initialized for all columns, for the sake of + ! DynamicColumnAdjustments + ! + ! TODO(wjs, 2016-02-11) Should the initial value of finundated depend on landunit + ! type? I am setting it to 1, because that's the appropriate value for lakes (and + ! probably other landunits, like wetlands and glaciers) - but this may not be + ! appropriate for urban. (The setting here should agree with the setting of + ! finundated_col where it was spval in subroutine Restart.) Note that + ! finundated_col is overwritten for istsoil / istcrop below. + this%finundated_col(c) = 1._r8 + this%finundated_pre_snow_col(c) = 1._r8 + this%finundated_lag_col(c) = 1._r8 + this%layer_sat_lag_col (c,1:nlevsoi) = 1._r8 + this%conc_ch4_sat_col (c,1:nlevsoi) = 0._r8 + this%conc_ch4_unsat_col (c,1:nlevsoi) = 0._r8 + this%conc_o2_sat_col (c,1:nlevsoi) = 0._r8 + this%conc_o2_unsat_col (c,1:nlevsoi) = 0._r8 + + l = col%landunit(c) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop .or. & + lun%itype(l) == istdlak) then + this%annsum_counter_col(c) = 0._r8 + this%tempavg_somhr_col(c) = 0._r8 + this%tempavg_finrw_col(c) = 0._r8 + end if + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + + this%o2stress_sat_col (c,1:nlevsoi) = 1._r8 + this%o2stress_unsat_col (c,1:nlevsoi) = 1._r8 + this%o2_decomp_depth_sat_col(c,1:nlevsoi) = 0._r8 + this%o2_decomp_depth_unsat_col(c,1:nlevsoi) = 0._r8 + + this%qflx_surf_lag_col (c) = 0._r8 + this%finundated_col (c) = 0._r8 + this%finundated_pre_snow_col(c) = 0._r8 + this%finundated_lag_col (c) = 0._r8 + + else if (lun%itype(l) == istdlak) then + + this%lake_soilc_col (c,1:nlevsoi) = 580._r8 * cellorg_col(c,1:nlevsoi) + + end if + + ! Set values for all columns equal below nlevsoi + + this%conc_ch4_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%conc_ch4_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%conc_o2_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%conc_o2_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%lake_soilc_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%o2stress_sat_col (c,nlevsoi+1:nlevgrnd) = 1._r8 + this%o2stress_unsat_col (c,nlevsoi+1:nlevgrnd) = 1._r8 + this%layer_sat_lag_col (c,nlevsoi+1:nlevgrnd) = 1._r8 + this%ch4_prod_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_prod_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_prod_depth_lake_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_oxid_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_oxid_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_oxid_depth_lake_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%o2_oxid_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%o2_oxid_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%o2_decomp_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%o2_decomp_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%o2_aere_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%o2_aere_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%co2_decomp_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%co2_decomp_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%co2_oxid_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%co2_oxid_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_aere_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_aere_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_tran_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_tran_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%co2_aere_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%co2_aere_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_ebul_depth_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4_ebul_depth_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%conc_ch4_lake_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%conc_o2_lake_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4stress_unsat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + this%ch4stress_sat_col (c,nlevsoi+1:nlevgrnd) = 0._r8 + + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + + this%conc_ch4_lake_col (c,:) = spval + this%conc_o2_lake_col (c,:) = spval + this%ch4_surf_diff_lake_col (c) = spval + this%ch4_surf_ebul_lake_col (c) = spval + this%ch4_prod_depth_lake_col (c,:) = spval + this%ch4_oxid_depth_lake_col (c,:) = spval + + else if (lun%itype(l) == istdlak .and. allowlakeprod) then + + this%ch4_prod_depth_unsat_col (c,:) = spval + this%ch4_oxid_depth_unsat_col (c,:) = spval + this%o2_oxid_depth_unsat_col (c,:) = spval + this%o2_decomp_depth_unsat_col (c,:) = spval + this%o2_aere_depth_unsat_col (c,:) = spval + this%co2_decomp_depth_unsat_col (c,:) = spval + this%co2_oxid_depth_unsat_col (c,:) = spval + this%ch4_aere_depth_unsat_col (c,:) = spval + this%ch4_tran_depth_unsat_col (c,:) = spval + this%co2_aere_depth_unsat_col (c,:) = spval + this%ch4_surf_aere_unsat_col (c) = spval + this%ch4_ebul_depth_unsat_col (c,:) = spval + this%ch4_ebul_total_unsat_col (c) = spval + this%ch4_surf_ebul_unsat_col (c) = spval + this%ch4_surf_diff_unsat_col (c) = spval + this%ch4_dfsat_flux_col (c) = spval + this%zwt_ch4_unsat_col (c) = spval + this%sif_col (c) = spval + this%o2stress_unsat_col (c,:) = spval + this%ch4stress_unsat_col (c,:) = spval + + else ! Inactive CH4 columns + + this%ch4_prod_depth_sat_col (c,:) = spval + this%ch4_prod_depth_unsat_col (c,:) = spval + this%ch4_prod_depth_lake_col (c,:) = spval + this%ch4_oxid_depth_sat_col (c,:) = spval + this%ch4_oxid_depth_unsat_col (c,:) = spval + this%ch4_oxid_depth_lake_col (c,:) = spval + this%o2_oxid_depth_sat_col (c,:) = spval + this%o2_oxid_depth_unsat_col (c,:) = spval + this%o2_decomp_depth_sat_col (c,:) = spval + this%o2_decomp_depth_unsat_col (c,:) = spval + this%o2_aere_depth_sat_col (c,:) = spval + this%o2_aere_depth_unsat_col (c,:) = spval + this%co2_decomp_depth_sat_col (c,:) = spval + this%co2_decomp_depth_unsat_col (c,:) = spval + this%co2_oxid_depth_sat_col (c,:) = spval + this%co2_oxid_depth_unsat_col (c,:) = spval + this%ch4_aere_depth_sat_col (c,:) = spval + this%ch4_aere_depth_unsat_col (c,:) = spval + this%ch4_tran_depth_sat_col (c,:) = spval + this%ch4_tran_depth_unsat_col (c,:) = spval + this%co2_aere_depth_sat_col (c,:) = spval + this%co2_aere_depth_unsat_col (c,:) = spval + this%ch4_surf_aere_sat_col (c) = spval + this%ch4_surf_aere_unsat_col (c) = spval + this%ch4_ebul_depth_sat_col (c,:) = spval + this%ch4_ebul_depth_unsat_col (c,:) = spval + this%ch4_ebul_total_sat_col (c) = spval + this%ch4_ebul_total_unsat_col (c) = spval + this%ch4_surf_ebul_sat_col (c) = spval + this%ch4_surf_ebul_unsat_col (c) = spval + this%ch4_surf_ebul_lake_col (c) = spval + this%ch4_surf_diff_sat_col (c) = spval + this%ch4_surf_diff_unsat_col (c) = spval + this%ch4_surf_diff_lake_col (c) = spval + this%ch4_dfsat_flux_col (c) = spval + this%zwt_ch4_unsat_col (c) = spval + this%conc_ch4_lake_col (c,:) = spval + this%conc_o2_lake_col (c,:) = spval + this%sif_col (c) = spval + this%o2stress_unsat_col (c,:) = spval + this%o2stress_sat_col (c,:) = spval + this%ch4stress_unsat_col (c,:) = spval + this%ch4stress_sat_col (c,:) = spval + this%grnd_ch4_cond_col (c) = spval + + ! totcolch4 Set to zero for inactive columns so that this can be used + ! as an appropriate area-weighted gridcell average soil methane content. + this%totcolch4_col (c) = 0._r8 + + end if + end do + + do p = bounds%begp, bounds%endp + l = patch%landunit(p) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop .or. & + lun%itype(l) == istdlak) then + this%tempavg_agnpp_patch(p) = 0._r8 + this%tempavg_bgnpp_patch(p) = 0._r8 + end if + end do + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine Restart( this, bounds, ncid, flag ) + ! + ! !DESCRIPTION: + ! Read/Write biogeophysics information to/from restart file. + ! + ! !USES: + use ncdio_pio , only : ncd_double + use pio , only : file_desc_t + use decompMod , only : bounds_type + use restUtilMod + use filterColMod, only : filter_col_type + ! + ! !ARGUMENTS: + class(ch4_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 :: c, p, j + logical :: readvar ! determine if variable is on initial file + !----------------------------------------------------------------------- + + call restartvar(ncid=ncid, flag=flag, varname='tempavg_agnpp', xtype=ncd_double, & + dim1name='pft',& + long_name='Temp. Average AGNPP',units='gC/m^2/s', & + readvar=readvar, interpinic_flag='interp', data=this%tempavg_agnpp_patch) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-16) The following is needed for backwards + ! compatibility with older restart files, where this variable was nan or spval rather + ! than 0 over inactive points + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%tempavg_agnpp_patch, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='tempavg_bgnpp', xtype=ncd_double, & + dim1name='pft',& + long_name='Temp. Average BGNPP',units='gC/m^2/s', & + readvar=readvar, interpinic_flag='interp', data=this%tempavg_bgnpp_patch) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-16) The following is needed for backwards + ! compatibility with older restart files, where this variable was nan or spval rather + ! than 0 over inactive points + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%tempavg_bgnpp_patch, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='annavg_agnpp', xtype=ncd_double, & + dim1name='pft',& + long_name='Ann. Average AGNPP',units='gC/m^2/s', & + readvar=readvar, interpinic_flag='interp', data=this%annavg_agnpp_patch) + + call restartvar(ncid=ncid, flag=flag, varname='annavg_bgnpp', xtype=ncd_double, & + dim1name='pft',& + long_name='Ann. Average BGNPP',units='gC/m^2/s', & + readvar=readvar, interpinic_flag='interp', data=this%annavg_bgnpp_patch) + + call restartvar(ncid=ncid, flag=flag, varname='CONC_O2_SAT', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='oxygen soil concentration', units='mol/m^3', & + readvar=readvar, interpinic_flag='interp', data=this%conc_o2_sat_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-17) The following is needed for backwards + ! compatibility with restart files generated from older versions of the code, where + ! this variable was initialized to spval rather than 0 for special landunits. + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%conc_o2_sat_col, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='CONC_O2_UNSAT', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='oxygen soil concentration', units='mol/m^3', & + readvar=readvar, interpinic_flag='interp', data=this%conc_o2_unsat_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-17) The following is needed for backwards + ! compatibility with restart files generated from older versions of the code, where + ! this variable was initialized to spval rather than 0 for special landunits. + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%conc_o2_unsat_col, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='O2STRESS_SAT', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='oxygen stress fraction', units='', & + readvar=readvar, interpinic_flag='interp', data=this%o2stress_sat_col) + + call restartvar(ncid=ncid, flag=flag, varname='O2STRESS_UNSAT', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='oxygen stress fraction', units='', & + readvar=readvar, interpinic_flag='interp', data=this%o2stress_unsat_col) + + call restartvar(ncid=ncid, flag=flag, varname='O2_DECOMP_DEPTH_SAT', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='O2 consumption during decomposition', units='mol/m3/s', & + readvar=readvar, interpinic_flag='interp', data=this%o2_decomp_depth_sat_col) + + call restartvar(ncid=ncid, flag=flag, varname='O2_DECOMP_DEPTH_UNSAT', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='O2 consumption during decomposition', units='mol/m3/s', & + readvar=readvar, interpinic_flag='interp', data=this%o2_decomp_depth_unsat_col) + + call restartvar(ncid=ncid, flag=flag, varname='CONC_CH4_SAT', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='methane soil concentration', units='mol/m^3', & + readvar=readvar, interpinic_flag='interp', data=this%conc_ch4_sat_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-02-11) The following is needed for backwards + ! compatibility with restart files generated from older versions of the code, where + ! this variable was initialized to spval rather than 0 for special landunits. + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%conc_ch4_sat_col, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='CONC_CH4_UNSAT', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='methane soil concentration', units='mol/m^3', & + readvar=readvar, interpinic_flag='interp', data=this%conc_ch4_unsat_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-02-11) The following is needed for backwards + ! compatibility with restart files generated from older versions of the code, where + ! this variable was initialized to spval rather than 0 for special landunits. + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%conc_ch4_unsat_col, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='LAYER_SAT_LAG', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true., & + long_name='lagged saturation status of layer in unsat. zone', units='', & + readvar=readvar, interpinic_flag='interp', data=this%layer_sat_lag_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-18) The following is needed for backwards + ! compatibility with restart files generated from older versions of the code, where + ! this variable was initialized to spval rather than 1 for special landunits. + if (flag == 'read' .and. readvar) then + ! The value here (1) should agree with the setting for special landunits in initCold + call set_missing_vals_to_constant(this%layer_sat_lag_col, 1._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='QFLX_SURF_LAG', xtype=ncd_double, & + dim1name='column', & + long_name='time-lagged surface runoff', units='mm/s', & + readvar=readvar, interpinic_flag='interp', data=this%qflx_surf_lag_col) + + call restartvar(ncid=ncid, flag=flag, varname='FINUNDATED_LAG', xtype=ncd_double, & + dim1name='column', & + long_name='time-lagged inundated fraction', units='', & + readvar=readvar, interpinic_flag='interp', data=this%finundated_lag_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-18) The following is needed for backwards + ! compatibility with restart files generated from older versions of the code, where + ! this variable was initialized to spval rather than 1 for special landunits. + if (flag == 'read' .and. readvar) then + ! The value here (1) should agree with the setting for special landunits in initCold + call set_missing_vals_to_constant(this%finundated_lag_col, 1._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='FINUNDATED', xtype=ncd_double, & + dim1name='column', & + long_name='inundated fraction', units='', & + readvar=readvar, interpinic_flag='interp', data=this%finundated_col) + if (flag == 'read' .and. readvar) then + ! Determine whether the methane model was present in the run that generated the + ! restart file based on whether FINUNDATED is present on the restart file. We + ! could use any methane variable, but FINUNDATED is a good choice because this + ! "first time" variable is used in connection with FINUNDATED. + this%ch4_first_time_grc(bounds%begg:bounds%endg) = .false. + + ! BACKWARDS_COMPATIBILITY(wjs, 2016-02-11) The following is needed for backwards + ! compatibility with restart files generated from older versions of the code, where + ! these variables were initialized to spval rather than 1 for special landunits. + ! + ! The value here (1) should agree with the setting for special landunits in initCold + call set_missing_vals_to_constant(this%finundated_col, 1._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='FINUNDATED_PRESNOW', xtype=ncd_double, & + dim1name='column', & + long_name='inundated fraction before snow', units='', & + readvar=readvar, interpinic_flag='interp', data=this%finundated_pre_snow_col) + if (flag == 'read' .and. readvar) then + ! BACKWARDS_COMPATIBILITY(wjs, 2016-02-11) The following is needed for backwards + ! compatibility with restart files generated from older versions of the code, where + ! these variables were initialized to spval rather than 1 for special landunits. + ! + ! The value here (1) should agree with the setting for special landunits in initCold + call set_missing_vals_to_constant(this%finundated_pre_snow_col, 1._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='annavg_somhr', xtype=ncd_double, & + dim1name='column',& + long_name='Annual Average SOMHR',units='gC/m^2/s', & + readvar=readvar, interpinic_flag='interp', data=this%annavg_somhr_col) + + call restartvar(ncid=ncid, flag=flag, varname='annavg_finrw', xtype=ncd_double, & + dim1name='column',& + long_name='Annual Average Respiration-Weighted FINUNDATED',units='', & + readvar=readvar, interpinic_flag='interp', data=this%annavg_finrw_col) + + call restartvar(ncid=ncid, flag=flag, varname='annsum_counter_ch4', xtype=ncd_double, & + dim1name='column',& + long_name='CH4 Ann. Sum Time Counter',units='s', & + readvar=readvar, interpinic_flag='interp', data=this%annsum_counter_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-16) The following is needed for backwards + ! compatibility with older restart files, where this variable was nan or spval rather + ! than 0 over inactive points + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%annsum_counter_col, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='tempavg_somhr', xtype=ncd_double, & + dim1name='column',& + long_name='Temp. Average SOMHR',units='gC/m^2/s', & + readvar=readvar, interpinic_flag='interp', data=this%tempavg_somhr_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-16) The following is needed for backwards + ! compatibility with older restart files, where this variable was nan or spval rather + ! than 0 over inactive points + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%tempavg_somhr_col, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='tempavg_finrw', xtype=ncd_double, & + dim1name='column',& + long_name='Temp. Average Respiration-Weighted FINUNDATED',units='', & + readvar=readvar, interpinic_flag='interp', data=this%tempavg_finrw_col) + ! BACKWARDS_COMPATIBILITY(wjs, 2016-05-16) The following is needed for backwards + ! compatibility with older restart files, where this variable was nan or spval rather + ! than 0 over inactive points + if (flag == 'read' .and. readvar) then + call set_missing_vals_to_constant(this%tempavg_finrw_col, 0._r8) + end if + + call restartvar(ncid=ncid, flag=flag, varname='LAKE_SOILC', xtype=ncd_double, & + dim1name='column', dim2name='levgrnd', switchdim=.true.,& + long_name='lake soil carbon concentration', units='g/m^3', & + readvar=readvar, interpinic_flag='interp', data=this%lake_soilc_col) + + end subroutine Restart + + !----------------------------------------------------------------------- + subroutine DynamicColumnAdjustments(this, bounds, clump_index, column_state_updater) + ! + ! !DESCRIPTION: + ! Adjust state variables when column areas change due to dynamic landuse + ! + ! !USES: + use dynColumnStateUpdaterMod, only : column_state_updater_type + ! + ! !ARGUMENTS: + class(ch4_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 + + type(column_state_updater_type) , intent(in) :: column_state_updater + ! + ! !LOCAL VARIABLES: + real(r8) :: finundated_new_col(bounds%begc:bounds%endc) ! finundated after column adjustments + real(r8) :: f_uninundated_col(bounds%begc:bounds%endc) ! 1 - finundated_col + real(r8) :: f_uninundated_new_col(bounds%begc:bounds%endc) ! f_uninundated after column adjustments + real(r8) :: adjustment_one_level(bounds%begc:bounds%endc) + integer :: j, c + integer :: begc, endc + + character(len=*), parameter :: subname = 'DynamicColumnAdjustments' + !----------------------------------------------------------------------- + + ! BUG(wjs, 2016-02-16, ESCOMP/CTSM#43) Need to do some special handling of finundated for + ! increases in lake area, since lakes are assumed to be 100% inundated. Probably it's + ! most appropriate for this special handling to happen elsewhere - i.e., within this + ! routine, we do the standard adjustments as they are currently done, but then in the + ! "science" code in this module, there is a check of whether a lake has finundated < + ! 1, and if so, variables are adjusted so that it is once again fully inundated. + + ! Note that some of the variables updated here aren't strictly needed for + ! conservation purposes (because they don't represent any mass in the system), but it + ! seems like a good idea to update these anyway so that growing columns will be in a + ! more self-consistent state. + + begc = bounds%begc + endc = bounds%endc + + finundated_new_col(begc:endc) = & + this%finundated_col(begc:endc) + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = finundated_new_col(begc:endc)) + + f_uninundated_col(begc:endc) = & + 1._r8 - this%finundated_col(begc:endc) + f_uninundated_new_col(begc:endc) = & + f_uninundated_col(begc:endc) + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = f_uninundated_new_col(begc:endc)) + + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%finundated_lag_col(begc:endc)) + + this%dyn_ch4bal_adjustments_col(begc:endc) = 0._r8 + + do j = 1, nlevsoi + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%conc_ch4_sat_col(begc:endc, j), & + fractional_area_old = this%finundated_col(begc:endc), & + fractional_area_new = finundated_new_col(begc:endc), & + adjustment = adjustment_one_level(begc:endc)) + do c = bounds%begc, bounds%endc + this%dyn_ch4bal_adjustments_col(c) = & + this%dyn_ch4bal_adjustments_col(c) + & + adjustment_one_level(c) * col%dz(c,j) * catomw + end do + + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%conc_ch4_unsat_col(begc:endc, j), & + fractional_area_old = f_uninundated_col(begc:endc), & + fractional_area_new = f_uninundated_new_col(begc:endc), & + adjustment = adjustment_one_level(begc:endc)) + do c = bounds%begc, bounds%endc + this%dyn_ch4bal_adjustments_col(c) = & + this%dyn_ch4bal_adjustments_col(c) + & + adjustment_one_level(c) * col%dz(c,j) * catomw + end do + + ! layer_sat_lag just applies to the UNinundated portion of the column + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%layer_sat_lag_col(begc:endc, j), & + fractional_area_old = f_uninundated_col(begc:endc), & + fractional_area_new = f_uninundated_new_col(begc:endc)) + + ! We don't bother tracking the adjustment terms for the following o2 state + ! variables, because they're not needed for balance checks and because people are + ! less likely to be interested in viewing those adjustment terms. + + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%conc_o2_sat_col(begc:endc, j), & + fractional_area_old = this%finundated_col(begc:endc), & + fractional_area_new = finundated_new_col(begc:endc)) + + call column_state_updater%update_column_state_no_special_handling( & + bounds = bounds, & + clump_index = clump_index, & + var = this%conc_o2_unsat_col(begc:endc, j), & + fractional_area_old = f_uninundated_col(begc:endc), & + fractional_area_new = f_uninundated_new_col(begc:endc)) + end do + + this%finundated_col(begc:endc) = & + finundated_new_col(begc:endc) + + end subroutine DynamicColumnAdjustments + + + !----------------------------------------------------------------------- + subroutine readParams ( ncid ) + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use ncdio_pio , only : file_desc_t,ncd_io + use ch4varcon , only : use_aereoxid_prog + ! + ! !ARGUMENTS: + implicit none + 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 + !-------------------------------------------------------------------- + + if ( .not. use_aereoxid_prog ) then + tString='aereoxid' + 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%aereoxid=tempr + else + ! value should never be used. + params_inst%aereoxid=nan + endif + + tString='q10ch4' + 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%q10ch4=tempr + + tString='q10ch4base' + 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%q10ch4base=tempr + + tString='f_ch4' + 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%f_ch4=tempr + + tString='rootlitfrac' + 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%rootlitfrac=tempr + + tString='cnscalefactor' + 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%cnscalefactor=tempr + + tString='redoxlag' + 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%redoxlag=tempr + + tString='lake_decomp_fact' + 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%lake_decomp_fact=tempr + + tString='redoxlag_vertical' + 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%redoxlag_vertical=tempr + + tString='pHmax' + 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%pHmax=tempr + + tString='pHmin' + 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%pHmin=tempr + + tString='vmax_ch4_oxid' + 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%vmax_ch4_oxid=45.e-6_r8 * 1000._r8 / 3600._r8 + ! FIX(FIX(SPM,032414),032414) can't be read off of param file. not bfb since it is a divide + !params_inst%vmax_ch4_oxid=tempr + + tString='oxinhib' + 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%oxinhib=tempr + + tString='k_m' + 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_m= 5.e-6_r8 * 1000._r8 + ! FIX(FIX(SPM,032414),032414) can't be read off of param file. not bfb since it is a divide + !params_inst%k_m=tempr + + tString='q10_ch4oxid' + 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%q10_ch4oxid=tempr + + tString='smp_crit' + 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%smp_crit=tempr + + tString='k_m_o2' + 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_m_o2 = 20.e-6_r8 * 1000._r8 + ! FIX(FIX(SPM,032414),032414) can't be read off of param file. not bfb since it is a divide + !params_inst%k_m_o2=tempr + + tString='k_m_unsat' + 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_m_unsat= 5.e-6_r8 * 1000._r8 / 10._r8 + ! FIX(FIX(SPM,032414),032414) can't be read off of param file. not bfb since it is a divide + !params_inst%k_m_unsat=tempr + + tString='vmax_oxid_unsat' + 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%vmax_oxid_unsat = 45.e-6_r8 * 1000._r8 / 3600._r8 / 10._r8 + ! FIX(FIX(SPM,032414),032414) can't be read off of param file. not bfb since it is a divide + !params_inst%vmax_oxid_unsat=tempr + + tString='scale_factor_aere' + 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%scale_factor_aere=tempr + + tString='nongrassporosratio' + 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%nongrassporosratio=tempr + + tString='unsat_aere_ratio' + 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%unsat_aere_ratio= 0.05_r8 / 0.3_r8 + ! FIX(FIX(SPM,032414),032414) can't be read off of param file. not bfb since it is a divide + !params_inst%unsat_aere_ratio=tempr + + tString='porosmin' + 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%porosmin=tempr + + tString='vgc_max' + 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%vgc_max=tempr + + tString='satpow' + 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%satpow=tempr + + tString='scale_factor_gasdiff' + 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%scale_factor_gasdiff=tempr + + tString='scale_factor_liqdiff' + 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%scale_factor_liqdiff=tempr + + tString='f_sat' + 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%f_sat=tempr + + tString='qflxlagd' + 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%qflxlagd=tempr + + tString='highlatfact' + 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%highlatfact=tempr + + tString='q10lakebase' + 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%q10lakebase=tempr + + tString='atmch4' + 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%atmch4=tempr + + tString='rob' + 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%rob=tempr + + tString='capthick' + 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%capthick=tempr + + end subroutine readParams + + !----------------------------------------------------------------------- + subroutine ch4_init_gridcell_balance_check(bounds, num_nolakec, & + filter_nolakec, num_lakec, filter_lakec, ch4_inst) + ! + ! !DESCRIPTION: + ! Calculate beginning gridcell-level ch4 balance for mass conservation + ! check + ! + ! This sets ch4_inst%totcolch4_bef_grc + ! + ! Called before the weight updates done for dynamic landunits and the + ! associated filter updates + ! + ! !USES: + use subgridAveMod, only: c2g + ! + ! !ARGUMENTS: + type(bounds_type), intent(in) :: bounds + integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points + integer , intent(in) :: num_lakec ! number of column lake points in column filter + integer , intent(in) :: filter_lakec(:) ! column filter for lake points + type(ch4_type) , intent(inout) :: ch4_inst + ! + ! !LOCAL VARIABLES: + + integer :: begc, endc, begg, endg + real(r8), allocatable :: totcolch4_bef_col(:) ! col total methane found in soil col, start of timestep (g C / m^2) NB: this variable appears with the same name in ch4_type but the one here is local and for temporary use + character(len=*), parameter :: subname = 'ch4_init_gridcell_balance_check' + !----------------------------------------------------------------------- + + begc = bounds%begc + endc = bounds%endc + begg = bounds%begg + endg = bounds%endg + + allocate(totcolch4_bef_col(begc:endc)) + + ! This is only really needed for soilc and lakec, but we use nolakec rather + ! than just soilc for consistency with the other call to ch4_totcolch4 + ! (which computes ch4_inst%totcolch4 over all columns for diagnostic + ! purposes). + call ch4_totcolch4(bounds, num_nolakec, filter_nolakec, num_lakec, & + filter_lakec, ch4_inst, & + totcolch4_bef_col(begc:endc)) + + call c2g( bounds, & + totcolch4_bef_col(begc:endc), & + ch4_inst%totcolch4_bef_grc(begg:endg), & + c2l_scale_type= 'unity', l2g_scale_type='unity' ) + + deallocate(totcolch4_bef_col) + + end subroutine ch4_init_gridcell_balance_check + + !----------------------------------------------------------------------- + subroutine ch4_init_column_balance_check(bounds, num_nolakec, filter_nolakec, num_lakec, filter_lakec, & + ch4_inst) + ! + ! !DESCRIPTION: + ! Calculate beginning column-level ch4 balance, for mass conservation check + ! + ! This sets ch4_inst%totcolch4_bef_col + ! + ! This should be called after the weight updates due to dynamic landunits, and the + ! associated filter updates - i.e., using the new version of the filters. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points + integer , intent(in) :: num_lakec ! number of column lake points in column filter + integer , intent(in) :: filter_lakec(:) ! column filter for lake points + type(ch4_type) , intent(inout) :: ch4_inst + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'ch4_init_column_balance_check' + !----------------------------------------------------------------------- + + ! This is only really needed for soilc and lakec, but we use nolakec rather than just + ! soilc for consistency with the other call to ch4_totcolch4 (which computes + ! ch4_inst%totcolch4 over all columns for diagnostic purposes). + call ch4_totcolch4(bounds, num_nolakec, filter_nolakec, num_lakec, filter_lakec, & + ch4_inst, ch4_inst%totcolch4_bef_col(bounds%begc:bounds%endc)) + + end subroutine ch4_init_column_balance_check + + + !----------------------------------------------------------------------- + subroutine ch4 (bounds, num_soilc, filter_soilc, num_lakec, filter_lakec, & + num_nolakec, filter_nolakec, num_soilp, filter_soilp, & + atm2lnd_inst, lakestate_inst, canopystate_inst, soilstate_inst, soilhydrology_inst, & + temperature_inst, energyflux_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, waterfluxbulk_inst, & + soilbiogeochem_carbonflux_inst, & + soilbiogeochem_nitrogenflux_inst, ch4_inst, lnd2atm_inst, & + agnpp, bgnpp, annsum_npp, rr) + ! + ! !DESCRIPTION: + ! Driver for the methane emissions model + ! + ! !USES: + use subgridAveMod , only : p2c, c2g + use clm_varpar , only : nlevgrnd, nlevdecomp + use pftconMod , only : noveg + use ch4varcon , only : replenishlakec, allowlakeprod, ch4offline + use clm_varcon , only : secspday + use ch4varcon , only : finundation_mtd, finundation_mtd_h2osfc + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of column soil points in column filter + integer , intent(in) :: filter_soilc(:) ! column filter for soil points + integer , intent(in) :: num_lakec ! number of column lake points in column filter + integer , intent(in) :: filter_lakec(:) ! column filter for lake points + integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points + integer , intent(in) :: num_soilp ! number of soil points in patch filter + integer , intent(in) :: filter_soilp(:) ! patch filter for soil points + type(atm2lnd_type) , intent(inout) :: atm2lnd_inst ! output ONLY for forcp_ch4 in ch4offline mode + type(lakestate_type) , intent(in) :: lakestate_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(soilhydrology_type) , intent(in) :: soilhydrology_inst + type(temperature_type) , intent(in) :: temperature_inst + type(energyflux_type) , intent(inout) :: energyflux_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenflux_type) , intent(in) :: soilbiogeochem_nitrogenflux_inst + type(ch4_type) , intent(inout) :: ch4_inst + type(lnd2atm_type) , intent(inout) :: lnd2atm_inst + real(r8) , intent(in) :: agnpp( bounds%begp: ) ! aboveground NPP (gC/m2/s) + real(r8) , intent(in) :: bgnpp( bounds%begp: ) ! belowground NPP (gC/m2/s) + real(r8) , intent(in) :: annsum_npp( bounds%begp: ) ! annual sum NPP (gC/m2/yr) + real(r8) , intent(in) :: rr ( bounds%begp: ) ! root respiration (fine root MR + total root GR) (gC/m2/s) + ! + ! !LOCAL VARIABLES: + integer :: sat ! 0 = unsatured, 1 = saturated + logical :: lake ! lake or not lake + integer :: j,fc,c,g,fp,p ! indices + real(r8) :: dtime ! land model time step (sec) + real(r8) :: dtime_ch4 ! ch4 model time step (sec) + integer :: nstep + integer :: jwt(bounds%begc:bounds%endc) ! index of the soil layer right above the water table (-) + real(r8) :: ch4_prod_tot(bounds%begc:bounds%endc) ! CH4 production for column (g C/m**2/s) + real(r8) :: ch4_oxid_tot(bounds%begc:bounds%endc) ! CH4 oxidation for column (g C/m**2/s) + real(r8) :: nem_col(bounds%begc:bounds%endc) ! net adjustment to atm. C flux from methane production (g C/m**2/s) + real(r8) :: totalsat + real(r8) :: totalunsat + real(r8) :: dfsat + real(r8) :: rootfraction(bounds%begp:bounds%endp, 1:nlevgrnd) + real(r8) :: fsat_bef(bounds%begc:bounds%endc) ! finundated from previous timestep + real(r8) :: errch4 ! g C / m^2 + !real(r8) :: zwt_actual + real(r8) :: qflxlags ! Time to lag qflx_surf_lag (s) + real(r8) :: redoxlag ! Redox time lag + real(r8) :: redoxlag_vertical ! Vertical redox lag time + real(r8) :: atmch4 ! Atmospheric CH4 mixing ratio to + ! prescribe if not provided by the atmospheric model (= 1.7e-6_r8) (mol/mol) + real(r8) :: redoxlags ! Redox time lag in s + real(r8) :: redoxlags_vertical ! Vertical redox lag time in s + real(r8) :: qflxlagd ! days to lag qflx_surf_lag in the tropics (days) + real(r8) :: highlatfact ! multiple of qflxlagd for high latitudes + integer :: dummyfilter(1) ! empty filter + character(len=32) :: subname='ch4' ! subroutine name + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(agnpp) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(bgnpp) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(annsum_npp) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(rr) == (/bounds%endp/)), sourcefile, __LINE__) + + associate( & + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) (-nlevsno+1:nlevsoi) + zi => col%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) + z => col%z , & ! Input: [real(r8) (:,:) ] layer depth (m) (-nlevsno+1:nlevsoi) + + forc_t => atm2lnd_inst%forc_t_not_downscaled_grc , & ! Input: [real(r8) (:) ] atmospheric temperature (Kelvin) + forc_pbot => atm2lnd_inst%forc_pbot_not_downscaled_grc , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + forc_po2 => atm2lnd_inst%forc_po2_grc , & ! Input: [real(r8) (:) ] O2 partial pressure (Pa) + forc_pco2 => atm2lnd_inst%forc_pco2_grc , & ! Input: [real(r8) (:) ] CO2 partial pressure (Pa) + forc_pch4 => atm2lnd_inst%forc_pch4_grc , & ! Input: [real(r8) (:) ] CH4 partial pressure (Pa) + + !zwt => soilhydrology_inst%zwt_col , & ! Input: [real(r8) (:) ] water table depth (m) + !zwt_perched => soilhydrology_inst%zwt_perched_col , & ! Input: [real(r8) (:) ] perched water table depth (m) + + rootfr => soilstate_inst%rootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer (nlevgrnd) + rootfr_col => soilstate_inst%rootfr_col , & ! Output: [real(r8) (:,:) ] fraction of roots in each soil layer (nlevgrnd) (p2c) + + frac_h2osfc => waterdiagnosticbulk_inst%frac_h2osfc_col , & ! Input: [real(r8) (:) ] fraction of ground covered by surface water (0 to 1) + snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) + tws => waterdiagnosticbulk_inst%tws_grc , & ! Input: [real(r8) (:) ] total water storage (kg m-2) + qflx_surf => waterfluxbulk_inst%qflx_surf_col , & ! Input: [real(r8) (:) ] total surface runoff (mm H2O /s) + + conc_o2_sat => ch4_inst%conc_o2_sat_col , & ! Input: [real(r8) (:,:) ] O2 conc in each soil layer (mol/m3) (nlevsoi) + totcolch4_bef_col => ch4_inst%totcolch4_bef_col , & ! Input: [real(r8) (:) ] column-level total methane in soil column, start of timestep (g C / m^2) + totcolch4_bef_grc => ch4_inst%totcolch4_bef_grc , & ! Input: [real(r8) (:) ] gridcell-level total methane in soil column, start of timestep (g C / m^2) + + grnd_ch4_cond_patch => ch4_inst%grnd_ch4_cond_patch , & ! Input: [real(r8) (:) ] tracer conductance for boundary layer [m/s] + grnd_ch4_cond_col => ch4_inst%grnd_ch4_cond_col , & ! Output: [real(r8) (:) ] tracer conductance for boundary layer [m/s] (p2c) + + ch4_surf_diff_sat => ch4_inst%ch4_surf_diff_sat_col , & ! Output: [real(r8) (:) ] CH4 surface flux (mol/m2/s) + ch4_surf_diff_unsat => ch4_inst%ch4_surf_diff_unsat_col , & ! Output: [real(r8) (:) ] CH4 surface flux (mol/m2/s) + ch4_surf_diff_lake => ch4_inst%ch4_surf_diff_lake_col , & ! Output: [real(r8) (:) ] CH4 surface flux (mol/m2/s) + ch4_surf_ebul_sat => ch4_inst%ch4_surf_ebul_sat_col , & ! Output: [real(r8) (:) ] CH4 ebullition to atmosphere (mol/m2/s) + ch4_surf_ebul_unsat => ch4_inst%ch4_surf_ebul_unsat_col , & ! Output: [real(r8) (:) ] CH4 ebullition to atmosphere (mol/m2/s) + ch4_surf_ebul_lake => ch4_inst%ch4_surf_ebul_lake_col , & ! Output: [real(r8) (:) ] CH4 ebullition to atmosphere (mol/m2/s) + ch4_surf_aere_sat => ch4_inst%ch4_surf_aere_sat_col , & ! Output: [real(r8) (:) ] Total column CH4 aerenchyma (mol/m2/s) + ch4_surf_aere_unsat => ch4_inst%ch4_surf_aere_unsat_col , & ! Output: [real(r8) (:) ] Total column CH4 aerenchyma (mol/m2/s) + ch4_oxid_depth_sat => ch4_inst%ch4_oxid_depth_sat_col , & ! Output: [real(r8) (:,:) ] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + ch4_oxid_depth_unsat => ch4_inst%ch4_oxid_depth_unsat_col , & ! Output: [real(r8) (:,:) ] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + ch4_oxid_depth_lake => ch4_inst%ch4_oxid_depth_lake_col , & ! Output: [real(r8) (:,:) ] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + ch4_prod_depth_sat => ch4_inst%ch4_prod_depth_sat_col , & ! Output: [real(r8) (:,:) ] production of CH4 in each soil layer (nlevsoi) (mol/m3/s) + ch4_prod_depth_unsat => ch4_inst%ch4_prod_depth_unsat_col , & ! Output: [real(r8) (:,:) ] production of CH4 in each soil layer (nlevsoi) (mol/m3/s) + ch4_prod_depth_lake => ch4_inst%ch4_prod_depth_lake_col , & ! Output: [real(r8) (:,:) ] production of CH4 in each soil layer (nlevsoi) (mol/m3/s) + lake_soilc => ch4_inst%lake_soilc_col , & ! Output: [real(r8) (:,:) ] total soil organic matter found in level (g C / m^3) (nlevsoi) + conc_ch4_sat => ch4_inst%conc_ch4_sat_col , & ! Output: [real(r8) (:,:) ] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_ch4_unsat => ch4_inst%conc_ch4_unsat_col , & ! Output: [real(r8) (:,:) ] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_ch4_lake => ch4_inst%conc_ch4_lake_col , & ! Output: [real(r8) (:,:) ] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_o2_lake => ch4_inst%conc_o2_lake_col , & ! Output: [real(r8) (:,:) ] O2 conc in each soil layer (mol/m3) (nlevsoi) + ch4_dfsat_flux => ch4_inst%ch4_dfsat_flux_col , & ! Output: [real(r8) (:) ] CH4 flux to atm due to decreasing finundated (kg C/m^2/s) [+] + zwt_ch4_unsat => ch4_inst%zwt_ch4_unsat_col , & ! Output: [real(r8) (:) ] depth of water table for unsaturated fraction (m) + totcolch4_col => ch4_inst%totcolch4_col , & ! Output: [real(r8) (:) ] column-level total methane in soil column (g C / m^2) + totcolch4_grc => ch4_inst%totcolch4_grc , & ! Output: [real(r8) (:) ] gridcell-level total methane in soil column (g C / m^2) + finundated => ch4_inst%finundated_col , & ! Output: [real(r8) (:) ] fractional inundated area in soil column (excluding dedicated wetland columns) + finundated_pre_snow => ch4_inst%finundated_pre_snow_col , & ! Output: [real(r8) (:) ] fractional inundated area in soil column (excluding dedicated wetland columns) before snow + ch4_first_time_grc => ch4_inst%ch4_first_time_grc , & ! Output: [logical (:) ] grc whether this is the first time step that includes ch4 + qflx_surf_lag => ch4_inst%qflx_surf_lag_col , & ! Output: [real(r8) (:) ] time-lagged surface runoff (mm H2O /s) + finundated_lag => ch4_inst%finundated_lag_col , & ! Output: [real(r8) (:) ] time-lagged fractional inundated area + layer_sat_lag => ch4_inst%layer_sat_lag_col , & ! Output: [real(r8) (:,:) ] Lagged saturation status of soil layer in the unsaturated zone (1 = sat) + c_atm => ch4_inst%c_atm_grc , & ! Output: [real(r8) (:,:) ] CH4, O2, CO2 atmospheric conc (mol/m3) + ch4co2f => ch4_inst%ch4co2f_grc , & ! Output: [real(r8) (:) ] gridcell CO2 production from CH4 oxidation (g C/m**2/s) + ch4prodg => ch4_inst%ch4prodg_grc , & ! Output: [real(r8) (:) ] gridcell average CH4 production (g C/m^2/s) + ch4_surf_flux_tot_col => ch4_inst%ch4_surf_flux_tot_col , & ! Output: [real(r8) (:) ] col CH4 flux to atm. (kg C/m**2/s) + ch4_surf_flux_tot_grc => lnd2atm_inst%ch4_surf_flux_tot_grc , & ! Output: [real(r8) (:) ] grc CH4 flux to atm. (kg C/m**2/s) + + nem_grc => lnd2atm_inst%nem_grc , & ! Output: [real(r8) (:) ] gridcell average net methane correction to CO2 flux (g C/m^2/s) + + begg => bounds%begg , & + endg => bounds%endg , & + begc => bounds%begc , & + endc => bounds%endc , & + begp => bounds%begp , & + endp => bounds%endp & + ) + + redoxlag = params_inst%redoxlag + redoxlag_vertical = params_inst%redoxlag_vertical + atmch4 = params_inst%atmch4 + qflxlagd = params_inst%qflxlagd + highlatfact = params_inst%highlatfact + + dtime = get_step_size_real() + nstep = get_nstep() + dtime_ch4 = dtime + redoxlags = redoxlag*secspday ! days --> s + redoxlags_vertical = redoxlag_vertical*secspday ! days --> s + rgasm = rgas / 1000._r8 + + jwt(begc:endc) = huge(1) + + ! Initialize local fluxes to zero: necessary for columns outside the filters because averaging up to gridcell will be done + ch4_surf_flux_tot_col(begc:endc) = 0._r8 + ch4_prod_tot(begc:endc) = 0._r8 + ch4_oxid_tot(begc:endc) = 0._r8 + rootfraction(begp:endp,:) = spval + + ! Adjustment to NEE for methane production - oxidation + nem_col(begc:endc) = 0._r8 + + do g= begg, endg + if (ch4offline) then + forc_pch4(g) = atmch4*forc_pbot(g) + else + if (forc_pch4(g) == 0._r8) then + write(iulog,*)'not using ch4offline, but methane concentration not passed from the atmosphere', & + 'to land model! CLM Model is stopping.' + call endrun(msg=' ERROR: Methane not being passed to atmosphere'//& + errMsg(sourcefile, __LINE__)) + end if + end if + + c_atm(g,1) = forc_pch4(g) / rgasm / forc_t(g) ! [mol/m3 air] + c_atm(g,2) = forc_po2(g) / rgasm / forc_t(g) ! [mol/m3 air] + c_atm(g,3) = forc_pco2(g) / rgasm / forc_t(g) ! [mol/m3 air] + end do + + ! Save finundated before, and calculate lagged surface runoff + do fc = 1, num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + + fsat_bef(c) = finundated(c) + + ! Update lagged surface runoff + + if (grc%latdeg(g) < 45._r8) then + qflxlags = qflxlagd * secspday ! 30 days + else + qflxlags = qflxlagd * secspday * highlatfact ! 60 days + end if + qflx_surf_lag(c) = qflx_surf_lag(c) * exp(-dtime/qflxlags) & + + qflx_surf(c) * (1._r8 - exp(-dtime/qflxlags)) + + end do + + ! Caulculate finundated + if ( ch4_inst%ch4findstream%useStreams() & + .or. (finundation_mtd == finundation_mtd_h2osfc) )then + call ch4_inst%ch4findstream%CalcFinundated( bounds, num_soilc, & + filter_soilc, soilhydrology_inst, & + waterdiagnosticbulk_inst, qflx_surf_lag(begc:endc), finundated(begc:endc) ) + else + + call endrun( "ERROR:: finundation method MUST now use a streams file to run, it can no longer read from the fsurdat file" ) + end if + + ! Calculate finundated before snow and lagged version of finundated + do fc = 1, num_soilc + c = filter_soilc(fc) + if (snow_depth(c) <= 0._r8) then ! If snow_depth<=0,use the above method to calculate finundated. + finundated(c) = max( min(finundated(c),1._r8), 0._r8) + finundated_pre_snow(c) = finundated(c) + else + finundated(c) = finundated_pre_snow(c) !If snow_depth>0, keep finundated from the previous time step of snow season. (by Xiyan Xu, 05/2016) + end if + + ! Update lagged finundated for redox calculation + if (redoxlags > 0._r8) then + finundated_lag(c) = finundated_lag(c) * exp(-dtime/redoxlags) & + + finundated(c) * (1._r8 - exp(-dtime/redoxlags)) + else + finundated_lag(c) = finundated(c) + end if + + end do + + ! Check to see if finundated changed since the last timestep. If it increased, then reduce conc_ch4_sat + ! proportionally. If it decreased, then add flux to atm. + + do j=1,nlevsoi + do fc = 1, num_soilc + c = filter_soilc(fc) + + if (j==1) then + ch4_dfsat_flux(c) = 0._r8 + end if + + g = col%gridcell(c) + if (.not. ch4_first_time_grc(g)) then + if (finundated(c) > fsat_bef(c)) then !Reduce conc_ch4_sat + dfsat = finundated(c) - fsat_bef(c) + conc_ch4_sat(c,j) = (fsat_bef(c)*conc_ch4_sat(c,j) + dfsat*conc_ch4_unsat(c,j)) / finundated(c) + else if (finundated(c) < fsat_bef(c)) then + ch4_dfsat_flux(c) = ch4_dfsat_flux(c) + & + (fsat_bef(c) - finundated(c))*(conc_ch4_sat(c,j) - conc_ch4_unsat(c,j)) * & + dz(c,j) / dtime * catomw / 1000._r8 ! mol --> kg + end if + end if + end do + end do + + !!!! Begin biochemistry + + ! First for soil + lake = .false. + + ! Do CH4 Annual Averages + call ch4_annualupdate(bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + agnpp(begp:endp), bgnpp(begp:endp), & + soilbiogeochem_carbonflux_inst, ch4_inst) + + ! Determine rootfr_col and also check for inactive columns + + if (nlevdecomp == 1) then + + ! Set rootfraction to spval for non-veg points, unless patch%wtcol > 0.99, + ! in which case set it equal to uniform dist. + do j=1, nlevsoi + do fp = 1, num_soilp + p = filter_soilp(fp) + c = patch%column(p) + + if (patch%itype(p) /= noveg) then + rootfraction(p,j) = rootfr(p,j) + else if (patch%wtcol(p) < 0.99_r8) then + rootfraction(p,j) = spval + else + rootfraction(p,j) = dz(c,j) / zi(c,nlevsoi) ! Set equal to uniform distribution + end if + end do + end do + + call p2c (bounds, nlevgrnd, & + rootfraction(bounds%begp:bounds%endp, :), & + rootfr_col(bounds%begc:bounds%endc, :), & + 'unity') + + do j=1, nlevsoi + do fc = 1, num_soilc + c = filter_soilc(fc) + if (.not. col%active(c)) rootfr_col(c,j) = dz(c,j) / zi(c,nlevsoi) + end do + end do + end if + + ! Determine grnd_ch4_cond_col + ! Needed to use non-filter form above so that spval would be treated properly. + + call p2c (bounds, num_soilc, filter_soilc, & + grnd_ch4_cond_patch(bounds%begp:bounds%endp), & + grnd_ch4_cond_col(bounds%begc:bounds%endc)) + + ! Set the gridcell atmospheric CH4 and O2 concentrations + do fc = 1, num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + + c_atm(g,1) = forc_pch4(g) / rgasm / forc_t(g) ! [mol/m3 air] + c_atm(g,2) = forc_po2(g) / rgasm / forc_t(g) ! [mol/m3 air] + !c_atm(g,3) = forc_pco2(g) / rgasm / forc_t(g) ! [mol/m3 air] - Not currently used + enddo + + !------------------------------------------------- + ! Loop over saturated and unsaturated, non-lakes + !------------------------------------------------ + + do sat = 0, 1 ! 0 == unsaturated; 1 = saturated + + ! Get index of water table + if (sat == 0) then ! unsaturated + + call get_jwt (bounds, num_soilc, filter_soilc, jwt(begc:endc), & + soilstate_inst, waterstatebulk_inst, temperature_inst) + + do fc = 1, num_soilc + c = filter_soilc(fc) + zwt_ch4_unsat(c) = zi(c,jwt(c)) + + end do + + ! Update lagged saturation status of layer + do j=1,nlevsoi + do fc = 1, num_soilc + c = filter_soilc(fc) + + if (j > jwt(c) .and. redoxlags_vertical > 0._r8) then ! saturated currently + layer_sat_lag(c,j) = layer_sat_lag(c,j) * exp(-dtime/redoxlags_vertical) & + + (1._r8 - exp(-dtime/redoxlags_vertical)) + else if (redoxlags_vertical > 0._r8) then + layer_sat_lag(c,j) = layer_sat_lag(c,j) * exp(-dtime/redoxlags_vertical) + else if (j > jwt(c)) then ! redoxlags_vertical = 0 + layer_sat_lag(c,j) = 1._r8 + else + layer_sat_lag(c,j) = 0._r8 + end if + end do + end do + + else ! saturated + do fc = 1, num_soilc + c = filter_soilc(fc) + jwt(c) = 0 + end do + endif + + ! calculate CH4 production in each soil layer + call ch4_prod (bounds, num_soilc, filter_soilc, num_soilp, filter_soilp, & + rr(begp:endp), jwt(begc:endc), sat, lake, & + soilstate_inst, temperature_inst, waterstatebulk_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenflux_inst, & + ch4_inst) + + ! calculate CH4 oxidation in each soil layer + call ch4_oxid (bounds, & + num_soilc, filter_soilc, & + jwt(begc:endc), sat, lake, & + waterstatebulk_inst, soilstate_inst, temperature_inst, ch4_inst) + + ! calculate CH4 aerenchyma losses in each soil layer + call ch4_aere (bounds, & + num_soilc, filter_soilc, & + num_soilp, filter_soilp, & + annsum_npp(begp:endp), jwt(begc:endc), sat, lake, & + canopystate_inst, soilstate_inst, temperature_inst, energyflux_inst, & + waterstatebulk_inst, waterfluxbulk_inst, ch4_inst) + + ! calculate CH4 ebullition losses in each soil layer + call ch4_ebul (bounds, & + num_soilc, filter_soilc, & + jwt(begc:endc), sat, lake, & + atm2lnd_inst, temperature_inst, lakestate_inst, soilstate_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, & + ch4_inst) + + ! Solve CH4 reaction/diffusion equation + ! Competition for oxygen will occur here. + call ch4_tran (bounds, & + num_soilc, filter_soilc, & + jwt(begc:endc), dtime_ch4, sat, lake, & + soilstate_inst, temperature_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, energyflux_inst, ch4_inst) + + enddo ! sat/unsat + + !------------------------------------------------- + ! Now do over lakes + !------------------------------------------------- + + if (allowlakeprod) then + lake = .true. + sat = 1 + do fc = 1, num_lakec + c = filter_lakec(fc) + jwt(c) = 0 + end do + + ! calculate CH4 production in each lake layer + call ch4_prod (bounds, num_lakec, filter_lakec, 0, dummyfilter, & + rr(begp:endp), jwt(begc:endc), sat, lake, & + soilstate_inst, temperature_inst, waterstatebulk_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenflux_inst, & + ch4_inst) + + ! calculate CH4 oxidation in each lake layer + call ch4_oxid (bounds, & + num_lakec, filter_lakec, & + jwt(begc:endc), sat, lake, & + waterstatebulk_inst, soilstate_inst, temperature_inst, ch4_inst) + + ! calculate CH4 aerenchyma losses in each lake layer + ! The p filter will not be used here; the relevant column vars will just be set to 0. + call ch4_aere (bounds, num_lakec, filter_lakec, 0, dummyfilter, & + annsum_npp(begp:endp), jwt(begc:endc), sat, lake, & + canopystate_inst, soilstate_inst, temperature_inst, energyflux_inst, & + waterstatebulk_inst, waterfluxbulk_inst, ch4_inst) + + ! calculate CH4 ebullition losses in each lake layer + call ch4_ebul (bounds, num_lakec, filter_lakec, & + jwt(begc:endc), sat, lake, & + atm2lnd_inst, temperature_inst, lakestate_inst, soilstate_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, & + ch4_inst) + + ! Solve CH4 reaction/diffusion equation + ! Competition for oxygen will occur here. + call ch4_tran (bounds, num_lakec, filter_lakec, & + jwt(begc:endc), dtime_ch4, sat, lake, & + soilstate_inst, temperature_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, energyflux_inst, ch4_inst) + + end if + + !------------------------------------------------- + ! Average up to gridcell flux and column oxidation and production rate. + !------------------------------------------------- + + ! First weight the soil columns by finundated. + do j=1,nlevsoi + do fc = 1, num_soilc + c = filter_soilc(fc) + + if (j == 1) then + totalsat = ch4_surf_diff_sat(c) + ch4_surf_aere_sat(c) + ch4_surf_ebul_sat(c) + totalunsat = ch4_surf_diff_unsat(c) + ch4_surf_aere_unsat(c) + ch4_surf_ebul_unsat(c) + ch4_surf_flux_tot_col(c) = (finundated(c)*totalsat + (1._r8 - finundated(c))*totalunsat) * & + catomw / 1000._r8 + !Convert from mol to kg C + ! ch4_oxid_tot and ch4_prod_tot are initialized to zero above + end if + + ch4_oxid_tot(c) = ch4_oxid_tot(c) + (finundated(c)*ch4_oxid_depth_sat(c,j) + & + (1._r8 - finundated(c))*ch4_oxid_depth_unsat(c,j))*dz(c,j) * catomw + !Convert from mol to g C + ch4_prod_tot(c) = ch4_prod_tot(c) + (finundated(c)*ch4_prod_depth_sat(c,j) + & + (1._r8 - finundated(c))*ch4_prod_depth_unsat(c,j))*dz(c,j) * catomw + !Convert from mol to g C + if (j == nlevsoi) then + ! Adjustment to NEE flux to atm. for methane production + nem_col(c) = nem_col(c) - ch4_prod_tot(c) + ! Adjustment to NEE flux to atm. for methane oxidation + nem_col(c) = nem_col(c) + ch4_oxid_tot(c) + end if + end do + end do + + ! Correct for discrepancies in CH4 concentration from changing finundated + + do fc = 1, num_soilc + c = filter_soilc(fc) + + ch4_surf_flux_tot_col(c) = ch4_surf_flux_tot_col(c) + ch4_dfsat_flux(c) + end do + + if (allowlakeprod) then + do j=1,nlevsoi + do fc = 1, num_lakec + c = filter_lakec(fc) + + if (j == 1) then + ! ch4_oxid_tot and ch4_prod_tot are initialized to zero above + totalsat = ch4_surf_diff_sat(c) + ch4_surf_aere_sat(c) + ch4_surf_ebul_sat(c) + ch4_surf_flux_tot_col(c) = totalsat*catomw / 1000._r8 + end if + + ch4_oxid_tot(c) = ch4_oxid_tot(c) + ch4_oxid_depth_sat(c,j)*dz(c,j)*catomw + ch4_prod_tot(c) = ch4_prod_tot(c) + ch4_prod_depth_sat(c,j)*dz(c,j)*catomw + + if (.not. replenishlakec) then + !Adjust lake_soilc for production. + lake_soilc(c,j) = lake_soilc(c,j) - 2._r8*ch4_prod_depth_sat(c,j)*dtime*catomw + ! Factor of 2 is for CO2 that comes off with CH4 because of stoichiometry + end if + + if (j == nlevsoi) then + ! Adjustment to NEE flux to atm. for methane production + if (.not. replenishlakec) then + nem_col(c) = nem_col(c) + ch4_prod_tot(c) + ! Here this is positive because it is actually the CO2 that comes off with the methane + ! NOTE THIS MODE ASSUMES TRANSIENT CARBON SUPPLY FROM LAKES; COUPLED MODEL WILL NOT CONSERVE CARBON + ! IN THIS MODE. + else ! replenishlakec + nem_col(c) = nem_col(c) - ch4_prod_tot(c) + ! Keep total C constant, just shift from CO2 to methane + end if + + ! Adjustment to NEE flux to atm. for methane oxidation + nem_col(c) = nem_col(c) + ch4_oxid_tot(c) + + end if + + + !Set lake diagnostic output variables + ch4_prod_depth_lake(c,j) = ch4_prod_depth_sat(c,j) + conc_ch4_lake(c,j) = conc_ch4_sat(c,j) + conc_o2_lake(c,j) = conc_o2_sat(c,j) + ch4_oxid_depth_lake(c,j) = ch4_oxid_depth_sat(c,j) + if (j == 1) then + ch4_surf_diff_lake(c) = ch4_surf_diff_sat(c) + ch4_surf_ebul_lake(c) = ch4_surf_ebul_sat(c) + end if + + end do + end do + end if ! ch4_surf_flux_tot, ch4_oxid_tot, and ch4_prod_tot should be initialized to 0 above if .not. allowlakeprod + + ! Finalize CH4 balance and check for errors + + call ch4_totcolch4(bounds, num_nolakec, filter_nolakec, num_lakec, filter_lakec, & + ch4_inst, totcolch4_col(bounds%begc:bounds%endc)) + + ! Column level balance + + do fc = 1, num_soilc + c = filter_soilc(fc) + g = col%gridcell(c) + + if (.not. ch4_first_time_grc(g)) then + ! Check balance + errch4 = totcolch4_col(c) - totcolch4_bef_col(c) & + - dtime*(ch4_prod_tot(c) - ch4_oxid_tot(c) & + - ch4_surf_flux_tot_col(c)*1000._r8) ! kg C --> g C + if (abs(errch4) > 1.e-7_r8) then ! g C / m^2 / timestep + write(iulog,*)'Column-level CH4 Conservation Error in CH4Mod driver, nstep, c, errch4 (gC /m^2.timestep)', & + nstep,c,errch4 + write(iulog,*)'Latdeg,Londeg,col%itype=',grc%latdeg(g),grc%londeg(g),col%itype(c) + write(iulog,*)'totcolch4_col = ', totcolch4_col(c) + write(iulog,*)'totcolch4_bef_col = ', totcolch4_bef_col(c) + write(iulog,*)'dtime*ch4_prod_tot = ', dtime*ch4_prod_tot(c) + write(iulog,*)'dtime*ch4_oxid_tot = ', dtime*ch4_oxid_tot(c) + write(iulog,*)'dtime*ch4_surf_flux_tot*1000 = ', dtime*& + ch4_surf_flux_tot_col(c)*1000._r8 + call endrun(msg=' ERROR: Methane conservation error'//errMsg(sourcefile, __LINE__)) + end if + end if + + end do + if (allowlakeprod) then + do fc = 1, num_lakec + c = filter_lakec(fc) + g = col%gridcell(c) + + if (.not. ch4_first_time_grc(g)) then + ! Check balance + errch4 = totcolch4_col(c) - totcolch4_bef_col(c) & + - dtime*(ch4_prod_tot(c) - ch4_oxid_tot(c) & + - ch4_surf_flux_tot_col(c)*1000._r8) ! kg C --> g C + if (abs(errch4) > 1.e-7_r8) then ! g C / m^2 / timestep + write(iulog,*)'Column-level CH4 Conservation Error in CH4Mod driver for lake column, nstep, c, errch4 (gC/m^2.timestep)', & + nstep,c,errch4 + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(g),grc%londeg(g) + write(iulog,*)'totcolch4_col = ', totcolch4_col(c) + write(iulog,*)'totcolch4_bef_col = ', totcolch4_bef_col(c) + write(iulog,*)'dtime*ch4_prod_tot = ', dtime*ch4_prod_tot(c) + write(iulog,*)'dtime*ch4_oxid_tot = ', dtime*ch4_oxid_tot(c) + write(iulog,*)'dtime*ch4_surf_flux_tot*1000 = ', dtime*& + ch4_surf_flux_tot_col(c)*1000._r8 + call endrun(msg=' ERROR: Methane conservation error, allowlakeprod'//& + errMsg(sourcefile, __LINE__)) + end if + end if + + end do + end if + + ! Now average up to gridcell for fluxes and totcolch4 + call c2g( bounds, & + ch4_oxid_tot(begc:endc), ch4co2f(begg:endg), & + c2l_scale_type= 'unity', l2g_scale_type='unity' ) + + call c2g( bounds, & + ch4_prod_tot(begc:endc), ch4prodg(begg:endg), & + c2l_scale_type= 'unity', l2g_scale_type='unity' ) + + call c2g( bounds, & + nem_col(begc:endc), nem_grc(begg:endg), & + c2l_scale_type= 'unity', l2g_scale_type='unity' ) + + call c2g( bounds, & + ch4_surf_flux_tot_col(begc:endc), ch4_surf_flux_tot_grc(begg:endg), & + c2l_scale_type= 'unity', l2g_scale_type='unity' ) + + call c2g( bounds, & + ch4_inst%totcolch4_col(begc:endc), & + ch4_inst%totcolch4_grc(begg:endg), & + c2l_scale_type= 'unity', l2g_scale_type='unity' ) + + ! Gricell level balance + + do g = begg, endg + if (.not. ch4_first_time_grc(g)) then + ! Check balance + errch4 = totcolch4_grc(g) - totcolch4_bef_grc(g) + dtime * & + (nem_grc(g) + ch4_surf_flux_tot_grc(g) * 1000._r8) ! kg C --> g C + + if (abs(errch4) > 1.e-7_r8) then ! g C / m^2 / timestep + write(iulog,*)'Gridcell-level CH4 Conservation Error in CH4Mod driver, nstep, g, errch4 (gC /m^2.timestep)', & + nstep, g, errch4 + write(iulog,*)'latdeg, londeg =', grc%latdeg(g), grc%londeg(g) + write(iulog,*)'totcolch4_grc =', totcolch4_grc(g) + write(iulog,*)'totcolch4_bef_grc =', totcolch4_bef_grc(g) + write(iulog,*)'dtime * nem_grc =', dtime * nem_grc(g) + write(iulog,*)'dtime * ch4_surf_flux_tot * 1000 =', dtime * ch4_surf_flux_tot_grc(g) * 1000._r8 + call endrun(msg=' ERROR: Methane conservation error'//errMsg(sourcefile, __LINE__)) + end if + end if + end do + + ch4_first_time_grc(begg:endg) = .false. + + end associate + + end subroutine ch4 + + !----------------------------------------------------------------------- + subroutine ch4_prod (bounds, num_methc, filter_methc, num_methp, & + filter_methp, rr, jwt, sat, lake, & + soilstate_inst, temperature_inst, waterstatebulk_inst, & + soilbiogeochem_carbonflux_inst, soilbiogeochem_nitrogenflux_inst, & + ch4_inst) + ! + ! !DESCRIPTION: + ! Production is done below the water table, based on CN heterotrophic respiration. + ! O2 is consumed by roots & by heterotrophic aerobes. + ! Production is done separately for sat & unsat, and is adjusted for temperature, seasonal inundation, + ! pH (optional), & redox lag factor. + ! + ! !USES: + use ch4varcon , only: usephfact, anoxicmicrosites, ch4rmcnlim + use clm_varctl , only: anoxia + use clm_varpar , only: nlevdecomp, nlevdecomp_full + use CNSharedParamsMod , only: nlev_soildecomp_standard + use pftconMod , only: noveg + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_methc ! number of column soil points in column filter + integer , intent(in) :: filter_methc(:) ! column filter for soil points + integer , intent(in) :: num_methp ! number of soil points in patch filter + integer , intent(in) :: filter_methp(:) ! patch filter for soil points + real(r8) , intent(in) :: rr ( bounds%begp: ) ! root respiration (fine root MR + total root GR) (gC/m2/s) + integer , intent(in) :: jwt( bounds%begc: ) ! index of the soil layer right above the water table (-) [col] + integer , intent(in) :: sat ! 0 = unsaturated; 1 = saturated + logical , intent(in) :: lake ! function called with lake filter + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(soilbiogeochem_nitrogenflux_type) , intent(in) :: soilbiogeochem_nitrogenflux_inst + type(ch4_type) , intent(inout) :: ch4_inst + ! + ! !LOCAL VARIABLES: + integer :: p,c,j,g ! indices + integer :: fc ! column index + integer :: fp ! PATCH index + real(r8) :: dtime + real(r8) :: base_decomp ! base rate (mol/m2/s) + real(r8) :: q10lake ! For now, take to be the same as q10ch4 * 1.5. + real(r8) :: q10lakebase ! (K) base temperature for lake CH4 production + real(r8) :: partition_z + real(r8) :: mino2lim ! minimum anaerobic decomposition rate as a fraction of potential aerobic rate + real(r8) :: q10ch4 ! additional Q10 for methane production ABOVE the soil decomposition temperature relationship + real(r8) :: q10ch4base ! temperature at which the effective f_ch4 actually equals the constant f_ch4 + real(r8) :: f_ch4 ! ratio of CH4 production to total C mineralization + real(r8) :: rootlitfrac ! Fraction of soil organic matter associated with roots + real(r8) :: cnscalefactor ! scale factor on CN decomposition for assigning methane flux + real(r8) :: lake_decomp_fact ! Base decomposition rate (1/s) at 25C + + ! added by Lei Meng to account for pH influence of CH4 production + real(r8) :: pHmax + real(r8) :: pHmin + real(r8) :: pH_fact_ch4 ! pH factor in methane production + + ! Factors for methanogen temperature dependence being greater than soil aerobes + real(r8) :: f_ch4_adj ! Adjusted f_ch4 + real(r8) :: t_fact_ch4 ! Temperature factor calculated using additional Q10 + ! O2 limitation on decomposition and methanogenesis + real(r8) :: seasonalfin ! finundated in excess of respiration-weighted annual average + real(r8) :: oxinhib ! inhibition of methane production by oxygen (m^3/mol) + + ! For calculating column average (rootfrac(p,j)*rr(p,j)) + real(r8) :: rr_vr(bounds%begc:bounds%endc, 1:nlevsoi) ! vertically resolved column-mean root respiration (g C/m^2/s) + real(r8), pointer :: ch4_prod_depth(:,:) ! backwards compatibility + real(r8), pointer :: o2_decomp_depth(:,:) ! backwards compatibility + real(r8), pointer :: co2_decomp_depth(:,:) ! backwards compatibility + real(r8), pointer :: conc_o2(:,:) ! backwards compatibility + + character(len=32) :: subname='ch4_prod' ! subroutine name + !----------------------------------------------------------------------- + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(rr) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(jwt) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + wtcol => patch%wtcol , & ! Input: [real(r8) (:) ] weight (relative to column) + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) (-nlevsno+1:nlevsoi) + z => col%z , & ! Input: [real(r8) (:,:) ] layer depth (m) (-nlevsno+1:nlevsoi) + zi => col%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevsoi) + + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) + crootfr => soilstate_inst%crootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots for carbon in each soil layer (nlevsoi) + rootfr_col => soilstate_inst%rootfr_col , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer (nlevsoi) + + somhr => soilbiogeochem_carbonflux_inst%somhr_col , & ! Input: [real(r8) (:) ] (gC/m2/s) soil organic matter heterotrophic respiration + lithr => soilbiogeochem_carbonflux_inst%lithr_col , & ! Input: [real(r8) (:) ] (gC/m2/s) litter heterotrophic respiration + hr_vr => soilbiogeochem_carbonflux_inst%hr_vr_col , & ! Input: [real(r8) (:,:) ] total vertically-resolved het. resp. from decomposing C pools (gC/m3/s) + o_scalar => soilbiogeochem_carbonflux_inst%o_scalar_col , & ! Input: [real(r8) (:,:) ] fraction by which decomposition is limited by anoxia + fphr => soilbiogeochem_carbonflux_inst%fphr_col , & ! Input: [real(r8) (:,:) ] fraction of potential heterotrophic respiration + + pot_f_nit_vr => soilbiogeochem_nitrogenflux_inst%pot_f_nit_vr_col , & ! Input: [real(r8) (:,:) ] (gN/m3/s) potential soil nitrification flux + + finundated => ch4_inst%finundated_col , & ! Input: [real(r8) (:) ] fractional inundated area in soil column + pH => ch4_inst%pH_col , & ! Input: [real(r8) (:) ] soil water pH + lake_soilc => ch4_inst%lake_soilc_col , & ! Input: [real(r8) (:,:) ] total soil organic matter found in level (g C / m^3) (nlevsoi) + annavg_finrw => ch4_inst%annavg_finrw_col , & ! Input: [real(r8) (:) ] respiration-weighted annual average of finundated + finundated_lag => ch4_inst%finundated_lag_col , & ! Input: [real(r8) (:) ] time-lagged fractional inundated area + layer_sat_lag => ch4_inst%layer_sat_lag_col , & ! Input: [real(r8) (: ,:) ] Lagged saturation status of soil layer in the unsaturated zone (1 = sat) + sif => ch4_inst%sif_col & ! Output: [real(r8) (:) ] (unitless) ratio applied to sat. prod. to account for seasonal inundation + ) + + if (sat == 0) then ! unsaturated + conc_o2 => ch4_inst%conc_o2_unsat_col ! Input: [real(r8) (:,:)] O2 conc in each soil layer (mol/m3) (nlevsoi) + ch4_prod_depth => ch4_inst%ch4_prod_depth_unsat_col ! Output: [real(r8) (:,:)] production of CH4 in each soil layer (nlevsoi) (mol/m3/s) + o2_decomp_depth => ch4_inst%o2_decomp_depth_unsat_col ! Output: [real(r8) (:,:)] O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + co2_decomp_depth => ch4_inst%co2_decomp_depth_unsat_col ! Output: [real(r8) (:,:)] CO2 production during decomposition in each soil layer (nlevsoi) (mol/m3/s) + else ! saturated + conc_o2 => ch4_inst%conc_o2_sat_col ! Input: [real(r8) (:,:)] O2 conc in each soil layer (mol/m3) (nlevsoi) + ch4_prod_depth => ch4_inst%ch4_prod_depth_sat_col ! Output: [real(r8) (:,:)] production of CH4 in each soil layer (nlevsoi) (mol/m3/s) + o2_decomp_depth => ch4_inst%o2_decomp_depth_sat_col ! Output: [real(r8) (:,:)] O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + co2_decomp_depth => ch4_inst%co2_decomp_depth_sat_col ! Output: [real(r8) (:,:)] CO2 production during decomposition in each soil layer (nlevsoi) (mol/m3/s) + endif + + dtime = get_step_size_real() + + q10ch4 = params_inst%q10ch4 + q10ch4base = params_inst%q10ch4base + f_ch4 = params_inst%f_ch4 + rootlitfrac = params_inst%rootlitfrac + cnscalefactor = params_inst%cnscalefactor + lake_decomp_fact = params_inst%lake_decomp_fact + pHmax = params_inst%pHmax + pHmin = params_inst%pHmin + oxinhib = params_inst%oxinhib + q10lakebase = params_inst%q10lakebase + + ! Shared constant with other modules + mino2lim = CNParamsShareInst%mino2lim + + q10lake = q10ch4 * 1.5_r8 + + ! PATCH loop to calculate vertically resolved column-averaged root respiration + if (.not. lake) then + rr_vr(bounds%begc:bounds%endc,:) = nan + + do fp = 1, num_methc + c = filter_methc(fp) + rr_vr(c,:) = 0.0_r8 + end do + do j=1,nlevsoi + do fp = 1, num_methp + p = filter_methp(fp) + c = patch%column(p) + + if (wtcol(p) > 0._r8 .and. patch%itype(p) /= noveg) then + rr_vr(c,j) = rr_vr(c,j) + rr(p)*crootfr(p,j)*wtcol(p) + end if + end do + end do + end if + + partition_z = 1._r8 + base_decomp = 0.0_r8 + + ! column loop to partition decomposition_rate into each soil layer + do j=1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + + if (.not. lake) then + + if (use_cn) then + ! Use soil heterotrophic respiration (based on Wania) + base_decomp = (somhr(c)+lithr(c)) / catomw + ! Convert from gC to molC + ! Multiply base_decomp by factor accounting for lower carbon stock in seasonally inundated areas than + ! if it were inundated all year. + ! This is to reduce emissions in seasonally inundated zones, because the eq. + ! C-flux will be less than predicted by a non-O2-lim model + if (sat == 1) then + sif(c) = 1._r8 + if (.not. anoxia) then + if (annavg_finrw(c) /= spval) then + seasonalfin = max(finundated(c)-annavg_finrw(c), 0._r8) + if (seasonalfin > 0._r8) then + sif(c) = (annavg_finrw(c) + mino2lim*seasonalfin) / finundated(c) + base_decomp = base_decomp * sif(c) + end if + end if + end if ! anoxia + end if + else + call endrun(msg=' ERROR: No source for decomp rate in CH4Prod.'//& + ' CH4 model currently requires CN.'//errMsg(sourcefile, __LINE__)) + end if ! use_cn + + ! For sensitivity studies + base_decomp = base_decomp * cnscalefactor + + else !lake + + base_decomp = lake_decomp_fact * lake_soilc(c,j) * dz(c,j) * & + q10lake**( (t_soisno(c,j)-q10lakebase)/10._r8) / catomw + ! convert from g C to mol C + end if + + ! For all landunits, prevent production or oxygen consumption when soil is at or below freezing. + ! If using VERTSOILC, it is OK to use base_decomp as given because liquid water stress will limit decomp. + if (t_soisno(c,j) <= tfrz .and. (nlevdecomp == 1 .or. lake)) base_decomp = 0._r8 + + ! depth dependence of production either from rootfr or decomp model + if (.not. lake) then ! use default rootfr, averaged to the column level in the ch4 driver, or vert HR + if (nlevdecomp == 1) then ! not VERTSOILC + if (j <= nlev_soildecomp_standard) then ! Top 5 levels are also used in the CLM code for establishing temperature + ! and moisture constraints on SOM activity + partition_z = rootfr_col(c,j)*rootlitfrac + (1._r8 - rootlitfrac)*dz(c,j)/zi(c,nlev_soildecomp_standard) + else + partition_z = rootfr_col(c,j)*rootlitfrac + end if + else + if ( (somhr(c) + lithr(c)) > 0._r8) then + partition_z = hr_vr(c,j) * dz(c,j) / (somhr(c) + lithr(c)) + else + partition_z = 1._r8 + end if + end if + else ! lake + partition_z = 1._r8 + endif + + ! Adjust f_ch4 to account for the fact that methanogens may have a higher Q10 than aerobic decomposers. + ! Note this is crude and should ideally be applied to all anaerobic decomposition rather than just the + ! f_ch4. + f_ch4_adj = 1.0_r8 + if (.not. lake) then + t_fact_ch4 = q10ch4**((t_soisno(c,j) - q10ch4base)/10._r8) + ! Adjust f_ch4 by the ratio + f_ch4_adj = f_ch4 * t_fact_ch4 + + ! Remove CN nitrogen limitation, as methanogenesis is not N limited. + ! Also remove (low) moisture limitation + if (ch4rmcnlim) then + if (j > nlevdecomp) then + if (fphr(c,1) > 0._r8) then + f_ch4_adj = f_ch4_adj / fphr(c,1) + end if + else ! j == 1 or VERTSOILC + if (fphr(c,j) > 0._r8) then + f_ch4_adj = f_ch4_adj / fphr(c,j) + end if + end if + end if + + else ! lake + f_ch4_adj = 0.5_r8 ! For lakes assume no redox limitation. Production only depends on temp, soil C, and + ! lifetime parameter. + end if + + ! If switched on, use pH factor for production based on spatial pH data defined in surface data. + if (.not. lake .and. usephfact .and. pH(c) > pHmin .and.pH(c) < pHmax) then + pH_fact_ch4 = 10._r8**(-0.2235_r8*pH(c)*pH(c) + 2.7727_r8*pH(c) - 8.6_r8) + ! fitted function using data from Dunfield et al. 1993 + ! Strictly less than one, with optimum at 6.5 + ! From Lei Meng + f_ch4_adj = f_ch4_adj * pH_fact_ch4 + else + ! if no data, then no pH effects + end if + + ! Redox factor + if ( (.not. lake) .and. sat == 1 .and. finundated_lag(c) < finundated(c)) then + f_ch4_adj = f_ch4_adj * finundated_lag(c) / finundated(c) + else if (sat == 0 .and. j > jwt(c)) then ! Assume lag in decay of alternative electron acceptors vertically + f_ch4_adj = f_ch4_adj * layer_sat_lag(c,j) + end if + ! Alternative electron acceptors will be consumed first after soil is inundated. + + f_ch4_adj = min(f_ch4_adj, 0.5_r8) + ! Must be less than 0.5 because otherwise the actual implied aerobic respiration would be negative. + ! The total of aer. respiration + methanogenesis must remain equal to the SOMHR calculated in CN, + ! so that the NEE is sensible. Even perfectly anaerobic conditions with no alternative + ! electron acceptors would predict no more than 0.5 b/c some oxygen is present in organic matter. + ! e.g. 2CH2O --> CH4 + CO2. + + + ! Decomposition uses 1 mol O2 per mol CO2 produced (happens below WT also, to deplete O2 below WT) + ! o2_decomp_depth is the demand in the absense of O2 supply limitation, in addition to autotrophic respiration. + ! Competition will be done in ch4_oxid + + o2_decomp_depth(c,j) = base_decomp * partition_z / dz (c,j) + if (anoxia) then + ! Divide off o_scalar to use potential O2-unlimited HR to represent aerobe demand for oxygen competition + if (.not. lake .and. j > nlevdecomp) then + if (o_scalar(c,1) > 0._r8) then + o2_decomp_depth(c,j) = o2_decomp_depth(c,j) / o_scalar(c,1) + end if + else if (.not. lake) then ! j == 1 or VERTSOILC + if (o_scalar(c,j) > 0._r8) then + o2_decomp_depth(c,j) = o2_decomp_depth(c,j) / o_scalar(c,j) + end if + end if + end if ! anoxia + + ! Add root respiration + if (.not. lake) then + o2_decomp_depth(c,j) = o2_decomp_depth(c,j) + rr_vr(c,j)/catomw/dz(c,j) ! mol/m^3/s + ! g C/m2/s ! gC/mol O2 ! m + end if + + ! Add oxygen demand for nitrification + if (use_nitrif_denitrif) then + if (.not. lake .and. j<= nlevdecomp_full ) then + o2_decomp_depth(c,j) = o2_decomp_depth(c,j) + pot_f_nit_vr(c,j) * 2.0_r8/14.0_r8 + ! g N/m^3/s mol O2 / g N + end if + end if + + if (j > jwt(c)) then ! Below the water table so anaerobic CH4 production can occur + ! partition decomposition to layer + ! turn into per volume-total by dz + ch4_prod_depth(c,j) = f_ch4_adj * base_decomp * partition_z / dz (c,j)! [mol/m3-total/s] + else ! Above the WT + if (anoxicmicrosites) then + ch4_prod_depth(c,j) = f_ch4_adj * base_decomp * partition_z / dz (c,j) & + / (1._r8 + oxinhib*conc_o2(c,j)) + else + ch4_prod_depth(c,j) = 0._r8 ! [mol/m3 total/s] + endif ! anoxicmicrosites + endif ! WT + + end do ! fc + end do ! nlevsoi + + end associate + + end subroutine ch4_prod + + !----------------------------------------------------------------------- + subroutine ch4_oxid (bounds, & + num_methc, filter_methc, & + jwt, sat, lake, & + waterstatebulk_inst, soilstate_inst, temperature_inst, ch4_inst) + ! + ! !DESCRIPTION: + ! Oxidation is based on double Michaelis-Mentin kinetics, and is adjusted for low soil moisture. + ! Oxidation will be limited by available oxygen in ch4_tran. + + ! !USES: + use clm_time_manager, only : get_step_size_real + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_methc ! number of column soil points in column filter + integer , intent(in) :: filter_methc(:) ! column filter for soil points + integer , intent(in) :: jwt( bounds%begc: ) ! index of the soil layer right above the water table (-) [col] + integer , intent(in) :: sat ! 0 = unsaturated; 1 = saturated + logical , intent(in) :: lake ! function called with lake filter + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(ch4_type) , intent(in) :: ch4_inst + ! + ! !LOCAL VARIABLES: + integer :: c,j ! indices + integer :: fc ! column index + real(r8) :: dtime ! land model time step (sec) + real(r8):: t0 ! Base temperature for Q10 + real(r8):: porevol ! air-filled volume ratio to total soil volume + real(r8):: h2osoi_vol_min ! h2osoi_vol restricted to be below watsat + real(r8):: conc_ch4_rel ! concentration with respect to water volume (mol/m^3 water) + real(r8):: conc_o2_rel ! concentration with respect to water volume (mol/m^3 water) + real(r8):: oxid_a ! Oxidation predicted by method A (temperature & enzyme limited) (mol CH4/m3/s) + real(r8):: smp_fact ! factor for reduction based on soil moisture (unitless) + real(r8):: porewatfrac ! fraction of soil pore space that is filled with water + real(r8):: k_h_cc, k_h_inv ! see functions below for description + real(r8):: k_m_eff ! effective k_m + real(r8):: vmax_eff ! effective vmax + ! ch4 oxidation parameters + real(r8) :: vmax_ch4_oxid ! oxidation rate constant (= 45.e-6_r8 * 1000._r8 / 3600._r8) [mol/m3-w/s]; + real(r8) :: k_m ! Michaelis-Menten oxidation rate constant for CH4 concentration + real(r8) :: q10_ch4oxid ! Q10 oxidation constant + real(r8) :: smp_crit ! Critical soil moisture potential + real(r8) :: k_m_o2 ! Michaelis-Menten oxidation rate constant for O2 concentration + real(r8) :: k_m_unsat ! Michaelis-Menten oxidation rate constant for CH4 concentration + real(r8) :: vmax_oxid_unsat ! (= 45.e-6_r8 * 1000._r8 / 3600._r8 / 10._r8) [mol/m3-w/s] + ! + real(r8), pointer :: ch4_oxid_depth(:,:) + real(r8), pointer :: o2_oxid_depth(:,:) + real(r8), pointer :: co2_oxid_depth(:,:) + real(r8), pointer :: o2_decomp_depth(:,:) + real(r8), pointer :: conc_o2(:,:) + real(r8), pointer :: conc_ch4(:,:) + !----------------------------------------------------------------------- + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(jwt) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + + smp_l => soilstate_inst%smp_l_col , & ! Input: [real(r8) (: ,:) ] soil matrix potential [mm] + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) + + t_soisno => temperature_inst%t_soisno_col & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevsoi) + ) + + if (sat == 0) then ! unsaturated + ch4_oxid_depth => ch4_inst%ch4_oxid_depth_unsat_col ! Output: [real(r8) (:,:)] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + o2_oxid_depth => ch4_inst%o2_oxid_depth_unsat_col ! Output: [real(r8) (:,:)] O2 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + co2_oxid_depth => ch4_inst%co2_oxid_depth_unsat_col ! Output: [real(r8) (:,:)] CO2 production rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + conc_ch4 => ch4_inst%conc_ch4_unsat_col ! Input: [real(r8) (:,:)] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_o2 => ch4_inst%conc_o2_unsat_col ! Input: [real(r8) (:,:)] O2 conc in each soil layer (mol/m3) (nlevsoi) + o2_decomp_depth => ch4_inst%o2_decomp_depth_unsat_col ! Output: [real(r8) (:,:)] O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + else ! saturated + ch4_oxid_depth => ch4_inst%ch4_oxid_depth_sat_col ! Output: [real(r8) (:,:)] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + o2_oxid_depth => ch4_inst%o2_oxid_depth_sat_col ! Output: [real(r8) (:,:)] O2 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + co2_oxid_depth => ch4_inst%co2_oxid_depth_sat_col ! Output: [real(r8) (:,:)] CO2 production rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + conc_ch4 => ch4_inst%conc_ch4_sat_col ! Input: [real(r8) (:,:)] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_o2 => ch4_inst%conc_o2_sat_col ! Input: [real(r8) (:,:)] O2 conc in each soil layer (mol/m3) (nlevsoi) + o2_decomp_depth => ch4_inst%o2_decomp_depth_sat_col ! Output: [real(r8) (:,:)] O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + endif + + ! Get land model time step + dtime = get_step_size_real() + + ! Set oxidation parameters + vmax_ch4_oxid = params_inst%vmax_ch4_oxid + k_m = params_inst%k_m + q10_ch4oxid = params_inst%q10_ch4oxid + smp_crit = params_inst%smp_crit + k_m_o2 = params_inst%k_m_o2 + k_m_unsat = params_inst%k_m_unsat + vmax_oxid_unsat = params_inst%vmax_oxid_unsat + + t0 = tfrz + 12._r8 ! Walter, for Michigan site where the 45 M/h comes from + + ! Loop to determine oxidation in each layer + do j=1,nlevsoi + do fc = 1, num_methc + c = filter_methc(fc) + + if (sat == 1 .or. j > jwt(c)) then + ! Literature (e.g. Bender & Conrad, 1992) suggests lower k_m and vmax for high-CH4-affinity methanotrophs in + ! upland soils consuming ambient methane. + k_m_eff = k_m + vmax_eff = vmax_ch4_oxid + else + k_m_eff = k_m_unsat + vmax_eff = vmax_oxid_unsat + end if + + porevol = max(watsat(c,j) - h2osoi_vol(c,j), 0._r8) + h2osoi_vol_min = min(watsat(c,j), h2osoi_vol(c,j)) + if (j <= jwt(c) .and. smp_l(c,j) < 0._r8) then + smp_fact = exp(-smp_l(c,j)/smp_crit) + ! Schnell & King, 1996, Figure 3 + else + smp_fact = 1._r8 + end if + + if (j <= jwt(c)) then ! Above the water table + k_h_inv = exp(-c_h_inv(1) * (1._r8 / t_soisno(c,j) - 1._r8 / kh_tbase) + log (kh_theta(1))) + k_h_cc = t_soisno(c,j) / k_h_inv * rgasLatm ! (4.21) Wania [(mol/m3w) / (mol/m3g)] + conc_ch4_rel = conc_ch4(c,j) / (h2osoi_vol_min + porevol/k_h_cc) + + k_h_inv = exp(-c_h_inv(2) * (1._r8 / t_soisno(c,j) - 1._r8 / kh_tbase) + log (kh_theta(2))) + k_h_cc = t_soisno(c,j) / k_h_inv * rgasLatm ! (4.21) Wania [(mol/m3w) / (mol/m3g)] + conc_o2_rel = conc_o2(c,j) / (h2osoi_vol_min + porevol/k_h_cc) + else + conc_ch4_rel = conc_ch4(c,j) / watsat(c,j) + conc_o2_rel = conc_o2(c,j) / watsat(c,j) + endif + + oxid_a = vmax_eff * h2osoi_vol_min* conc_ch4_rel / (k_m_eff + conc_ch4_rel) & + ![mol/m3-t/s] [mol/m3-w/s] [m3-w/m3-t] [mol/m3-w] [mol/m3-w] [mol/m3-w] + * conc_o2_rel / (k_m_o2 + conc_o2_rel) & + * q10_ch4oxid ** ((t_soisno(c,j) - t0) / 10._r8) * smp_fact + + ! For all landunits / levels, prevent oxidation if at or below freezing + if (t_soisno(c,j) <= tfrz) oxid_a = 0._r8 + + ch4_oxid_depth(c,j) = oxid_a + o2_oxid_depth(c,j) = ch4_oxid_depth(c,j) * 2._r8 + + end do + end do + + end associate + end subroutine ch4_oxid + + !----------------------------------------------------------------------- + subroutine ch4_aere (bounds, num_methc, filter_methc, num_methp, filter_methp, & + annsum_npp, jwt, sat, lake, & + canopystate_inst, soilstate_inst, temperature_inst, energyflux_inst, & + waterstatebulk_inst, waterfluxbulk_inst, ch4_inst) + ! + ! !DESCRIPTION: + ! Arctic c3 grass (which is often present in fens) and all vegetation in inundated areas is assumed to have + ! some root porosity. Currently, root porosity is allowed to be different for grasses & non-grasses. + ! CH4 diffuses out and O2 diffuses into the soil. CH4 is also lossed via transpiration, which is both + ! included in the "aere" variables and output separately. In practice this value is small. + ! By default upland veg. has small 5% porosity but this can be switched to be equal to inundated porosity. + + ! !USES: + use clm_varcon , only : rpi + use clm_time_manager , only : get_step_size_real + use pftconMod , only : nc3_arctic_grass, nc3_nonarctic_grass, nc4_grass, noveg, pftcon + use ch4varcon , only : transpirationloss, use_aereoxid_prog + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_methc ! number of column soil points in column filter + integer , intent(in) :: filter_methc(:) ! column filter for soil points + integer , intent(in) :: num_methp ! number of soil points in patch filter + integer , intent(in) :: filter_methp(:) ! patch filter for soil points + real(r8) , intent(in) :: annsum_npp( bounds%begp: ) ! annual sum NPP (gC/m2/yr) + integer , intent(in) :: jwt( bounds%begc: ) ! index of the soil layer right above the water table (-) [col] + integer , intent(in) :: sat ! 0 = unsaturated; 1 = saturated + logical , intent(in) :: lake ! function called with lake filter + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(energyflux_type) , intent(in) :: energyflux_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + type(ch4_type) , intent(inout) :: ch4_inst + ! + ! !LOCAL VARIABLES: + integer :: p,c,g,j ! indices + integer :: fc,fp ! soil filter column index + integer :: itype ! temporary + real(r8) :: f_oxid ! fraction of CH4 oxidized in oxic zone around roots + real(r8) :: diffus_aere ! gas diffusivity through aerenchyma (m^2/s) + real(r8) :: m_tiller + real(r8) :: n_tiller + real(r8) :: poros_tiller + real(r8) :: rob ! root obliquity, e.g. csc of root angle relative to vertical + ! (ratio of root total length to depth) + real(r8) :: area_tiller ! cross-sectional area of tillers (m^2/m^2) + real(r8) :: tranloss ! loss due to transpiration (mol / m3 /s) + real(r8) :: aere, aeretran, oxaere ! (mol / m3 /s) + real(r8) :: k_h_cc, k_h_inv, dtime, oxdiffus, anpp, nppratio, h2osoi_vol_min, conc_ch4_wat + real(r8) :: aerecond ! aerenchyma conductance (m/s) + ! ch4 aerenchyma parameters + real(r8) :: aereoxid ! fraction of methane flux entering aerenchyma rhizosphere + real(r8) :: scale_factor_aere ! scale factor on the aerenchyma area for sensitivity tests + real(r8) :: nongrassporosratio ! Ratio of root porosity in non-grass to grass, used for aerenchyma transport + real(r8) :: unsat_aere_ratio ! Ratio to multiply upland vegetation aerenchyma porosity by compared to inundated systems (= 0.05_r8 / 0.3_r8) + real(r8) :: porosmin ! minimum aerenchyma porosity (unitless)(= 0.05_r8) + + real(r8), parameter :: smallnumber = 1.e-12_r8 + + real(r8), pointer :: ch4_aere_depth(:,:) + real(r8), pointer :: ch4_tran_depth(:,:) + real(r8), pointer :: o2_aere_depth(:,:) + real(r8), pointer :: co2_aere_depth(:,:) + real(r8), pointer :: ch4_oxid_depth(:,:) + real(r8), pointer :: ch4_prod_depth(:,:) + real(r8), pointer :: conc_o2(:,:) + real(r8), pointer :: conc_ch4(:,:) + !----------------------------------------------------------------------- + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(annsum_npp) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(jwt) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + z => col%z , & ! Input: [real(r8) (:,:) ] layer depth (m) (-nlevsno+1:nlevsoi) + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) (-nlevsno+1:nlevsoi) + wtcol => patch%wtcol , & ! Input: [real(r8) (:) ] weight (relative to column) + + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevsoi) + + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) + rootr => soilstate_inst%rootr_patch , & ! Input: [real(r8) (:,:) ] effective fraction of roots in each soil layer (SMS method only) (nlevgrnd) + rootfr => soilstate_inst%rootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer (nlevsoi) + + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + + qflx_tran_veg => waterfluxbulk_inst%qflx_tran_veg_patch , & ! Input: [real(r8) (:) ] vegetation transpiration (mm H2O/s) (+ = to atm) + + canopy_cond => energyflux_inst%canopy_cond_patch , & ! Input: [real(r8) (:) ] tracer conductance for canopy [m/s] + + annavg_agnpp => ch4_inst%annavg_agnpp_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) annual average aboveground NPP + annavg_bgnpp => ch4_inst%annavg_bgnpp_patch , & ! Input: [real(r8) (:) ] (gC/m2/s) annual average belowground NPP + grnd_ch4_cond => ch4_inst%grnd_ch4_cond_patch , & ! Input: [real(r8) (:) ] tracer conductance for boundary layer [m/s] + c_atm => ch4_inst%c_atm_grc & ! Input: [real(r8) (: ,:) ] CH4, O2, CO2 atmospheric conc (mol/m3) + ) + + if (sat == 0) then ! unsaturated + ch4_aere_depth => ch4_inst%ch4_aere_depth_unsat_col ! Output: [real(r8) (:,:)] CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + ch4_tran_depth => ch4_inst%ch4_tran_depth_unsat_col ! Output: [real(r8) (:,:)] CH4 loss rate via transpiration in each soil layer (mol/m3/s) (nlevsoi) + o2_aere_depth => ch4_inst%o2_aere_depth_unsat_col ! Output: [real(r8) (:,:)] O2 gain rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + co2_aere_depth => ch4_inst%co2_aere_depth_unsat_col ! Output: [real(r8) (:,:)] CO2 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + conc_ch4 => ch4_inst%conc_ch4_unsat_col ! Input: [real(r8) (:,:)] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_o2 => ch4_inst%conc_o2_unsat_col ! Input: [real(r8) (:,:)] O2 conc in each soil layer (mol/m3) (nlevsoi) + ch4_oxid_depth => ch4_inst%ch4_oxid_depth_unsat_col ! Input: [real(r8) (:,:)] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + ch4_prod_depth => ch4_inst%ch4_prod_depth_unsat_col ! Input: [real(r8) (:,:)] production of CH4 in each soil layer (nlevsoi) (mol/m3/s) + else ! saturated + ch4_aere_depth => ch4_inst%ch4_aere_depth_sat_col ! Output: [real(r8) (:,:)] CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + ch4_tran_depth => ch4_inst%ch4_tran_depth_sat_col ! Output: [real(r8) (:,:)] CH4 loss rate via transpiration in each soil layer (mol/m3/s) (nlevsoi) + o2_aere_depth => ch4_inst%o2_aere_depth_sat_col ! Output: [real(r8) (:,:)] O2 gain rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + co2_aere_depth => ch4_inst%co2_aere_depth_sat_col ! Output: [real(r8) (:,:)] CO2 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + conc_ch4 => ch4_inst%conc_ch4_sat_col ! Input: [real(r8) (:,:)] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_o2 => ch4_inst%conc_o2_sat_col ! Input: [real(r8) (:,:)] O2 conc in each soil layer (mol/m3) (nlevsoi) + ch4_oxid_depth => ch4_inst%ch4_oxid_depth_sat_col ! Input: [real(r8) (:,:)] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + ch4_prod_depth => ch4_inst%ch4_prod_depth_sat_col ! Input: [real(r8) (:,:)] production of CH4 in each soil layer (nlevsoi) (mol/m3/s) + endif + + dtime = get_step_size_real() + + ! Set aerenchyma parameters + aereoxid = params_inst%aereoxid + scale_factor_aere = params_inst%scale_factor_aere + nongrassporosratio = params_inst%nongrassporosratio + unsat_aere_ratio = params_inst%unsat_aere_ratio + porosmin = params_inst%porosmin + rob = params_inst%rob + + ! Initialize ch4_aere_depth + do j=1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + ch4_aere_depth(c,j) = 0._r8 + ch4_tran_depth(c,j) = 0._r8 + o2_aere_depth(c,j) = 0._r8 + end do + end do + + diffus_aere = d_con_g(1,1)*1.e-4_r8 ! for CH4: m^2/s + ! This parameter is poorly constrained and should be done on a patch-specific basis... + + ! point loop to partition aerenchyma flux into each soil layer + if (.not. lake) then + do j=1,nlevsoi + do fp = 1, num_methp + p = filter_methp (fp) + c = patch%column(p) + g = col%gridcell(c) + + ! Calculate transpiration loss + if (transpirationloss .and. patch%itype(p) /= noveg) then !allow tloss above WT ! .and. j > jwt(c)) then + ! Calculate water concentration + h2osoi_vol_min = min(watsat(c,j), h2osoi_vol(c,j)) + k_h_inv = exp(-c_h_inv(1) * (1._r8 / t_soisno(c,j) - 1._r8 / kh_tbase) + log (kh_theta(1))) + k_h_cc = t_soisno(c,j) / k_h_inv * rgasLatm + conc_ch4_wat = conc_ch4(c,j) / ( (watsat(c,j)-h2osoi_vol_min)/k_h_cc + h2osoi_vol_min) + + tranloss = conc_ch4_wat * rootr(p,j)*qflx_tran_veg(p) / dz(c,j) / 1000._r8 + ! mol/m3/s mol/m3 mm / s m mm/m + ! Use rootr here for effective per-layer transpiration, which may not be the same as rootfr + tranloss = max(tranloss, 0._r8) ! in case transpiration is pathological + else + tranloss = 0._r8 + end if + + ! Calculate aerenchyma diffusion + if (j > jwt(c) .and. t_soisno(c,j) > tfrz .and. patch%itype(p) /= noveg) then + ! Attn EK: This calculation of aerenchyma properties is very uncertain. Let's check in once all + ! the new components are in; if there is any tuning to be done to get a realistic global flux, + ! this would probably be the place. We will have to document clearly in the Tech Note + ! any major changes from the Riley et al. 2011 version. (There are a few other minor ones.) + + anpp = annsum_npp(p) ! g C / m^2/yr + anpp = max(anpp, 0._r8) ! NPP can be negative b/c of consumption of storage pools + + if (annavg_agnpp(p) /= spval .and. annavg_bgnpp(p) /= spval .and. & + annavg_agnpp(p) > 0._r8 .and. annavg_bgnpp(p) > 0._r8) then + nppratio = annavg_bgnpp(p) / (annavg_agnpp(p) + annavg_bgnpp(p)) + else + nppratio = 0.5_r8 + end if + + ! Estimate area of tillers (see Wania thesis) + ! m_tiller = anpp * r_leaf_root * lai ! (4.17 Wania) + ! m_tiller = 600._r8 * 0.5_r8 * 2._r8 ! used to be 300 + ! Note: this calculation is based on Arctic graminoids, and should be refined for woody plants, if not + ! done on a patch-specific basis. + + m_tiller = anpp * nppratio * 4._r8 !replace the elai(p) by constant 4 (by Xiyan Xu, 05/2016) + + n_tiller = m_tiller / 0.22_r8 + + itype = patch%itype(p) + if (itype == nc3_arctic_grass .or. pftcon%crop(itype) == 1 .or. & + itype == nc3_nonarctic_grass .or. itype == nc4_grass) then + poros_tiller = 0.3_r8 ! Colmer 2003 + else + poros_tiller = 0.3_r8 * nongrassporosratio + end if + + if (sat == 0) then + poros_tiller = poros_tiller * unsat_aere_ratio + end if + + poros_tiller = max(poros_tiller, porosmin) + + area_tiller = scale_factor_aere * n_tiller * poros_tiller * rpi * 2.9e-3_r8**2._r8 ! (m2/m2) + + k_h_inv = exp(-c_h_inv(1) * (1._r8 / t_soisno(c,j) - 1._r8 / kh_tbase) + log (kh_theta(1))) ! (4.12) Wania (L atm/mol) + k_h_cc = t_soisno(c,j) / k_h_inv * rgasLatm ! (4.21) Wania [(mol/m3w) / (mol/m3g)] + aerecond = area_tiller * rootfr(p,j) * diffus_aere / (z(c,j)*rob) + ! Add in boundary layer resistance + aerecond = 1._r8 / (1._r8/(aerecond+smallnumber) + 1._r8/(grnd_ch4_cond(p)+smallnumber)) + + aere = aerecond * (conc_ch4(c,j)/watsat(c,j)/k_h_cc - c_atm(g,1)) / dz(c,j) ![mol/m3-total/s] + !ZS: Added watsat & Henry's const. + aere = max(aere, 0._r8) ! prevent backwards diffusion + + ! Do oxygen diffusion into layer + k_h_inv = exp(-c_h_inv(2) * (1._r8 / t_soisno(c,j) - 1._r8 / kh_tbase) + log (kh_theta(2))) + k_h_cc = t_soisno(c,j) / k_h_inv * rgasLatm ! (4.21) Wania [(mol/m3w) / (mol/m3g)] + oxdiffus = diffus_aere * d_con_g(2,1) / d_con_g(1,1) ! adjust for O2:CH4 molecular diffusion + aerecond = area_tiller * rootfr(p,j) * oxdiffus / (z(c,j)*rob) + aerecond = 1._r8 / (1._r8/(aerecond+smallnumber) + 1._r8/(grnd_ch4_cond(p)+smallnumber)) + oxaere = -aerecond *(conc_o2(c,j)/watsat(c,j)/k_h_cc - c_atm(g,2)) / dz(c,j) ![mol/m3-total/s] + oxaere = max(oxaere, 0._r8) + ! Diffusion in is positive; prevent backwards diffusion + if ( .not. use_aereoxid_prog ) then ! fixed aere oxid proportion; will be done in ch4_tran + oxaere = 0._r8 + end if + else + aere = 0._r8 + oxaere = 0._r8 + end if ! veg type, below water table, & above freezing + + ! Impose limitation based on available methane during timestep + ! By imposing the limitation here, don't allow aerenchyma access to methane from other Patches. + aeretran = min(aere+tranloss, conc_ch4(c,j)/dtime + ch4_prod_depth(c,j)) + ch4_aere_depth (c, j) = ch4_aere_depth(c,j) + aeretran*wtcol(p) ! patch weight in col. + ch4_tran_depth (c, j) = ch4_tran_depth(c,j) + min(tranloss, aeretran)*wtcol(p) + o2_aere_depth (c, j) = o2_aere_depth (c,j) + oxaere*wtcol(p) + end do ! p filter + end do ! over levels + end if ! not lake + + end associate + + end subroutine ch4_aere + + !----------------------------------------------------------------------- + subroutine ch4_ebul (bounds, & + num_methc, filter_methc, & + jwt, sat, lake, & + atm2lnd_inst, temperature_inst, lakestate_inst, soilstate_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, & + ch4_inst) + ! + ! !DESCRIPTION: + ! Bubbling is based on temperature & pressure dependent solubility (k_h_cc), + ! with assumed proportion of bubbles + ! which are CH4, and assumed early nucleation at vgc_max sat (Wania). + ! Bubbles are released to the water table surface in ch4_tran. + + ! !USES: + use clm_time_manager , only : get_step_size_real + use LakeCon + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_methc ! number of column soil points in column filter + integer , intent(in) :: filter_methc(:) ! column filter for soil points + integer , intent(in) :: jwt( bounds%begc: ) ! index of the soil layer right above the water table (-) [col] + integer , intent(in) :: sat ! 0 = unsaturated; 1 = saturated + logical , intent(in) :: lake ! function called with lake filter + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(temperature_type) , intent(in) :: temperature_inst + type(lakestate_type) , intent(in) :: lakestate_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(ch4_type) , intent(inout) :: ch4_inst + ! + ! !LOCAL VARIABLES: + integer :: c,j ! indices + integer :: fc ! soil filter column index + integer :: fp ! soil filter patch index + real(r8) :: dtime ! land model time step (sec) + real(r8) :: vgc ! volumetric CH4 content (m3 CH4/m3 pore air) + real(r8) :: vgc_min ! minimum aqueous CH4 content when ebullition ceases + real(r8) :: k_h_inv ! + real(r8) :: k_h ! + real(r8) :: k_h_cc ! + real(r8) :: pressure! sum atmospheric and hydrostatic pressure + real(r8) :: bubble_f! CH4 content in gas bubbles (Kellner et al. 2006) + real(r8) :: ebul_timescale + real(r8) :: vgc_max ! ratio of saturation pressure triggering ebullition + real(r8), pointer :: ch4_ebul_depth(:,:) ! backwards compatibility + real(r8), pointer :: ch4_ebul_total(:) ! backwards compatibility + real(r8), pointer :: conc_ch4(:,:) ! backwards compatibility + real(r8), pointer :: ch4_aere_depth(:,:) ! backwards compatibility + real(r8), pointer :: ch4_oxid_depth(:,:) ! backwards compatibility + !----------------------------------------------------------------------- + + ! Enforce expected array sizes + SHR_ASSERT_ALL_FL((ubound(jwt) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + z => col%z , & ! Input: [real(r8) (:,:) ] soil layer depth (m) + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) (-nlevsno+1:nlevsoi) + zi => col%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) + lakedepth => col%lakedepth , & ! Input: [real(r8) (:) ] column lake depth (m) + + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevsoi) + + lake_icefrac => lakestate_inst%lake_icefrac_col , & ! Input: [real(r8) (:,:) ] mass fraction of lake layer that is frozen + + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) + + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + h2osfc => waterstatebulk_inst%h2osfc_col , & ! Input: [real(r8) (:) ] surface water (mm) + frac_h2osfc => waterdiagnosticbulk_inst%frac_h2osfc_col & ! Input: [real(r8) (:) ] fraction of ground covered by surface water (0 to 1) + ) + + if (sat == 0) then ! unsaturated + ch4_ebul_depth => ch4_inst%ch4_ebul_depth_unsat_col ! Output: [real(r8) (:,:)] CH4 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) + ch4_ebul_total => ch4_inst%ch4_ebul_total_unsat_col ! Output: [real(r8) (:)] Total column CH4 ebullition (mol/m2/s) + conc_ch4 => ch4_inst%conc_ch4_unsat_col ! Output: [real(r8) (:,:)] CH4 conc in each soil layer (mol/m3) (nlevsoi) + ch4_aere_depth => ch4_inst%ch4_aere_depth_unsat_col ! Input: [real(r8) (:,:)] CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + ch4_oxid_depth => ch4_inst%ch4_oxid_depth_unsat_col ! Input: [real(r8) (:,:)] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + else ! saturated + ch4_ebul_depth => ch4_inst%ch4_ebul_depth_sat_col ! Output: [real(r8) (:,:)] CH4 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) + ch4_ebul_total => ch4_inst%ch4_ebul_total_sat_col ! Output: [real(r8) (:)] Total column CH4 ebullition (mol/m2/s) + conc_ch4 => ch4_inst%conc_ch4_sat_col ! Output: [real(r8) (:,:)] CH4 conc in each soil layer (mol/m3) (nlevsoi) + ch4_aere_depth => ch4_inst%ch4_aere_depth_sat_col ! Input: [real(r8) (:,:)] CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + ch4_oxid_depth => ch4_inst%ch4_oxid_depth_sat_col ! Input: [real(r8) (:,:)] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + endif + + ! Get land model time step + dtime = get_step_size_real() + vgc_max = params_inst%vgc_max + + bubble_f = 0.57_r8 ! CH4 content in gas bubbles (Kellner et al. 2006) + vgc_min = vgc_max + ebul_timescale = dtime ! Allow fast bubbling + + ! column loop to estimate ebullition CH4 flux from each soil layer + do j=1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + + if (j > jwt(c) .and. t_soisno(c,j) > tfrz) then ! Ebullition occurs only below the water table + + k_h_inv = exp(-c_h_inv(1) * (1._r8 / t_soisno(c,j) - 1._r8 / kh_tbase) + log (kh_theta(1))) ! (4.12 Wania) (atm.L/mol) + k_h = 1._r8 / k_h_inv ! (mol/L.atm) + k_h_cc = t_soisno(c,j) * k_h * rgasLatm ! (4.21) Wania [(mol/m3w) / (mol/m3g)] + + if (.not. lake) then + pressure = forc_pbot(c) + denh2o * grav * (z(c,j)-zi(c,jwt(c))) ! (Pa) + if (sat == 1 .and. frac_h2osfc(c) > 0._r8) then ! Add ponding pressure head + pressure = pressure + denh2o * grav * h2osfc(c)/1000._r8/frac_h2osfc(c) + ! mm / mm/m + end if + else + pressure = forc_pbot(c) + denh2o * grav * (z(c,j) + lakedepth(c)) + end if + + ! Compare partial pressure to ambient pressure. + vgc = conc_ch4(c,j) / watsat(c,j) / k_h_cc * rgasm * t_soisno(c,j) / pressure + ! [mol/m3t] [m3w/m3t] [m3g/m3w] [Pa/(mol/m3g)] [Pa] + + if (vgc > vgc_max * bubble_f) then ! If greater than max value, remove amount down to vgc_min + ch4_ebul_depth (c,j) = (vgc - vgc_min * bubble_f) * conc_ch4(c,j) / ebul_timescale + ! [mol/m3t/s] [mol/m3t] [s] + else + ch4_ebul_depth (c,j) = 0._r8 + endif + + else ! above the water table or freezing + ch4_ebul_depth (c,j) = 0._r8 + endif ! below the water table and not freezing + + ! Prevent ebullition from reaching the surface for frozen lakes + if (lake .and. lake_icefrac(c,1) > 0.1_r8) ch4_ebul_depth(c,j) = 0._r8 + + end do ! fc + end do ! j + + end associate + + end subroutine ch4_ebul + + !----------------------------------------------------------------------- + subroutine ch4_tran (bounds, & + num_methc, filter_methc, & + jwt, dtime_ch4, sat, lake, & + soilstate_inst, temperature_inst, waterstatebulk_inst, waterdiagnosticbulk_inst, energyflux_inst, ch4_inst) + ! + ! !DESCRIPTION: + ! Solves the reaction & diffusion equation for the timestep. First "competition" between processes for + ! CH4 & O2 demand is done. Then concentrations are apportioned into gas & liquid fractions; only the gas + ! fraction is considered for diffusion in unsat. Snow and lake water resistance to diffusion is added as + ! a bulk term in the ground conductance (which is really a surface layer conductance), but concentrations + ! are not tracked and oxidation is not allowed inside snow and lake water. + ! Diffusivity is set based on soil texture and organic matter fraction. A Crank-Nicholson solution is used. + ! Then CH4 diffusive flux is calculated and consistency is checked. + + ! !USES: + use clm_time_manager , only : get_step_size_real, get_nstep + use TridiagonalMod , only : Tridiagonal + use ch4varcon , only : ch4frzout, use_aereoxid_prog + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_methc ! number of column soil points in column filter + integer , intent(in) :: filter_methc(:) ! column filter for soil points + integer , intent(in) :: jwt( bounds%begc: ) ! index of the soil layer right above the water table (-) [col] + integer , intent(in) :: sat ! 0 = unsaturated; 1 = saturated + logical , intent(in) :: lake ! function called with lake filter + real(r8) , intent(in) :: dtime_ch4 ! time step for ch4 calculations + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(energyflux_type) , intent(in) :: energyflux_inst + type(ch4_type) , intent(inout) :: ch4_inst + ! + ! !LOCAL VARIABLES: + integer :: c,j,g,p,s,i,ll ! indices + integer :: fc ! soil filter column index + integer :: fp ! soil filter patch index + integer :: jtop(bounds%begc:bounds%endc) ! top level at each column + integer :: iter ! iteration counter when dtime_ch4 < dtime + real(r8) :: dtime ! land model time step (sec) + real(r8) :: at (bounds%begc:bounds%endc,0:nlevsoi) ! "a" vector for tridiagonal matrix + real(r8) :: bt (bounds%begc:bounds%endc,0:nlevsoi) ! "b" vector for tridiagonal matrix + real(r8) :: ct (bounds%begc:bounds%endc,0:nlevsoi) ! "c" vector for tridiagonal matrix + real(r8) :: rt (bounds%begc:bounds%endc,0:nlevsoi) ! "r" vector for tridiagonal solution + real(r8) :: f_a ! air-filled fraction of available pore space + real(r8) :: diffus (bounds%begc:bounds%endc,0:nlevsoi) ! diffusivity (m2/s) + real(r8) :: k_h_inv ! 1/Henry's Law Constant in Latm/mol + real(r8) :: k_h_cc(bounds%begc:bounds%endc,0:nlevsoi,ngases) ! ratio of mol/m3 in liquid to mol/m3 in gas + real(r8) :: dzj ! + real(r8) :: dp1_zp1 (bounds%begc:bounds%endc,0:nlevsoi) ! diffusivity/delta_z for next j + real(r8) :: dm1_zm1 (bounds%begc:bounds%endc,0:nlevsoi) ! diffusivity/delta_z for previous j + real(r8) :: t_soisno_c ! soil temperature (C) (-nlevsno+1:nlevsoi) + real(r8) :: eps ! either epsilon_a or epsilon_w, depending on where in soil, wrt WT + real(r8) :: deficit ! mol CH4 /m^2 that must be subtracted from diffusive flux to atm. to make up + ! for keeping concentrations always above zero + real(r8) :: conc_ch4_bef(bounds%begc:bounds%endc,1:nlevsoi) ! concentration at the beginning of the timestep + real(r8) :: errch4(bounds%begc:bounds%endc) ! Error (Mol CH4 /m^2) [+ = too much CH4] + real(r8) :: conc_ch4_rel(bounds%begc:bounds%endc,0:nlevsoi) ! Concentration per volume of air or water + real(r8) :: conc_o2_rel(bounds%begc:bounds%endc,0:nlevsoi) ! Concentration per volume of air or water + real(r8) :: conc_ch4_rel_old(bounds%begc:bounds%endc,0:nlevsoi) ! Concentration during last Crank-Nich. loop + real(r8) :: h2osoi_vol_min(bounds%begc:bounds%endc,1:nlevsoi) ! h2osoi_vol restricted to be <= watsat + real(r8), parameter :: smallnumber = 1.e-12_r8 + real(r8) :: snowdiff ! snow diffusivity (m^2/s) + real(r8) :: snowres(bounds%begc:bounds%endc) ! Cumulative Snow resistance (s/m). Also includes + real(r8) :: pondres ! Additional resistance from ponding, up to pondmx water on top of top soil layer (s/m) + real(r8) :: pondz ! Depth of ponding (m) + real(r8) :: ponddiff ! Pondwater diffusivity (m^2/s) + real(r8) :: spec_grnd_cond(bounds%begc:bounds%endc,1:ngases) ! species grnd conductance (s/m) + real(r8) :: airfrac ! air fraction in snow + real(r8) :: waterfrac ! water fraction in snow + real(r8) :: icefrac ! ice fraction in snow + real(r8) :: epsilon_t (bounds%begc:bounds%endc,1:nlevsoi,1:ngases) ! + real(r8) :: epsilon_t_old (bounds%begc:bounds%endc,1:nlevsoi,1:ngases) ! epsilon_t from last time step !Currently deprecated + real(r8) :: source (bounds%begc:bounds%endc,1:nlevsoi,1:ngases) ! source + real(r8) :: source_old (bounds%begc:bounds%endc,1:nlevsoi,1:ngases) ! source from last time step !Currently deprecated + real(r8) :: om_frac ! organic matter fraction + real(r8) :: o2demand, ch4demand ! mol/m^3/s + real(r8) :: liqfrac(bounds%begc:bounds%endc, 1:nlevsoi) + real(r8) :: capthick ! (mm) min thickness before assuming h2osfc is impermeable + real(r8) :: satpow ! exponent on watsat for saturated soil solute diffusion + real(r8) :: scale_factor_gasdiff ! For sensitivity tests; convection would allow this to be > 1 + real(r8) :: scale_factor_liqdiff ! For sensitivity tests; convection would allow this to be > 1 + real(r8) :: organic_max ! organic matter content (kg/m3) where soil is assumed to act like peat + real(r8) :: aereoxid ! fraction of methane flux entering aerenchyma rhizosphere + + real(r8), pointer :: ch4_prod_depth (:,:) + real(r8), pointer :: ch4_oxid_depth (:,:) + real(r8), pointer :: ch4_aere_depth (:,:) + real(r8), pointer :: ch4_surf_aere (:) + real(r8), pointer :: ch4_ebul_depth (:,:) + real(r8), pointer :: ch4_ebul_total (:) + real(r8), pointer :: ch4_surf_ebul (:) + real(r8), pointer :: ch4_surf_diff (:) + real(r8), pointer :: o2_oxid_depth (:,:) + real(r8), pointer :: o2_decomp_depth (:,:) + real(r8), pointer :: o2_aere_depth (:,:) + real(r8), pointer :: o2stress (:,:) + real(r8), pointer :: ch4stress (:,:) + real(r8), pointer :: co2_decomp_depth (:,:) + real(r8), pointer :: conc_o2 (:,:) + real(r8), pointer :: conc_ch4 (:,:) + + integer :: nstep ! time step number + character(len=32) :: subname='ch4_tran' ! subroutine name + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(jwt) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + z => col%z , & ! Input: [real(r8) (:,:) ] soil layer depth (m) + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) (-nlevsno+1:nlevsoi) + zi => col%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) + snl => col%snl , & ! Input: [integer (:) ] negative of number of snow layers + + bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" (nlevgrnd) + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) + cellorg => soilstate_inst%cellorg_col , & ! Input: [real(r8) (:,:) ] column 3D org (kg/m^3 organic matter) (nlevgrnd) + + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevsoi) + t_grnd => temperature_inst%t_grnd_col , & ! Input: [real(r8) (:) ] ground temperature (Kelvin) + t_h2osfc => temperature_inst%t_h2osfc_col , & ! Input: [real(r8) (:) ] surface water temperature + + frac_h2osfc => waterdiagnosticbulk_inst%frac_h2osfc_col , & ! Input: [real(r8) (:) ] fraction of ground covered by surface water (0 to 1) + snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + h2osoi_liq => waterstatebulk_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) [for snow & soil layers] + h2osoi_ice => waterstatebulk_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) [for snow & soil layers] + h2osfc => waterstatebulk_inst%h2osfc_col , & ! Input: [real(r8) (:) ] surface water (mm) + + c_atm => ch4_inst%c_atm_grc , & ! Input: [real(r8) (:,:) ] CH4, O2, CO2 atmospheric conc (mol/m3) + + grnd_ch4_cond => ch4_inst%grnd_ch4_cond_col & ! Output: [real(r8) (:) ] tracer conductance for boundary layer [m/s] + ) + + if (sat == 0) then ! unsaturated + o2_decomp_depth => ch4_inst%o2_decomp_depth_unsat_col ! Output: [real(r8) (:,:) ] O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + o2stress => ch4_inst%o2stress_unsat_col ! Output: [real(r8) (:,:) ] Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) + ch4_oxid_depth => ch4_inst%ch4_oxid_depth_unsat_col ! Output: [real(r8) (:,:) ] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + ch4_prod_depth => ch4_inst%ch4_prod_depth_unsat_col ! Output: [real(r8) (:,:) ] CH4 production rate from methanotrophs (mol/m3/s) (nlevsoi) + ch4_aere_depth => ch4_inst%ch4_aere_depth_unsat_col ! Output: [real(r8) (:,:) ] CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + ch4_surf_aere => ch4_inst%ch4_surf_aere_unsat_col ! Output: [real(r8) (:) ] Total column CH4 aerenchyma (mol/m2/s) + ch4_ebul_depth => ch4_inst%ch4_ebul_depth_unsat_col ! Output: [real(r8) (:,:) ] CH4 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) + ch4_ebul_total => ch4_inst%ch4_ebul_total_unsat_col ! Output: [real(r8) (:) ] Total column CH4 ebullition (mol/m2/s) + ch4_surf_ebul => ch4_inst%ch4_surf_ebul_unsat_col ! Output: [real(r8) (:) ] CH4 ebullition to atmosphere (mol/m2/s) + ch4_surf_diff => ch4_inst%ch4_surf_diff_unsat_col ! Output: [real(r8) (:) ] CH4 surface flux (mol/m2/s) + o2_oxid_depth => ch4_inst%o2_oxid_depth_unsat_col ! Output: [real(r8) (:,:) ] O2 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) + o2_aere_depth => ch4_inst%o2_aere_depth_unsat_col ! Output: [real(r8) (:,:) ] O2 gain rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + ch4stress => ch4_inst%ch4stress_unsat_col ! Output: [real(r8) (:,:) ] Ratio of methane available to the total per-timestep methane sinks (nlevsoi) + co2_decomp_depth => ch4_inst%co2_decomp_depth_unsat_col ! Output: [real(r8) (:,:) ] CO2 production during decomposition in each soil layer (nlevsoi) (mol/m3/s) + conc_ch4 => ch4_inst%conc_ch4_unsat_col ! Output: [real(r8) (:,:) ] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_o2 => ch4_inst%conc_o2_unsat_col ! Output: [real(r8) (:,:) ] O2 conc in each soil layer (mol/m3) (nlevsoi) + else ! saturated + o2_decomp_depth => ch4_inst%o2_decomp_depth_sat_col ! Output: [real(r8) (:,:) ] O2 consumption during decomposition in each soil layer (nlevsoi) (mol/m3/s) + o2stress => ch4_inst%o2stress_sat_col ! Output: [real(r8) (:,:) ] Ratio of oxygen available to that demanded by roots, aerobes, & methanotrophs (nlevsoi) + ch4_oxid_depth => ch4_inst%ch4_oxid_depth_sat_col ! Output: [real(r8) (:,:) ] CH4 consumption rate via oxidation in each soil layer (mol/m3/s) (nlevsoi) + ch4_prod_depth => ch4_inst%ch4_prod_depth_sat_col ! Output: [real(r8) (:,:) ] CH4 production rate from methanotrophs (mol/m3/s) (nlevsoi) + ch4_aere_depth => ch4_inst%ch4_aere_depth_sat_col ! Output: [real(r8) (:,:) ] CH4 loss rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + ch4_surf_aere => ch4_inst%ch4_surf_aere_sat_col ! Output: [real(r8) (:) ] Total column CH4 aerenchyma (mol/m2/s) + ch4_ebul_depth => ch4_inst%ch4_ebul_depth_sat_col ! Output: [real(r8) (:,:) ] CH4 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) + ch4_ebul_total => ch4_inst%ch4_ebul_total_sat_col ! Output: [real(r8) (:) ] Total column CH4 ebullition (mol/m2/s) + ch4_surf_ebul => ch4_inst%ch4_surf_ebul_sat_col ! Output: [real(r8) (:) ] CH4 ebullition to atmosphere (mol/m2/s) + ch4_surf_diff => ch4_inst%ch4_surf_diff_sat_col ! Output: [real(r8) (:) ] CH4 surface flux (mol/m2/s) + o2_oxid_depth => ch4_inst%o2_oxid_depth_sat_col ! Output: [real(r8) (:,:) ] O2 loss rate via ebullition in each soil layer (mol/m3/s) (nlevsoi) + o2_aere_depth => ch4_inst%o2_aere_depth_sat_col ! Output: [real(r8) (:,:) ] O2 gain rate via aerenchyma in each soil layer (mol/m3/s) (nlevsoi) + ch4stress => ch4_inst%ch4stress_sat_col ! Output: [real(r8) (:,:) ] Ratio of methane available to the total per-timestep methane sinks (nlevsoi) + co2_decomp_depth => ch4_inst%co2_decomp_depth_sat_col ! Output: [real(r8) (:,:) ] CO2 production during decomposition in each soil layer (nlevsoi) (mol/m3/s) + conc_ch4 => ch4_inst%conc_ch4_sat_col ! Output: [real(r8) (:,:) ] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_o2 => ch4_inst%conc_o2_sat_col ! Output: [real(r8) (:,:) ] O2 conc in each soil layer (mol/m3) (nlevsoi) + endif + + ! Get land model time step + dtime = get_step_size_real() + nstep = get_nstep() + + ! Set transport parameters + satpow = params_inst%satpow + scale_factor_gasdiff = params_inst%scale_factor_gasdiff + scale_factor_liqdiff = params_inst%scale_factor_liqdiff + capthick = params_inst%capthick + aereoxid = params_inst%aereoxid + + ! Set shared constant + organic_max = CNParamsShareInst%organic_max + + ! Perform competition for oxygen and methane in each soil layer if demands over the course of the timestep + ! exceed that available. Assign to each process in proportion to the quantity demanded in the absense of + ! the limitation. + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + + o2demand = o2_decomp_depth(c,j) + o2_oxid_depth(c,j) ! o2_decomp_depth includes autotrophic root respiration + if (o2demand > 0._r8) then + if ( (conc_o2(c,j) / dtime + o2_aere_depth(c,j)) > o2demand )then + o2stress(c,j) = 1._r8 + else + o2stress(c,j) = (conc_o2(c,j) / dtime + o2_aere_depth(c,j)) / o2demand + end if + else + o2stress(c,j) = 1._r8 + end if + + ch4demand = ch4_oxid_depth(c,j) + ch4_aere_depth(c,j) + ch4_ebul_depth(c,j) + if (ch4demand > 0._r8) then + ch4stress(c,j) = min((conc_ch4(c,j) / dtime + ch4_prod_depth(c,j)) / ch4demand, 1._r8) + else + ch4stress(c,j) = 1._r8 + end if + + ! Resolve methane oxidation + if (o2stress(c,j) < 1._r8 .or. ch4stress(c,j) < 1._r8) then + if (ch4stress(c,j) <= o2stress(c,j)) then ! methane limited + if (o2stress(c,j) < 1._r8) then + ! Recalculate oxygen limitation + o2demand = o2_decomp_depth(c,j) + if (o2demand > 0._r8) then + o2stress(c,j) = min( (conc_o2(c,j) / dtime + o2_aere_depth(c,j) - ch4stress(c,j)*o2_oxid_depth(c,j) ) & + / o2demand, 1._r8) + else + o2stress(c,j) = 1._r8 + end if + end if + ! Reset oxidation + ch4_oxid_depth(c,j) = ch4_oxid_depth(c,j) * ch4stress(c,j) + o2_oxid_depth(c,j) = o2_oxid_depth(c,j) * ch4stress(c,j) + else ! oxygen limited + if (ch4stress(c,j) < 1._r8) then + ! Recalculate methane limitation + ch4demand = ch4_aere_depth(c,j) + ch4_ebul_depth(c,j) + if (ch4demand > 0._r8) then + ch4stress(c,j) = min( (conc_ch4(c,j) / dtime + ch4_prod_depth(c,j) - & + o2stress(c,j)*ch4_oxid_depth(c,j)) / ch4demand, 1._r8) + else + ch4stress(c,j) = 1._r8 + end if + end if + ! Reset oxidation + ch4_oxid_depth(c,j) = ch4_oxid_depth(c,j) * o2stress(c,j) + o2_oxid_depth(c,j) = o2_oxid_depth(c,j) * o2stress(c,j) + end if + end if + + ! Reset non-methanotroph demands + ch4_aere_depth(c,j) = ch4_aere_depth(c,j) * ch4stress(c,j) + ch4_ebul_depth(c,j) = ch4_ebul_depth(c,j) * ch4stress(c,j) + o2_decomp_depth(c,j) = o2_decomp_depth(c,j) * o2stress(c,j) + + end do !c + end do !j + + + ! Accumulate ebullition to place in first layer above water table, or directly to atmosphere + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + if (j == 1) ch4_ebul_total(c) = 0._r8 + ch4_ebul_total(c) = ch4_ebul_total(c) + ch4_ebul_depth(c,j) * dz(c,j) + enddo + enddo + + + ! Set the Henry's Law coefficients + do j = 0,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + + do s=1,2 + if (j == 0) then + k_h_inv = exp(-c_h_inv(s) * (1._r8 / t_grnd(c) - 1._r8 / kh_tbase) + log (kh_theta(s))) + ! (4.12) Wania (L atm/mol) + k_h_cc(c,j,s) = t_grnd(c) / k_h_inv * rgasLatm ! (4.21) Wania [(mol/m3w) / (mol/m3g)] + else + k_h_inv = exp(-c_h_inv(s) * (1._r8 / t_soisno(c,j) - 1._r8 / kh_tbase) + log (kh_theta(s))) + ! (4.12) Wania (L atm/mol) + k_h_cc(c,j,s) = t_soisno(c,j) / k_h_inv * rgasLatm ! (4.21) Wania [(mol/m3w) / (mol/m3g)] + end if + end do + end do + end do + + + ! Set the source term for each species (no need to do j=0, since epsilon_t and source not used there) + ! Note that because of the semi-implicit diffusion and the 30 min timestep combined with explicit + ! sources, occasionally negative concentration will result. In this case it is brought to zero and the + ! surface flux is adjusted to conserve. This results in some inaccuracy as compared to a shorter timestep + ! or iterative solution. + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + + if ( .not. use_aereoxid_prog ) then + ! First remove the CH4 oxidation that occurs at the base of root tissues (aere), and add to oxidation + ch4_oxid_depth(c,j) = ch4_oxid_depth(c,j) + aereoxid * ch4_aere_depth(c,j) + ch4_aere_depth(c,j) = ch4_aere_depth(c,j) - aereoxid * ch4_aere_depth(c,j) + end if ! else oxygen is allowed to diffuse in via aerenchyma + + source(c,j,1) = ch4_prod_depth(c,j) - ch4_oxid_depth(c,j) - & + ch4_aere_depth(c,j) - ch4_ebul_depth(c,j) ! [mol/m3-total/s] + ! aerenchyma added to surface flux below + ! ebul added to soil depth just above WT + if (source(c,j,1) + conc_ch4(c,j) / dtime < -1.e-12_r8)then + write(iulog,*) 'Methane demands exceed methane available. Error in methane competition (mol/m^3/s), c,j:', & + source(c,j,1) + conc_ch4(c,j) / dtime, c, j + g = col%gridcell(c) + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(g),grc%londeg(g) + call endrun(msg=' ERROR: Methane demands exceed methane available.'& + //errMsg(sourcefile, __LINE__)) + else if (ch4stress(c,j) < 1._r8 .and. source(c,j,1) + conc_ch4(c,j) / dtime > 1.e-12_r8) then + write(iulog,*) 'Methane limited, yet some left over. Error in methane competition (mol/m^3/s), c,j:', & + source(c,j,1) + conc_ch4(c,j) / dtime, c, j + g = col%gridcell(c) + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(g),grc%londeg(g) + call endrun(msg=' ERROR: Methane limited, yet some left over.'//& + errMsg(sourcefile, __LINE__)) + end if + + source(c,j,2) = -o2_oxid_depth(c,j) - o2_decomp_depth(c,j) + o2_aere_depth(c,j) ! O2 [mol/m3/s] + if (source(c,j,2) + conc_o2(c,j) / dtime < -1.e-12_r8) then + write(iulog,*) 'Oxygen demands exceed oxygen available. Error in oxygen competition (mol/m^3/s), c,j:', & + source(c,j,2) + conc_o2(c,j) / dtime, c, j + g = col%gridcell(c) + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(g),grc%londeg(g) + call endrun(msg=' ERROR: Oxygen demands exceed oxygen available.'//& + errMsg(sourcefile, __LINE__) ) + else if (o2stress(c,j) < 1._r8 .and. source(c,j,2) + conc_o2(c,j) / dtime > 1.e-12_r8) then + write(iulog,*) 'Oxygen limited, yet some left over. Error in oxygen competition (mol/m^3/s), c,j:', & + source(c,j,2) + conc_o2(c,j) / dtime, c, j + g = col%gridcell(c) + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(g),grc%londeg(g) + call endrun(msg=' ERROR: Oxygen limited, yet some left over.'//errMsg(sourcefile, __LINE__)) + end if + + conc_ch4_bef(c,j) = conc_ch4(c,j) !For Balance Check + enddo ! fc + enddo ! j + + ! Accumulate aerenchyma to add directly to atmospheric flux + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + if (j==1) ch4_surf_aere(c) = 0._r8 + ch4_surf_aere(c) = ch4_surf_aere(c) + ch4_aere_depth(c,j) * dz(c,j) + enddo + enddo + + ! Add in ebullition to source at depth just above WT + do fc = 1, num_methc + c = filter_methc(fc) + if (jwt(c) /= 0) then + source(c,jwt(c),1) = source(c,jwt(c),1) + ch4_ebul_total(c)/dz(c,jwt(c)) + endif + enddo ! fc + + ! Calculate concentration relative to m^3 of air or water: needed for the diffusion + do j = 0,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + g = col%gridcell(c) + + if (j == 0) then + conc_ch4_rel(c,j) = c_atm(g,1) + conc_o2_rel(c,j) = c_atm(g,2) + else + h2osoi_vol_min(c,j) = min(watsat(c,j), h2osoi_vol(c,j)) + if (ch4frzout) then + liqfrac(c,j) = max(0.05_r8, (h2osoi_liq(c,j)/denh2o+smallnumber)/ & + (h2osoi_liq(c,j)/denh2o+h2osoi_ice(c,j)/denice+smallnumber)) + else + liqfrac(c,j) = 1._r8 + end if + if (j <= jwt(c)) then ! Above the WT + do s=1,2 + epsilon_t(c,j,s) = watsat(c,j)- (1._r8-k_h_cc(c,j,s))*h2osoi_vol_min(c,j)*liqfrac(c,j) + end do + ! Partition between the liquid and gas phases. The gas phase will drive the diffusion. + else ! Below the WT + do s=1,2 + epsilon_t(c,j,s) = watsat(c,j)*liqfrac(c,j) + end do + end if + conc_ch4_rel(c,j) = conc_ch4(c,j)/epsilon_t(c,j,1) + conc_o2_rel(c,j) = conc_o2(c,j) /epsilon_t(c,j,2) + end if + end do + end do + + + ! Loop over species + do s = 1, 2 ! 1=CH4; 2=O2; 3=CO2 + + + ! Adjust the grnd_ch4_cond to keep it positive, and add the snow resistance & pond resistance + do j = -nlevsno + 1,0 + do fc = 1, num_methc + c = filter_methc (fc) + + if (j == -nlevsno + 1) then + if (grnd_ch4_cond(c) < smallnumber .and. s==1) grnd_ch4_cond(c) = smallnumber + ! Needed to prevent overflow when ground is frozen, e.g. for lakes + snowres(c) = 0._r8 + end if + + ! Add snow resistance + if (j >= snl(c) + 1) then + t_soisno_c = t_soisno(c,j) - tfrz + icefrac = h2osoi_ice(c,j)/denice/dz(c,j) + waterfrac = h2osoi_liq(c,j)/denh2o/dz(c,j) + airfrac = max(1._r8 - icefrac - waterfrac, 0._r8) + ! Calculate snow diffusivity + if (airfrac > 0.05_r8) then + f_a = airfrac / (airfrac + waterfrac) + eps = airfrac ! Air-filled fraction of total snow volume + ! Use Millington-Quirk Expression, as hydraulic properties (bsw) not available + snowdiff = (d_con_g(s,1) + d_con_g(s,2)*t_soisno_c) * 1.e-4_r8 * & + f_a**(10._r8/3._r8) / (airfrac+waterfrac)**2 & + * scale_factor_gasdiff + else !solute diffusion in water only + eps = waterfrac ! Water-filled fraction of total soil volume + snowdiff = eps**satpow * (d_con_w(s,1) + d_con_w(s,2)*t_soisno_c + d_con_w(s,3)*t_soisno_c**2) * 1.e-9_r8 & + * scale_factor_liqdiff + end if + snowdiff = max(snowdiff, smallnumber) + snowres(c) = snowres(c) + dz(c,j)/snowdiff + end if + + if (j == 0) then ! final loop + ! Add pond resistance + pondres = 0._r8 + + ! First old pond formulation up to pondmx + if (.not. lake .and. snl(c) == 0 .and. h2osoi_vol(c,1) > watsat(c,1)) then + t_soisno_c = t_soisno(c,1) - tfrz + if (t_soisno(c,1) <= tfrz) then + ponddiff = (d_con_w(s,1) + d_con_w(s,2)*t_soisno_c + d_con_w(s,3)*t_soisno_c**2) * 1.e-9_r8 & + * (h2osoi_liq(c,1)/denh2o+smallnumber)/ & + (h2osoi_liq(c,1)/denh2o+h2osoi_ice(c,1)/denice+smallnumber) & + * scale_factor_liqdiff + else ! Unfrozen + ponddiff = (d_con_w(s,1) + d_con_w(s,2)*t_soisno_c + d_con_w(s,3)*t_soisno_c**2) * 1.e-9_r8 & + * scale_factor_liqdiff + end if + pondz = dz(c,1) * (h2osoi_vol(c,1) - watsat(c,1)) + pondres = pondz / ponddiff + end if + + ! Now add new h2osfc form + if (.not. lake .and. sat == 1 .and. frac_h2osfc(c) > 0._r8) then + if (t_h2osfc(c) >= tfrz) then + t_soisno_c = t_h2osfc(c) - tfrz + ponddiff = (d_con_w(s,1) + d_con_w(s,2)*t_soisno_c + d_con_w(s,3)*t_soisno_c**2) * 1.e-9_r8 & + * scale_factor_liqdiff + pondz = h2osfc(c) / 1000._r8 / frac_h2osfc(c) ! Assume all h2osfc corresponds to sat area + ! mm / mm/m + pondres = pondres + pondz / ponddiff + else if (h2osfc(c)/frac_h2osfc(c) > capthick) then + ! assume surface ice is impermeable + pondres = 1/smallnumber + end if + end if + + spec_grnd_cond(c,s) = 1._r8/(1._r8/grnd_ch4_cond(c) + snowres(c) + pondres) + end if + + end do ! fc + end do ! j + + ! Determine gas diffusion and fraction of open pore (f_a) + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + g = col%gridcell(c) + + t_soisno_c = t_soisno(c,j) - tfrz + + if (j <= jwt(c)) then ! Above the WT + f_a = 1._r8 - h2osoi_vol_min(c,j) / watsat(c,j) + ! Provisionally calculate diffusivity as linear combination of the Millington-Quirk + ! expression in Wania (for peat) & Moldrup (for mineral soil) + eps = watsat(c,j)-h2osoi_vol_min(c,j) ! Air-filled fraction of total soil volume + 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(s,1) + d_con_g(s,2)*t_soisno_c) * 1.e-4_r8 * & + (om_frac * f_a**(10._r8/3._r8) / watsat(c,j)**2._r8 + & + (1._r8-om_frac) * eps**2._r8 * f_a**(3._r8 / bsw(c,j)) ) & + * scale_factor_gasdiff + else ! Below the WT use saturated diffusivity and only water in epsilon_t + ! Note the following is not currently corrected for the effect on diffusivity of excess ice in soil under + ! lakes (which is currently experimental only). + eps = watsat(c,j) ! Water-filled fraction of total soil volume + diffus (c,j) = eps**satpow * (d_con_w(s,1) + d_con_w(s,2)*t_soisno_c + d_con_w(s,3)*t_soisno_c**2) * 1.e-9_r8 & + * scale_factor_liqdiff + if (t_soisno(c,j)<=tfrz) then + diffus(c,j) = diffus(c,j)*(h2osoi_liq(c,j)/denh2o+smallnumber)/ & + (h2osoi_liq(c,j)/denh2o+h2osoi_ice(c,j)/denice+smallnumber) + end if + endif ! Above/below the WT + diffus(c,j) = max(diffus(c,j), smallnumber) ! Prevent overflow + + enddo ! fp + enddo ! j + + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + + ! Set up coefficients for tridiagonal solver. + if (j == 1 .and. j /= jwt(c) .and. j /= jwt(c)+1) then + dm1_zm1(c,j) = 1._r8/(1._r8/spec_grnd_cond(c,s)+dz(c,j)/(diffus(c,j)*2._r8)) + ! replace Diffusivity / Delta_z by conductance (grnd_ch4_cond) for top layer + dp1_zp1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j+1)/diffus(c,j+1)) + else if (j == 1 .and. j == jwt(c)) then + dm1_zm1(c,j) = 1._r8/(1._r8/spec_grnd_cond(c,s)+dz(c,j)/(diffus(c,j)*2._r8)) + ! layer resistance mult. by k_h_cc for dp1_zp1 term + dp1_zp1(c,j) = 2._r8/(dz(c,j)*k_h_cc(c,j,s)/diffus(c,j)+dz(c,j+1)/diffus(c,j+1)) + else if (j == 1) then ! water table at surface: multiply ground resistance by k_h_cc + dm1_zm1(c,j) = 1._r8/(k_h_cc(c,j-1,s)/spec_grnd_cond(c,s)+dz(c,j)/(diffus(c,j)*2._r8)) + ! air concentration will be mult. by k_h_cc below + dp1_zp1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j+1)/diffus(c,j+1)) + else if (j <= nlevsoi-1 .and. j /= jwt(c) .and. j /= jwt(c)+1) then + dm1_zm1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j-1)/diffus(c,j-1)) + dp1_zp1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j+1)/diffus(c,j+1)) + else if (j <= nlevsoi-1 .and. j == jwt(c)) then ! layer resistance mult. by k_h_cc for dp1_zp1 term + dm1_zm1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j-1)/diffus(c,j-1)) + dp1_zp1(c,j) = 2._r8/(dz(c,j)*k_h_cc(c,j,s)/diffus(c,j)+dz(c,j+1)/diffus(c,j+1)) + ! Concentration in layer will be mult. by k_h_cc below + else if (j <= nlevsoi-1) then ! j==jwt+1: layer above resistance mult. by k_h_cc for dm1_zm1 term + dm1_zm1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j-1)*k_h_cc(c,j-1,s)/diffus(c,j-1)) + ! Concentration in layer above will be mult. by k_h_cc below + dp1_zp1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j+1)/diffus(c,j+1)) + else if (j /= jwt(c)+1) then ! j ==nlevsoi + dm1_zm1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j-1)/diffus(c,j-1)) + else ! jwt == nlevsoi-1: layer above resistance mult. by k_h_cc for dm1_zm1 term + dm1_zm1(c,j) = 2._r8/(dz(c,j)/diffus(c,j)+dz(c,j-1)*k_h_cc(c,j-1,s)/diffus(c,j-1)) + end if + enddo ! fp; patch + end do ! j; nlevsoi + + ! Perform a second loop for the tridiagonal coefficients since need dp1_zp1 and dm1_z1 at each depth + do j = 0,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + g = col%gridcell(c) + + conc_ch4_rel_old(c,j) = conc_ch4_rel(c,j) + + if (j > 0) dzj = dz(c,j) + if (j == 0) then ! top layer (atmosphere) doesn't change regardless of where WT is + at(c,j) = 0._r8 + bt(c,j) = 1._r8 + ct(c,j) = 0._r8 + rt(c,j) = c_atm(g,s) ! 0th level stays at constant atmospheric conc + elseif (j < nlevsoi .and. j == jwt(c)) then ! concentration inside needs to be mult. by k_h_cc for dp1_zp1 term + at(c,j) = -0.5_r8 / dzj * dm1_zm1(c,j) + bt(c,j) = epsilon_t(c,j,s) / dtime_ch4 + 0.5_r8 / dzj * (dp1_zp1(c,j)*k_h_cc(c,j,s) + dm1_zm1(c,j)) + ct(c,j) = -0.5_r8 / dzj * dp1_zp1(c,j) + elseif (j < nlevsoi .and. j == jwt(c)+1) then + ! concentration above needs to be mult. by k_h_cc for dm1_zm1 term + at(c,j) = -0.5_r8 / dzj * dm1_zm1(c,j) * k_h_cc(c,j-1,s) + bt(c,j) = epsilon_t(c,j,s) / dtime_ch4 + 0.5_r8 / dzj * (dp1_zp1(c,j) + dm1_zm1(c,j)) + ct(c,j) = -0.5_r8 / dzj * dp1_zp1(c,j) + elseif (j < nlevsoi) then + at(c,j) = -0.5_r8 / dzj * dm1_zm1(c,j) + bt(c,j) = epsilon_t(c,j,s) / dtime_ch4 + 0.5_r8 / dzj * (dp1_zp1(c,j) + dm1_zm1(c,j)) + ct(c,j) = -0.5_r8 / dzj * dp1_zp1(c,j) + else if (j == nlevsoi .and. j== jwt(c)+1) then + ! concentration above needs to be mult. by k_h_cc for dm1_zm1 term + at(c,j) = -0.5_r8 / dzj * dm1_zm1(c,j) * k_h_cc(c,j-1,s) + bt(c,j) = epsilon_t(c,j,s) / dtime_ch4 + 0.5_r8 / dzj * dm1_zm1(c,j) + ct(c,j) = 0._r8 + else ! j==nlevsoi and jwt 1.e-3_r8 * scale_factor_gasdiff) then + if (deficit > 1.e-2_r8) then + write(iulog,*)'Note: sink > source in ch4_tran, sources are changing '// & + ' quickly relative to diffusion timestep, and/or diffusion is rapid.' + g = col%gridcell(c) + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(g),grc%londeg(g) + write(iulog,*)'This typically occurs when there is a larger than normal '// & + ' diffusive flux.' + write(iulog,*)'If this occurs frequently, consider reducing land model (or '// & + ' methane model) timestep, or reducing the max. sink per timestep in the methane model.' + end if + write(iulog,*) 'Negative conc. in ch4tran. c,j,deficit (mol):',c,j,deficit + end if + conc_ch4_rel(c,j) = 0._r8 + ! Subtract deficit + ch4_surf_diff(c) = ch4_surf_diff(c) - deficit/dtime_ch4 + end if + enddo + enddo + + + elseif (s == 2) then ! O2 + + ! Set rt, since it depends on conc + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + + ! For correct balance, deprecate source_old. + source_old(c,j,s) = source(c,j,s) + ! source_old could be removed later + epsilon_t_old(c,j,s) = epsilon_t(c,j,s) + ! epsilon_t acts like source also + dzj = dz(c,j) + if (j < nlevsoi .and. j == jwt(c)) then ! concentration inside needs to be mult. by k_h_cc for dp1_zp1 term + rt(c,j) = epsilon_t_old(c,j,s) / dtime_ch4 * conc_o2_rel(c,j) + & + 0.5_r8 / dzj * (dp1_zp1(c,j) * (conc_o2_rel(c,j+1)-conc_o2_rel(c,j)*k_h_cc(c,j,s)) - & + dm1_zm1(c,j) * (conc_o2_rel(c,j) -conc_o2_rel(c,j-1))) + & + 0.5_r8 * (source(c,j,s) + source_old(c,j,s)) + elseif (j < nlevsoi .and. j == jwt(c)+1) then + ! concentration above needs to be mult. by k_h_cc for dm1_zm1 term + rt(c,j) = epsilon_t_old(c,j,s) / dtime_ch4 * conc_o2_rel(c,j) + & + 0.5_r8 / dzj * (dp1_zp1(c,j) * (conc_o2_rel(c,j+1)-conc_o2_rel(c,j)) - & + dm1_zm1(c,j) * (conc_o2_rel(c,j) -conc_o2_rel(c,j-1)*k_h_cc(c,j-1,s))) + & + 0.5_r8 * (source(c,j,s) + source_old(c,j,s)) + elseif (j < nlevsoi) then + rt(c,j) = epsilon_t_old(c,j,s) / dtime_ch4 * conc_o2_rel(c,j) + & + 0.5_r8 / dzj * (dp1_zp1(c,j) * (conc_o2_rel(c,j+1)-conc_o2_rel(c,j)) - & + dm1_zm1(c,j) * (conc_o2_rel(c,j) -conc_o2_rel(c,j-1))) + & + 0.5_r8 * (source(c,j,s) + source_old(c,j,s)) + else if (j == nlevsoi .and. j== jwt(c)+1) then + ! concentration above needs to be mult. by k_h_cc for dm1_zm1 term + rt(c,j) = epsilon_t_old(c,j,s) / dtime_ch4 * conc_o2_rel(c,j) + & + 0.5_r8 / dzj * ( - dm1_zm1(c,j) * (conc_o2_rel(c,j) -conc_o2_rel(c,j-1)*k_h_cc(c,j-1,s))) + & + 0.5_r8 * (source(c,j,s) + source_old(c,j,s)) + else !j==nlevsoi + rt(c,j) = epsilon_t_old(c,j,s) / dtime_ch4 * conc_o2_rel(c,j) + & + 0.5_r8 / dzj * ( - dm1_zm1(c,j) * (conc_o2_rel(c,j) -conc_o2_rel(c,j-1))) + & + 0.5_r8 * (source(c,j,s) + source_old(c,j,s)) + endif + epsilon_t_old(c,j,s) = epsilon_t(c,j,s) + source_old(c,j,s) = source(c,j,s) + + enddo ! fc; column + enddo ! j; nlevsoi + + call Tridiagonal(bounds, 0, nlevsoi, jtop(bounds%begc:bounds%endc), & + num_methc, filter_methc, & + at(bounds%begc:bounds%endc, :), & + bt(bounds%begc:bounds%endc, :), & + ct(bounds%begc:bounds%endc, :), & + rt(bounds%begc:bounds%endc, :), & + conc_o2_rel(bounds%begc:bounds%endc,0:nlevsoi)) + + ! Ensure that concentrations stay above 0 + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + g = col%gridcell(c) + conc_o2_rel(c,j) = max (conc_o2_rel(c,j), 1.e-12_r8) + ! In case of pathologically large aerenchyma conductance. Should be OK in general but + ! this will maintain stability even if a PATCH with very small weight somehow has an absurd NPP or LAI. + ! Also, oxygen above ambient will probably bubble. + conc_o2_rel(c,j) = min (conc_o2_rel(c,j), c_atm(g,2)/epsilon_t(c,j,2)) + enddo + enddo + + endif ! species + + enddo ! species + + ! Update absolute concentrations per unit volume + do j = 1,nlevsoi ! No need to update the atm. level concentrations + do fc = 1, num_methc + c = filter_methc (fc) + + conc_ch4(c,j) = conc_ch4_rel(c,j)*epsilon_t(c,j,1) + conc_o2(c,j) = conc_o2_rel(c,j) *epsilon_t(c,j,2) + end do + end do + + ! Do Balance Check and absorb small + ! discrepancy into surface flux. + do j = 1,nlevsoi + do fc = 1, num_methc + c = filter_methc (fc) + + if (j == 1) errch4(c) = 0._r8 + errch4(c) = errch4(c) + (conc_ch4(c,j) - conc_ch4_bef(c,j))*dz(c,j) + errch4(c) = errch4(c) - ch4_prod_depth(c,j)*dz(c,j)*dtime + errch4(c) = errch4(c) + ch4_oxid_depth(c,j)*dz(c,j)*dtime + end do + end do + + do fc = 1, num_methc + c = filter_methc (fc) + + ! For history make sure that grnd_ch4_cond includes snow, for methane diffusivity + grnd_ch4_cond(c) = spec_grnd_cond(c,1) + + errch4(c) = errch4(c) + (ch4_surf_aere(c) + ch4_surf_ebul(c) + ch4_surf_diff(c))*dtime + + if (abs(errch4(c)) < 1.e-8_r8) then + ch4_surf_diff(c) = ch4_surf_diff(c) - errch4(c)/dtime + else ! errch4 > 1e-8 mol / m^2 / timestep + write(iulog,*)'CH4 Conservation Error in CH4Mod during diffusion, nstep, c, errch4 (mol /m^2.timestep)', & + nstep,c,errch4(c) + g = col%gridcell(c) + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(g),grc%londeg(g) + call endrun(msg=' ERROR: CH4 Conservation Error in CH4Mod during diffusion'//& + errMsg(sourcefile, __LINE__)) + end if + end do + + end associate + + end subroutine ch4_tran + + !----------------------------------------------------------------------- + subroutine get_jwt (bounds, num_methc, filter_methc, jwt, & + soilstate_inst, waterstatebulk_inst, temperature_inst) + ! + ! !DESCRIPTION: + ! Finds the first unsaturated layer going up. Also allows a perched water table over ice. + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_methc ! number of column soil points in column filter + integer , intent(in) :: filter_methc(:) ! column filter for soil points + integer , intent(out) :: jwt( bounds%begc: ) ! index of the soil layer right above the water table (-) [col] + type(soilstate_type) , intent(in) :: soilstate_inst + type(waterstatebulk_type) , intent(in) :: waterstatebulk_inst + type(temperature_type) , intent(in) :: temperature_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: f_sat ! volumetric soil water defining top of water table or where production is allowed + integer :: c,j,perch! indices + integer :: fc ! filter column index + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(jwt) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + t_soisno => temperature_inst%t_soisno_col & ! Input: [real(r8) (: ,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevsoi) + ) + + f_sat = params_inst%f_sat + + ! The layer index of the first unsaturated layer, i.e., the layer right above + ! the water table. + ! ZS: Loop is currently not vectorized. + do fc = 1, num_methc + c = filter_methc(fc) + + ! Check to see if any soil layers are frozen and saturated. If so, start looking at the first layer above the top + ! such layer. This is potentially important for perched water tables in the Tundra. + + perch = nlevsoi + do j = nlevsoi, 1, -1 + if (t_soisno(c,j) < tfrz .and. h2osoi_vol(c,j) > f_sat * watsat(c,j)) then + ! strictly less than freezing because it could be permeable otherwise + perch = j-1 + end if + end do + jwt(c) = perch + + do j = perch, 2, -1 + if(h2osoi_vol(c,j) > f_sat * watsat(c,j) .and. h2osoi_vol(c,j-1) < f_sat * watsat(c,j-1)) then + jwt(c) = j-1 + exit + end if + enddo + if (jwt(c) == perch .and. h2osoi_vol(c,1) > f_sat * watsat(c,1)) then ! missed that the top layer is saturated + jwt(c) = 0 + endif + end do + + end associate + + end subroutine get_jwt + + !----------------------------------------------------------------------- + subroutine ch4_annualupdate(bounds, num_methc, filter_methc, num_methp, filter_methp, & + agnpp, bgnpp, & + soilbiogeochem_carbonflux_inst, ch4_inst) + ! + ! !DESCRIPTION: Annual mean fields. + ! + ! !USES: + use clm_time_manager, only: get_step_size_real, get_days_per_year, get_nstep + use clm_varcon , only: secspday + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_methc ! number of soil columns in filter + integer , intent(in) :: filter_methc(:) ! filter for soil columns + integer , intent(in) :: num_methp ! number of soil points in patch filter + integer , intent(in) :: filter_methp(:) ! patch filter for soil points + real(r8) , intent(in) :: agnpp( bounds%begp: ) ! aboveground NPP (gC/m2/s) + real(r8) , intent(in) :: bgnpp( bounds%begp: ) ! belowground NPP (gC/m2/s) + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(ch4_type) , intent(inout) :: ch4_inst + ! + ! !LOCAL VARIABLES: + integer :: c,p ! indices + integer :: fc ! soil column filter indices + integer :: fp ! soil patch filter indices + real(r8):: dt ! time step (seconds) + real(r8):: secsperyear + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(agnpp) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(bgnpp) == (/bounds%endp/)), sourcefile, __LINE__) + + associate( & + somhr => soilbiogeochem_carbonflux_inst%somhr_col , & ! Input: [real(r8) (:) ] (gC/m2/s) soil organic matter heterotrophic respiration + + finundated => ch4_inst%finundated_col , & ! Input: [real(r8) (:) ] fractional inundated area in soil column + tempavg_agnpp => ch4_inst%tempavg_agnpp_patch , & ! Output: [real(r8) (:) ] temporary average above-ground NPP (gC/m2/s) + annavg_agnpp => ch4_inst%annavg_agnpp_patch , & ! Output: [real(r8) (:) ] annual average above-ground NPP (gC/m2/s) + tempavg_bgnpp => ch4_inst%tempavg_bgnpp_patch , & ! Output: [real(r8) (:) ] temporary average below-ground NPP (gC/m2/s) + annavg_bgnpp => ch4_inst%annavg_bgnpp_patch , & ! Output: [real(r8) (:) ] annual average below-ground NPP (gC/m2/s) + annsum_counter => ch4_inst%annsum_counter_col , & ! Output: [real(r8) (:) ] seconds since last annual accumulator turnover + tempavg_somhr => ch4_inst%tempavg_somhr_col , & ! Output: [real(r8) (:) ] temporary average SOM heterotrophic resp. (gC/m2/s) + annavg_somhr => ch4_inst%annavg_somhr_col , & ! Output: [real(r8) (:) ] annual average SOM heterotrophic resp. (gC/m2/s) + tempavg_finrw => ch4_inst%tempavg_finrw_col , & ! Output: [real(r8) (:) ] respiration-weighted annual average of finundated + annavg_finrw => ch4_inst%annavg_finrw_col & ! Output: [real(r8) (:) ] respiration-weighted annual average of finundated + ) + + ! set time steps + dt = get_step_size_real() + secsperyear = real( get_days_per_year() * secspday, r8) + + do fc = 1,num_methc + c = filter_methc(fc) + annsum_counter(c) = annsum_counter(c) + dt + end do + + do fc = 1,num_methc + c = filter_methc(fc) + if (annsum_counter(c) >= secsperyear) then + + ! update annual average somhr + annavg_somhr(c) = tempavg_somhr(c) + tempavg_somhr(c) = 0._r8 + + ! update annual average finrw + if (annavg_somhr(c) > 0._r8) then + annavg_finrw(c) = tempavg_finrw(c) / annavg_somhr(c) + else + annavg_finrw(c) = 0._r8 + end if + tempavg_finrw(c) = 0._r8 + else + tempavg_somhr(c) = tempavg_somhr(c) + dt/secsperyear * somhr(c) + tempavg_finrw(c) = tempavg_finrw(c) + dt/secsperyear * finundated(c) * somhr(c) + end if + end do + + do fp = 1,num_methp + p = filter_methp(fp) + c = patch%column(p) + if (annsum_counter(c) >= secsperyear) then + + annavg_agnpp(p) = tempavg_agnpp(p) + tempavg_agnpp(p) = 0._r8 + + annavg_bgnpp(p) = tempavg_bgnpp(p) + tempavg_bgnpp(p) = 0._r8 + + else + tempavg_agnpp(p) = tempavg_agnpp(p) + dt/secsperyear * agnpp(p) + tempavg_bgnpp(p) = tempavg_bgnpp(p) + dt/secsperyear * bgnpp(p) + end if + end do + + ! column loop + do fc = 1,num_methc + c = filter_methc(fc) + if (annsum_counter(c) >= secsperyear) annsum_counter(c) = 0._r8 + end do + + end associate + + end subroutine ch4_annualupdate + + !----------------------------------------------------------------------- + subroutine ch4_totcolch4(bounds, num_nolakec, filter_nolakec, num_lakec, filter_lakec, & + ch4_inst, totcolch4) + ! + ! !DESCRIPTION: + ! Computes total column ch4, returned in totcolch4 + ! + ! totcolch4 is set over both the nolakec and the lakec filters; elsewhere, it retains + ! its original values + ! + ! !USES: + use ch4varcon , only : allowlakeprod + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points + integer , intent(in) :: num_lakec ! number of column lake points in column filter + integer , intent(in) :: filter_lakec(:) ! column filter for lake points + type(ch4_type) , intent(in) :: ch4_inst + real(r8) , intent(inout) :: totcolch4( bounds%begc: ) ! total methane in soil column (g C / m^2) + ! + ! !LOCAL VARIABLES: + integer :: fc, c + integer :: j + + character(len=*), parameter :: subname = 'ch4_totcolch4' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(totcolch4) == (/bounds%endc/)), sourcefile, __LINE__) + + associate( & + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) (-nlevsno+1:nlevsoi) + finundated => ch4_inst%finundated_col , & ! Input: [real(r8) (:) ] fractional inundated area in soil column (excluding dedicated wetland columns) + conc_ch4_sat => ch4_inst%conc_ch4_sat_col , & ! Input: [real(r8) (:,:) ] CH4 conc in each soil layer (mol/m3) (nlevsoi) + conc_ch4_unsat => ch4_inst%conc_ch4_unsat_col & ! Input: [real(r8) (:,:) ] CH4 conc in each soil layer (mol/m3) (nlevsoi) + ) + + do fc = 1, num_nolakec + c = filter_nolakec(fc) + totcolch4(c) = 0._r8 + end do + + do fc = 1, num_lakec + c = filter_lakec(fc) + totcolch4(c) = 0._r8 + end do + + do j = 1, nlevsoi + do fc = 1, num_nolakec + c = filter_nolakec(fc) + totcolch4(c) = totcolch4(c) + & + (finundated(c)*conc_ch4_sat(c,j) + (1._r8-finundated(c))*conc_ch4_unsat(c,j)) * & + dz(c,j)*catomw + ! mol CH4 --> g C + end do + + if (allowlakeprod) then + do fc = 1, num_lakec + c = filter_lakec(fc) + totcolch4(c) = totcolch4(c) + conc_ch4_sat(c,j)*dz(c,j)*catomw ! mol CH4 --> g C + end do + end if + end do + + end associate + + end subroutine ch4_totcolch4 + + +end module ch4Mod + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_time_manager.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_time_manager.F90 new file mode 100644 index 000000000..9ad956ebc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_time_manager.F90 @@ -0,0 +1,1862 @@ +module clm_time_manager + +#include "shr_assert.h" + use shr_kind_mod, only: r8 => shr_kind_r8 + use shr_sys_mod , only: shr_sys_abort + use spmdMod , only: masterproc + use clm_varctl , only: iulog + use clm_varcon , only: isecspday + use ESMF + + implicit none + private + + ! Public methods + + public ::& + set_timemgr_init, &! setup startup values + timemgr_init, &! time manager initialization + timemgr_restart_io, &! read/write time manager restart info and restart time manager + timemgr_restart, &! restart the time manager using info from timemgr_restart + timemgr_datediff, &! calculate difference between two time instants + advance_timestep, &! increment timestep number + get_curr_ESMF_Time, &! get current time in terms of the ESMF_Time + 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 timestep number + get_nstep_since_startup_or_lastDA_restart_or_pause, &! return number of timesteps since restart was modified + get_curr_date, &! return date components at end of current timestep + get_prev_date, &! return date components at beginning of current timestep + 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_perp_date, &! return components of the perpetual date, and current time of day + get_curr_time, &! return components of elapsed time since reference date at end of current timestep + get_prev_time, &! return components of elapsed time since reference date at beg 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_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 + get_rest_date, &! return the date from the restart file + 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 + set_nextsw_cday, &! set the next radiation calendar day + is_first_step, &! return true on first step of initial run + is_first_restart_step, &! return true on first step of restart or branch run + is_first_step_of_this_run_segment, &! return true on first step of any run segment (initial, restart or branch run) + is_beg_curr_day, &! return true on first timestep in current day + is_end_curr_day, &! return true on last timestep in current day + is_end_curr_month, &! return true on last timestep in current month + 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_perpetual, &! return true if perpetual calendar is in use + is_near_local_noon, &! return true if near local noon + is_restart, &! return true if this is a restart run + update_rad_dtime, &! track radiation interval via nstep + update_DA_nstep, &! update the Data Assimulation time step + timemgr_reset ! reset values to their defaults, and free memory + + ! Public methods, but just to support unit testing: + public :: for_test_set_curr_date ! set the current date and time + + ! Public parameter data + character(len=*), public, parameter :: NO_LEAP_C = 'NO_LEAP' + character(len=*), public, parameter :: GREGORIAN_C = 'GREGORIAN' + + ! Private module data + + ! Private data for input + + character(len=ESMF_MAXSTR), save ::& + calendar = NO_LEAP_C ! Calendar to use in date calculations. + integer, parameter :: uninit_int = -999999999 + real(r8), parameter :: uninit_r8 = -999999999.0 + + ! We'll use this really big year to effectively mean infinitely into the future. + integer, parameter :: really_big_year = 999999999 + + ! Input + integer, save ::& + dtime = uninit_int, &! timestep in seconds + dtime_rad = uninit_int, &! radiation interval in seconds + nstep_rad_prev = uninit_int ! radiation interval in seconds + + ! Input from CESM driver + integer, save ::& + start_ymd = uninit_int, &! starting date for run in yearmmdd format + start_tod = 0, &! starting time of day for run in seconds + ref_ymd = uninit_int, &! reference date for time coordinate in yearmmdd format + ref_tod = 0 ! reference time of day for time coordinate in seconds + type(ESMF_Calendar), target, save :: tm_cal ! calendar + type(ESMF_Clock), save :: tm_clock ! model clock + type(ESMF_Time), save :: tm_perp_date ! perpetual date + + ! Data required to restart time manager: + integer, save :: rst_step_sec = uninit_int ! timestep size seconds + integer, save :: rst_start_ymd = uninit_int ! start date + integer, save :: rst_start_tod = uninit_int ! start time of day + integer, save :: rst_ref_ymd = uninit_int ! reference date + integer, save :: rst_ref_tod = uninit_int ! reference time of day + integer, save :: rst_curr_ymd = uninit_int ! current date + integer, save :: rst_curr_tod = uninit_int ! current time of day + + integer, save :: rst_nstep_rad_prev ! nstep of previous radiation call + integer, save :: perpetual_ymd = uninit_int ! Perpetual calendar date (YYYYMMDD) + logical, save :: tm_first_restart_step = .false. ! true for first step of a restart or branch run + logical, save :: tm_perp_calendar = .false. ! true when using perpetual calendar + logical, save :: timemgr_set = .false. ! true when timemgr initialized + ! + ! Next short-wave radiation calendar day + ! + real(r8) :: nextsw_cday = uninit_r8 ! calday from clock of next radiation computation + + ! + ! The time-step number of startup or last Data Assimulation (DA) restart or pause + integer, save :: DA_nstep = 0 ! Last step number that state was modified externally (by DA) + + ! Private module methods + + private :: timemgr_spmdbcast + private :: init_calendar + private :: init_clock + private :: timemgr_print + private :: TimeGetymd + private :: check_timemgr_initialized + + !========================================================================================= +contains + !========================================================================================= + + subroutine set_timemgr_init( calendar_in, start_ymd_in, start_tod_in, ref_ymd_in, & + ref_tod_in, perpetual_run_in, perpetual_ymd_in, dtime_in ) + + !--------------------------------------------------------------------------------- + ! set time manager startup values + ! + ! Arguments + character(len=*), optional, intent(IN) :: calendar_in ! Calendar type + integer , optional, intent(IN) :: start_ymd_in ! Start date (YYYYMMDD) + integer , optional, intent(IN) :: start_tod_in ! Start time of day (sec) + integer , optional, intent(IN) :: ref_ymd_in ! Reference date (YYYYMMDD) + integer , optional, intent(IN) :: ref_tod_in ! Reference time of day (sec) + logical , optional, intent(IN) :: perpetual_run_in ! If in perpetual mode or not + integer , optional, intent(IN) :: perpetual_ymd_in ! Perpetual date (YYYYMMDD) + integer , optional, intent(IN) :: dtime_in ! Time-step (sec) + ! + character(len=*), parameter :: sub = 'clm::set_timemgr_init' + + if ( timemgr_set ) call shr_sys_abort( sub//":: timemgr_init or timemgr_restart already called" ) + if (present(calendar_in) ) calendar = trim(calendar_in) + if (present(start_ymd_in) ) start_ymd = start_ymd_in + if (present(start_tod_in) ) start_tod = start_tod_in + if (present(ref_ymd_in) ) ref_ymd = ref_ymd_in + if (present(ref_tod_in) ) ref_tod = ref_tod_in + if (present(perpetual_run_in) )then + tm_perp_calendar = perpetual_run_in + if ( tm_perp_calendar ) then + if ( .not. present(perpetual_ymd_in) .or. perpetual_ymd == uninit_int) & + call shr_sys_abort( sub//":: perpetual_run set but NOT perpetual_ymd" ) + perpetual_ymd = perpetual_ymd_in + end if + end if + if (present(dtime_in) ) dtime = dtime_in + + end subroutine set_timemgr_init + + !========================================================================================= + + subroutine timemgr_init( ) + + !--------------------------------------------------------------------------------- + ! Initialize the ESMF time manager from the sync clock + ! + ! Arguments + ! + character(len=*), parameter :: sub = 'clm::timemgr_init' + integer :: rc ! return code + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: curr_date ! temporary date used in logic + type(ESMF_Time) :: ref_date ! reference date for time coordinate + type(ESMF_TimeInterval) :: day_step_size ! day step size + type(ESMF_TimeInterval) :: step_size ! timestep size + !--------------------------------------------------------------------------------- + call timemgr_spmdbcast( ) + + ! Initalize calendar + + call init_calendar() + + ! Initalize start date. + + if ( start_ymd == uninit_int ) then + write(iulog,*)sub,': start_ymd must be specified ' + call shr_sys_abort + end if + if ( start_tod == uninit_int ) then + write(iulog,*)sub,': start_tod must be specified ' + call shr_sys_abort + end if + start_date = TimeSetymd( start_ymd, start_tod, "start_date" ) + + ! Initialize current date + + curr_date = start_date + + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + + call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') + + ! Initalize reference date for time coordinate. + + if ( ref_ymd /= uninit_int ) then + ref_date = TimeSetymd( ref_ymd, ref_tod, "ref_date" ) + else + ref_date = start_date + end if + + ! Initialize clock + + call init_clock( start_date, ref_date, curr_date) + + ! Initialize date used for perpetual calendar day calculation. + + if (tm_perp_calendar) then + tm_perp_date = TimeSetymd( perpetual_ymd, 0, "tm_perp_date" ) + end if + + ! Print configuration summary to log file (stdout). + + if (masterproc) call timemgr_print() + + timemgr_set = .true. + + end subroutine timemgr_init + + !========================================================================================= + + subroutine init_clock( start_date, ref_date, curr_date ) + + !--------------------------------------------------------------------------------- + ! Purpose: Initialize the clock based on the start_date, ref_date and curr_date + ! + type(ESMF_Time), intent(in) :: start_date ! start date for run + type(ESMF_Time), intent(in) :: ref_date ! reference date for time coordinate + type(ESMF_Time), intent(in) :: curr_date ! current date (equal to start_date) + ! + character(len=*), parameter :: sub = 'clm::init_clock' + type(ESMF_Time) :: stop_date ! stop date for run + type(ESMF_TimeInterval) :: step_size ! timestep size + type(ESMF_Time) :: current ! current date (from clock) + integer :: yr, mon, day, tod ! Year, month, day, and second as integers + integer :: rc ! return code + !--------------------------------------------------------------------------------- + + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + + ! We don't use a stop time in the CTSM clock. Instead, we set the clock to + ! effectively have a stop time infinitely far into the future, and rely on other + ! mechanisms to tell CTSM when to stop. If we were always using the real ESMF + ! library, we could avoid setting the stopTime on the clock. But the ESMF time + ! manager included in cime appears to require stopTime. + call ESMF_TimeSet(stop_date, yy=really_big_year, mm=12, dd=31, s=0, & + calendar=tm_cal, rc=rc) + + ! Error check + + if ( stop_date <= start_date ) then + write(iulog,*)sub, ': Assumed stop date is earlier than start date: ' + call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if + if ( stop_date <= curr_date ) then + write(iulog,*)sub, ': Assumed stop date is earlier than current date: ' + call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if + + ! Initialize the clock + + tm_clock = ESMF_ClockCreate(name="CLM Time-manager clock", timeStep=step_size, startTime=start_date, & + stopTime=stop_date, refTime=ref_date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockSetup') + + ! Advance clock to the current time (in case of a restart) + + call ESMF_ClockGet(tm_clock, currTime=current, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + do while( curr_date > current ) + call ESMF_ClockAdvance( tm_clock, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockAdvance') + call ESMF_ClockGet(tm_clock, currTime=current ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + end do + end subroutine init_clock + + !========================================================================================= + + function TimeSetymd( ymd, tod, desc ) + !--------------------------------------------------------------------------------- + ! + ! Set the time by an integer as YYYYMMDD and integer seconds in the day + ! + integer, intent(in) :: ymd ! Year, month, day YYYYMMDD + integer, intent(in) :: tod ! Time of day in seconds + character(len=*), intent(in) :: desc ! Description of time to set + + type(ESMF_Time) :: TimeSetymd ! Return value + + character(len=*), parameter :: sub = 'clm::TimeSetymd' + integer :: yr, mon, day ! Year, month, day as integers + integer :: rc ! return code + !--------------------------------------------------------------------------------- + + if ( (ymd < 0) .or. (tod < 0) .or. (tod > isecspday) )then + write(iulog,*) sub//': error yymmdd is a negative number or time-of-day out of bounds', & + ymd, tod + call shr_sys_abort + end if + yr = ymd / 10000 + mon = (ymd - yr*10000) / 100 + day = ymd - yr*10000 - mon*100 + call ESMF_TimeSet( TimeSetymd, yy=yr, mm=mon, dd=day, s=tod, & + calendar=tm_cal, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeSet: setting '//trim(desc)) + end function TimeSetymd + + !========================================================================================= + + integer function TimeGetymd( date, tod ) + ! + ! Get the date and time of day in ymd from ESMF Time. + ! + type(ESMF_Time), intent(inout) :: date ! Input date to convert to ymd + integer, intent(out), optional :: tod ! Time of day in seconds + + character(len=*), parameter :: sub = 'clm::TimeGetymd' + integer :: yr, mon, day + integer :: rc ! return code + + call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + TimeGetymd = yr*10000 + mon*100 + day + if ( present( tod ) )then + call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + end if + if ( yr < 0 )then + write(iulog,*) sub//': error year is less than zero', yr + call shr_sys_abort + end if + end function TimeGetymd + + !========================================================================================= + + subroutine timemgr_restart_io( ncid, flag ) + + !--------------------------------------------------------------------------------- + ! Read/Write information needed on restart to a netcdf file. + use ncdio_pio, only: ncd_int, file_desc_t + use restUtilMod + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf id + character(len=*), intent(in) :: flag ! 'read' or 'write' + ! + ! Local variables + character(len=*), parameter :: sub = 'clm::timemgr_restart' + integer :: rc ! return code + logical :: readvar ! determine if variable is on initial file + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: ref_date ! reference date for run + type(ESMF_Time) :: curr_date ! date of data in restart file + integer :: rst_caltype ! calendar type + integer, parameter :: noleap = 1 + integer, parameter :: gregorian = 2 + character(len=len(calendar)) :: cal + !--------------------------------------------------------------------------------- + + if (flag == 'write') then + rst_nstep_rad_prev = nstep_rad_prev + end if + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_nstep_rad_prev', xtype=ncd_int, & + long_name='previous_radiation_nstep', units='unitless positive integer', & + ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_nstep_rad_prev) + if (flag == 'read') then + nstep_rad_prev = rst_nstep_rad_prev + end if + + if (flag == 'write') then + cal = to_upper(calendar) + if ( trim(cal) == NO_LEAP_C ) then + rst_caltype = noleap + else if ( trim(cal) == GREGORIAN_C ) then + rst_caltype = gregorian + else + call shr_sys_abort(sub//'ERROR: unrecognized calendar specified= '//trim(calendar)) + end if + end if + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_type', xtype=ncd_int, & + long_name='calendar type', units='unitless', flag_meanings=(/ "NO_LEAP_C", "GREGORIAN" /), & + flag_values=(/ noleap, gregorian /), ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_caltype) + if (flag == 'read') then + if ( rst_caltype == noleap ) then + calendar = NO_LEAP_C + else if ( rst_caltype == gregorian ) then + calendar = GREGORIAN_C + else + write(iulog,*)sub,': unrecognized calendar type in restart file: ',rst_caltype + call shr_sys_abort( sub//'ERROR: bad calendar type in restart file') + end if + end if + + if (flag == 'write') then + call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, refTime=ref_date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + rst_step_sec = dtime + rst_start_ymd = TimeGetymd( start_date, tod=rst_start_tod ) + rst_ref_ymd = TimeGetymd( ref_date, tod=rst_ref_tod ) + rst_curr_ymd = TimeGetymd( curr_date, tod=rst_curr_tod ) + end if + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_step_sec', xtype=ncd_int, & + long_name='seconds component of timestep size', units='sec', & + nvalid_range=(/0,isecspday/), ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_step_sec) + if ((flag == 'read') .and. ( rst_step_sec < 0 .or. rst_step_sec > isecspday )) then + call shr_sys_abort( sub//'ERROR: timemgr_rst_step_sec out of range') + end if + + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_start_ymd', xtype=ncd_int, & + long_name='start date', units='YYYYMMDD', ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_start_ymd) + + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_start_tod', xtype=ncd_int, & + long_name='start time of day', units='sec', & + nvalid_range=(/0,isecspday/), ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_start_tod) + if ((flag == 'read') .and. ( rst_start_tod < 0 .or. rst_start_tod > isecspday )) then + call shr_sys_abort( sub//'ERROR: timemgr_rst_strart_tod out of range') + end if + + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_ref_ymd', xtype=ncd_int, & + long_name='reference date', units='YYYYMMDD', ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_ref_ymd) + + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_ref_tod', xtype=ncd_int, & + long_name='reference time of day', units='sec', & + nvalid_range=(/0,isecspday/), ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_ref_tod) + if ((flag == 'read') .and. ( rst_start_tod < 0 .or. rst_start_tod > isecspday )) then + call shr_sys_abort( sub//'ERROR: timemgr_rst_ref_tod out of range') + end if + + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_curr_ymd', xtype=ncd_int, & + long_name='current date', units='YYYYMMDD', ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_curr_ymd) + + call restartvar(ncid=ncid, flag=flag, varname='timemgr_rst_curr_tod', xtype=ncd_int, & + long_name='current time of day', units='sec', & + nvalid_range=(/0,isecspday/), ifill_value=uninit_int, & + interpinic_flag='skip', readvar=readvar, data=rst_curr_tod) + if ((flag == 'read') .and. ( rst_curr_tod < 0 .or. rst_curr_tod > isecspday )) then + call shr_sys_abort( sub//'ERROR: timemgr_rst_ref_ymd out of range') + end if + + end subroutine timemgr_restart_io + + !========================================================================================= + + subroutine timemgr_restart( ) + + !--------------------------------------------------------------------------------- + ! Restart the ESMF time manager using the synclock for ending date. + ! + character(len=*), parameter :: sub = 'clm::timemgr_restart' + integer :: rc ! return code + integer :: yr, mon, day, tod ! Year, month, day, and second as integers + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: ref_date ! reference date for run + type(ESMF_Time) :: curr_date ! date of data in restart file + type(ESMF_TimeInterval) :: day_step_size ! day step size + type(ESMF_TimeInterval) :: step_size ! timestep size + !--------------------------------------------------------------------------------- + call timemgr_spmdbcast( ) + + ! Initialize calendar from restart info + + call init_calendar() + + ! Initialize the timestep from restart info + + dtime = rst_step_sec + + ! Initialize start date from restart info + + start_date = TimeSetymd( rst_start_ymd, rst_start_tod, "start_date" ) + + ! Initialize current date from restart info + + curr_date = TimeSetymd( rst_curr_ymd, rst_curr_tod, "curr_date" ) + + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + + call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') + + ! Initialize nstep_rad_prev from restart info + + nstep_rad_prev = rst_nstep_rad_prev + + ! Initialize ref date from restart info + + ref_date = TimeSetymd( rst_ref_ymd, rst_ref_tod, "ref_date" ) + + ! Initialize clock + + call init_clock( start_date, ref_date, curr_date) + + ! Advance the timestep. + ! Data from the restart file corresponds to the last timestep of the previous run. + + call advance_timestep() + + ! Set flag that this is the first timestep of the restart run. + + tm_first_restart_step = .true. + + ! Print configuration summary to log file (stdout). + + if (masterproc) call timemgr_print() + + timemgr_set = .true. + + end subroutine timemgr_restart + + !========================================================================================= + + subroutine init_calendar( ) + + !--------------------------------------------------------------------------------- + ! Initialize calendar + ! + ! Local variables + ! + character(len=*), parameter :: sub = 'clm::init_calendar' + type(ESMF_CalKind_Flag) :: cal_type ! calendar type + character(len=len(calendar)) :: caltmp + integer :: rc ! return code + !--------------------------------------------------------------------------------- + + caltmp = to_upper(calendar) + if ( trim(caltmp) == NO_LEAP_C ) then + cal_type = ESMF_CALKIND_NOLEAP + else if ( trim(caltmp) == GREGORIAN_C ) then + cal_type = ESMF_CALKIND_GREGORIAN + else + write(iulog,*)sub,': unrecognized calendar specified: ',calendar + call shr_sys_abort + end if + tm_cal = ESMF_CalendarCreate( name=caltmp, calkindflag=cal_type, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_CalendarSet') + end subroutine init_calendar + + !========================================================================================= + + subroutine timemgr_print() + + !--------------------------------------------------------------------------------- + character(len=*), parameter :: sub = 'clm::timemgr_print' + integer :: rc + integer :: yr, mon, day + integer :: & ! Data required to restart time manager: + nstep = uninit_int, &! current step number + step_sec = uninit_int, &! timestep size seconds + start_yr = uninit_int, &! start year + start_mon = uninit_int, &! start month + start_day = uninit_int, &! start day of month + start_tod = uninit_int, &! start time of day + ref_yr = uninit_int, &! reference year + ref_mon = uninit_int, &! reference month + ref_day = uninit_int, &! reference day of month + ref_tod = uninit_int, &! reference time of day + curr_yr = uninit_int, &! current year + curr_mon = uninit_int, &! current month + curr_day = uninit_int, &! current day of month + curr_tod = uninit_int ! current time of day + integer(ESMF_KIND_I8) :: step_no + type(ESMF_Time) :: start_date! start date for run + type(ESMF_Time) :: curr_date ! date of data in restart file + type(ESMF_Time) :: ref_date ! reference date + type(ESMF_TimeInterval) :: step ! Time-step + !--------------------------------------------------------------------------------- + + call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, & + refTime=ref_date, timeStep=step, & + advanceCount=step_no, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + nstep = step_no + + write(iulog,*)' ******** CLM Time Manager Configuration ********' + + call ESMF_TimeIntervalGet( step, s=step_sec, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') + + call ESMF_TimeGet( start_date, yy=start_yr, mm=start_mon, dd=start_day, & + s=start_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeGet( ref_date, yy=ref_yr, mm=ref_mon, dd=ref_day, s=ref_tod, & + rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeGet( curr_date, yy=curr_yr, mm=curr_mon, dd=curr_day, & + s=curr_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + write(iulog,*)' Calendar type: ',trim(calendar) + write(iulog,*)' Timestep size (seconds): ', step_sec + write(iulog,*)' Start date (yr mon day tod): ', start_yr, start_mon, & + start_day, start_tod + write(iulog,*)' Reference date (yr mon day tod): ', ref_yr, ref_mon, & + ref_day, ref_tod + write(iulog,*)' Current step number: ', nstep + write(iulog,*)' Current date (yr mon day tod): ', curr_yr, curr_mon, & + curr_day, curr_tod + + if ( tm_perp_calendar ) then + call ESMF_TimeGet( tm_perp_date, yy=yr, mm=mon, dd=day, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + write(iulog,*)' Use perpetual diurnal cycle date (yr mon day): ', & + yr, mon, day + end if + + write(iulog,*)' ************************************************' + + end subroutine timemgr_print + + !========================================================================================= + + subroutine advance_timestep() + + ! Increment the timestep number. + + character(len=*), parameter :: sub = 'clm::advance_timestep' + integer :: rc + + call ESMF_ClockAdvance( tm_clock, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockAdvance') + + tm_first_restart_step = .false. + + end subroutine advance_timestep + + !========================================================================================= + + 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 + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet( tm_clock, currTime=get_curr_ESMF_Time, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + end function get_curr_ESMF_Time + + !========================================================================================= + + integer function get_step_size() + + ! Return the step size in seconds. + + character(len=*), parameter :: sub = 'clm::get_step_size' + type(ESMF_TimeInterval) :: step_size ! timestep size + integer :: rc + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet(tm_clock, timeStep=step_size, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + call ESMF_TimeIntervalGet(step_size, s=get_step_size, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockTimeIntervalGet') + + 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 + + !========================================================================================= + + subroutine update_DA_nstep() + ! Update the Data Assimulation time-step to the current time step, since DA has been done + DA_nstep = get_nstep() + end subroutine update_DA_nstep + + !========================================================================================= + + subroutine update_rad_dtime(doalb) + !--------------------------------------------------------------------------------- + ! called only on doalb timesteps to save off radiation nsteps + ! + ! Local Arguments + logical,intent(in) :: doalb + integer :: dtime,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 + + !========================================================================================= + + integer function get_nstep() + + ! Return the timestep number. + + character(len=*), parameter :: sub = 'clm::get_nstep' + integer :: rc + integer(ESMF_KIND_I8) :: step_no + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet(tm_clock, advanceCount=step_no, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + get_nstep = step_no + + end function get_nstep + + !========================================================================================= + + integer function get_nstep_since_startup_or_lastDA_restart_or_pause() + + ! Return the number of time-steps since the restart file was modified + + character(len=*), parameter :: sub = 'clm::get_nstep_since_rest_mod' + + get_nstep_since_startup_or_lastDA_restart_or_pause = get_nstep() - DA_nstep + + end function get_nstep_since_startup_or_lastDA_restart_or_pause + + !========================================================================================= + + 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. + + 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. + ! Positive for future times, negative + ! for previous times. + + character(len=*), parameter :: sub = 'clm::get_curr_date' + integer :: rc + type(ESMF_Time) :: date + type(ESMF_TimeInterval) :: off + !----------------------------------------------------------------------------------------- + + 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 + + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_curr_date + + !========================================================================================= + + subroutine get_perp_date(yr, mon, day, tod, offset) + + !----------------------------------------------------------------------------------------- + ! Return time of day valid at end of current timestep and the components + ! of the perpetual date (with an optional offset (positive or negative) in seconds. + + 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. + ! Positive for future times, negative + ! for previous times. + + character(len=*), parameter :: sub = 'clm::get_perp_date' + integer :: rc + type(ESMF_Time) :: date + type(ESMF_TimeInterval) :: DelTime + !----------------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet( tm_clock, currTime=date, rc=rc ) + ! Get time of day add it to perpetual date + ! Get year, month, day so that seconds are time-of-day rather than since start time + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeIntervalSet(DelTime, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') + date = tm_perp_date + DelTime + if ( present(offset) )then + call ESMF_TimeIntervalSet(DelTime, s=offset, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') + date = date + DelTime + end if + ! Get time of day from the result + ! Get year, month, day so that seconds are time-of-day rather than since start time + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + + ! Get the date from the fixed perpetual date (in case it overflows to next day) + call ESMF_TimeGet(tm_perp_date, yy=yr, mm=mon, dd=day, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_perp_date + + !========================================================================================= + + subroutine get_prev_date(yr, mon, day, tod) + + ! Return date components valid at beginning of current timestep. + + ! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + ! Local variables + character(len=*), parameter :: sub = 'clm::get_prev_date' + integer :: rc + type(ESMF_Time) :: date + !----------------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_prev_date + + !========================================================================================= + + subroutine get_start_date(yr, mon, day, tod) + + ! Return date components valid at beginning of initial run. + + ! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + ! Local variables + character(len=*), parameter :: sub = 'clm::get_start_date' + integer :: rc + type(ESMF_Time) :: date + !----------------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet(tm_clock, startTime=date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_start_date + + !========================================================================================= + + integer function get_driver_start_ymd( tod ) + + ! Return date of start of simulation from driver (i.e. NOT from restart file) + ! Note: get_start_date gets you the date from the beginning of the simulation + ! on the restart file. + + ! Arguments + integer, optional, intent(out) ::& + tod ! time of day (seconds past 0Z) + + ! Local variables + character(len=*), parameter :: sub = 'clm::get_driver_start_ymd' + !----------------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + if ( start_ymd == uninit_int )then + call shr_sys_abort( sub//': error driver start date is NOT set yet' ) + end if + if ( start_ymd < 101 .or. start_ymd > 99991231 )then + call shr_sys_abort( sub//': error driver start date is invalid' ) + end if + if ( present(tod) )then + tod = start_tod + if ( (tod < 0) .or. (tod > isecspday) )then + call shr_sys_abort( sub//': error driver start tod is invalid' ) + end if + end if + get_driver_start_ymd = start_ymd + + end function get_driver_start_ymd + + !========================================================================================= + + subroutine get_ref_date(yr, mon, day, tod) + + ! Return date components of the reference date. + + ! Arguments + integer, intent(out) ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + ! Local variables + character(len=*), parameter :: sub = 'clm::get_ref_date' + integer :: rc + type(ESMF_Time) :: date + !----------------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet(tm_clock, refTime=date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_ref_date + + !========================================================================================= + + subroutine get_curr_time(days, seconds) + + ! Return time components valid at end of current timestep. + ! Current time is the time interval between the current date and the reference date. + + ! Arguments + integer, intent(out) ::& + days, &! number of whole days in time interval + seconds ! remaining seconds in time interval + + ! Local variables + character(len=*), parameter :: sub = 'clm::get_curr_time' + integer :: rc + type(ESMF_Time) :: cdate, rdate + type(ESMF_TimeInterval) :: diff + !----------------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet( tm_clock, currTime=cdate, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + call ESMF_ClockGet( tm_clock, refTime=rdate, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + diff = cdate - rdate + + call ESMF_TimeIntervalGet(diff, d=days, s=seconds, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') + + end subroutine get_curr_time + + !========================================================================================= + + subroutine get_prev_time(days, seconds) + + ! Return time components valid at beg of current timestep. + ! prev time is the time interval between the prev date and the reference date. + + ! Arguments + integer, intent(out) ::& + days, &! number of whole days in time interval + seconds ! remaining seconds in time interval + + ! Local variables + character(len=*), parameter :: sub = 'clm::get_prev_time' + integer :: rc + type(ESMF_Time) :: date, ref_date + type(ESMF_TimeInterval) :: diff + !----------------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet for prevTime') + call ESMF_ClockGet(tm_clock, refTime=ref_date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet for refTime') + diff = date - ref_date + call ESMF_TimeIntervalGet( diff, d=days, s=seconds, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeintervalGet') + + end subroutine get_prev_time + + !========================================================================================= + + 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 + + !========================================================================================= + + function get_calday(ymd, tod) + + ! Return calendar day corresponding to specified time instant. + ! Calendar day 1.0 = 0Z on Jan 1. + + ! Arguments + integer, intent(in) :: & + ymd, &! date in yearmmdd format + tod ! time of day (seconds past 0Z) + + ! Return value + real(r8) :: get_calday + + ! Local variables + character(len=*), parameter :: sub = 'clm::get_calday' + integer :: rc ! return code + type(ESMF_Time) :: date + !----------------------------------------------------------------------------------------- + + date = TimeSetymd( ymd, tod, "get_calday" ) + call ESMF_TimeGet( date, dayOfYear_r8=get_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_calday > 366.0) .and. (get_calday <= 367.0) .and. & + (trim(calendar) == GREGORIAN_C) )then + get_calday = get_calday - 1.0_r8 + end if +!!!!!!!!!!!!!! END HACK TO ENABLE Gregorian CALENDAR WITH SHR_ORB !!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------------------------! + if ( (get_calday < 1.0) .or. (get_calday > 366.0) )then + write(iulog,*) sub, ' = ', get_calday + call shr_sys_abort( sub//': error calday out of range' ) + end if + + end function get_calday + + !========================================================================================= + + function get_calendar() + + ! Return calendar + + ! Return value + character(len=ESMF_MAXSTR) :: get_calendar + + get_calendar = calendar + + end function get_calendar + + !========================================================================================= + + integer function get_days_per_year( offset ) + + !--------------------------------------------------------------------------------- + ! Get the number of days per year for currrent year + + ! + ! Arguments + 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_days_per_year' + integer :: yr, mon, day, tod ! current date year, month, day and time-of-day + type(ESMF_Time) :: eDate ! ESMF date + integer :: rc ! ESMF return code + !--------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + if ( present(offset) )then + call get_curr_date(yr, mon, day, tod, offset ) + else + call get_curr_date(yr, mon, day, tod ) + end if + eDate = TimeSetymd( ymd=yr*10000+1231, tod=0, desc="end of year" ) + call ESMF_TimeGet( eDate, dayOfYear=get_days_per_year, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end function get_days_per_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 + + + !========================================================================================= + + subroutine get_rest_date(ncid, yr) + + !--------------------------------------------------------------------------------- + ! Get the date from the restart file. + ! + ! Currently just returns the year (because the month & day are harder to extract, and + ! currently aren't needed). + use ncdio_pio, only: ncd_io, file_desc_t + ! + ! Arguments + type(file_desc_t) , intent(inout) :: ncid ! netcdf id for the restart file + integer , intent(out) :: yr ! year from restart file + + integer :: ymd ! yyyymmdd from the restart file + logical :: readvar ! whether the variable was read from the file + + integer, parameter :: year_mask = 10000 ! divide by this to get year from ymd + + character(len=*), parameter :: subname = 'get_rest_date' + !----------------------------------------------------------------------- + + ! Get the date (yyyymmdd) from restart file. + ! Note that we cannot simply use the rst_curr_ymd module variable, because that isn't + ! set under some circumstances + call ncd_io(varname='timemgr_rst_curr_ymd', data=ymd, & + ncid=ncid, flag='read', readvar=readvar) + if (.not. readvar) then + call shr_sys_abort(subname//' ERROR: timemgr_rst_curr_ymd not found on restart file') + end if + + ! Extract the year + yr = ymd / year_mask + end subroutine get_rest_date + + !========================================================================================= + + integer function get_local_timestep_time( londeg, offset ) + + !--------------------------------------------------------------------------------- + ! 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) + + ! 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 + 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, offset=offset_sec ) + 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 + + !========================================================================================= + + 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_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 + + !========================================================================================= + + subroutine set_nextsw_cday( nextsw_cday_in ) + + ! Set the next radiation calendar day, so that radiation step can be calculated + ! + ! Arguments + real(r8), intent(IN) :: nextsw_cday_in ! input calday of next radiation computation + + character(len=*), parameter :: sub = 'clm::set_nextsw_cday' + + nextsw_cday = nextsw_cday_in + + end subroutine set_nextsw_cday + + !========================================================================================= + + function is_beg_curr_day() + + ! Return true if current timestep is first timestep in current day. + + ! Return value + logical :: is_beg_curr_day + + ! Local variables + integer ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + character(len=*), parameter :: sub = 'clm::is_beg_curr_day' + + if ( .not. check_timemgr_initialized(sub) ) return + + call get_curr_date(yr, mon, day, tod) + is_beg_curr_day = ( tod == dtime ) + + end function is_beg_curr_day + + !========================================================================================= + + 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) + + character(len=*), parameter :: sub = 'clm::is_end_curr_day' + !--------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call get_curr_date(yr, mon, day, tod) + is_end_curr_day = (tod == 0) + + end function is_end_curr_day + + !========================================================================================= + + logical function is_end_curr_month() + + !--------------------------------------------------------------------------------- + ! Return true if current timestep is last timestep in current month. + + ! Local variables + integer ::& + yr, &! year + mon, &! month + day, &! day of month + tod ! time of day (seconds past 0Z) + + character(len=*), parameter :: sub = 'clm::is_end_curr_month' + !--------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call get_curr_date(yr, mon, day, tod) + is_end_curr_month = (day == 1 .and. tod == 0) + + end function is_end_curr_month + + !----------------------------------------------------------------------- + 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 + + !----------------------------------------------------------------------- + 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' + !----------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(subname) ) return + + 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() + + !--------------------------------------------------------------------------------- + ! Return true on first step of initial run only. + + ! Local variables + character(len=*), parameter :: sub = 'clm::is_first_step' + integer :: rc + integer :: nstep + integer(ESMF_KIND_I8) :: step_no + !--------------------------------------------------------------------------------- + + if ( .not. check_timemgr_initialized(sub) ) return + + call ESMF_ClockGet( tm_clock, advanceCount=step_no, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + nstep = step_no + is_first_step = (nstep == 0) + + end function is_first_step + !========================================================================================= + + logical function is_first_restart_step() + + ! Return true on first step of restart or branch run only. + character(len=*), parameter :: sub = 'clm::is_first_restart_step' + + if ( .not. check_timemgr_initialized(sub) ) return + + is_first_restart_step = tm_first_restart_step + + end function is_first_restart_step + + !========================================================================================= + + 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() .or. is_first_restart_step()) + + end function is_first_step_of_this_run_segment + + !========================================================================================= + + logical function is_perpetual() + + ! Return true on last timestep. + character(len=*), parameter :: sub = 'clm::is_perpetual' + + if ( .not. check_timemgr_initialized(sub) ) return + + is_perpetual = tm_perp_calendar + + end function is_perpetual + + !========================================================================================= + + subroutine timemgr_datediff(ymd1, tod1, ymd2, tod2, days) + + ! Calculate the difference (ymd2,tod2) - (ymd1,tod1) and return the result in days. + ! Arguments + integer, intent(in) ::& + ymd1, &! date1 in yyyymmdd format + tod1, &! time of day relative to date1 (seconds past 0Z) + ymd2, &! date2 in yyyymmdd format + tod2 ! time of day relative to date2 (seconds past 0Z) + + real(r8) :: days ! (ymd2,tod2)-(ymd1,tod1) in days + + ! Local variables + character(len=*), parameter :: sub = 'clm::timemgr_datediff' + integer :: rc ! return code + + type(ESMF_Time) :: date1 + type(ESMF_Time) :: date2 + type(ESMF_TimeInterval) :: diff + !----------------------------------------------------------------------------------------- + + date1 = TimeSetymd( ymd1, tod1, "date1" ) + date2 = TimeSetymd( ymd2, tod2, "date2" ) + diff = date2 - date1 + call ESMF_TimeIntervalGet( diff, d_r8=days, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') + days = days + 1.0_r8 + + end subroutine timemgr_datediff + + !========================================================================================= + + subroutine chkrc(rc, mes) + integer, intent(in) :: rc ! return code from time management library + character(len=*), intent(in) :: mes ! error message + if ( rc == ESMF_SUCCESS ) return + write(iulog,*) mes + call shr_sys_abort ('CHKRC') + end subroutine chkrc + + !========================================================================================= + + function to_upper(str) + + !--------------------------------------------------------------------------------- + ! Convert character string to upper case. Use achar and iachar intrinsics + ! to ensure use of ascii collating sequence. + ! + ! !INPUT PARAMETERS: + character(len=*), intent(in) :: str ! String to convert to upper case + ! !RETURN VALUE: + character(len=len(str)) :: to_upper + ! !LOCAL VARIABLES: + integer :: i ! Index + integer :: aseq ! ascii collating sequence + character(len=1) :: ctmp ! Character temporary + !--------------------------------------------------------------------------------- + + do i = 1, len(str) + ctmp = str(i:i) + aseq = iachar(ctmp) + if ( aseq >= 97 .and. aseq <= 122 ) ctmp = achar(aseq - 32) + to_upper(i:i) = ctmp + end do + + end function to_upper + + !========================================================================================= + + logical function is_restart( ) + ! Determine if restart run + use clm_varctl, only : nsrest, nsrContinue + if (nsrest == nsrContinue) then + is_restart = .true. + else + is_restart = .false. + end if + end function is_restart + + !========================================================================================= + + subroutine timemgr_spmdbcast( ) + + use spmdMod , only : mpicom, MPI_INTEGER + use shr_mpi_mod, only : shr_mpi_bcast + + integer :: ier + + call shr_mpi_bcast (dtime, mpicom) + + end subroutine timemgr_spmdbcast + + !========================================================================================= + + logical function check_timemgr_initialized(caller) + ! + ! !DESCRIPTION: + ! Checks if the time manager has been initialized. If not, aborts with an error + ! message. + ! + ! !USES: + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: caller ! name of calling routine + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'check_timemgr_initialized' + !----------------------------------------------------------------------- + + if (.not. timemgr_set) then + call shr_sys_abort(trim(caller)//":: Time manager has not been initialized") + check_timemgr_initialized = .false. + else + check_timemgr_initialized = .true. + end if + + end function check_timemgr_initialized + + !----------------------------------------------------------------------- + subroutine timemgr_reset() + ! + ! !DESCRIPTION: + ! Reset time manager module data to default values. + ! + ! All unit tests that modify the time manager should call this routine in their + ! teardown section. + ! + ! Note: we could probably get away with doing much less resetting than is currently + ! done here. For example, we could simply set timemgr_set = .false., and deallocate + ! anything that needs deallocation. That would provide the benefit of less + ! maintenance, at the cost of slightly less robustness (in case some variable isn't + ! set in the initialization of a unit test, either because the unit test forgets to + ! call the time manager initialization method, or because the initialization method + ! does not explicitly initialize all variables). + ! + ! !USES: + ! + ! !ARGUMENTS: + ! + ! !LOCAL VARIABLES: + integer :: rc ! return code + + character(len=*), parameter :: sub = 'timemgr_reset' + !----------------------------------------------------------------------- + + ! ------------------------------------------------------------------------ + ! The values in the following section should match the initialization values given in + ! the variable declarations at the top of the module. + ! + ! Note: it would be easier to ensure this match if we introduced a time manager + ! derived type, which had default initialization of its components. Then this routine + ! could simply set to time manager instance to a new instance of the derived type. + ! ------------------------------------------------------------------------ + + calendar = NO_LEAP_C + + dtime = uninit_int + dtime_rad = uninit_int + nstep_rad_prev = uninit_int + + start_ymd = uninit_int + start_tod = 0 + ref_ymd = uninit_int + ref_tod = 0 + + rst_step_sec = uninit_int + rst_start_ymd = uninit_int + rst_start_tod = uninit_int + rst_ref_ymd = uninit_int + rst_ref_tod = uninit_int + rst_curr_ymd = uninit_int + rst_curr_tod = uninit_int + + ! note that rst_nstep_rad_prev is NOT initialized in its declaration + rst_nstep_rad_prev = uninit_int + perpetual_ymd = uninit_int + tm_first_restart_step = .false. + tm_perp_calendar = .false. + timemgr_set = .false. + + nextsw_cday = uninit_r8 + + ! ------------------------------------------------------------------------ + ! Reset other module-level variables to some reasonable default, to ensure that they + ! don't carry over any state from one unit test to the next. + ! ------------------------------------------------------------------------ + + ! Reset tm_cal + call init_calendar() + + ! Reset portions of the clock. Note that this does not fully reset the clock, and so + ! there is still the potential for information in the clock to carry over to the next + ! unit test if the next test does not properly initialize things. + call ESMF_ClockDestroy(tm_clock, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockDestroy') + + ! Note that we do NOT currently reset tm_perp_date, because it's unclear what that + ! should be reset to. Thus, there is potential for its information to carry over to + ! the next unit test if the next test does not properly initialize things. + + end subroutine timemgr_reset + + ! ======================================================================== + ! The following routines are meant to be used just in unit tests + ! ======================================================================== + + !----------------------------------------------------------------------- + subroutine for_test_set_curr_date(yr, mon, day, tod) + ! + ! !DESCRIPTION: + ! Sets the current date - i.e., the date at the end of the time step + ! + ! *** Should only be used in unit tests!!! *** + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: yr ! year + integer, intent(in) :: mon ! month + integer, intent(in) :: day ! day of month + integer, intent(in) :: tod ! time of day (seconds past 0Z) + ! + ! !LOCAL VARIABLES: + type(ESMF_Time) :: my_time ! ESMF Time corresponding to the inputs + integer :: rc ! return code + + character(len=*), parameter :: sub = 'for_test_set_curr_date' + !----------------------------------------------------------------------- + + call ESMF_TimeSet(my_time, yy=yr, mm=mon, dd=day, s=tod, & + calendar=tm_cal, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeSet') + + call ESMF_ClockSet(tm_clock, CurrTime=my_time, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockSet') + + end subroutine for_test_set_curr_date + + +end module clm_time_manager diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varcon.F90 new file mode 100644 index 000000000..9f66d335a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varcon.F90 @@ -0,0 +1,317 @@ +module clm_varcon + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing various model constants. + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use shr_const_mod, only: SHR_CONST_G,SHR_CONST_STEBOL,SHR_CONST_KARMAN, & + SHR_CONST_RWV,SHR_CONST_RDAIR,SHR_CONST_CPFW, & + SHR_CONST_CPICE,SHR_CONST_CPDAIR,SHR_CONST_LATVAP, & + SHR_CONST_LATSUB,SHR_CONST_LATICE,SHR_CONST_RHOFW, & + SHR_CONST_RHOICE,SHR_CONST_TKFRZ,SHR_CONST_REARTH, & + SHR_CONST_PDB, SHR_CONST_PI, SHR_CONST_CDAY, & + SHR_CONST_RGAS, SHR_CONST_PSTD, & + SHR_CONST_MWDAIR, SHR_CONST_MWWV, SHR_CONST_CPFW + use clm_varpar , only: numrad, nlevgrnd, nlevlak, nlevdecomp_full + use clm_varpar , only: ngases + use clm_varpar , only: nlayer + + ! + ! !PUBLIC TYPES: + implicit none + save + private + !----------------------------------------------------------------------- + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: clm_varcon_init ! initialize constants in clm_varcon + public :: clm_varcon_clean ! deallocate variables allocated by clm_varcon_init + ! + ! !REVISION HISTORY: + ! Created by Mariana Vertenstein + ! 27 February 2008: Keith Oleson; Add forcing height and aerodynamic parameters + !----------------------------------------------------------------------- + + !------------------------------------------------------------------ + ! Initialize mathmatical constants + !------------------------------------------------------------------ + + real(r8), public :: rpi = SHR_CONST_PI + + !------------------------------------------------------------------ + ! Initialize physical constants + !------------------------------------------------------------------ + + real(r8), public, parameter :: pc = 0.4 ! threshold probability + real(r8), public, parameter :: mu = 0.13889 ! connectivity exponent + real(r8), public, parameter :: secsphr = 3600._r8 ! Seconds in an hour + integer, public, parameter :: isecsphr = int(secsphr) ! Integer seconds in an hour + integer, public, parameter :: isecspmin= 60 ! Integer seconds in a minute + real(r8), public :: grav = SHR_CONST_G ! gravity constant [m/s2] + real(r8), public :: sb = SHR_CONST_STEBOL ! stefan-boltzmann constant [W/m2/K4] + real(r8), public :: vkc = SHR_CONST_KARMAN ! von Karman constant [-] + real(r8), public :: rwat = SHR_CONST_RWV ! gas constant for water vapor [J/(kg K)] + real(r8), public :: rair = SHR_CONST_RDAIR ! gas constant for dry air [J/kg/K] + real(r8), public :: roverg = SHR_CONST_RWV/SHR_CONST_G*1000._r8 ! Rw/g constant = (8.3144/0.018)/(9.80616)*1000. mm/K + real(r8), public :: cpliq = SHR_CONST_CPFW ! Specific heat of water [J/kg-K] + real(r8), public :: cpice = SHR_CONST_CPICE ! Specific heat of ice [J/kg-K] + real(r8), public :: cpair = SHR_CONST_CPDAIR ! specific heat of dry air [J/kg/K] + real(r8), public :: hvap = SHR_CONST_LATVAP ! Latent heat of evap for water [J/kg] + real(r8), public :: hsub = SHR_CONST_LATSUB ! Latent heat of sublimation [J/kg] + real(r8), public :: hfus = SHR_CONST_LATICE ! Latent heat of fusion for ice [J/kg] + real(r8), public :: denh2o = SHR_CONST_RHOFW ! density of liquid water [kg/m3] + real(r8), public :: denice = SHR_CONST_RHOICE ! density of ice [kg/m3] + real(r8), public :: rgas = SHR_CONST_RGAS ! universal gas constant [J/K/kmole] + real(r8), public :: pstd = SHR_CONST_PSTD ! standard pressure [Pa] + + ! TODO(wjs, 2016-04-08) The following should be used in place of hard-coded constants + ! of 0.622 and 0.378 (which is 1 - 0.622) in various places in the code: + real(r8), public, parameter :: wv_to_dair_weight_ratio = SHR_CONST_MWWV/SHR_CONST_MWDAIR ! ratio of molecular weight of water vapor to that of dry air [-] + + real(r8), public :: tkair = 0.023_r8 ! thermal conductivity of air [W/m/K] + real(r8), public :: tkice = 2.290_r8 ! thermal conductivity of ice [W/m/K] + real(r8), public :: tkwat = 0.57_r8 ! thermal conductivity of water [W/m/K] + real(r8), public, parameter :: tfrz = SHR_CONST_TKFRZ ! freezing temperature [K] + real(r8), public, parameter :: tcrit = 2.5_r8 ! critical temperature to determine rain or snow + real(r8), public :: o2_molar_const = 0.209_r8 ! constant atmospheric O2 molar ratio (mol/mol) + real(r8), public :: oneatm = 1.01325e5_r8 ! one standard atmospheric pressure [Pa] + real(r8), public :: bdsno = 250._r8 ! bulk density snow (kg/m**3) + real(r8), public :: alpha_aero = 1.0_r8 ! constant for aerodynamic parameter weighting + real(r8), public :: tlsai_crit = 2.0_r8 ! critical value of elai+esai for which aerodynamic parameters are maximum + real(r8), public :: watmin = 0.01_r8 ! minimum soil moisture (mm) + real(r8), public :: c_water = SHR_CONST_CPFW ! specific heat of water [J/kg/K] + real(r8), public :: c_dry_biomass = 1400_r8 ! specific heat of dry biomass + + real(r8), public :: re = SHR_CONST_REARTH*0.001_r8 ! radius of earth (km) + + real(r8), public, parameter :: degpsec = 15._r8/3600.0_r8 ! Degree's earth rotates per second + real(r8), public, parameter :: secspday= SHR_CONST_CDAY ! Seconds per day + integer, public, parameter :: isecspday= secspday ! Integer seconds per day + + 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 + + ! ------------------------------------------------------------------------ + ! Special value flags + ! ------------------------------------------------------------------------ + + ! NOTE(wjs, 2015-11-23) The presence / absence of spval should be static in time for + ! multi-level fields. i.e., if a given level & column has spval at initialization, it + ! should remain spval throughout the run (e.g., indicating that this level is not valid + ! for this column type); similarly, if it starts as a valid value, it should never + ! become spval. This is needed for init_interp to work correctly on multi-level fields. + ! For more details, see the note near the top of initInterpMultilevelInterp. + real(r8), public, parameter :: spval = 1.e36_r8 ! special value for real data + + ! Keep this negative to avoid conflicts with possible valid values + integer , public, parameter :: ispval = -9999 ! special value for int data + + ! ------------------------------------------------------------------------ + ! These are tunable constants from clm2_3 + ! ------------------------------------------------------------------------ + + real(r8), public :: capr = 0.34_r8 ! Tuning factor to turn first layer T into surface T + real(r8), public :: cnfac = 0.5_r8 ! Crank Nicholson factor between 0 and 1 + real(r8), public :: pondmx = 0.0_r8 ! Ponding depth (mm) + real(r8), public :: pondmx_urban = 1.0_r8 ! Ponding depth for urban roof and impervious road (mm) + + real(r8), public :: thk_bedrock = 3.0_r8 ! thermal conductivity of 'typical' saturated granitic rock + ! (Clauser and Huenges, 1995)(W/m/K) + real(r8), public :: csol_bedrock = 2.0e6_r8 ! vol. heat capacity of granite/sandstone J/(m3 K)(Shabbir, 2000) + real(r8), public, parameter :: zmin_bedrock = 0.4_r8 ! minimum soil depth [m] + + real(r8), public, parameter :: aquifer_water_baseline = 5000._r8 ! baseline value for water in the unconfined aquifer [mm] + real(r8), public, parameter :: c_to_b = 2.0_r8 ! conversion between mass carbon and total biomass (g biomass /g C) + + !!! C13 + real(r8), public, parameter :: preind_atm_del13c = -6.0 ! preindustrial value for atmospheric del13C + real(r8), public, parameter :: preind_atm_ratio = SHR_CONST_PDB + (preind_atm_del13c * SHR_CONST_PDB)/1000.0 ! 13C/12C + real(r8), public :: c13ratio = preind_atm_ratio/(1.0+preind_atm_ratio) ! 13C/(12+13)C preind atmosphere + + ! 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) + + ! isotope ratio (13c/12c) for C4 photosynthesis + real(r8), public, parameter :: c4_r1 = SHR_CONST_PDB + ((c4_del13c*SHR_CONST_PDB)/1000._r8) + + ! isotope ratio (13c/[12c+13c]) for C4 photosynthesis + real(r8), public, parameter :: c4_r2 = c4_r1/(1._r8 + c4_r1) + + !!! C14 + real(r8), public :: c14ratio = 1.e-12_r8 + ! real(r8) :: c14ratio = 1._r8 ! debug lets set to 1 to try to avoid numerical errors + + !------------------------------------------------------------------ + ! Urban building temperature constants + !------------------------------------------------------------------ + real(r8), public :: ht_wasteheat_factor = 0.2_r8 ! wasteheat factor for urban heating (-) + real(r8), public :: ac_wasteheat_factor = 0.6_r8 ! wasteheat factor for urban air conditioning (-) + real(r8), public :: em_roof_int = 0.9_r8 ! emissivity of interior surface of roof (Bueno et al. 2012, GMD) + real(r8), public :: em_sunw_int = 0.9_r8 ! emissivity of interior surface of sunwall (Bueno et al. 2012, GMD) + real(r8), public :: em_shdw_int = 0.9_r8 ! emissivity of interior surface of shadewall Bueno et al. 2012, GMD) + real(r8), public :: em_floor_int = 0.9_r8 ! emissivity of interior surface of floor (Bueno et al. 2012, GMD) + real(r8), public :: hcv_roof = 0.948_r8 ! interior convective heat transfer coefficient for roof (Bueno et al. 2012, GMD) (W m-2 K-1) + real(r8), public :: hcv_roof_enhanced = 4.040_r8 ! enhanced (t_roof_int <= t_room) interior convective heat transfer coefficient for roof (Bueno et al. 2012, GMD) !(W m-2 K-1) + real(r8), public :: hcv_floor = 0.948_r8 ! interior convective heat transfer coefficient for floor (Bueno et al. 2012, GMD) (W m-2 K-1) + real(r8), public :: hcv_floor_enhanced = 4.040_r8 ! enhanced (t_floor_int >= t_room) interior convective heat transfer coefficient for floor (Bueno et al. !2012, GMD) (W m-2 K-1) + real(r8), public :: hcv_sunw = 3.076_r8 ! interior convective heat transfer coefficient for sunwall (Bueno et al. 2012, GMD) (W m-2 K-1) + real(r8), public :: hcv_shdw = 3.076_r8 ! interior convective heat transfer coefficient for shadewall (Bueno et al. 2012, GMD) (W m-2 K-1) + real(r8), public :: dz_floor = 0.1_r8 ! floor thickness - concrete (Salmanca et al. 2010, TAC) (m) + real(r8), public, parameter :: dens_floor = 2.35e3_r8 ! density of floor - concrete (Salmanca et al. 2010, TAC) (kg m-3) + real(r8), public, parameter :: sh_floor = 880._r8 ! specific heat of floor - concrete (Salmanca et al. 2010, TAC) (J kg-1 K-1) + real(r8), public :: cp_floor = dens_floor*sh_floor ! volumetric heat capacity of floor - concrete (Salmanca et al. 2010, TAC) (J m-3 K-1) + real(r8), public :: vent_ach = 0.3 ! ventilation rate (air exchanges per hour) + + real(r8), public :: wasteheat_limit = 100._r8 ! limit on wasteheat (W/m2) + + !------------------------------------------------------------------ + + real(r8), public :: h2osno_max = -999.0_r8 ! max allowed snow thickness (mm H2O) + + integer, private :: i ! loop index + + !real(r8), parameter :: nitrif_n2o_loss_frac = 0.02_r8 ! fraction of N lost as N2O in nitrification (Parton et al., 2001) + 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 :: frac_minrlztn_to_no3 = 0.2_r8 ! fraction of N mineralized that is dieverted to the nitrification stream (Parton et al., 2001) + + !------------------------------------------------------------------ + ! 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) ! two-stream parameter omega for snow by band + data (omegas(i),i=1,numrad) /0.8_r8, 0.4_r8/ + + ! Lake Model Constants will be defined in LakeCon. + + !------------------------------------------------------------------ + ! Soil depths are constants for now; lake depths can vary by gridcell + ! zlak and dzlak correspond to the default 50 m lake depth. + ! The values for the following arrays are set in routine iniTimeConst + !------------------------------------------------------------------ + + real(r8), public, allocatable :: zlak(:) !lake z (layers) + real(r8), public, allocatable :: dzlak(:) !lake dz (thickness) + real(r8), public, allocatable :: zsoi(:) !soil z (layers) + real(r8), public, allocatable :: dzsoi(:) !soil dz (thickness) + real(r8), public, allocatable :: zisoi(:) !soil zi (interfaces) + real(r8), public, allocatable :: dzsoi_decomp(:) !soil dz (thickness) + integer , public, allocatable :: nlvic(:) !number of CLM layers in each VIC layer (#) + real(r8), public, allocatable :: dzvic(:) !soil dz (thickness) of each VIC layer + + !------------------------------------------------------------------ + ! (Non-tunable) Constants for the CH4 submodel (Tuneable constants in ch4varcon) + !------------------------------------------------------------------ + ! Note some of these constants are also used in CNNitrifDenitrifMod + + real(r8), public, parameter :: catomw = 12.011_r8 ! molar mass of C atoms (g/mol) + + real(r8), public :: s_con(ngases,4) ! Schmidt # calculation constants (spp, #) + data (s_con(1,i),i=1,4) /1898_r8, -110.1_r8, 2.834_r8, -0.02791_r8/ ! CH4 + data (s_con(2,i),i=1,4) /1801_r8, -120.1_r8, 3.7818_r8, -0.047608_r8/ ! O2 + data (s_con(3,i),i=1,4) /1911_r8, -113.7_r8, 2.967_r8, -0.02943_r8/ ! CO2 + + 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 + + real(r8), public :: c_h_inv(ngases) ! constant (K) for Henry's law (4.12, Wania) + data c_h_inv(1:3) /1600._r8, 1500._r8, 2400._r8/ ! CH4, O2, CO2 + + real(r8), public :: kh_theta(ngases) ! Henry's constant (L.atm/mol) at standard temperature (298K) + data kh_theta(1:3) /714.29_r8, 769.23_r8, 29.4_r8/ ! CH4, O2, CO2 + + real(r8), public :: kh_tbase = 298._r8 ! base temperature for calculation of Henry's constant (K) + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------------ + subroutine clm_varcon_init( is_simple_buildtemp ) + ! + ! !DESCRIPTION: + ! This subroutine initializes constant arrays in clm_varcon. + ! MUST be called after clm_varpar_init. + ! + ! !USES: + use clm_varpar, only: nlevgrnd, nlevlak, nlevdecomp_full, nlayer + ! + ! !ARGUMENTS: + implicit none + logical, intent(in) :: is_simple_buildtemp ! If simple building temp method is being used + ! + ! !REVISION HISTORY: + ! Created by E. Kluzek +!------------------------------------------------------------------------------ + + allocate( zlak(1:nlevlak )) + allocate( dzlak(1:nlevlak )) + allocate( zsoi(1:nlevgrnd )) + allocate( dzsoi(1:nlevgrnd )) + allocate( zisoi(0:nlevgrnd )) + allocate( dzsoi_decomp(1:nlevdecomp_full )) + allocate( nlvic(1:nlayer )) + allocate( dzvic(1:nlayer )) + + ! Zero out wastheat factors for simpler building temperature method (introduced in CLM4.5) + if ( is_simple_buildtemp )then + ht_wasteheat_factor = 0.0_r8 + ac_wasteheat_factor = 0.0_r8 + end if + + end subroutine clm_varcon_init + + !----------------------------------------------------------------------- + subroutine clm_varcon_clean() + ! + ! !DESCRIPTION: + ! Deallocate variables allocated by clm_varcon_init + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'clm_varcon_clean' + !----------------------------------------------------------------------- + + deallocate(zlak) + deallocate(dzlak) + deallocate(zsoi) + deallocate(dzsoi) + deallocate(zisoi) + deallocate(dzsoi_decomp) + deallocate(nlvic) + deallocate(dzvic) + + end subroutine clm_varcon_clean + + +end module clm_varcon diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varctl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varctl.F90 new file mode 100644 index 000000000..0a6ee15dd --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varctl.F90 @@ -0,0 +1,468 @@ +module clm_varctl + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing run control variables + ! + ! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8, SHR_KIND_CL + use shr_sys_mod , only: shr_sys_abort ! cannot use endrun here due to circular dependency + ! + ! !PUBLIC MEMBER FUNCTIONS: + implicit none + public :: clm_varctl_set ! Set variables + public :: cnallocate_carbon_only_set + public :: cnallocate_carbon_only + ! + private + save + ! + ! !PUBLIC TYPES: + ! + integer , parameter, public :: iundef = -9999999 + real(r8), parameter, public :: rundef = -9999999._r8 + integer , parameter, public :: fname_len = SHR_KIND_CL ! max length of file names in this module + !---------------------------------------------------------- + ! + ! Run control variables + ! + ! case id + character(len=256), public :: caseid = ' ' + + ! case title + character(len=256), public :: ctitle = ' ' + + ! Type of run + integer, public :: nsrest = iundef + logical, public :: is_cold_start = .false. + logical, public :: is_interpolated_start = .false. ! True if we're starting from initial conditions that have been run through init_interp + + ! Startup from initial conditions + integer, public, parameter :: nsrStartup = 0 + + ! Continue from restart files + integer, public, parameter :: nsrContinue = 1 + + ! Branch from restart files + integer, public, parameter :: nsrBranch = 2 + + ! true => allow case name to remain the same for branch run + ! by default this is not allowed + logical, public :: brnch_retain_casename = .false. + + !true => no valid land points -- do NOT run + logical, public :: noland = .false. + + ! true => run tests of ncdio_pio + logical, public :: for_testing_run_ncdiopio_tests = .false. + + ! Hostname of machine running on + character(len=256), public :: hostname = ' ' + + ! username of user running program + character(len=256), public :: username = ' ' + + ! description of this source + character(len=256), public :: source = "Community Terrestrial Systems Model" + + ! version of program + character(len=256), public :: version = " " + + ! dataset conventions + character(len=256), public :: conventions = "CF-1.0" + + ! component name for filenames (history or restart files) + character(len=8), public :: compname = 'clm2' + + !---------------------------------------------------------- + ! Unit Numbers + !---------------------------------------------------------- + ! + integer, public :: iulog = 6 ! "stdout" log file unit number, default is 6 + + !---------------------------------------------------------- + ! Output NetCDF files + !---------------------------------------------------------- + + logical, public :: outnc_large_files = .true. ! large file support for output NetCDF files + + !---------------------------------------------------------- + ! Run input files + !---------------------------------------------------------- + + character(len=fname_len), public :: finidat = ' ' ! initial conditions file name + character(len=fname_len), public :: fsurdat = ' ' ! surface data file name + character(len=fname_len), public :: fatmgrid = ' ' ! atm grid file name + character(len=fname_len), public :: fatmlndfrc = ' ' ! lnd frac file on atm grid + character(len=fname_len), public :: paramfile = ' ' ! ASCII data file with PFT physiological constants + character(len=fname_len), public :: nrevsn = ' ' ! restart data file name for branch run + character(len=fname_len), public :: fsnowoptics = ' ' ! snow optical properties file name + character(len=fname_len), public :: fsnowaging = ' ' ! snow aging parameters file name + + !---------------------------------------------------------- + ! Flag to read ndep rather than obtain it from coupler + !---------------------------------------------------------- + + logical, public :: ndep_from_cpl = .false. + + !---------------------------------------------------------- + ! Interpolation of finidat if requested + !---------------------------------------------------------- + + logical, public :: bound_h2osoi = .true. ! for debugging + + ! If finidat_interp_source is non-blank and finidat is blank then interpolation will be + ! done from finidat_interp_source to finidat_interp_dest. Note that + ! finidat_interp_source is not read in directly from the namelist - rather, it is set + ! from finidat if use_init_interp is .true. + + character(len=fname_len), public :: finidat_interp_source = ' ' + character(len=fname_len), public :: finidat_interp_dest = '' + + !---------------------------------------------------------- + ! Crop & Irrigation logic + !---------------------------------------------------------- + + ! If prognostic crops are turned on + logical, public :: use_crop = .false. + + ! true => separate crop landunit is not created by default + logical, public :: create_crop_landunit = .false. + + ! do not irrigate by default + logical, public :: irrigate = .false. + + ! set saturated excess runoff to zero for crops + logical, public :: crop_fsat_equals_zero = .false. + + !---------------------------------------------------------- + ! Other subgrid logic + !---------------------------------------------------------- + + ! true => allocate and run urban landunits everywhere where we have valid urban data + logical, public :: run_zero_weight_urban = .false. + + ! true => make ALL patches, cols & landunits active (even if weight is 0) + logical, public :: all_active = .false. + + logical, public :: collapse_urban = .false. ! true => collapse urban landunits to the dominant urban landunit; default = .false. means "do nothing" i.e. keep all urban landunits as found in the input data + integer, public :: n_dom_landunits = -1 ! # of dominant landunits; determines the number of active landunits; default = 0 (set in namelist_defaults_ctsm.xml) means "do nothing" + integer, public :: n_dom_pfts = -1 ! # of dominant pfts; determines the number of active pfts; default = 0 (set in namelist_defaults_ctsm.xml) means "do nothing" + + real(r8), public :: toosmall_soil = -1._r8 ! threshold above which the model keeps the soil landunit; default = 0 (set in namelist_defaults_ctsm.xml) means "do nothing" + real(r8), public :: toosmall_crop = -1._r8 ! threshold above which the model keeps the crop landunit; default = 0 (set in namelist_defaults_ctsm.xml) means "do nothing" + real(r8), public :: toosmall_glacier = -1._r8 ! threshold above which the model keeps the glacier landunit; default = 0 (set in namelist_defaults_ctsm.xml) means "do nothing" + real(r8), public :: toosmall_lake = -1._r8 ! threshold above which the model keeps the lake landunit; default = 0 (set in namelist_defaults_ctsm.xml) means "do nothing" + real(r8), public :: toosmall_wetland = -1._r8 ! threshold above which the model keeps the wetland landunit; default = 0 (set in namelist_defaults_ctsm.xml) means "do nothing" + real(r8), public :: toosmall_urban = -1._r8 ! threshold above which the model keeps any urban landunits that are present; default = 0 (set in namelist_defaults_ctsm.xml) means "do nothing" + + !---------------------------------------------------------- + ! BGC logic and datasets + !---------------------------------------------------------- + + ! values of 'prognostic','diagnostic','constant' + character(len=16), public :: co2_type = 'constant' + + ! State of the model for the accelerated decomposition (AD) spinup. + ! 0 (default) = normal model; 1 = AD SPINUP + integer, public :: spinup_state = 0 + + ! true => anoxia is applied to heterotrophic respiration also considered in CH4 model + ! default value reset in controlMod + logical, public :: anoxia = .true. + + ! used to override an error check on reading in restart files + logical, public :: override_bgc_restart_mismatch_dump = .false. + + ! Set in CNAllocationInit (TODO - had to move it here to avoid circular dependency) + logical, private:: carbon_only + + ! Set in CNNDynamicsInit + ! NOTE (mvertens, 2014-9 had to move it here to avoid confusion when carbon data types + ! wehre split - TODO - should move it our of this module) + ! NOTE(bandre, 2013-10) according to Charlie Koven, nfix_timeconst + ! is currently used as a flag and rate constant. + ! Rate constant: time over which to exponentially relax the npp flux for N fixation term + ! (days) time over which to exponentially relax the npp flux for N fixation term + ! flag: (if <= 0. or >= 365; use old annual method). + ! Default value is junk that should always be overwritten by the namelist or init function! + ! + real(r8), public :: nfix_timeconst = -1.2345_r8 + + !---------------------------------------------------------- + ! Physics + !---------------------------------------------------------- + + ! use subgrid fluxes + logical, public :: use_subgrid_fluxes = .true. + + ! which snow cover fraction parameterization to use + character(len=64), public :: snow_cover_fraction_method + + ! true => write global average diagnostics to std out + logical, public :: wrtdia = .false. + + ! atmospheric CO2 molar ratio (by volume) (umol/mol) + real(r8), public :: co2_ppmv = 355._r8 ! + + !---------------------------------------------------------- + ! C isotopes + !---------------------------------------------------------- + + logical, public :: use_c13 = .false. ! true => use C-13 model + logical, public :: use_c14 = .false. ! true => use C-14 model + !---------------------------------------------------------- + ! CN matrix + !---------------------------------------------------------- + logical, public :: use_matrixcn = .true. !.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 + ! SASU + 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. + ! eg. if nyr_forcing = 20, iloop_avg = 8, the restart file in yr 160 will be based on analytic solutions from yr 141 to 160. + ! The number of the analytic solutions within one loop depends on ratio between nyr_forcing and nyr_SASU. + ! eg. if nyr_forcing = 20, nyr_SASU = 5, number of analytic solutions is 20/5=4 + + ! BUG(wjs, 2018-10-25, ESCOMP/ctsm#67) There is a bug that causes incorrect values for C + ! isotopes if running init_interp from a case without C isotopes to a case with C + ! isotopes (https://github.com/ESCOMP/ctsm/issues/67). Normally, an error-check prevents + ! you from doing this interpolation (until we have fixed that bug). However, we + ! sometimes want to bypass this error-check in system tests. This namelist flag bypasses + ! this error-check. + logical, public :: for_testing_allow_interp_non_ciso_to_ciso = .false. + + !---------------------------------------------------------- + ! FATES switches + !---------------------------------------------------------- + + logical, public :: use_fates = .false. ! true => use fates + + ! These are INTERNAL to the FATES module + integer, public :: fates_parteh_mode = -9 ! 1 => carbon only + ! 2 => C+N+P (not enabled yet) + ! no others enabled + integer, public :: fates_spitfire_mode = 0 + ! 0 for no fire; 1 for constant ignitions; > 1 for external data (lightning and/or anthropogenic ignitions) + ! see bld/namelist_files/namelist_definition_clm4_5.xml for details + logical, public :: use_fates_logging = .false. ! true => turn on logging module + logical, public :: use_fates_planthydro = .false. ! true => turn on fates hydro + logical, public :: use_fates_cohort_age_tracking = .false. ! true => turn on cohort age tracking + logical, public :: use_fates_ed_st3 = .false. ! true => static stand structure + logical, public :: use_fates_ed_prescribed_phys = .false. ! true => prescribed physiology + logical, public :: use_fates_inventory_init = .false. ! true => initialize fates from inventory + logical, public :: use_fates_fixed_biogeog = .false. ! true => use fixed biogeography mode + character(len=256), public :: fates_inventory_ctrl_filename = '' ! filename for inventory control + + !---------------------------------------------------------- + ! LUNA switches + !---------------------------------------------------------- + + logical, public :: use_luna = .false. ! true => use LUNA + + !---------------------------------------------------------- + ! flexibleCN + !---------------------------------------------------------- + ! TODO(bja, 2015-08) some of these need to be moved into the + ! appropriate module. + logical, public :: use_flexibleCN = .false. + logical, public :: MM_Nuptake_opt = .false. + logical, public :: downreg_opt = .true. + integer, public :: plant_ndemand_opt = 0 + logical, public :: substrate_term_opt = .true. + logical, public :: nscalar_opt = .true. + logical, public :: temp_scalar_opt = .true. + logical, public :: CNratio_floating = .false. + logical, public :: lnc_opt = .false. + logical, public :: reduce_dayl_factor = .false. + integer, public :: vcmax_opt = 0 + integer, public :: CN_residual_opt = 0 + integer, public :: CN_partition_opt = 0 + integer, public :: CN_evergreen_phenology_opt = 0 + integer, public :: carbon_resp_opt = 0 + + !---------------------------------------------------------- + ! prescribed soil moisture streams switch + !---------------------------------------------------------- + + logical, public :: use_soil_moisture_streams = .false. ! true => use prescribed soil moisture stream + + !---------------------------------------------------------- + ! lai streams switch for Sat. Phenology + !---------------------------------------------------------- + + logical, public :: use_lai_streams = .false. ! true => use lai streams in SatellitePhenologyMod.F90 + + !---------------------------------------------------------- + ! biomass heat storage switch + !---------------------------------------------------------- + + logical, public :: use_biomass_heat_storage = .false. ! true => include biomass heat storage in canopy energy budget + + !---------------------------------------------------------- + ! bedrock / soil depth switch + !---------------------------------------------------------- + + logical, public :: use_bedrock = .false. ! true => use spatially variable soil depth + character(len=16), public :: soil_layerstruct_predefined = 'UNSET' + real(r8), public :: soil_layerstruct_userdefined(99) = rundef + integer, public :: soil_layerstruct_userdefined_nlevsoi = iundef + + !---------------------------------------------------------- + ! plant hydraulic stress switch + !---------------------------------------------------------- + + logical, public :: use_hydrstress = .false. ! true => use plant hydraulic stress calculation + + !---------------------------------------------------------- + ! dynamic root switch + !---------------------------------------------------------- + + logical, public :: use_dynroot = .false. ! true => use dynamic root module + + !---------------------------------------------------------- + ! glacier_mec control variables: default values (may be overwritten by namelist) + !---------------------------------------------------------- + + ! true => CLM glacier area & topography changes dynamically + logical , public :: glc_do_dynglacier = .false. + + ! number of days before one considers the perennially snow-covered point 'land ice' + integer , public :: glc_snow_persistence_max_days = 7300 + + ! + !---------------------------------------------------------- + ! single column control variables + !---------------------------------------------------------- + + logical, public :: single_column = .false. ! true => single column mode + real(r8), public :: scmlat = rundef ! single column lat + real(r8), public :: scmlon = rundef ! single column lon + + !---------------------------------------------------------- + ! instance control + !---------------------------------------------------------- + + integer, public :: inst_index + character(len=16), public :: inst_name + character(len=16), public :: inst_suffix + + !---------------------------------------------------------- + ! Decomp control variables + !---------------------------------------------------------- + + ! number of segments per clump for decomp + integer, public :: nsegspc = 20 + + !---------------------------------------------------------- + ! Derived variables (run, history and restart file) + !---------------------------------------------------------- + + ! directory name for local restart pointer file + character(len=256), public :: rpntdir = '.' + + ! file name for local restart pointer file + character(len=256), public :: rpntfil = 'rpointer.lnd' + + ! moved hist_wrtch4diag from histFileMod.F90 to here - caused compiler error with intel + ! namelist: write CH4 extra diagnostic output + logical, public :: hist_wrtch4diag = .false. + + ! namelist: write history master list to a file for use in documentation + logical, public :: hist_master_list_file = .false. + + !---------------------------------------------------------- + ! FATES + !---------------------------------------------------------- + character(len=fname_len), public :: fates_paramfile = ' ' + !---------------------------------------------------------- + ! SSRE diagnostic + !---------------------------------------------------------- + logical, public :: use_SSRE = .false. ! flag for SSRE diagnostic + + !---------------------------------------------------------- + ! Migration of CPP variables + !---------------------------------------------------------- + + logical, public :: use_lch4 = .false. + logical, public :: use_nitrif_denitrif = .false. + logical, public :: use_vertsoilc = .false. + logical, public :: use_extralakelayers = .false. + logical, public :: use_vichydro = .false. + logical, public :: use_century_decomp = .false. + logical, public :: use_cn = .false. + logical, public :: use_cndv = .false. + logical, public :: use_grainproduct = .false. + logical, public :: use_fertilizer = .false. + logical, public :: use_ozone = .false. + logical, public :: use_snicar_frc = .false. + logical, public :: use_vancouver = .false. + logical, public :: use_mexicocity = .false. + logical, public :: use_noio = .false. + + logical, public :: use_nguardrail = .false. + + !---------------------------------------------------------- + ! To retrieve namelist + !---------------------------------------------------------- + character(len=SHR_KIND_CL), public :: NLFilename_in ! Namelist filename + ! + logical, private :: clmvarctl_isset = .false. + !----------------------------------------------------------------------- + +contains + + !--------------------------------------------------------------------------- + subroutine clm_varctl_set( caseid_in, ctitle_in, brnch_retain_casename_in, & + single_column_in, scmlat_in, scmlon_in, nsrest_in, & + version_in, hostname_in, username_in) + ! + ! !DESCRIPTION: + ! Set input control variables. + ! + ! !ARGUMENTS: + character(len=256), optional, intent(IN) :: caseid_in ! case id + character(len=256), optional, intent(IN) :: ctitle_in ! case title + logical, optional, intent(IN) :: brnch_retain_casename_in ! true => allow case name to remain the + ! same for branch run + logical, optional, intent(IN) :: single_column_in ! true => single column mode + real(r8), optional, intent(IN) :: scmlat_in ! single column lat + real(r8), optional, intent(IN) :: scmlon_in ! single column lon + integer, optional, intent(IN) :: nsrest_in ! 0: initial run. 1: restart: 3: branch + character(len=256), optional, intent(IN) :: version_in ! model version + character(len=256), optional, intent(IN) :: hostname_in ! hostname running on + character(len=256), optional, intent(IN) :: username_in ! username running job + !----------------------------------------------------------------------- + + if ( clmvarctl_isset )then + call shr_sys_abort(' ERROR:: control variables already set, cannot call this routine') + end if + + if ( present(caseid_in ) ) caseid = caseid_in + if ( present(ctitle_in ) ) ctitle = ctitle_in + if ( present(single_column_in) ) single_column = single_column_in + if ( present(scmlat_in ) ) scmlat = scmlat_in + if ( present(scmlon_in ) ) scmlon = scmlon_in + if ( present(nsrest_in ) ) nsrest = nsrest_in + if ( present(brnch_retain_casename_in) ) brnch_retain_casename = brnch_retain_casename_in + if ( present(version_in ) ) version = version_in + if ( present(username_in ) ) username = username_in + if ( present(hostname_in ) ) hostname = hostname_in + + end subroutine clm_varctl_set + + ! 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 + + ! Get module carbon_only flag + logical function CNAllocate_Carbon_only() + cnallocate_carbon_only = carbon_only + end function CNAllocate_Carbon_only + +end module clm_varctl diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varpar.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varpar.F90 new file mode 100644 index 000000000..e1150c72a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/clm_varpar.F90 @@ -0,0 +1,331 @@ +module clm_varpar + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing CLM parameters + ! + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + use shr_sys_mod , only: shr_sys_abort + use spmdMod , only: masterproc + use clm_varctl , only: use_extralakelayers, use_vertsoilc + use clm_varctl , only: use_century_decomp, use_c13, use_c14 + use clm_varctl , only: iulog, use_crop, create_crop_landunit, irrigate + use clm_varctl , only: use_vichydro, rundef + use clm_varctl , only: soil_layerstruct_predefined + use clm_varctl , only: soil_layerstruct_userdefined + use clm_varctl , only: soil_layerstruct_userdefined_nlevsoi + use clm_varctl , only: use_fates + + ! + ! !PUBLIC TYPES: + implicit none + save + private + + ! Note - model resolution is read in from the surface dataset + + integer, public, parameter :: nlev_equalspace = 15 + integer, public, parameter :: toplev_equalspace = 6 + integer, public :: nlevsoi ! number of hydrologically active soil layers + integer, public :: nlevsoifl ! number of soil layers on input file + integer, public :: nlevgrnd ! number of ground layers + ! (includes lower layers that are hydrologically inactive) + integer, public :: nlevurb ! number of urban layers + integer, public :: nlevmaxurbgrnd ! maximum of the number of ground and urban layers + 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 :: nlevsno = -1 ! maximum number of snow layers + integer, public, parameter :: ngases = 3 ! CH4, O2, & CO2 + integer, public, parameter :: nlevcan = 1 ! number of leaf layers in canopy layer + integer, public, parameter :: nvegwcs = 4 ! number of vegetation water conductance segments + !ED variables + integer, public, parameter :: numwat = 5 ! number of water types (soil, ice, 2 lakes, wetland) + 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 :: numsolar = 2 ! number of solar type bands: direct, diffuse + integer, public, parameter :: ndst = 4 ! number of dust size classes (BGC only) + integer, public, parameter :: dst_src_nbr = 3 ! number of size distns in src soil (BGC only) + integer, public, parameter :: sz_nbr = 200 ! number of sub-grid bins in large bin of dust size distribution (BGC only) + integer, public, parameter :: mxpft = 78 ! maximum number of PFT's for any mode; + ! FIX(RF,032414) might we set some of these automatically from reading pft-physiology? + integer, public, parameter :: nlayer = 3 ! number of VIC soil layer --Added by AWang + integer, public :: nlayert ! number of VIC soil layer + 3 lower thermal layers + integer, public, parameter :: nvariants = 2 ! number of variants of PFT constants + 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 + + integer, public :: maxveg ! # of pfts + cfts + integer, public :: maxpatch_urb= 5 ! max number of urban patches (columns) in urban landunit + + integer, public :: maxsoil_patches ! # of pfts + cfts + bare ground; replaces maxpatch_pft, which is obsolete + + ! 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 index + + 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 :: 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 + + ! Indices used in surface file read and set in clm_varpar_init + + integer, public :: natpft_lb ! In PATCH arrays, lower bound of Patches on the natural veg landunit (i.e., bare ground index) + integer, public :: natpft_ub ! In PATCH arrays, upper bound of Patches on the natural veg landunit + integer, public :: natpft_size ! Number of Patches on natural veg landunit (including bare ground) + + ! The following variables pertain to arrays of all PFTs - e.g., those dimensioned (g, + ! pft_index). These include unused CFTs that are merged into other CFTs. Thus, these + ! variables do NOT give the actual number of CFTs on the crop landunit - that number + ! will generally be less because CLM does not simulate all crop types (some crop types + ! are merged into other types). + integer, public :: cft_lb ! In arrays of PFTs, lower bound of PFTs on the crop landunit + integer, public :: cft_ub ! In arrays of PFTs, upper bound of PFTs on the crop landunit + integer, public :: cft_size ! Number of PFTs on crop landunit in arrays of PFTs + + integer, public :: maxpatch_glcmec ! max number of elevation classes + integer, public :: max_patch_per_col + ! + ! !PUBLIC MEMBER FUNCTIONS: + public clm_varpar_init ! set parameters + ! + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------------ + subroutine clm_varpar_init(actual_maxsoil_patches, actual_numcft) + ! + ! !DESCRIPTION: + ! Initialize module variables + ! + ! !ARGUMENTS: + implicit none + integer, intent(in) :: actual_maxsoil_patches ! value from surface dataset + integer, intent(in) :: actual_numcft ! Actual number of crops + ! + ! !LOCAL VARIABLES: + ! + integer :: j ! loop index + character(len=32) :: subname = 'clm_varpar_init' ! subroutine name + !------------------------------------------------------------------------------ + + ! actual_maxsoil_patches and actual_numcft were read directly from the + ! surface dataset + maxsoil_patches = actual_maxsoil_patches ! # of patches with bare ground + maxveg = maxsoil_patches - 1 ! # of patches without bare ground + + ! For arrays containing all Patches (natural veg & crop), determine lower and upper bounds + ! for (1) Patches on the natural vegetation landunit (includes bare ground, and includes + ! crops if create_crop_landunit=false), and (2) CFTs on the crop landunit (no elements + ! if create_crop_landunit=false) + + if (create_crop_landunit) then + natpft_size = maxsoil_patches - actual_numcft ! includes bare ground + cft_size = actual_numcft + else + natpft_size = maxsoil_patches ! includes bare ground + cft_size = 0 + end if + + natpft_lb = 0 + natpft_ub = natpft_lb + natpft_size - 1 + cft_lb = natpft_ub + 1 + cft_ub = cft_lb + cft_size - 1 + + ! TODO(wjs, 2015-10-04, bugz 2227) Using actual_numcft in this 'max' gives a significant + ! overestimate of max_patch_per_col when use_crop is true. This should be reworked - + ! or, better, removed from the code entirely (because it is a maintenance problem, and + ! I can't imagine that looping idioms that use it help performance that much, and + ! likely they hurt performance.) + max_patch_per_col= max(maxsoil_patches, actual_numcft, maxpatch_urb) + + nlevsoifl = 10 + nlevurb = 5 + + if ( masterproc ) write(iulog, *) 'soil_layerstruct_predefined varpar ', soil_layerstruct_predefined + if ( masterproc ) write(iulog, *) 'soil_layerstruct_userdefined varpar ', soil_layerstruct_userdefined + + if (soil_layerstruct_userdefined(1) /= rundef) then ! user defined soil layers + if (soil_layerstruct_predefined /= 'UNSET') then + write(iulog,*) subname//' ERROR: Both soil_layerstruct_predefined and soil_layer_userdefined have values' + call shr_sys_abort(subname//' ERROR: Cannot decide how to set the soil layer structure') + else + nlevgrnd = size(soil_layerstruct_userdefined) + ! loops backwards until it hits the last valid user-defined value + do j = nlevgrnd,1,-1 + if (soil_layerstruct_userdefined(j) /= rundef) then + exit + else + nlevgrnd = nlevgrnd - 1 + end if + end do + nlevsoi = soil_layerstruct_userdefined_nlevsoi ! read in namelist + if (nlevsoi >= nlevgrnd) then + write(iulog,*) subname//' ERROR: nlevsoi >= nlevgrnd; did you enter soil_layerstruct_userdefined_nlevsoi correctly in user_nl_clm?' + call shr_sys_abort(subname//' ERROR: nlevsoi must be less than nlevgrnd') + end if + end if + else ! pre-defined soil structure options + if ( soil_layerstruct_predefined == '10SL_3.5m' ) then + nlevsoi = nlevsoifl + nlevgrnd = 15 + else if ( soil_layerstruct_predefined == '23SL_3.5m' ) then + nlevsoi = 8 + nlev_equalspace + nlevgrnd = 15 + nlev_equalspace + else if ( soil_layerstruct_predefined == '49SL_10m' ) then + nlevsoi = 49 ! 10x10 + 9x100 + 30x300 = 1e4mm = 10m +! nlevsoi = 29 ! 10x10 + 9x100 + 10x300 = 4e3mm = 4m + nlevgrnd = nlevsoi+5 + else if ( soil_layerstruct_predefined == '20SL_8.5m' ) then + nlevsoi = 20 + nlevgrnd = nlevsoi+5 + else if ( soil_layerstruct_predefined == '4SL_2m' ) then + nlevsoi = 4 + nlevgrnd = 5 + else if (soil_layerstruct_predefined == 'UNSET') then + write(iulog,*) subname//' ERROR: Both soil_layerstruct_predefined and soil_layer_userdefined currently undefined' + call shr_sys_abort(subname//' ERROR: Cannot set the soil layer structure') + else + write(iulog,*) subname//' ERROR: Unrecognized pre-defined soil layer structure: ', trim(soil_layerstruct_predefined) + call shr_sys_abort(subname//' ERROR: Unrecognized pre-defined soil layer structure') + end if + endif + nlevmaxurbgrnd = max0(nlevurb,nlevgrnd) + if ( masterproc ) write(iulog, *) 'nlevsoi, nlevgrnd varpar ', nlevsoi, nlevgrnd + + if (use_vichydro) then + nlayert = nlayer + (nlevgrnd -nlevsoi) + endif + + ! 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 + 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 ( masterproc )then + write(iulog, *) 'CLM varpar subsurface discretization levels ' + write(iulog, '(a, i3)') ' nlevsoi = ', nlevsoi + write(iulog, '(a, i3)') ' nlevgrnd = ', nlevgrnd + write(iulog, '(a, i3)') ' nlevdecomp = ', nlevdecomp + write(iulog, '(a, i3)') ' nlevdecomp_full = ', nlevdecomp_full + write(iulog, '(a, i3)') ' nlevlak = ', nlevlak + write(iulog, *) + 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_orig_files/cmake/genf90_utils.cmake b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/cmake/genf90_utils.cmake new file mode 100644 index 000000000..2ecc81f59 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/cmake/genf90_utils.cmake @@ -0,0 +1,90 @@ +# 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) + + # 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_orig_files/column_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/column_varcon.F90 new file mode 100644 index 000000000..d57006859 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/decompMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/decompMod.F90 new file mode 100644 index 000000000..3f885e090 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/decompMod.F90 @@ -0,0 +1,485 @@ +module decompMod + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Module provides a descomposition into a clumped data structure which can + ! be mapped back to atmosphere physics chunks. + ! + ! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + ! Must use shr_sys_abort rather than endrun here to avoid circular dependency + use shr_sys_mod , only : shr_sys_abort + use clm_varctl , only : iulog + use clm_varcon , only : grlnd, nameg, namel, namec, namep, nameCohort + use mct_mod , only : mct_gsMap + ! + ! !PUBLIC TYPES: + implicit none + integer, public :: clump_pproc ! number of clumps per MPI process + + ! 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 + + ! Define possible bounds levels + integer, parameter, public :: BOUNDS_LEVEL_PROC = 1 + integer, parameter, public :: BOUNDS_LEVEL_CLUMP = 2 + ! + ! !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 + public get_proc_clumps ! number of clumps for this processor + public get_proc_total ! total no. of gridcells, landunits, columns and patchs for any processor + public get_proc_global ! total gridcells, landunits, columns, patchs across all processors + public get_clmlevel_gsize ! get global size associated with clmlevel + public get_clmlevel_gsmap ! get gsmap associated with clmlevel + + interface get_clump_bounds + module procedure get_clump_bounds_old + module procedure get_clump_bounds_new + end interface + public get_clump_bounds ! clump beg and end gridcell,landunit,column,patch + + interface get_proc_bounds + module procedure get_proc_bounds_old + module procedure get_proc_bounds_new + end interface + public get_proc_bounds ! this processor beg and end gridcell,landunit,column,patch + + ! !PRIVATE MEMBER FUNCTIONS: + ! + ! !PRIVATE TYPES: + private ! (now mostly public for decompinitmod) + + integer,public :: nclumps ! total number of clumps across all processors + integer,public :: numg ! total number of gridcells on all procs + integer,public :: numl ! total number of landunits on all procs + integer,public :: numc ! total number of columns on all procs + integer,public :: nump ! total number of patchs on all procs + integer,public :: numCohort ! total number of fates cohorts on all procs + + 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 + end type bounds_type + public bounds_type + + !---global information on each pe + type processor_type + integer :: nclumps ! number of clumps for processor_type iam + integer,pointer :: cid(:) ! clump indices + integer :: ncells ! number of gridcells in proc + integer :: nlunits ! number of landunits in proc + integer :: ncols ! number of columns in proc + integer :: npatches ! number of patchs in proc + integer :: nCohorts ! number of cohorts in proc + 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 + end type processor_type + public processor_type + type(processor_type),public :: procinfo + + !---global information on each pe + type clump_type + integer :: owner ! process id owning clump + integer :: ncells ! number of gridcells in clump + integer :: nlunits ! number of landunits in clump + integer :: ncols ! number of columns in clump + integer :: npatches ! number of patchs in clump + integer :: nCohorts ! number of cohorts in proc + 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 + end type clump_type + public clump_type + type(clump_type),public, allocatable :: clumps(:) + + !---global information on each pe + !--- glo = 1d global sn ordered + !--- gdc = 1d global dc ordered compressed + type decomp_type + integer,pointer :: gdc2glo(:) ! 1d gdc to 1d glo + end type decomp_type + public decomp_type + type(decomp_type),public,target :: ldecomp + + type(mct_gsMap) ,public,target :: gsMap_lnd_gdc2glo ! GS map for full 2D land grid + type(mct_gsMap) ,public,target :: gsMap_gce_gdc2glo ! GS map for 1D gridcells + type(mct_gsMap) ,public,target :: gsMap_lun_gdc2glo ! GS map for 1D landunits + type(mct_gsMap) ,public,target :: gsMap_col_gdc2glo ! GS map for 1d columns + type(mct_gsMap) ,public,target :: gsMap_patch_gdc2glo ! GS map for 1D patches + type(mct_gsMap) ,public,target :: gsMap_cohort_gdc2glo ! GS map for 1D cohorts (only for FATES) + + type(mct_gsMap) ,public,target :: gsMap_lnd2Dsoi_gdc2glo ! GS map for full 3D land grid with soil levels as 3rd dim + !------------------------------------------------------------------------------ + +contains + + !----------------------------------------------------------------------- + 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 + + !------------------------------------------------------------------------------ + subroutine get_clump_bounds_new (n, bounds) + ! + ! !DESCRIPTION: + ! Determine clump bounds + ! + ! !ARGUMENTS: + integer, intent(in) :: n ! processor clump index + type(bounds_type), intent(out) :: bounds ! clump bounds + ! + ! !LOCAL VARIABLES: + character(len=32), parameter :: subname = 'get_clump_bounds' ! Subroutine name + integer :: cid ! clump id +#ifdef _OPENMP + integer, external :: OMP_GET_MAX_THREADS + integer, external :: OMP_GET_NUM_THREADS + integer, external :: OMP_GET_THREAD_NUM +#endif + !------------------------------------------------------------------------------ + ! Make sure this IS being called from a threaded region +#ifdef _OPENMP + ! FIX(SPM, 090314) - for debugging fates and openMP + !write(iulog,*) 'SPM omp debug decompMod 1 ', & + !OMP_GET_NUM_THREADS(),OMP_GET_MAX_THREADS(),OMP_GET_THREAD_NUM() + + if ( OMP_GET_NUM_THREADS() == 1 .and. OMP_GET_MAX_THREADS() > 1 )then + call shr_sys_abort( trim(subname)//' ERROR: Calling from inside a non-threaded region)') + end if +#endif + + cid = procinfo%cid(n) + bounds%begp = clumps(cid)%begp + bounds%endp = clumps(cid)%endp + bounds%begc = clumps(cid)%begc + bounds%endc = clumps(cid)%endc + bounds%begl = clumps(cid)%begl + bounds%endl = clumps(cid)%endl + bounds%begg = clumps(cid)%begg + bounds%endg = clumps(cid)%endg + bounds%begCohort = clumps(cid)%begCohort + bounds%endCohort = clumps(cid)%endCohort + + bounds%level = BOUNDS_LEVEL_CLUMP + bounds%clump_index = n + + end subroutine get_clump_bounds_new + + !------------------------------------------------------------------------------ + subroutine get_clump_bounds_old (n, begg, endg, begl, endl, begc, endc, begp, endp, & + begCohort, endCohort) + integer, intent(in) :: n ! proc clump index + integer, intent(out) :: begp, endp ! clump beg and end patch indices + integer, intent(out) :: begc, endc ! clump beg and end column indices + integer, intent(out) :: begl, endl ! clump beg and end landunit indices + integer, intent(out) :: begg, endg ! clump beg and end gridcell indices + integer, intent(out) :: begCohort, endCohort ! cohort beg and end gridcell indices + integer :: cid ! clump id + !------------------------------------------------------------------------------ + + cid = procinfo%cid(n) + begp = clumps(cid)%begp + endp = clumps(cid)%endp + begc = clumps(cid)%begc + endc = clumps(cid)%endc + begl = clumps(cid)%begl + endl = clumps(cid)%endl + begg = clumps(cid)%begg + endg = clumps(cid)%endg + begCohort = clumps(cid)%begCohort + endCohort = clumps(cid)%endCohort + end subroutine get_clump_bounds_old + + !------------------------------------------------------------------------------ + subroutine get_proc_bounds_new (bounds) + ! + ! !DESCRIPTION: + ! Retrieve processor bounds + ! + ! !ARGUMENTS: + type(bounds_type), intent(out) :: bounds ! processor bounds bounds + ! + ! !LOCAL VARIABLES: +#ifdef _OPENMP + integer, external :: OMP_GET_NUM_THREADS + integer, external :: OMP_GET_MAX_THREADS + integer, external :: OMP_GET_THREAD_NUM +#endif + character(len=32), parameter :: subname = 'get_proc_bounds' ! Subroutine name + !------------------------------------------------------------------------------ + ! Make sure this is NOT being called from a threaded region +#ifdef _OPENMP + ! FIX(SPM, 090314) - for debugging fates and openMP + !write(*,*) 'SPM omp debug decompMod 2 ', & + !OMP_GET_NUM_THREADS(),OMP_GET_MAX_THREADS(),OMP_GET_THREAD_NUM() + + if ( OMP_GET_NUM_THREADS() > 1 )then + call shr_sys_abort( trim(subname)//' ERROR: Calling from inside a threaded region') + end if +#endif + + bounds%begp = procinfo%begp + bounds%endp = procinfo%endp + bounds%begc = procinfo%begc + bounds%endc = procinfo%endc + bounds%begl = procinfo%begl + bounds%endl = procinfo%endl + bounds%begg = procinfo%begg + bounds%endg = procinfo%endg + bounds%begCohort = procinfo%begCohort + bounds%endCohort = procinfo%endCohort + + bounds%level = BOUNDS_LEVEL_PROC + bounds%clump_index = -1 ! irrelevant for proc, so assigned a bogus value + + end subroutine get_proc_bounds_new + + !------------------------------------------------------------------------------ + subroutine get_proc_bounds_old (begg, endg, begl, endl, begc, endc, begp, endp, & + begCohort, endCohort) + + integer, optional, intent(out) :: begp, endp ! proc beg and end patch indices + integer, optional, intent(out) :: begc, endc ! proc beg and end column indices + integer, optional, intent(out) :: begl, endl ! proc beg and end landunit indices + integer, optional, intent(out) :: begg, endg ! proc beg and end gridcell indices + integer, optional, intent(out) :: begCohort, endCohort ! cohort beg and end gridcell indices + !------------------------------------------------------------------------------ + + if (present(begp)) begp = procinfo%begp + if (present(endp)) endp = procinfo%endp + if (present(begc)) begc = procinfo%begc + if (present(endc)) endc = procinfo%endc + if (present(begl)) begl = procinfo%begl + if (present(endl)) endl = procinfo%endl + if (present(begg)) begg = procinfo%begg + if (present(endg)) endg = procinfo%endg + if (present(begCohort)) begCohort = procinfo%begCohort + if (present(endCohort)) endCohort = procinfo%endCohort + end subroutine get_proc_bounds_old + + !------------------------------------------------------------------------------ + subroutine get_proc_total(pid, ncells, nlunits, ncols, npatches, nCohorts) + ! + ! !DESCRIPTION: + ! Count up gridcells, landunits, columns, and patchs on process. + ! + ! !ARGUMENTS: + integer, intent(in) :: pid ! proc id + integer, intent(out) :: ncells ! total number of gridcells on the processor + integer, intent(out) :: nlunits ! total number of landunits on the processor + integer, intent(out) :: ncols ! total number of columns on the processor + integer, intent(out) :: npatches ! total number of patchs on the processor + integer, intent(out) :: nCohorts! total number of cohorts on the processor + ! + ! !LOCAL VARIABLES: + integer :: cid ! clump index + !------------------------------------------------------------------------------ + + npatches = 0 + nlunits = 0 + ncols = 0 + ncells = 0 + nCohorts = 0 + do cid = 1,nclumps + if (clumps(cid)%owner == pid) then + ncells = ncells + clumps(cid)%ncells + nlunits = nlunits + clumps(cid)%nlunits + ncols = ncols + clumps(cid)%ncols + npatches = npatches + clumps(cid)%npatches + nCohorts = nCohorts + clumps(cid)%nCohorts + end if + end do + end subroutine get_proc_total + + !------------------------------------------------------------------------------ + subroutine get_proc_global(ng, nl, nc, np, nCohorts) + ! + ! !DESCRIPTION: + ! Return number of gridcells, landunits, columns, and patchs across all processes. + ! + ! !ARGUMENTS: + integer, optional, intent(out) :: ng ! total number of gridcells across all processors + integer, optional, intent(out) :: nl ! total number of landunits across all processors + integer, optional, intent(out) :: nc ! total number of columns across all processors + integer, optional, intent(out) :: np ! total number of patchs across all processors + integer, optional, intent(out) :: nCohorts ! total number fates cohorts + !------------------------------------------------------------------------------ + + if (present(np)) np = nump + if (present(nc)) nc = numc + if (present(nl)) nl = numl + if (present(ng)) ng = numg + if (present(nCohorts)) nCohorts = numCohort + + end subroutine get_proc_global + + !------------------------------------------------------------------------------ + integer function get_proc_clumps() + ! + ! !DESCRIPTION: + ! Return the number of clumps. + !------------------------------------------------------------------------------ + + get_proc_clumps = procinfo%nclumps + + end function get_proc_clumps + + !----------------------------------------------------------------------- + integer function get_clmlevel_gsize (clmlevel) + ! + ! !DESCRIPTION: + ! Determine 1d size from clmlevel + ! + ! !USES: + use domainMod , only : ldomain + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: clmlevel !type of clm 1d array + !----------------------------------------------------------------------- + + select case (clmlevel) + case(grlnd) + get_clmlevel_gsize = ldomain%ns + case(nameg) + get_clmlevel_gsize = numg + case(namel) + get_clmlevel_gsize = numl + case(namec) + get_clmlevel_gsize = numc + case(namep) + get_clmlevel_gsize = nump + case(nameCohort) + get_clmlevel_gsize = numCohort + case default + write(iulog,*) 'get_clmlevel_gsize does not match clmlevel type: ', trim(clmlevel) + call shr_sys_abort() + end select + + end function get_clmlevel_gsize + + !----------------------------------------------------------------------- + subroutine get_clmlevel_gsmap (clmlevel, gsmap) + ! + ! !DESCRIPTION: + ! Compute arguments for gatherv, scatterv for vectors + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: clmlevel ! type of input data + type(mct_gsmap) , pointer :: gsmap + !---------------------------------------------------------------------- + + select case (clmlevel) + case(grlnd) + gsmap => gsmap_lnd_gdc2glo + case(nameg) + gsmap => gsmap_gce_gdc2glo + case(namel) + gsmap => gsmap_lun_gdc2glo + case(namec) + gsmap => gsmap_col_gdc2glo + case(namep) + gsmap => gsmap_patch_gdc2glo + case(nameCohort) + gsmap => gsMap_cohort_gdc2glo + case default + write(iulog,*) 'get_clmlevel_gsmap: Invalid expansion character: ',trim(clmlevel) + call shr_sys_abort() + end select + + end subroutine get_clmlevel_gsmap + +end module decompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/dynSubgridControlMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/dynSubgridControlMod.F90 new file mode 100644 index 000000000..b4da85be7 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/dynSubgridControlMod.F90 @@ -0,0 +1,417 @@ +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 + use clm_varctl , only : fname_len + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: dynSubgridControl_init + public :: get_flanduse_timeseries ! return the value of the flanduse_timeseries file name + 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_transient_lakes ! return the value of the do_transient_lakes control flag + public :: run_has_transient_landcover ! returns true if any aspects of prescribed transient landcover are enabled + public :: get_do_harvest ! return the value of the do_harvest control flag + public :: get_reset_dynbal_baselines ! return the value of the reset_dynbal_baselines control flag + public :: get_for_testing_allow_non_annual_changes ! return true if user has requested to allow area changes at times other than the year boundary, for testing purposes + public :: get_for_testing_zero_dynbal_fluxes ! return true if user has requested to set the dynbal water and energy fluxes to zero, for testing purposes + ! + ! !PRIVATE MEMBER FUNCTIONS: + private :: read_namelist ! read namelist variables + private :: check_namelist_consistency ! check consistency of namelist settings + ! + ! !PRIVATE TYPES: + type dyn_subgrid_control_type + private + character(len=fname_len) :: flanduse_timeseries = ' ' ! transient landuse dataset + 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( NLFilename ) + ! + ! !DESCRIPTION: + ! Initialize the dyn_subgrid_control settings. + ! + ! !USES: + use spmdMod , only : masterproc + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'dynSubgridControl_init' + !----------------------------------------------------------------------- + + call read_namelist( NLFilename ) + if (masterproc) then + call check_namelist_consistency + end if + + dyn_subgrid_control_inst%initialized = .true. + + end subroutine dynSubgridControl_init + + !----------------------------------------------------------------------- + subroutine read_namelist( NLFilename ) + ! + ! !DESCRIPTION: + ! Read dyn_subgrid_control namelist variables + ! + ! !USES: + use fileutils , only : getavu, relavu + use clm_nlUtilsMod , only : find_nlgroup_name + use clm_varctl , only : iulog + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + ! temporary variables corresponding to the components of dyn_subgrid_control_type: + character(len=fname_len) :: flanduse_timeseries + logical :: do_transient_pfts + logical :: do_transient_crops + logical :: do_transient_lakes + logical :: do_harvest + logical :: reset_dynbal_baselines + logical :: for_testing_allow_non_annual_changes + logical :: for_testing_zero_dynbal_fluxes + ! other local variables: + integer :: nu_nml ! unit for namelist file + integer :: nml_error ! namelist i/o error flag + + character(len=*), parameter :: subname = 'read_namelist' + !----------------------------------------------------------------------- + + namelist /dynamic_subgrid/ & + flanduse_timeseries, & + do_transient_pfts, & + do_transient_crops, & + do_transient_lakes, & + do_harvest, & + reset_dynbal_baselines, & + for_testing_allow_non_annual_changes, & + for_testing_zero_dynbal_fluxes + + ! Initialize options to default values, in case they are not specified in the namelist + flanduse_timeseries = ' ' + do_transient_pfts = .false. + do_transient_crops = .false. + do_transient_lakes = .false. + do_harvest = .false. + reset_dynbal_baselines = .false. + for_testing_allow_non_annual_changes = .false. + for_testing_zero_dynbal_fluxes = .false. + + if (masterproc) then + nu_nml = getavu() + open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) + call find_nlgroup_name(nu_nml, 'dynamic_subgrid', status=nml_error) + if (nml_error == 0) then + read(nu_nml, nml=dynamic_subgrid, iostat=nml_error) + if (nml_error /= 0) then + call endrun(msg='ERROR reading dynamic_subgrid namelist'//errMsg(sourcefile, __LINE__)) + end if + else + call endrun(msg='ERROR finding dynamic_subgrid namelist'//errMsg(sourcefile, __LINE__)) + end if + close(nu_nml) + call relavu( nu_nml ) + endif + + call shr_mpi_bcast (flanduse_timeseries, mpicom) + call shr_mpi_bcast (do_transient_pfts, mpicom) + call shr_mpi_bcast (do_transient_crops, mpicom) + call shr_mpi_bcast (do_transient_lakes, mpicom) + call shr_mpi_bcast (do_harvest, mpicom) + call shr_mpi_bcast (reset_dynbal_baselines, mpicom) + call shr_mpi_bcast (for_testing_allow_non_annual_changes, mpicom) + call shr_mpi_bcast (for_testing_zero_dynbal_fluxes, mpicom) + + dyn_subgrid_control_inst = dyn_subgrid_control_type( & + flanduse_timeseries = flanduse_timeseries, & + do_transient_pfts = do_transient_pfts, & + do_transient_crops = do_transient_crops, & + do_transient_lakes = do_transient_lakes, & + do_harvest = do_harvest, & + reset_dynbal_baselines = reset_dynbal_baselines, & + for_testing_allow_non_annual_changes = for_testing_allow_non_annual_changes, & + for_testing_zero_dynbal_fluxes = for_testing_zero_dynbal_fluxes) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) 'dynamic_subgrid settings:' + write(iulog,nml=dynamic_subgrid) + write(iulog,*) ' ' + end if + + end subroutine read_namelist + + !----------------------------------------------------------------------- + subroutine check_namelist_consistency + ! + ! !DESCRIPTION: + ! Check consistency of namelist settings + ! + ! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varctl, only : iulog, use_cndv, use_fates, use_cn, use_crop, & + n_dom_pfts, n_dom_landunits, collapse_urban, & + toosmall_soil, toosmall_crop, toosmall_glacier, & + toosmall_lake, toosmall_wetland, toosmall_urban + ! + ! !ARGUMENTS: + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'check_namelist_consistency' + !----------------------------------------------------------------------- + + if (dyn_subgrid_control_inst%flanduse_timeseries == ' ') then + if (dyn_subgrid_control_inst%do_transient_pfts) then + write(iulog,*) 'ERROR: do_transient_pfts can only be true if you are running with' + write(iulog,*) 'a flanduse_timeseries file (currently flanduse_timeseries is blank)' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (dyn_subgrid_control_inst%do_transient_crops) then + write(iulog,*) 'ERROR: do_transient_crops can only be true if you are running with' + write(iulog,*) 'a flanduse_timeseries file (currently flanduse_timeseries is blank)' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (dyn_subgrid_control_inst%do_transient_lakes) then + write(iulog,*) 'ERROR: do_transient_lakes can only be true if you are running with' + write(iulog,*) 'a flanduse_timeseries file (currently flanduse_timeseries is blank)' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (dyn_subgrid_control_inst%do_harvest) then + write(iulog,*) 'ERROR: do_harvest can only be true if you are running with' + write(iulog,*) 'a flanduse_timeseries file (currently flanduse_timeseries is blank)' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if (dyn_subgrid_control_inst%do_transient_pfts) then + if (use_cndv) then + write(iulog,*) 'ERROR: do_transient_pfts is incompatible with use_cndv' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (use_fates) then + write(iulog,*) 'ERROR: do_transient_pfts is incompatible with use_fates' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! NOTE(wjs, 2020-08-23) In the following error checks, I'm treating do_transient_lakes + ! similar to do_transient_pfts and do_transient_crops. I'm not sure if all of these + ! checks are truly important for transient lakes (in particular, my guess is that + ! collapse_urban could probably be done with transient lakes - as well as transient + ! pfts and transient crops for that matter), but some of the checks probably are + ! needed, and it seems best to keep transient lakes consistent with other transient + ! areas in this respect. + if (dyn_subgrid_control_inst%do_transient_pfts .or. & + dyn_subgrid_control_inst%do_transient_crops .or. & + dyn_subgrid_control_inst%do_transient_lakes) then + if (collapse_urban) then + write(iulog,*) 'ERROR: do_transient_pfts, do_transient_crops and do_transient_lakes are & + incompatible with collapse_urban = .true.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (n_dom_pfts > 0 .or. n_dom_landunits > 0 & + .or. toosmall_soil > 0._r8 .or. toosmall_crop > 0._r8 & + .or. toosmall_glacier > 0._r8 .or. toosmall_lake > 0._r8 & + .or. toosmall_wetland > 0._r8 .or. toosmall_urban > 0._r8) then + write(iulog,*) 'ERROR: do_transient_pfts, do_transient_crops and do_transient_lakes are & + incompatible with any of the following set to > 0: & + n_dom_pfts > 0, n_dom_landunits > 0, & + toosmall_soil > 0._r8, toosmall_crop > 0._r8, & + toosmall_glacier > 0._r8, toosmall_lake > 0._r8, & + toosmall_wetland > 0._r8, toosmall_urban > 0._r8.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if (dyn_subgrid_control_inst%do_transient_crops) then + if (use_fates) then + ! NOTE(wjs, 2017-01-13) ED / FATES does not currently have a mechanism for + ! changing its column areas, with the consequent changes in aboveground biomass + ! per unit area. See https://github.com/NGEET/ed-clm/issues/173 + write(iulog,*) 'ERROR: do_transient_crops does not currently work with use_fates' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if (dyn_subgrid_control_inst%do_harvest) then + if (.not. (use_cn .or. use_fates)) then + write(iulog,*) 'ERROR: do_harvest can only be true if either use_cn or use_fates are true' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end subroutine check_namelist_consistency + + !----------------------------------------------------------------------- + character(len=fname_len) function get_flanduse_timeseries() + ! !DESCRIPTION: + ! Return the value of the flanduse_timeseries file name + + character(len=*), parameter :: subname = 'get_flanduse_timeseries' + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(dyn_subgrid_control_inst%initialized, sourcefile, __LINE__) + + get_flanduse_timeseries = dyn_subgrid_control_inst%flanduse_timeseries + + end function get_flanduse_timeseries + + !----------------------------------------------------------------------- + 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 get_do_transient_lakes() + ! !DESCRIPTION: + ! Return the value of the do_transient_lakes control flag + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(dyn_subgrid_control_inst%initialized, sourcefile, __LINE__) + + get_do_transient_lakes = dyn_subgrid_control_inst%do_transient_lakes + + end function get_do_transient_lakes + + !----------------------------------------------------------------------- + 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 + + !----------------------------------------------------------------------- + logical function get_reset_dynbal_baselines() + ! !DESCRIPTION: + ! Return the value of the reset_dynbal_baselines control flag + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(dyn_subgrid_control_inst%initialized, sourcefile, __LINE__) + + get_reset_dynbal_baselines = dyn_subgrid_control_inst%reset_dynbal_baselines + + end function get_reset_dynbal_baselines + + !----------------------------------------------------------------------- + logical function get_for_testing_allow_non_annual_changes() + ! + ! !DESCRIPTION: + ! Return true if the user has requested to allow area changes at times other than the + ! year boundary. (This should typically only be true for testing.) (This only + ! controls error-checking, not any operation of the code.) + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(dyn_subgrid_control_inst%initialized, sourcefile, __LINE__) + + get_for_testing_allow_non_annual_changes = dyn_subgrid_control_inst%for_testing_allow_non_annual_changes + + end function get_for_testing_allow_non_annual_changes + + !----------------------------------------------------------------------- + logical function get_for_testing_zero_dynbal_fluxes() + ! + ! !DESCRIPTION: + ! Return true if the user has requested to set the dynbal water and energy fluxes to + ! zero. This should typically only be true for testing: 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! + ! ----------------------------------------------------------------------- + + SHR_ASSERT_FL(dyn_subgrid_control_inst%initialized, sourcefile, __LINE__) + + get_for_testing_zero_dynbal_fluxes = dyn_subgrid_control_inst%for_testing_zero_dynbal_fluxes + + end function get_for_testing_zero_dynbal_fluxes + +end module dynSubgridControlMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/fileutils.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/fileutils.F90 new file mode 100644 index 000000000..b74af4242 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/filterColMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/filterColMod.F90 new file mode 100644 index 000000000..345108588 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/filterMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/filterMod.F90 new file mode 100644 index 000000000..246d0c614 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/filterMod.F90 @@ -0,0 +1,595 @@ +module filterMod + +#include "shr_assert.h" + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module of filters used for processing columns and pfts of particular + ! types, including lake, non-lake, urban, soil, snow, non-snow, and + ! naturally-vegetated patches. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use clm_varctl , only : iulog + use decompMod , only : bounds_type + use GridcellType , only : grc + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use glcBehaviorMod , only : glc_behavior_type + ! + ! !PUBLIC TYPES: + implicit none + save + private + ! + 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(:) + + ! --- DO NOT USING THE FOLLOWING VARIABLE UNLESS YOU KNOW WHAT YOU'RE DOING! --- + ! + ! This is a separate set of filters that contains both inactive and active points. It is + ! rarely appropriate to use these, but they are needed in a few places, e.g., where + ! quantities are computed before weights, active flags and filters are updated due to + ! landuse change. Note that, for the handful of filters that are computed outside of + ! setFiltersOneGroup (including the CNDV natvegp filter and the snow filters), these + ! filters are NOT included in this variable - so they can only be used from the main + ! 'filter' variable. + ! + ! Ideally, we would like to restructure the initialization code and driver ordering so + ! that this version of the filters is never needed. At that point, we could remove this + ! filter_inactive_and_active variable, and simplify filterMod to look the way it did + ! before this variable was added (i.e., when there was only a single group of filters). + ! + type(clumpfilter), allocatable, public :: filter_inactive_and_active(:) + ! + public allocFilters ! allocate memory for filters + public setFilters ! set filters + public setExposedvegpFilter ! set the exposedvegp and noexposedvegp filters + + private allocFiltersOneGroup ! allocate memory for one group of filters + private setFiltersOneGroup ! set one group of filters + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! + ! !REVISION HISTORY: + ! Created by Mariana Vertenstein + ! 11/13/03, Peter Thornton: Added soilp and num_soilp + ! Jan/08, S. Levis: Added crop-related filters + ! June/13, Bill Sacks: Change main filters to just work over 'active' points; + ! add filter_inactive_and_active + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------ + subroutine allocFilters() + ! + ! !DESCRIPTION: + ! Allocate CLM filters. + ! + ! !REVISION HISTORY: + ! Created by Bill Sacks + !------------------------------------------------------------------------ + + call allocFiltersOneGroup(filter) + call allocFiltersOneGroup(filter_inactive_and_active) + + end subroutine allocFilters + + !------------------------------------------------------------------------ + subroutine allocFiltersOneGroup(this_filter) + ! + ! !DESCRIPTION: + ! Allocate CLM filters, for one group of filters. + ! + ! !USES: + use decompMod , only : get_proc_clumps, get_clump_bounds + ! + ! !ARGUMENTS: + type(clumpfilter), intent(inout), allocatable :: this_filter(:) ! the filter to allocate + ! + ! LOCAL VARAIBLES: + integer :: nc ! clump index + integer :: nclumps ! total number of clumps on this processor + integer :: ier ! error status + type(bounds_type) :: bounds + !------------------------------------------------------------------------ + + ! Determine clump variables for this processor + + nclumps = get_proc_clumps() + + ier = 0 + if( .not. allocated(this_filter)) then + allocate(this_filter(nclumps), stat=ier) + end if + if (ier /= 0) then + write(iulog,*) 'allocFiltersOneGroup(): allocation error for clumpsfilters' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Loop over clumps on this processor + +!$OMP PARALLEL DO PRIVATE (nc,bounds) + do nc = 1, nclumps + call get_clump_bounds(nc, bounds) + + allocate(this_filter(nc)%allc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(nc)%lakep(bounds%endp-bounds%begp+1)) + allocate(this_filter(nc)%nolakep(bounds%endp-bounds%begp+1)) + allocate(this_filter(nc)%nolakeurbanp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(nc)%lakec(bounds%endc-bounds%begc+1)) + allocate(this_filter(nc)%nolakec(bounds%endc-bounds%begc+1)) + + allocate(this_filter(nc)%soilc(bounds%endc-bounds%begc+1)) + allocate(this_filter(nc)%soilp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(nc)%snowc(bounds%endc-bounds%begc+1)) + allocate(this_filter(nc)%nosnowc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(nc)%lakesnowc(bounds%endc-bounds%begc+1)) + allocate(this_filter(nc)%lakenosnowc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(nc)%exposedvegp(bounds%endp-bounds%begp+1)) + allocate(this_filter(nc)%noexposedvegp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(nc)%natvegp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(nc)%hydrologyc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(nc)%urbanp(bounds%endp-bounds%begp+1)) + allocate(this_filter(nc)%nourbanp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(nc)%urbanc(bounds%endc-bounds%begc+1)) + allocate(this_filter(nc)%nourbanc(bounds%endc-bounds%begc+1)) + + allocate(this_filter(nc)%urbanl(bounds%endl-bounds%begl+1)) + allocate(this_filter(nc)%nourbanl(bounds%endl-bounds%begl+1)) + + allocate(this_filter(nc)%pcropp(bounds%endp-bounds%begp+1)) + allocate(this_filter(nc)%soilnopcropp(bounds%endp-bounds%begp+1)) + + allocate(this_filter(nc)%icemecc(bounds%endc-bounds%begc+1)) + allocate(this_filter(nc)%do_smb_c(bounds%endc-bounds%begc+1)) + + allocate(this_filter(nc)%actfirec(bounds%endc-bounds%begc+1)) + allocate(this_filter(nc)%actfirep(bounds%endp-bounds%begp+1)) + + this_filter(nc)%num_actfirep = 1 + this_filter(nc)%num_actfirec = 1 + + end do +!$OMP END PARALLEL DO + + end subroutine allocFiltersOneGroup + + !------------------------------------------------------------------------ + subroutine setFilters(bounds, glc_behavior) + ! + ! !DESCRIPTION: + ! Set CLM filters. + use decompMod , only : BOUNDS_LEVEL_CLUMP + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(glc_behavior_type) , intent(in) :: glc_behavior + !------------------------------------------------------------------------ + + SHR_ASSERT_FL(bounds%level == BOUNDS_LEVEL_CLUMP, sourcefile, __LINE__) + + call setFiltersOneGroup(bounds, & + filter, include_inactive = .false., & + glc_behavior = glc_behavior) + + ! At least as of June, 2013, the 'inactive_and_active' version of the filters is + ! static in time. Thus, we could have some logic saying whether we're in + ! initialization, and if so, skip this call. But this is problematic for two reasons: + ! (1) it requires that the caller of this routine (currently reweight_wrapup) know + ! whether it is in initialization; and (2) it assumes that the filter definitions + ! won't be changed in the future in a way that creates some variability in time. So + ! for now, it seems cleanest and safest to just update these filters whenever the main + ! filters are updated. But if this proves to be a performance problem, we could + ! introduce an argument saying whether we're in initialization, and if so, skip this + ! call. + + call setFiltersOneGroup(bounds, & + filter_inactive_and_active, include_inactive = .true., & + glc_behavior = glc_behavior) + + end subroutine setFilters + + + !------------------------------------------------------------------------ + subroutine setFiltersOneGroup(bounds, this_filter, include_inactive, glc_behavior) + ! + ! !DESCRIPTION: + ! Set CLM filters for one group of filters. + ! + ! "Standard" filters only include active points. However, this routine can be used to set + ! alternative filters that also apply over inactive points, by setting include_inactive = + ! .true. + ! + ! This routine sets filters that are determined by subgrid type, "active" status of + ! patch, col or landunit, and the like. Filters based on model state (e.g., snow + ! cover) should generally be set elsewhere, to ensure that the routine that sets them + ! is called at the right time in the driver loop. + ! + ! !USES: + use decompMod , only : BOUNDS_LEVEL_CLUMP + use pftconMod , only : npcropmin + use landunit_varcon , only : istsoil, istcrop, istice_mec + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(clumpfilter) , intent(inout) :: this_filter(:) ! the group of filters to set + logical , intent(in) :: include_inactive ! whether inactive points should be included in the filters + type(glc_behavior_type) , intent(in) :: glc_behavior + ! + ! LOCAL VARAIBLES: + integer :: nc ! clump index + integer :: c,l,p ! column, landunit, patch indices + integer :: fl ! lake filter index + integer :: fnl,fnlu ! non-lake filter index + integer :: fs ! soil filter index + integer :: f, fn ! general indices + integer :: g !gridcell index + !------------------------------------------------------------------------ + + SHR_ASSERT_FL(bounds%level == BOUNDS_LEVEL_CLUMP, sourcefile, __LINE__) + + nc = bounds%clump_index + + ! Create filter of all columns + fl = 0 + do c = bounds%begc,bounds%endc + if (col%active(c) .or. include_inactive) then + fl = fl + 1 + this_filter(nc)%allc(fl) = c + end if + end do + this_filter(nc)%num_allc = fl + + ! Create lake and non-lake filters at column-level + + fl = 0 + fnl = 0 + do c = bounds%begc,bounds%endc + if (col%active(c) .or. include_inactive) then + l =col%landunit(c) + if (lun%lakpoi(l)) then + fl = fl + 1 + this_filter(nc)%lakec(fl) = c + else + fnl = fnl + 1 + this_filter(nc)%nolakec(fnl) = c + end if + end if + end do + this_filter(nc)%num_lakec = fl + this_filter(nc)%num_nolakec = fnl + + ! Create lake and non-lake filters at patch-level + + fl = 0 + fnl = 0 + fnlu = 0 + do p = bounds%begp,bounds%endp + if (patch%active(p) .or. include_inactive) then + l =patch%landunit(p) + if (lun%lakpoi(l) ) then + fl = fl + 1 + this_filter(nc)%lakep(fl) = p + else + fnl = fnl + 1 + this_filter(nc)%nolakep(fnl) = p + if (.not. lun%urbpoi(l)) then + fnlu = fnlu + 1 + this_filter(nc)%nolakeurbanp(fnlu) = p + end if + end if + end if + end do + this_filter(nc)%num_lakep = fl + this_filter(nc)%num_nolakep = fnl + this_filter(nc)%num_nolakeurbanp = fnlu + + ! Create soil filter at column-level + + fs = 0 + do c = bounds%begc,bounds%endc + if (col%active(c) .or. include_inactive) then + l =col%landunit(c) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + fs = fs + 1 + this_filter(nc)%soilc(fs) = c + end if + end if + end do + this_filter(nc)%num_soilc = fs + ! Create soil filter at patch-level + + fs = 0 + do p = bounds%begp,bounds%endp + if (patch%active(p) .or. include_inactive) then + l =patch%landunit(p) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + fs = fs + 1 + this_filter(nc)%soilp(fs) = p + end if + end if + end do + this_filter(nc)%num_soilp = fs + + ! Create column-level hydrology filter (soil and Urban pervious road cols) + + f = 0 + do c = bounds%begc,bounds%endc + if (col%active(c) .or. include_inactive) then + if (col%hydrologically_active(c)) then + f = f + 1 + this_filter(nc)%hydrologyc(f) = c + end if + end if + end do + this_filter(nc)%num_hydrologyc = f + + ! Create prognostic crop and soil w/o prog. crop filters at patch-level + ! according to where the crop model should be used + + fl = 0 + fnl = 0 + do p = bounds%begp,bounds%endp + if (patch%active(p) .or. include_inactive) then + if (patch%itype(p) >= npcropmin) then !skips 2 generic crop types + fl = fl + 1 + this_filter(nc)%pcropp(fl) = p + else + l =patch%landunit(p) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + fnl = fnl + 1 + this_filter(nc)%soilnopcropp(fnl) = p + end if + end if + end if + end do + this_filter(nc)%num_pcropp = fl + this_filter(nc)%num_soilnopcropp = fnl ! This wasn't being set before... + + ! Create landunit-level urban and non-urban filters + + f = 0 + fn = 0 + do l = bounds%begl,bounds%endl + if (lun%active(l) .or. include_inactive) then + if (lun%urbpoi(l)) then + f = f + 1 + this_filter(nc)%urbanl(f) = l + else + fn = fn + 1 + this_filter(nc)%nourbanl(fn) = l + end if + end if + end do + this_filter(nc)%num_urbanl = f + this_filter(nc)%num_nourbanl = fn + + ! Create column-level urban and non-urban filters + + f = 0 + fn = 0 + do c = bounds%begc,bounds%endc + if (col%active(c) .or. include_inactive) then + l = col%landunit(c) + if (lun%urbpoi(l)) then + f = f + 1 + this_filter(nc)%urbanc(f) = c + else + fn = fn + 1 + this_filter(nc)%nourbanc(fn) = c + end if + end if + end do + this_filter(nc)%num_urbanc = f + this_filter(nc)%num_nourbanc = fn + + ! Create patch-level urban and non-urban filters + + f = 0 + fn = 0 + do p = bounds%begp,bounds%endp + if (patch%active(p) .or. include_inactive) then + l = patch%landunit(p) + if (lun%urbpoi(l)) then + f = f + 1 + this_filter(nc)%urbanp(f) = p + else + fn = fn + 1 + this_filter(nc)%nourbanp(fn) = p + end if + end if + end do + this_filter(nc)%num_urbanp = f + this_filter(nc)%num_nourbanp = fn + + f = 0 + do c = bounds%begc,bounds%endc + if (col%active(c) .or. include_inactive) then + l = col%landunit(c) + if (lun%itype(l) == istice_mec) then + f = f + 1 + this_filter(nc)%icemecc(f) = c + end if + end if + end do + this_filter(nc)%num_icemecc = f + + f = 0 + do c = bounds%begc,bounds%endc + if (col%active(c) .or. include_inactive) then + l = col%landunit(c) + g = col%gridcell(c) + + ! Only compute SMB in regions where we replace ice melt with new ice: + ! Elsewhere (where ice melt remains in place), we cannot compute a sensible + ! negative SMB. + ! + ! In addition to istice_mec columns, we also compute SMB for any soil column in + ! this region, in order to provide SMB forcing for the bare ground elevation + ! class (elevation class 0). + if ( glc_behavior%melt_replaced_by_ice_grc(g) .and. & + (lun%itype(l) == istice_mec .or. lun%itype(l) == istsoil)) then + f = f + 1 + this_filter(nc)%do_smb_c(f) = c + end if + end if + end do + this_filter(nc)%num_do_smb_c = f + + ! Note: snow filters are reconstructed each time step in + ! LakeHydrology and SnowHydrology + ! Note: CNDV "pft present" filter is reconstructed each time CNDV is run + + end subroutine setFiltersOneGroup + + !----------------------------------------------------------------------- + subroutine setExposedvegpFilter(bounds, frac_veg_nosno) + ! + ! !DESCRIPTION: + ! Sets the exposedvegp and noexposedvegp filters for one clump. + ! + ! The exposedvegp filter includes points for which frac_veg_nosno > 0. noexposedvegp + ! includes points for which frac_veg_nosno <= 0. However, note that neither filter + ! includes urban or lake points! + ! + ! Should be called from within a loop over clumps. + ! + ! Only sets this filter in the main 'filter' variable, NOT in + ! filter_inactive_and_active. + ! + ! Note that this is done separately from the main setFilters routine, because it may + ! need to be called at a different time in the driver loop. + ! + ! !USES: + use decompMod , only : BOUNDS_LEVEL_CLUMP + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: frac_veg_nosno( bounds%begp: ) ! fraction of vegetation not covered by snow [patch] + ! + ! !LOCAL VARIABLES: + integer :: nc ! clump index + integer :: fp ! filter index + integer :: p ! patch index + integer :: fe, fn ! filter counts + + character(len=*), parameter :: subname = 'setExposedvegpFilter' + !----------------------------------------------------------------------- + + SHR_ASSERT_FL(bounds%level == BOUNDS_LEVEL_CLUMP, sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(frac_veg_nosno) == (/bounds%endp/)), sourcefile, __LINE__) + + nc = bounds%clump_index + + fe = 0 + fn = 0 + do fp = 1, filter(nc)%num_nolakeurbanp + p = filter(nc)%nolakeurbanp(fp) + if (frac_veg_nosno(p) > 0) then + fe = fe + 1 + filter(nc)%exposedvegp(fe) = p + else + fn = fn + 1 + filter(nc)%noexposedvegp(fn) = p + end if + end do + filter(nc)%num_exposedvegp = fe + filter(nc)%num_noexposedvegp = fn + + end subroutine setExposedvegpFilter + + +end module filterMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/initSubgridMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/initSubgridMod.F90 new file mode 100644 index 000000000..43851c337 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/initVerticalMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/initVerticalMod.F90 new file mode 100644 index 000000000..58bf29afc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/initVerticalMod.F90 @@ -0,0 +1,813 @@ +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, assignment(=) + 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 : toplev_equalspace, nlev_equalspace + use clm_varpar , only : nlevsoi, nlevsoifl, nlevurb, nlevmaxurbgrnd + use clm_varctl , only : fsurdat, iulog + use clm_varctl , only : use_vancouver, use_mexicocity, use_vertsoilc, use_extralakelayers + use clm_varctl , only : use_bedrock, rundef + use clm_varctl , only : soil_layerstruct_predefined, soil_layerstruct_userdefined + use clm_varctl , only : use_fates + use clm_varcon , only : zlak, dzlak, zsoi, dzsoi, zisoi, dzsoi_decomp, spval, ispval, grlnd + use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall, is_hydrologically_active + use landunit_varcon , only : istdlak, istice_mec + use fileutils , only : getfil + use LandunitType , only : lun + use GridcellType , only : grc + use ColumnType , only : col + use glcBehaviorMod , only : glc_behavior_type + use SnowHydrologyMod , only : InitSnowLayers + use abortUtils , only : endrun + use ncdio_pio + ! + ! !PUBLIC TYPES: + implicit none + save + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: initVertical + public :: find_soil_layer_containing_depth + + ! !PRIVATE MEMBER FUNCTIONS: + private :: hasBedrock ! true if the given column type includes bedrock layers + ! + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine initVertical(bounds, glc_behavior, snow_depth, thick_wall, thick_roof) + use clm_varcon, only : zmin_bedrock + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + type(glc_behavior_type), intent(in) :: glc_behavior + real(r8) , intent(in) :: snow_depth(bounds%begc:) + real(r8) , intent(in) :: thick_wall(bounds%begl:) + real(r8) , intent(in) :: thick_roof(bounds%begl:) + ! + ! LOCAL VARAIBLES: + integer :: c,l,g,i,j,lev ! indices + type(file_desc_t) :: ncid ! netcdf id + logical :: readvar + integer :: dimid ! dimension id + character(len=256) :: locfn ! local filename + real(r8) ,pointer :: std (:) ! read in - topo_std + real(r8) ,pointer :: tslope (:) ! read in - topo_slope + real(r8) :: slope0 ! temporary + real(r8) :: slopebeta ! temporary + real(r8) :: slopemax ! temporary + integer :: ier ! error status + real(r8) :: scalez = 0.025_r8 ! Soil layer thickness discretization (m) + real(r8) :: thick_equal = 0.2 + character(len=20) :: calc_method ! soil layer calculation method + real(r8) ,pointer :: zbedrock_in(:) ! read in - z_bedrock + real(r8) ,pointer :: lakedepth_in(:) ! read in - lakedepth + real(r8), allocatable :: zurb_wall(:,:) ! wall (layer node depth) + real(r8), allocatable :: zurb_roof(:,:) ! roof (layer node depth) + real(r8), allocatable :: dzurb_wall(:,:) ! wall (layer thickness) + real(r8), allocatable :: dzurb_roof(:,:) ! roof (layer thickness) + real(r8), allocatable :: ziurb_wall(:,:) ! wall (layer interface) + real(r8), allocatable :: ziurb_roof(:,:) ! roof (layer interface) + real(r8) :: depthratio ! ratio of lake depth to standard deep lake depth + integer :: begc, endc + integer :: begl, endl + integer :: jmin_bedrock + + ! Possible values for levgrnd_class. The important thing is that, for a given column, + ! layers that are fundamentally different (e.g., soil vs bedrock) have different + ! values. This information is used in the vertical interpolation in init_interp. + ! + ! IMPORTANT: These values should not be changed lightly. e.g., try to avoid changing + ! the values assigned to LEVGRND_CLASS_STANDARD, LEVGRND_CLASS_DEEP_BEDROCK, etc. The + ! problem with changing these is that init_interp expects that layers with a value of + ! (e.g.) 1 on the source file correspond to layers with a value of 1 on the + ! destination file. So if you change the values of these constants, you either need to + ! adequately inform users of this change, or build in some translation mechanism in + ! init_interp (such as via adding more metadata to the restart file on the meaning of + ! these different values). + ! + ! The distinction between "shallow" and "deep" bedrock is not made explicitly + ! elsewhere. But, since these classes have somewhat different behavior, they are + ! distinguished explicitly here. + integer, parameter :: LEVGRND_CLASS_STANDARD = 1 + integer, parameter :: LEVGRND_CLASS_DEEP_BEDROCK = 2 + integer, parameter :: LEVGRND_CLASS_SHALLOW_BEDROCK = 3 + + character(len=*), parameter :: subname = 'initVertical' + !------------------------------------------------------------------------ + + begc = bounds%begc; endc= bounds%endc + begl = bounds%begl; endl= bounds%endl + + SHR_ASSERT_ALL_FL((ubound(snow_depth) == (/endc/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(thick_wall) == (/endl/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(thick_roof) == (/endl/)), sourcefile, __LINE__) + + ! Open surface dataset to read in data below + + call getfil (fsurdat, locfn, 0) + call ncd_pio_openfile (ncid, locfn, 0) + + ! -------------------------------------------------------------------- + ! Define layer structure for soil, lakes, urban walls and roof + ! Vertical profile of snow is not initialized here - but below + ! -------------------------------------------------------------------- + + ! Soil layers and interfaces (assumed same for all non-lake patches) + ! "0" refers to soil surface and "nlevsoi" refers to the bottom of model soil + + if (soil_layerstruct_predefined == '10SL_3.5m' .or. soil_layerstruct_predefined == '23SL_3.5m') then + calc_method = 'node-based' ! node-based followed by error check + if (soil_layerstruct_userdefined(1) /= rundef) then + write(iulog,*) subname//' ERROR: Both soil_layerstruct_predefined and soil_layer_userdefined have values' + call shr_sys_abort(subname//' ERROR: Cannot decide how to set the soil layer structure') + end if + ! thickness-based (part 1) and error check + else if (soil_layerstruct_predefined == '49SL_10m' .or. & + soil_layerstruct_predefined == '20SL_8.5m' .or. & + soil_layerstruct_predefined == '4SL_2m') then + calc_method = 'thickness-based' + if (soil_layerstruct_userdefined(1) /= rundef) then + write(iulog,*) subname//' ERROR: Both soil_layerstruct_predefined and soil_layer_userdefined have values' + call shr_sys_abort(subname//' ERROR: Cannot decide how to set the soil layer structure') + end if + ! thickness-based (part 2) and error check + else if (soil_layerstruct_userdefined(1) /= rundef) then + calc_method = 'thickness-based' + if (soil_layerstruct_predefined /= 'UNSET') then + write(iulog,*) subname//' ERROR: Both soil_layerstruct_predefined and soil_layer_userdefined have values' + call shr_sys_abort(subname//' ERROR: Cannot decide how to set the soil layer structure') + end if + else ! error check + write(iulog,*) subname//' ERROR: Unrecognized pre-defined and user-defined soil layer structures: ', trim(soil_layerstruct_predefined), soil_layerstruct_userdefined + call endrun(subname//' ERROR: Unrecognized soil layer structure') + end if + + if (calc_method == 'node-based') then + do j = 1, nlevgrnd + zsoi(j) = scalez*(exp(0.5_r8*(j-0.5_r8))-1._r8) !node depths + enddo + + if (soil_layerstruct_predefined == '23SL_3.5m') then + ! Soil layer structure that starts with standard exponential, + ! then has several evenly spaced layers and finishes off exponential. + ! This allows the upper soil to behave as standard, but then continues + ! with higher resolution to a deeper depth, so that, e.g., permafrost + ! dynamics are not lost due to an inability to resolve temperature, + ! moisture, and biogeochemical dynamics at the base of the active layer + do j = toplev_equalspace + 1, toplev_equalspace + nlev_equalspace + zsoi(j) = zsoi(j-1) + thick_equal + enddo + do j = toplev_equalspace + nlev_equalspace + 1, nlevgrnd + zsoi(j) = scalez * (exp(0.5_r8 * (j - nlev_equalspace - 0.5_r8)) - 1._r8) + nlev_equalspace * thick_equal + enddo + end if ! soil_layerstruct_predefined == '23SL_3.5m' + + dzsoi(1) = 0.5_r8*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces + do j = 2,nlevgrnd-1 + dzsoi(j)= 0.5_r8*(zsoi(j+1)-zsoi(j-1)) + enddo + dzsoi(nlevgrnd) = zsoi(nlevgrnd)-zsoi(nlevgrnd-1) + + zisoi(0) = 0._r8 + do j = 1, nlevgrnd-1 + zisoi(j) = 0.5_r8*(zsoi(j)+zsoi(j+1)) !interface depths + enddo + zisoi(nlevgrnd) = zsoi(nlevgrnd) + 0.5_r8*dzsoi(nlevgrnd) + + else if (calc_method == 'thickness-based') then + if (soil_layerstruct_userdefined(1) /= rundef) then + do j = 1, nlevgrnd + ! read dzsoi from user-entered namelist vector + dzsoi(j) = soil_layerstruct_userdefined(j) + end do + else if (soil_layerstruct_predefined == '49SL_10m') then + !scs: 10 meter soil column, nlevsoi set to 49 in clm_varpar + do j = 1, 10 + dzsoi(j) = 1.e-2_r8 ! 10-mm layers + enddo + do j = 11, 19 + dzsoi(j) = 1.e-1_r8 ! 100-mm layers + enddo + do j = 20, nlevsoi+1 ! 300-mm layers + dzsoi(j) = 3.e-1_r8 + enddo + do j = nlevsoi+2,nlevgrnd ! 10-m bedrock layers + dzsoi(j) = 10._r8 + enddo + else if (soil_layerstruct_predefined == '20SL_8.5m') then + do j = 1, 4 ! linear increase in layer thickness of... + dzsoi(j) = j * 0.02_r8 ! ...2 cm each layer + enddo + do j = 5, 13 + dzsoi(j) = dzsoi(4) + (j - 4) * 0.04_r8 ! ...4 cm each layer + enddo + do j = 14, nlevsoi + dzsoi(j) = dzsoi(13) + (j - 13) * 0.10_r8 ! ...10 cm each layer + enddo + do j = nlevsoi + 1, nlevgrnd ! bedrock layers + dzsoi(j) = dzsoi(nlevsoi) + (((j - nlevsoi) * 25._r8)**1.5_r8) / 100._r8 + enddo + else if (soil_layerstruct_predefined == '4SL_2m') then + dzsoi(1) = 0.1_r8 + dzsoi(2) = 0.3_r8 + dzsoi(3) = 0.6_r8 + dzsoi(4) = 1.0_r8 + dzsoi(5) = 1.0_r8 + end if ! thickness-based options + + zisoi(0) = 0._r8 + do j = 1,nlevgrnd + zisoi(j)= sum(dzsoi(1:j)) + enddo + + do j = 1, nlevgrnd + zsoi(j) = 0.5*(zisoi(j-1) + zisoi(j)) + enddo + + else ! error check + write(iulog,*) subname//' ERROR: Unrecognized calc_method: ', trim(calc_method) + call endrun(subname//' ERROR: Unrecognized calc_method') + end if ! calc_method is node-based or thickness-based + + ! define a vertical grid spacing such that it is the normal dzsoi if + ! nlevdecomp =nlevgrnd, or else 1 meter + if (use_vertsoilc) then + dzsoi_decomp = dzsoi !thickness b/n two interfaces + else + dzsoi_decomp(1) = 1._r8 + end if + + if (masterproc) then + write(iulog, *) 'zsoi', zsoi(:) + write(iulog, *) 'zisoi: ', zisoi(:) + write(iulog, *) 'dzsoi: ', dzsoi(:) + write(iulog, *) 'dzsoi_decomp: ',dzsoi_decomp + end if + + if (nlevurb > 0) then + allocate(zurb_wall(bounds%begl:bounds%endl,nlevurb), & + zurb_roof(bounds%begl:bounds%endl,nlevurb), & + dzurb_wall(bounds%begl:bounds%endl,nlevurb), & + dzurb_roof(bounds%begl:bounds%endl,nlevurb), & + ziurb_wall(bounds%begl:bounds%endl,0:nlevurb), & + ziurb_roof(bounds%begl:bounds%endl,0:nlevurb), & + stat=ier) + if (ier /= 0) then + call shr_sys_abort(' ERROR allocation error for '//& + 'zurb_wall,zurb_roof,dzurb_wall,dzurb_roof,ziurb_wall,ziurb_roof'//& + errMsg(sourcefile, __LINE__)) + end if + end if + + ! Column level initialization for urban wall and roof layers and interfaces + do l = bounds%begl,bounds%endl + + ! "0" refers to urban wall/roof surface and "nlevsoi" refers to urban wall/roof bottom + if (lun%urbpoi(l)) then + if (use_vancouver) then + zurb_wall(l,1) = 0.010_r8/2._r8 + zurb_wall(l,2) = zurb_wall(l,1) + 0.010_r8/2._r8 + 0.020_r8/2._r8 + zurb_wall(l,3) = zurb_wall(l,2) + 0.020_r8/2._r8 + 0.070_r8/2._r8 + zurb_wall(l,4) = zurb_wall(l,3) + 0.070_r8/2._r8 + 0.070_r8/2._r8 + zurb_wall(l,5) = zurb_wall(l,4) + 0.070_r8/2._r8 + 0.030_r8/2._r8 + + zurb_roof(l,1) = 0.010_r8/2._r8 + zurb_roof(l,2) = zurb_roof(l,1) + 0.010_r8/2._r8 + 0.010_r8/2._r8 + zurb_roof(l,3) = zurb_roof(l,2) + 0.010_r8/2._r8 + 0.010_r8/2._r8 + zurb_roof(l,4) = zurb_roof(l,3) + 0.010_r8/2._r8 + 0.010_r8/2._r8 + zurb_roof(l,5) = zurb_roof(l,4) + 0.010_r8/2._r8 + 0.030_r8/2._r8 + + dzurb_wall(l,1) = 0.010_r8 + dzurb_wall(l,2) = 0.020_r8 + dzurb_wall(l,3) = 0.070_r8 + dzurb_wall(l,4) = 0.070_r8 + dzurb_wall(l,5) = 0.030_r8 + write(iulog,*)'Total thickness of wall: ',sum(dzurb_wall(l,:)) + write(iulog,*)'Wall layer thicknesses: ',dzurb_wall(l,:) + + dzurb_roof(l,1) = 0.010_r8 + dzurb_roof(l,2) = 0.010_r8 + dzurb_roof(l,3) = 0.010_r8 + dzurb_roof(l,4) = 0.010_r8 + dzurb_roof(l,5) = 0.030_r8 + write(iulog,*)'Total thickness of roof: ',sum(dzurb_roof(l,:)) + write(iulog,*)'Roof layer thicknesses: ',dzurb_roof(l,:) + + ziurb_wall(l,0) = 0. + ziurb_wall(l,1) = dzurb_wall(l,1) + do j = 2,nlevurb + ziurb_wall(l,j) = sum(dzurb_wall(l,1:j)) + end do + write(iulog,*)'Wall layer interface depths: ',ziurb_wall(l,:) + + ziurb_roof(l,0) = 0. + ziurb_roof(l,1) = dzurb_roof(l,1) + do j = 2,nlevurb + ziurb_roof(l,j) = sum(dzurb_roof(l,1:j)) + end do + write(iulog,*)'Roof layer interface depths: ',ziurb_roof(l,:) + else if (use_mexicocity) then + zurb_wall(l,1) = 0.015_r8/2._r8 + zurb_wall(l,2) = zurb_wall(l,1) + 0.015_r8/2._r8 + 0.120_r8/2._r8 + zurb_wall(l,3) = zurb_wall(l,2) + 0.120_r8/2._r8 + 0.150_r8/2._r8 + zurb_wall(l,4) = zurb_wall(l,3) + 0.150_r8/2._r8 + 0.150_r8/2._r8 + zurb_wall(l,5) = zurb_wall(l,4) + 0.150_r8/2._r8 + 0.015_r8/2._r8 + + zurb_roof(l,1) = 0.010_r8/2._r8 + zurb_roof(l,2) = zurb_roof(l,1) + 0.010_r8/2._r8 + 0.050_r8/2._r8 + zurb_roof(l,3) = zurb_roof(l,2) + 0.050_r8/2._r8 + 0.050_r8/2._r8 + zurb_roof(l,4) = zurb_roof(l,3) + 0.050_r8/2._r8 + 0.050_r8/2._r8 + zurb_roof(l,5) = zurb_roof(l,4) + 0.050_r8/2._r8 + 0.025_r8/2._r8 + + dzurb_wall(l,1) = 0.015_r8 + dzurb_wall(l,2) = 0.120_r8 + dzurb_wall(l,3) = 0.150_r8 + dzurb_wall(l,4) = 0.150_r8 + dzurb_wall(l,5) = 0.015_r8 + write(iulog,*)'Total thickness of wall: ',sum(dzurb_wall(l,:)) + write(iulog,*)'Wall layer thicknesses: ',dzurb_wall(l,:) + + dzurb_roof(l,1) = 0.010_r8 + dzurb_roof(l,2) = 0.050_r8 + dzurb_roof(l,3) = 0.050_r8 + dzurb_roof(l,4) = 0.050_r8 + dzurb_roof(l,5) = 0.025_r8 + write(iulog,*)'Total thickness of roof: ',sum(dzurb_roof(l,:)) + write(iulog,*)'Roof layer thicknesses: ',dzurb_roof(l,:) + + ziurb_wall(l,0) = 0. + ziurb_wall(l,1) = dzurb_wall(l,1) + do j = 2,nlevurb + ziurb_wall(l,j) = sum(dzurb_wall(l,1:j)) + end do + write(iulog,*)'Wall layer interface depths: ',ziurb_wall(l,:) + + ziurb_roof(l,0) = 0. + ziurb_roof(l,1) = dzurb_roof(l,1) + do j = 2,nlevurb + ziurb_roof(l,j) = sum(dzurb_roof(l,1:j)) + end do + write(iulog,*)'Roof layer interface depths: ',ziurb_roof(l,:) + else + do j = 1, nlevurb + zurb_wall(l,j) = (j-0.5)*(thick_wall(l)/float(nlevurb)) !node depths + end do + do j = 1, nlevurb + zurb_roof(l,j) = (j-0.5)*(thick_roof(l)/float(nlevurb)) !node depths + end do + + dzurb_roof(l,1) = 0.5*(zurb_roof(l,1)+zurb_roof(l,2)) !thickness b/n two interfaces + do j = 2,nlevurb-1 + dzurb_roof(l,j)= 0.5*(zurb_roof(l,j+1)-zurb_roof(l,j-1)) + enddo + dzurb_roof(l,nlevurb) = zurb_roof(l,nlevurb)-zurb_roof(l,nlevurb-1) + + dzurb_wall(l,1) = 0.5*(zurb_wall(l,1)+zurb_wall(l,2)) !thickness b/n two interfaces + do j = 2,nlevurb-1 + dzurb_wall(l,j)= 0.5*(zurb_wall(l,j+1)-zurb_wall(l,j-1)) + enddo + dzurb_wall(l,nlevurb) = zurb_wall(l,nlevurb)-zurb_wall(l,nlevurb-1) + + ziurb_wall(l,0) = 0. + do j = 1, nlevurb-1 + ziurb_wall(l,j) = 0.5*(zurb_wall(l,j)+zurb_wall(l,j+1)) !interface depths + enddo + ziurb_wall(l,nlevurb) = zurb_wall(l,nlevurb) + 0.5*dzurb_wall(l,nlevurb) + + ziurb_roof(l,0) = 0. + do j = 1, nlevurb-1 + ziurb_roof(l,j) = 0.5*(zurb_roof(l,j)+zurb_roof(l,j+1)) !interface depths + enddo + ziurb_roof(l,nlevurb) = zurb_roof(l,nlevurb) + 0.5*dzurb_roof(l,nlevurb) + end if + end if + end do + + do c = bounds%begc,bounds%endc + l = col%landunit(c) + + if (lun%urbpoi(l)) then + if (col%itype(c)==icol_sunwall .or. col%itype(c)==icol_shadewall) then + col%z(c,1:nlevurb) = zurb_wall(l,1:nlevurb) + col%zi(c,0:nlevurb) = ziurb_wall(l,0:nlevurb) + col%dz(c,1:nlevurb) = dzurb_wall(l,1:nlevurb) + if (nlevurb < nlevgrnd) then + col%z(c,nlevurb+1:nlevgrnd) = spval + col%zi(c,nlevurb+1:nlevgrnd) = spval + col%dz(c,nlevurb+1:nlevgrnd) = spval + end if + else if (col%itype(c)==icol_roof) then + col%z(c,1:nlevurb) = zurb_roof(l,1:nlevurb) + col%zi(c,0:nlevurb) = ziurb_roof(l,0:nlevurb) + col%dz(c,1:nlevurb) = dzurb_roof(l,1:nlevurb) + if (nlevurb < nlevgrnd) then + col%z(c,nlevurb+1:nlevgrnd) = spval + col%zi(c,nlevurb+1:nlevgrnd) = spval + col%dz(c,nlevurb+1:nlevgrnd) = spval + end if + else + col%z(c,1:nlevgrnd) = zsoi(1:nlevgrnd) + col%zi(c,0:nlevgrnd) = zisoi(0:nlevgrnd) + col%dz(c,1:nlevgrnd) = dzsoi(1:nlevgrnd) + if (nlevgrnd < nlevurb) then + col%z(c,nlevgrnd+1:nlevurb) = spval + col%zi(c,nlevgrnd+1:nlevurb) = spval + col%dz(c,nlevgrnd+1:nlevurb) = spval + end if + end if + else if (lun%itype(l) /= istdlak) then + col%z(c,1:nlevgrnd) = zsoi(1:nlevgrnd) + col%zi(c,0:nlevgrnd) = zisoi(0:nlevgrnd) + col%dz(c,1:nlevgrnd) = dzsoi(1:nlevgrnd) + if (nlevgrnd < nlevurb) then + col%z(c,nlevgrnd+1:nlevurb) = spval + col%zi(c,nlevgrnd+1:nlevurb) = spval + col%dz(c,nlevgrnd+1:nlevurb) = spval + end if + end if + end do + + if (nlevurb > 0) then + deallocate(zurb_wall, zurb_roof, dzurb_wall, dzurb_roof, ziurb_wall, ziurb_roof) + end if + + !----------------------------------------------- + ! Set index defining depth to bedrock + !----------------------------------------------- + + allocate(zbedrock_in(bounds%begg:bounds%endg)) + if (use_bedrock) then + call ncd_io(ncid=ncid, varname='zbedrock', flag='read', data=zbedrock_in, dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + if (masterproc) then + call endrun( 'ERROR:: zbedrock not found on surface data set, and use_bedrock is true.'//errmsg(sourcefile, __LINE__) ) + end if + end if + + ! if use_bedrock = false, set zbedrock to lowest layer bottom interface + else + if (masterproc) write(iulog,*) 'not using use_bedrock!!' + zbedrock_in(:) = zisoi(nlevsoi) + endif + + ! determine minimum index of minimum soil depth + jmin_bedrock = 3 + do j = 3,nlevsoi + if (zisoi(j-1) < zmin_bedrock .and. zisoi(j) >= zmin_bedrock) then + jmin_bedrock = j + endif + enddo + + if (masterproc) write(iulog,*) 'jmin_bedrock: ', jmin_bedrock + + ! Determine gridcell bedrock index + do g = bounds%begg,bounds%endg + grc%nbedrock(g) = nlevsoi + do j = jmin_bedrock,nlevsoi + if (zisoi(j-1) < zbedrock_in(g) .and. zisoi(j) >= zbedrock_in(g)) then + grc%nbedrock(g) = j + end if + end do + end do + + ! Set column bedrock index + do c = begc, endc + g = col%gridcell(c) + col%nbedrock(c) = grc%nbedrock(g) + end do + + deallocate(zbedrock_in) + + !----------------------------------------------- + ! Set lake levels and layers (no interfaces) + !----------------------------------------------- + + allocate(lakedepth_in(bounds%begg:bounds%endg)) + call ncd_io(ncid=ncid, varname='LAKEDEPTH', flag='read', data=lakedepth_in, dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + if (masterproc) then + write(iulog,*) 'WARNING:: LAKEDEPTH not found on surface data set. All lake columns will have lake depth', & + ' set equal to default value.' + end if + lakedepth_in(:) = spval + end if + do c = begc, endc + g = col%gridcell(c) + col%lakedepth(c) = lakedepth_in(g) + end do + deallocate(lakedepth_in) + + ! Lake layers + if (.not. use_extralakelayers) then + dzlak(1) = 0.1_r8 + dzlak(2) = 1._r8 + dzlak(3) = 2._r8 + dzlak(4) = 3._r8 + dzlak(5) = 4._r8 + dzlak(6) = 5._r8 + dzlak(7) = 7._r8 + dzlak(8) = 7._r8 + dzlak(9) = 10.45_r8 + dzlak(10)= 10.45_r8 + + zlak(1) = 0.05_r8 + zlak(2) = 0.6_r8 + zlak(3) = 2.1_r8 + zlak(4) = 4.6_r8 + zlak(5) = 8.1_r8 + zlak(6) = 12.6_r8 + zlak(7) = 18.6_r8 + zlak(8) = 25.6_r8 + zlak(9) = 34.325_r8 + zlak(10)= 44.775_r8 + else + dzlak(1) =0.1_r8 + dzlak(2) =0.25_r8 + dzlak(3) =0.25_r8 + dzlak(4) =0.25_r8 + dzlak(5) =0.25_r8 + dzlak(6) =0.5_r8 + dzlak(7) =0.5_r8 + dzlak(8) =0.5_r8 + dzlak(9) =0.5_r8 + dzlak(10) =0.75_r8 + dzlak(11) =0.75_r8 + dzlak(12) =0.75_r8 + dzlak(13) =0.75_r8 + dzlak(14) =2_r8 + dzlak(15) =2_r8 + dzlak(16) =2.5_r8 + dzlak(17) =2.5_r8 + dzlak(18) =3.5_r8 + dzlak(19) =3.5_r8 + dzlak(20) =3.5_r8 + dzlak(21) =3.5_r8 + dzlak(22) =5.225_r8 + dzlak(23) =5.225_r8 + dzlak(24) =5.225_r8 + dzlak(25) =5.225_r8 + + zlak(1) = dzlak(1)/2._r8 + do i=2,nlevlak + zlak(i) = zlak(i-1) + (dzlak(i-1)+dzlak(i))/2._r8 + end do + end if + + do c = bounds%begc,bounds%endc + l = col%landunit(c) + + if (lun%itype(l) == istdlak) then + + if (col%lakedepth(c) == spval) then + col%lakedepth(c) = zlak(nlevlak) + 0.5_r8*dzlak(nlevlak) + col%z_lake(c,1:nlevlak) = zlak(1:nlevlak) + col%dz_lake(c,1:nlevlak) = dzlak(1:nlevlak) + + else if (col%lakedepth(c) > 1._r8 .and. col%lakedepth(c) < 5000._r8) then + + depthratio = col%lakedepth(c) / (zlak(nlevlak) + 0.5_r8*dzlak(nlevlak)) + col%z_lake(c,1) = zlak(1) + col%dz_lake(c,1) = dzlak(1) + col%dz_lake(c,2:nlevlak-1) = dzlak(2:nlevlak-1)*depthratio + col%dz_lake(c,nlevlak) = dzlak(nlevlak)*depthratio - (col%dz_lake(c,1) - dzlak(1)*depthratio) + do lev=2,nlevlak + col%z_lake(c,lev) = col%z_lake(c,lev-1) + (col%dz_lake(c,lev-1)+col%dz_lake(c,lev))/2._r8 + end do + + else if (col%lakedepth(c) > 0._r8 .and. col%lakedepth(c) <= 1._r8) then + + col%dz_lake(c,:) = col%lakedepth(c) / nlevlak; + col%z_lake(c,1) = col%dz_lake(c,1) / 2._r8; + do lev=2,nlevlak + col%z_lake(c,lev) = col%z_lake(c,lev-1) + (col%dz_lake(c,lev-1)+col%dz_lake(c,lev))/2._r8 + end do + + else + + write(iulog,*)'Bad lake depth: lakedepth: ', col%lakedepth(c) + call shr_sys_abort(errmsg(sourcefile, __LINE__)) + + end if + + col%z(c,1:nlevgrnd) = zsoi(1:nlevgrnd) + col%zi(c,0:nlevgrnd) = zisoi(0:nlevgrnd) + col%dz(c,1:nlevgrnd) = dzsoi(1:nlevgrnd) + if (nlevgrnd < nlevurb) then + col%z(c,nlevgrnd+1:nlevurb) = spval + col%zi(c,nlevgrnd+1:nlevurb) = spval + col%dz(c,nlevgrnd+1:nlevurb) = spval + end if + end if + end do + + ! ------------------------------------------------------------------------ + ! Set classes of layers + ! ------------------------------------------------------------------------ + + do c = bounds%begc, bounds%endc + l = col%landunit(c) + if (hasBedrock(col_itype=col%itype(c), lun_itype=lun%itype(l))) then + ! NOTE(wjs, 2015-10-17) We are assuming that points with bedrock have both + ! "shallow" and "deep" bedrock. Currently, this is not true for lake columns: + ! lakes do not distinguish between "shallow" bedrock and "normal" soil. + ! However, that was just due to an oversight that is supposed to be corrected + ! soon; so to keep things simple we assume that any point with bedrock + ! potentially has both shallow and deep bedrock. + col%levgrnd_class(c, 1:col%nbedrock(c)) = LEVGRND_CLASS_STANDARD + if (col%nbedrock(c) < nlevsoi) then + col%levgrnd_class(c, (col%nbedrock(c) + 1) : nlevsoi) = LEVGRND_CLASS_SHALLOW_BEDROCK + end if + col%levgrnd_class(c, (nlevsoi + 1) : nlevmaxurbgrnd) = LEVGRND_CLASS_DEEP_BEDROCK + else + col%levgrnd_class(c, 1:nlevmaxurbgrnd) = LEVGRND_CLASS_STANDARD + end if + end do + + do j = 1, nlevmaxurbgrnd + do c = bounds%begc, bounds%endc + if (col%z(c,j) == spval) then + col%levgrnd_class(c,j) = ispval + end if + end do + end do + + !----------------------------------------------- + ! Set cold-start values for snow levels, snow layers and snow interfaces + !----------------------------------------------- + + call InitSnowLayers(bounds, snow_depth(bounds%begc:bounds%endc)) + + !----------------------------------------------- + ! Read in topographic index and slope + !----------------------------------------------- + + allocate(tslope(bounds%begg:bounds%endg)) + call ncd_io(ncid=ncid, varname='SLOPE', flag='read', data=tslope, dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + call shr_sys_abort(' ERROR: TOPOGRAPHIC SLOPE NOT on surfdata file'//& + errMsg(sourcefile, __LINE__)) + end if + do c = begc,endc + g = col%gridcell(c) + ! check for near zero slopes, set minimum value + col%topo_slope(c) = max(tslope(g), 0.2_r8) + end do + deallocate(tslope) + + allocate(std(bounds%begg:bounds%endg)) + call ncd_io(ncid=ncid, varname='STD_ELEV', flag='read', data=std, dim1name=grlnd, readvar=readvar) + if (.not. readvar) then + call shr_sys_abort(' ERROR: TOPOGRAPHIC STDdev (STD_ELEV) NOT on surfdata file'//& + errMsg(sourcefile, __LINE__)) + end if + do c = begc,endc + g = col%gridcell(c) + ! Topographic variables + col%topo_std(c) = std(g) + end do + deallocate(std) + + !----------------------------------------------- + ! SCA shape function defined + !----------------------------------------------- + + do c = begc,endc + ! microtopographic parameter, units are meters (try smooth function of slope) + slopebeta = 3._r8 + slopemax = 0.4_r8 + slope0 = slopemax**(-1._r8/slopebeta) + col%micro_sigma(c) = (col%topo_slope(c) + slope0)**(-slopebeta) + end do + + call ncd_pio_closefile(ncid) + + end subroutine initVertical + + !----------------------------------------------------------------------- + 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 + + !----------------------------------------------------------------------- + logical function hasBedrock(col_itype, lun_itype) + ! + ! !DESCRIPTION: + ! Returns true if the given column type has a representation of bedrock - i.e., a set + ! of layers at the bottom of the column that are treated fundamentally differently + ! from the upper layers. + ! + ! !USES: + use landunit_varcon, only : istice_mec, isturb_MIN, isturb_MAX + use column_varcon , only : icol_road_perv + ! + ! !ARGUMENTS: + integer, intent(in) :: col_itype ! col%itype value + integer, intent(in) :: lun_itype ! lun%itype value for the landunit on which this column sits + ! 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. + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'hasBedrock' + !----------------------------------------------------------------------- + + ! TODO(wjs, 2015-10-17) I don't like that the logic here implicitly duplicates logic + ! elsewhere in the code. For example, if there were a change in the lake code so that + ! it no longer treated the bottom layers as bedrock, then that change would need to be + ! reflected here. One solution would be to set some has_bedrock flag in one central + ! place, and then have the science code use that. But that could get messy in the + ! science code. Another solution would be to decentralize the definition of + ! hasBedrock, so that (for example) the lake code itself sets the value for lun_itype + ! == istdlak - that way, hasBedrock(lake) would be more likely to get updated + ! correctly if the lake logic changes. + + if (lun_itype == istice_mec) then + hasBedrock = .false. + else if (lun_itype >= isturb_MIN .and. lun_itype <= isturb_MAX) then + if (col_itype == icol_road_perv) then + hasBedrock = .true. + else + hasBedrock = .false. + end if + else + hasBedrock = .true. + end if + + ! As an independent check of the above logic, assert that, at the very least, any + ! hydrologically-active column is given hasBedrock = .true. This is to try to catch + ! problems with new column types being added that aren't handled properly by the + ! above logic, since (as noted in the todo note above) there is some implicit + ! duplication of logic between this routine and other parts of the code, which is + ! dangerous. For example, if a new "urban lawn" type is added, then it should have + ! hasBedrock = .true. - and this omission will hopefully be caught by this assertion. + if (is_hydrologically_active(col_itype=col_itype, lun_itype=lun_itype)) then + SHR_ASSERT(hasBedrock, "hasBedrock should be true for all hydrologically-active columns") + end if + + end function hasBedrock + + +end module initVerticalMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/landunit_varcon.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/landunit_varcon.F90 new file mode 100644 index 000000000..b6ddc7cf5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/ncdio_pio.F90.in b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ncdio_pio.F90.in new file mode 100644 index 000000000..4b7b75c82 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/ncdio_pio.F90.in @@ -0,0 +1,2745 @@ +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, assignment(=) + use shr_sys_mod , only : shr_sys_abort + use shr_file_mod , only : shr_file_getunit, shr_file_freeunit + use shr_string_mod , only : shr_string_toUpper + use shr_log_mod , only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc, mpicom, iam, npes + use spmdMod , only : MPI_REAL8, MPI_INTEGER, MPI_LOGICAL + use clm_varcon , only : spval,ispval, grlnd, nameg, namel, namec, namep + use clm_varctl , only : single_column, iulog + use shr_sys_mod , only : shr_sys_flush + use decompMod , only : get_clmlevel_gsize,get_clmlevel_gsmap + use perf_mod , only : t_startf, t_stopf + use fileutils , only : getavu, relavu + use mct_mod , only : mct_gsMap, mct_gsMap_lsize, mct_gsMap_gsize, mct_gsMap_orderedPoints + use pio , only : file_desc_t, io_desc_t, iosystem_desc_t + use pio , only : pio_bcast_error, pio_char, pio_clobber, pio_closefile, pio_createfile, pio_def_dim + use pio , only : pio_def_var, pio_double, pio_redef, pio_enddef, pio_get_att, pio_get_var, pio_global, pio_initdecomp + use pio , only : pio_inq_att, pio_inq_dimid, pio_inq_dimlen, pio_inq_dimname, pio_inq_vardimid, pio_inq_varid + use pio , only : pio_inq_attname, pio_inq_varname, pio_inq_varndims, pio_inquire, pio_int, pio_internal_error + use pio , only : pio_noclobber, pio_noerr, pio_nofill, pio_nowrite, pio_offset_kind, pio_openfile + use pio , only : pio_put_att, pio_put_var, pio_read_darray, pio_real, pio_seterrorhandling + use pio , only : pio_setframe, pio_unlimited, pio_write, pio_write_darray, var_desc_t + use pio , only : pio_iotask_rank, PIO_REARR_SUBSET, PIO_REARR_BOX + use pio , only : pio_inq_vartype, pio_real + use array_utils , only : convert_to_logical + ! + ! !PUBLIC TYPES: + implicit none + private + save + ! + ! !PUBLIC MEMBER FUNCTIONS: + ! + public :: check_var ! determine if variable is on netcdf file + public :: check_dim ! determine if dimension is on netcdf file + public :: check_var_or_dim ! determine if variable or dimension is on netcdf file + public :: check_att ! check if attribute is on file + public :: check_dim_size ! validity check on dimension + public :: ncd_pio_openfile ! open a file + public :: ncd_pio_createfile ! create a new file + public :: ncd_pio_closefile ! close a file + public :: ncd_pio_init ! called from clm_comp + public :: ncd_redef ! re-enter define mode + public :: ncd_enddef ! end define mode + public :: ncd_inqnatts ! inquire number of global attributes + public :: ncd_inqattname ! inquire attribute name, given attribute number + public :: ncd_putatt ! put attribute + public :: ncd_getatt ! get attribute + public :: ncd_defdim ! define dimension + public :: ncd_inqdid ! inquire dimension id + public :: ncd_inqdname ! inquire dimension name + public :: ncd_inqdlen ! inquire dimension length + public :: ncd_inqfdims ! inquire file dimnesions + public :: ncd_defvar ! define variables + public :: ncd_inqvid ! inquire variable id + public :: ncd_inqvname ! inquire variable name + public :: ncd_inqvtype ! inquire variable type + public :: ncd_inqvdims ! inquire variable ndims + public :: ncd_inqvdids ! inquire variable dimids + public :: ncd_inqvdlen ! inquire variable dimension size + public :: ncd_inqvdname ! inquire variable dimension name + public :: ncd_io ! write local data + + integer,parameter,public :: ncd_int = pio_int + integer,parameter,public :: ncd_log =-pio_int + integer,parameter,public :: ncd_float = pio_real + integer,parameter,public :: ncd_double = pio_double + integer,parameter,public :: ncd_char = pio_char + integer,parameter,public :: ncd_global = pio_global + integer,parameter,public :: ncd_write = pio_write + integer,parameter,public :: ncd_nowrite = pio_nowrite + integer,parameter,public :: ncd_clobber = pio_clobber + integer,parameter,public :: ncd_noclobber = pio_noclobber + integer,parameter,public :: ncd_nofill = pio_nofill + integer,parameter,public :: ncd_unlimited = pio_unlimited + + ! PIO types needed for ncdio_pio interface calls + public file_desc_t + public var_desc_t + + ! + ! !PRIVATE MEMBER FUNCTIONS: + ! + interface ncd_defvar + module procedure ncd_defvar_bynf + module procedure ncd_defvar_bygrid + end interface + + interface ncd_putatt + module procedure ncd_putatt_int + module procedure ncd_putatt_real + module procedure ncd_putatt_char + end interface + + interface ncd_getatt + module procedure ncd_getatt_char + module procedure ncd_getatt_int + end interface ncd_getatt + + interface ncd_io + module procedure ncd_io_char_var0_start_glob + + !DIMS 0,1 + module procedure ncd_io_{DIMS}d_log_glob + + !DIMS 0,1,2,3 + !TYPE int,double + module procedure ncd_io_{DIMS}d_{TYPE}_glob + + !DIMS 0,1,2 + !TYPE text + module procedure ncd_io_{DIMS}d_{TYPE}_glob + + !TYPE int,double + !DIMS 1,2,3 + module procedure ncd_io_{DIMS}d_{TYPE} + + !TYPE logical + !DIMS 1 + module procedure ncd_io_{DIMS}d_{TYPE} + end interface + + interface ncd_inqvdlen + module procedure ncd_inqvdlen_byDesc + module procedure ncd_inqvdlen_byName + end interface + + interface ncd_inqvdname + module procedure ncd_inqvdname_byDesc + module procedure ncd_inqvdname_byName + end interface + + interface read_darray_dispatcher + !TYPE int,double,logical + !DIMS 1,2,3 + module procedure read_darray_{TYPE}_dispatcher_{DIMS} + end interface read_darray_dispatcher + + private :: ncd_getiodesc ! obtain iodesc + private :: scam_field_offsets ! get offset to proper lat/lon gridcell for SCAM + + integer,parameter,private :: debug = 0 ! local debug level + + integer , parameter , public :: max_string_len = 256 ! length of strings + real(r8), parameter , public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields + + integer, public :: io_type + integer :: io_netcdf_format + type(iosystem_desc_t), pointer, public :: pio_subsystem + + type iodesc_plus_type + character(len=64) :: name + type(IO_desc_t) :: iodesc + integer :: type + integer :: ndims + integer :: dims(4) + integer :: dimids(4) + end type iodesc_plus_type + integer,parameter ,private :: max_iodesc = 100 + integer ,private :: num_iodesc = 0 + type(iodesc_plus_type) ,private, target :: iodesc_list(max_iodesc) + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine ncd_pio_init() + ! + ! !DESCRIPTION: + ! Initial PIO + ! + ! !USES: + use shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat + use clm_varctl , only : inst_name + !----------------------------------------------------------------------- + + PIO_subsystem => shr_pio_getiosys(inst_name) + io_type = shr_pio_getiotype(inst_name) + io_netcdf_format = shr_pio_getioformat(inst_name) + end subroutine ncd_pio_init + + !----------------------------------------------------------------------- + subroutine ncd_pio_openfile(file, fname, mode) + ! + ! !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 + ! + ! !LOCAL VARIABLES: + integer :: ierr + !----------------------------------------------------------------------- + + ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) + + if(ierr/= PIO_NOERR) then + call shr_sys_abort('ncd_pio_openfile ERROR: Failed to open file') + else if(pio_iotask_rank(pio_subsystem)==0 .and. masterproc) then + write(iulog,*) 'Opened existing file ', trim(fname), file%fh + 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 pio_closefile(file) + + end subroutine ncd_pio_closefile + + !----------------------------------------------------------------------- + subroutine ncd_pio_createfile(file, fname) + ! + ! !DESCRIPTION: + ! Create a new NetCDF file with PIO + ! + ! !USES: + use pio, only : pio_iotype_pnetcdf, pio_iotype_netcdf,pio_iotask_rank + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: file ! PIO file descriptor + character(len=*) , intent(in) :: fname ! File name to create + + ! + ! !LOCAL VARIABLES: + integer :: ierr + !----------------------------------------------------------------------- + + ierr = pio_createfile(pio_subsystem, file, io_type, fname, ior(PIO_CLOBBER,io_netcdf_format)) + + if(ierr/= PIO_NOERR) then + call shr_sys_abort( ' ncd_pio_createfile ERROR: Failed to open file to write: '//trim(fname)) + else if(pio_iotask_rank(pio_subsystem)==0 .and. masterproc) then + write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh + end if + + end subroutine ncd_pio_createfile + + !----------------------------------------------------------------------- + subroutine check_var(ncid, varname, readvar, vardesc, print_err ) + ! + ! !DESCRIPTION: + ! Check if variable is on netcdf file + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: ncid ! PIO file descriptor + character(len=*) , intent(in) :: varname ! Varible name to check + logical , intent(out) :: readvar ! If variable exists or not + type(Var_desc_t) , optional, intent(out) :: vardesc ! Output variable descriptor (if desired) + logical , optional, intent(in) :: print_err ! If should print about error + ! + ! !LOCAL VARIABLES: + integer :: ret ! return value + logical :: log_err ! if should log error + type(Var_desc_t) :: vardesc_local + character(len=*),parameter :: subname='check_var' ! subroutine name + !----------------------------------------------------------------------- + + + if ( present(print_err) )then + log_err = print_err + else + log_err = .true. + end if + readvar = .true. + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ret = PIO_inq_varid (ncid, varname, vardesc_local) + if (present(vardesc)) then + vardesc = vardesc_local + end if + if (ret /= PIO_noerr) then + readvar = .false. + if (masterproc .and. log_err) & + write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' + end if + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + + end subroutine check_var + + !----------------------------------------------------------------------- + subroutine check_dim(ncid, dimname, dimexist) + ! + ! !DESCRIPTION: + ! Check if dimension is on netcdf file + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: ncid ! PIO file descriptor + character(len=*) , intent(in) :: dimname ! dimension name + logical , intent(out) :: dimexist ! if this dimension exists or not + ! + ! !LOCAL VARIABLES: + integer :: dimid + + character(len=*), parameter :: subname = 'check_dim' + !----------------------------------------------------------------------- + + call ncd_inqdid(ncid, dimname, dimid, dimexist) + + end subroutine check_dim + + !----------------------------------------------------------------------- + subroutine check_var_or_dim(ncid, name, is_dim, exists) + ! + ! !DESCRIPTION: + ! Check if variable or dimension is on netcdf file + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: ncid ! PIO file descriptor + character(len=*) , intent(in) :: name ! variable or dimension name to check + logical , intent(in) :: is_dim ! if true, check for dimension; if false, check for variable + logical , intent(out) :: exists ! whether the given variable or dimension exists on file + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'check_var_or_dim' + !----------------------------------------------------------------------- + + if (is_dim) then + call check_dim(ncid, name, exists) + else + call check_var(ncid, name, exists, print_err=.false.) + end if + + end subroutine check_var_or_dim + + !----------------------------------------------------------------------- + subroutine check_att(ncid, varid, attrib, att_found) + ! + ! !DESCRIPTION: + ! Check if attribute is on file + ! + ! !USES: + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + logical ,intent(out) :: att_found ! true if the attribute was found + ! + ! !LOCAL VARIABLES: + integer :: att_type ! attribute type + integer(pio_offset_kind) :: att_len ! attribute length + integer :: status + + character(len=*), parameter :: subname = 'check_att' + !----------------------------------------------------------------------- + + att_found = .true. + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + status = PIO_inq_att(ncid, varid, trim(attrib), att_type, att_len) + if (status /= PIO_noerr) then + att_found = .false. + end if + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + + end subroutine check_att + + !----------------------------------------------------------------------- + subroutine check_dim_size(ncid, dimname, value, msg) + ! + ! !DESCRIPTION: + ! Validity check on dimension + ! + ! !ARGUMENTS: + class(file_desc_t),intent(in) :: ncid ! PIO file handle + character(len=*) , intent(in) :: dimname ! Dimension name + integer, intent(in) :: value ! Expected dimension size + + character(len=*), intent(in), optional :: msg ! Optional additional message printed upon error + ! + ! !LOCAL VARIABLES: + integer :: dimid, dimlen ! temporaries + integer :: status ! error code + character(len=*),parameter :: subname='check_dim_size' ! subroutine name + !----------------------------------------------------------------------- + + status = pio_inq_dimid (ncid, trim(dimname), dimid) + status = pio_inq_dimlen (ncid, dimid, dimlen) + if (dimlen /= value) then + write(iulog,*) subname//' ERROR: mismatch of input dimension ',dimlen, & + ' with expected value ',value,' for variable ',trim(dimname) + if (present(msg)) then + write(iulog,'(a)') msg + end if + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + end if + + end subroutine check_dim_size + + !----------------------------------------------------------------------- + subroutine ncd_redef(ncid) + ! + ! !DESCRIPTION: + ! Re-enter define mode for this netcdf file + ! + ! Remember to call ncd_enddef when finished + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + ! + ! !LOCAL VARIABLES: + integer :: status ! error status + !----------------------------------------------------------------------- + + status = PIO_redef(ncid) + + end subroutine ncd_redef + + !----------------------------------------------------------------------- + subroutine ncd_enddef(ncid) + ! + ! !DESCRIPTION: + ! enddef netcdf file + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + ! + ! !LOCAL VARIABLES: + integer :: status ! error status + !----------------------------------------------------------------------- + + status = PIO_enddef(ncid) + + end subroutine ncd_enddef + + !----------------------------------------------------------------------- + subroutine ncd_inqdid(ncid,name,dimid,dimexist) + ! + ! !DESCRIPTION: + ! inquire on a dimension id + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: name ! dimension name + integer , intent(out):: dimid ! dimension id + logical,optional , intent(out):: dimexist ! if this dimension exists or not + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + if ( present(dimexist) )then + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + end if + status = PIO_inq_dimid(ncid,name,dimid) + if ( present(dimexist) )then + if ( status == PIO_NOERR)then + dimexist = .true. + else + dimexist = .false. + end if + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + end if + + end subroutine ncd_inqdid + + !----------------------------------------------------------------------- + subroutine ncd_inqdlen(ncid,dimid,len,name) + ! + ! !DESCRIPTION: + ! Gets the length of the given dimension + ! + ! If 'name' is absent, then 'dimid' is used as an input: the dimension id to inquire. + ! If 'name' is present, then it gives the name of the dimension to inquire, and + ! 'dimid' is set to the ID associated with this dimension. + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer , intent(inout) :: dimid ! dimension id + integer , intent(out) :: len ! dimension len + character(len=*), optional, intent(in) :: name ! dimension name + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + if ( present(name) )then + call ncd_inqdid(ncid,name,dimid) + end if + len = -1 + status = PIO_inq_dimlen(ncid,dimid,len) + + end subroutine ncd_inqdlen + + !----------------------------------------------------------------------- + subroutine ncd_inqdname(ncid,dimid,dname) + ! + ! !DESCRIPTION: + ! inquire dim name + ! + ! !ARGUMENTS: + class(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(in) :: dimid ! dimension id + character(len=*) , intent(out):: dname ! dimension name + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + status = PIO_inq_dimname(ncid,dimid,dname) + + end subroutine ncd_inqdname + + !----------------------------------------------------------------------- + subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout):: ncid + logical , intent(out) :: isgrid2d + integer , intent(out) :: ni + integer , intent(out) :: nj + integer , intent(out) :: ns + ! + ! !LOCAL VARIABLES: + integer :: dimid ! netCDF id + integer :: ier ! error status + character(len=32) :: subname = 'ncd_inqfdims' ! subroutine name + !----------------------------------------------------------------------- + + if (single_column) then + ni = 1 + nj = 1 + ns = 1 + isgrid2d = .true. + RETURN + end if + + ni = 0 + nj = 0 + + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ier = pio_inq_dimid (ncid, 'lon', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'lat', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'lsmlon', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'lsmlat', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'ni', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'nj', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'gridcell', dimid) + if (ier == PIO_NOERR) then + ier = pio_inq_dimlen(ncid, dimid, ni) + if (ier == PIO_NOERR) nj = 1 + end if + + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + + if (ni == 0 .or. nj == 0) then + write(iulog,*) trim(subname),' ERROR: ni,nj = ',ni,nj,' cannot be zero ' + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + end if + + if (nj == 1) then + isgrid2d = .false. + else + isgrid2d = .true. + end if + + ns = ni*nj + + end subroutine ncd_inqfdims + + !----------------------------------------------------------------------- + subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) + ! + ! !DESCRIPTION: + ! Inquire on a variable ID + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: name ! variable name + integer , intent(out) :: varid ! variable id + type(Var_desc_t) , intent(out) :: vardesc ! variable descriptor + logical, optional , intent(out) :: readvar ! does variable exist + ! + ! !LOCAL VARIABLES: + integer :: ret ! return code + character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name + !----------------------------------------------------------------------- + + if (present(readvar)) then + readvar = .false. + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ret = PIO_inq_varid(ncid,name,vardesc) + if (ret /= PIO_noerr) then + if (masterproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' + readvar = .false. + else + readvar = .true. + end if + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + else + ret = PIO_inq_varid(ncid,name,vardesc) + endif + varid = vardesc%varid + + end subroutine ncd_inqvid + + !----------------------------------------------------------------------- + subroutine ncd_inqvtype(ncid, vardesc, vartype) + ! + ! !DESCRIPTION: + ! Inquire variable type + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(in) :: ncid ! netcdf file id + type(var_desc_t) , intent(in) :: vardesc ! variable descriptor + integer , intent(out) :: vartype ! type of var in file (ncd_int, ncd_float, ncd_double, etc.) + ! + ! !LOCAL VARIABLES: + integer :: status + + character(len=*), parameter :: subname = 'ncd_inqvtype' + !----------------------------------------------------------------------- + + vartype = -9999 + status = pio_inq_vartype(ncid, vardesc, vartype) + + end subroutine ncd_inqvtype + + !----------------------------------------------------------------------- + subroutine ncd_inqvdims(ncid,ndims,vardesc) + ! + ! !DESCRIPTION: + ! inquire variable dimensions + ! + ! !ARGUMENTS: + class(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(out) :: ndims ! variable ndims + type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + ndims = -1 + status = PIO_inq_varndims(ncid,vardesc,ndims) + + end subroutine ncd_inqvdims + + !----------------------------------------------------------------------- + subroutine ncd_inqvname(ncid,varid,vname,vardesc) + ! + ! !DESCRIPTION: + ! inquire variable name + ! + ! !ARGUMENTS: + class(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(in) :: varid ! variable id + character(len=*) , intent(out) :: vname ! variable vname + type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + vname = '' + status = PIO_inq_varname(ncid,vardesc,vname) + + end subroutine ncd_inqvname + + !----------------------------------------------------------------------- + subroutine ncd_inqvdids(ncid,dids,vardesc) + ! + ! !DESCRIPTION: + ! inquire variable dimension ids + ! + ! !ARGUMENTS: + class(file_desc_t),intent(in) :: ncid ! netcdf file id + integer ,intent(out) :: dids(:) ! variable dids + type(Var_desc_t) ,intent(inout):: vardesc ! variable descriptor + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + dids = -1 + status = PIO_inq_vardimid(ncid,vardesc,dids) + + end subroutine ncd_inqvdids + + !----------------------------------------------------------------------- + subroutine ncd_inqvdlen_byDesc(ncid,vardesc,dimnum,dlen,err_code) + ! + ! !DESCRIPTION: + ! inquire size of one of a variable's dimensions, given a vardesc + ! + ! If the variable has n dimensions, then dimnum should be between 1 and n; this routine + ! returns the size of the dimnum'th dimension. + ! + ! If there is an error condition, dlen will be -1, and err_code will hold the error + ! code; possible error codes are: + ! 0: no error + ! 1: dimnum out of range + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + type(Var_desc_t) ,intent(inout) :: vardesc ! variable descriptor + integer ,intent(in) :: dimnum ! dimension number to query + integer ,intent(out) :: dlen ! length of the dimension + integer ,intent(out) :: err_code ! error code (0 means no error) + ! + ! !LOCAL VARIABLES: + integer :: ndims ! number of dimensions + integer, allocatable :: dimids(:) ! dimension IDs + + integer, parameter :: dlen_invalid = -1 + integer, parameter :: error_none = 0 + integer, parameter :: error_dimnum_out_of_range = 1 + !----------------------------------------------------------------------- + + err_code = error_none + + call ncd_inqvdims(ncid, ndims, vardesc) + + if (dimnum > 0 .and. dimnum <= ndims) then + allocate(dimids(ndims)) + call ncd_inqvdids(ncid, dimids, vardesc) + call ncd_inqdlen(ncid, dimids(dimnum), dlen) + deallocate(dimids) + else + dlen = dlen_invalid + err_code = error_dimnum_out_of_range + end if + + end subroutine ncd_inqvdlen_byDesc + + + !----------------------------------------------------------------------- + subroutine ncd_inqvdlen_byName(ncid,varname,dimnum,dlen,err_code) + ! + ! !DESCRIPTION: + ! inquire size of one of a variable's dimensions, given a variable name + ! + ! If the variable has n dimensions, then dimnum should be between 1 and n; this routine + ! returns the size of the dimnum'th dimension. + ! + ! If there is an error condition, dlen will be -1, and err_code will hold the error + ! code; possible error codes are: + ! 0: no error + ! 1: dimnum out of range + ! 11: variable not found + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*) ,intent(in) :: varname ! variable name + integer ,intent(in) :: dimnum ! dimension number to query + integer ,intent(out) :: dlen ! length of the dimension + integer ,intent(out) :: err_code ! error code (0 means no error) + ! + ! !LOCAL VARIABLES: + type(Var_desc_t) :: vardesc ! variable descriptor + logical :: readvar ! whether the variable was found + integer, parameter :: dlen_invalid = -1 + integer, parameter :: error_variable_not_found = 11 + !----------------------------------------------------------------------- + + call check_var(ncid, varname, readvar, vardesc=vardesc) + if (readvar) then + call ncd_inqvdlen_byDesc(ncid, vardesc, dimnum, dlen, err_code) + else + dlen = dlen_invalid + err_code = error_variable_not_found + end if + + end subroutine ncd_inqvdlen_byName + + !----------------------------------------------------------------------- + subroutine ncd_inqvdname_byDesc(ncid,vardesc,dimnum,dname,err_code) + ! + ! !DESCRIPTION: + ! Inquire name of one of a variable's dimensions, given a vardesc + ! + ! If the variable has n dimensions, then dimnum should be between 1 and n; this + ! routine returns the name of the dimnum'th dimension. + ! + ! If there is an error condition, dname will be ' ', and err_code will hold the error + ! code; possible error codes are: + ! 0: no error + ! 1: dimnum out of range + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + type(Var_desc_t) ,intent(inout) :: vardesc ! variable descriptor + integer ,intent(in) :: dimnum ! dimension number to query + character(len=*) ,intent(out) :: dname ! name of the dimension + integer ,intent(out) :: err_code ! error code (0 means no error) + ! + ! !LOCAL VARIABLES: + integer :: ndims ! number of dimensions + integer, allocatable :: dimids(:) ! dimension IDs + + character(len=*), parameter :: dname_invalid = ' ' + integer, parameter :: error_none = 0 + integer, parameter :: error_dimnum_out_of_range = 1 + + character(len=*), parameter :: subname = 'ncd_inqvdname_byDesc' + !----------------------------------------------------------------------- + + err_code = error_none + + call ncd_inqvdims(ncid, ndims, vardesc) + + if (dimnum > 0 .and. dimnum <= ndims) then + allocate(dimids(ndims)) + call ncd_inqvdids(ncid, dimids, vardesc) + call ncd_inqdname(ncid, dimids(dimnum), dname) + deallocate(dimids) + else + dname = dname_invalid + err_code = error_dimnum_out_of_range + end if + + end subroutine ncd_inqvdname_byDesc + + !----------------------------------------------------------------------- + subroutine ncd_inqvdname_byName(ncid,varname,dimnum,dname,err_code) + ! + ! !DESCRIPTION: + ! Inquire name of one of a variable's dimensions, given a variable name + ! + ! If the variable has n dimensions, then dimnum should be between 1 and n; this + ! routine returns the name of the dimnum'th dimension. + ! + ! If there is an error condition, dname will be ' ', and err_code will hold the error + ! code; possible error codes are: + ! 0: no error + ! 1: dimnum out of range + ! 11: variable not found + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*) ,intent(in) :: varname ! variable name + integer ,intent(in) :: dimnum ! dimension number to query + character(len=*) ,intent(out) :: dname ! name of the dimension + integer ,intent(out) :: err_code ! error code (0 means no error) + ! + ! !LOCAL VARIABLES: + type(Var_desc_t) :: vardesc ! variable descriptor + logical :: readvar ! whether the variable was found + character(len=*), parameter :: dname_invalid = ' ' + integer, parameter :: error_variable_not_found = 11 + + character(len=*), parameter :: subname = 'ncd_inqvdname_byName' + !----------------------------------------------------------------------- + + call check_var(ncid, varname, readvar, vardesc=vardesc) + if (readvar) then + call ncd_inqvdname_byDesc(ncid, vardesc, dimnum, dname, err_code) + else + dname = dname_invalid + err_code = error_variable_not_found + end if + + end subroutine ncd_inqvdname_byName + + !----------------------------------------------------------------------- + subroutine ncd_inqnatts(ncid, nattributes) + ! + ! !DESCRIPTION: + ! Inquire number of global attributes + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer , intent(out) :: nattributes ! number of global attributes + ! + ! !LOCAL VARIABLES: + integer :: status + + character(len=*), parameter :: subname = 'ncd_inqnatts' + !----------------------------------------------------------------------- + + status = PIO_inquire(ncid, nattributes=nattributes) + + end subroutine ncd_inqnatts + + !----------------------------------------------------------------------- + subroutine ncd_inqattname(ncid, varid, attnum, attname) + ! + ! !DESCRIPTION: + ! Inquire attribute name, given attribute number + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: ncid ! netcdf file id + integer , intent(in) :: varid ! netcdf var id (can be ncd_global) + integer , intent(in) :: attnum ! attribute number + character(len=*) , intent(out) :: attname + ! + ! !LOCAL VARIABLES: + integer :: status + + character(len=*), parameter :: subname = 'ncd_inqattname' + !----------------------------------------------------------------------- + + status = PIO_inq_attname(ncid, varid, attnum, attname) + + end subroutine ncd_inqattname + + !----------------------------------------------------------------------- + subroutine ncd_putatt_int(ncid,varid,attrib,value,xtype) + ! + ! !DESCRIPTION: + ! put integer attributes + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + integer ,intent(in) :: value ! netcdf attrib value + integer,optional ,intent(in) :: xtype ! netcdf data type + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + status = PIO_put_att(ncid,varid,trim(attrib),value) + + end subroutine ncd_putatt_int + + !----------------------------------------------------------------------- + subroutine ncd_putatt_char(ncid,varid,attrib,value,xtype) + ! + ! !DESCRIPTION: + ! put character attributes + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + character(len=*) ,intent(in) :: value ! netcdf attrib value + integer,optional ,intent(in) :: xtype ! netcdf data type + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + status = PIO_put_att(ncid,varid,trim(attrib),value) + + end subroutine ncd_putatt_char + + !----------------------------------------------------------------------- + subroutine ncd_putatt_real(ncid,varid,attrib,value,xtype) + ! + ! !DESCRIPTION: + ! put real attributes + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + real(r8) ,intent(in) :: value ! netcdf attrib value + integer ,intent(in) :: xtype ! netcdf data type + ! + ! !LOCAL VARIABLES: + integer :: status + real*4 :: value4 + !----------------------------------------------------------------------- + + value4 = value + + if (xtype == pio_double) then + status = PIO_put_att(ncid,varid,trim(attrib),value) + else + status = PIO_put_att(ncid,varid,trim(attrib),value4) + endif + + end subroutine ncd_putatt_real + + !----------------------------------------------------------------------- + subroutine ncd_getatt_char(ncid,varid,attrib,value) + ! + ! !DESCRIPTION: + ! get a character attribute + ! + ! !USES: + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + character(len=*) ,intent(out) :: value ! netcdf attrib value + ! + ! !LOCAL VARIABLES: + integer :: status + + character(len=*), parameter :: subname = 'ncd_getatt_char' + !----------------------------------------------------------------------- + + status = PIO_get_att(ncid,varid,trim(attrib),value) + + end subroutine ncd_getatt_char + + !----------------------------------------------------------------------- + subroutine ncd_getatt_int(ncid,varid,attrib,value) + ! + ! !DESCRIPTION: + ! get an integer attribute + ! + ! !USES: + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + integer ,intent(out) :: value ! netcdf attrib value + ! + ! !LOCAL VARIABLES: + integer :: status + + character(len=*), parameter :: subname = 'ncd_getatt_int' + !----------------------------------------------------------------------- + + status = PIO_get_att(ncid,varid,trim(attrib),value) + + end subroutine ncd_getatt_int + + + !----------------------------------------------------------------------- + subroutine ncd_defdim(ncid,attrib,value,dimid) + ! + ! !DESCRIPTION: + ! define dimension + ! + ! !ARGUMENTS: + class(file_desc_t), intent(in) :: ncid ! netcdf file id + character(len=*) , intent(in) :: attrib ! netcdf attrib + integer , intent(in) :: value ! netcdf attrib value + integer , intent(out):: dimid ! netcdf dimension id + ! + ! !LOCAL VARIABLES: + integer :: status + !----------------------------------------------------------------------- + + status = pio_def_dim(ncid,attrib,value,dimid) + + end subroutine ncd_defdim + + !----------------------------------------------------------------------- + subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & + long_name, units, cell_method, missing_value, fill_value, & + imissing_value, ifill_value, comment, flag_meanings, & + flag_values, nvalid_range ) + ! + ! !DESCRIPTION: + ! Define a netcdf variable + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: varname ! variable name + integer , intent(in) :: xtype ! external type + integer , intent(in) :: ndims ! number of dims + integer , intent(inout) :: varid ! returned var id + integer , intent(in), optional :: dimid(:) ! dimids + character(len=*) , intent(in), optional :: long_name ! attribute + character(len=*) , intent(in), optional :: units ! attribute + character(len=*) , intent(in), optional :: cell_method ! attribute + character(len=*) , intent(in), optional :: comment ! attribute + character(len=*) , intent(in), optional :: flag_meanings(:) ! attribute + real(r8) , intent(in), optional :: missing_value ! attribute for real + real(r8) , intent(in), optional :: fill_value ! attribute for real + integer , intent(in), optional :: imissing_value ! attribute for int + integer , intent(in), optional :: ifill_value ! attribute for int + integer , intent(in), optional :: flag_values(:) ! attribute for int + integer , intent(in), optional :: nvalid_range(2) ! attribute for int + ! + ! !LOCAL VARIABLES: + integer :: n ! indices + integer :: ldimid(4) ! local dimid + integer :: dimid0(1) ! local dimid + integer :: status ! error status + integer :: lxtype ! local external type (in case logical variable) + type(var_desc_t) :: vardesc ! local vardesc + character(len=128) :: dimname ! temporary + character(len=256) :: str ! temporary + character(len=*),parameter :: subname='ncd_defvar_bynf' ! subroutine name + !----------------------------------------------------------------------- + + varid = -1 + + dimid0 = 0 + ldimid = 0 + if (present(dimid)) then + ldimid(1:ndims) = dimid(1:ndims) + else ! ndims must be zero if dimid not present + if (ndims /= 0) then + write(iulog,*) subname//' ERROR: dimid not supplied and ndims ne 0 ',trim(varname),ndims + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + endif + endif + + if ( xtype == ncd_log )then + lxtype = ncd_int + else + lxtype = xtype + end if + if (masterproc .and. debug > 1) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + write(iulog,*) subname//' ',trim(varname),lxtype,ndims,ldimid(1:ndims) + endif + + if (ndims > 0) then + status = pio_inq_dimname(ncid,ldimid(ndims),dimname) + end if + + ! Define variable + if (present(dimid)) then + status = PIO_def_var(ncid,trim(varname),lxtype,dimid(1:ndims),vardesc) + else + status = PIO_def_var(ncid,trim(varname),lxtype,dimid0 ,vardesc) + endif + varid = vardesc%varid + + ! + ! Add attributes + ! + if (present(long_name)) then + call ncd_putatt(ncid, varid, 'long_name', trim(long_name)) + end if + if (present(flag_values)) then + status = PIO_put_att(ncid,varid,'flag_values',flag_values) + if ( .not. present(flag_meanings)) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort(" ERROR:: flag_values set -- but not flag_meanings"//errMsg(sourcefile, __LINE__)) + end if + end if + if (present(flag_meanings)) then + if ( .not. present(flag_values)) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort(" ERROR:: flag_meanings set -- but not flag_values"//errMsg(sourcefile, __LINE__) ) + end if + if ( size(flag_values) /= size(flag_meanings) ) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort(" ERROR:: flag_meanings and flag_values dimension different"//errMsg(sourcefile, __LINE__)) + end if + str = flag_meanings(1) + do n = 1, size(flag_meanings) + if ( index(flag_meanings(n), ' ') /= 0 )then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort(" ERROR:: flag_meanings has an invalid space in it"//errMsg(sourcefile, __LINE__) ) + end if + if ( n > 1 ) str = trim(str)//" "//flag_meanings(n) + end do + status = PIO_put_att(ncid,varid,'flag_meanings', trim(str) ) + end if + if (present(comment)) then + call ncd_putatt(ncid, varid, 'comment', trim(comment)) + end if + if (present(units)) then + call ncd_putatt(ncid, varid, 'units', trim(units)) + end if + if (present(cell_method)) then + str = 'time: ' // trim(cell_method) + call ncd_putatt(ncid, varid, 'cell_methods', trim(str)) + end if + if (present(fill_value)) then + call ncd_putatt(ncid, varid, '_FillValue', fill_value, lxtype) + end if + if (present(missing_value)) then + call ncd_putatt(ncid, varid, 'missing_value', missing_value, lxtype) + end if + if (present(ifill_value)) then + call ncd_putatt(ncid, varid, '_FillValue', ifill_value, lxtype) + end if + if (present(imissing_value)) then + call ncd_putatt(ncid, varid, 'missing_value', imissing_value, lxtype) + end if + if (present(nvalid_range)) then + status = PIO_put_att(ncid,varid,'valid_range', nvalid_range ) + end if + if ( xtype == ncd_log )then + status = PIO_put_att(ncid,varid,'flag_values', (/0, 1/) ) + status = PIO_put_att(ncid,varid,'flag_meanings', "FALSE TRUE" ) + status = PIO_put_att(ncid,varid,'valid_range', (/0, 1/) ) + end if + + end subroutine ncd_defvar_bynf + + !----------------------------------------------------------------------- + subroutine ncd_defvar_bygrid(ncid, varname, xtype, & + dim1name, dim2name, dim3name, dim4name, dim5name, & + long_name, units, cell_method, missing_value, fill_value, & + imissing_value, ifill_value, switchdim, comment, & + flag_meanings, flag_values, nvalid_range ) + ! + ! !DESCRIPTION: + ! Define a netcdf variable + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: varname ! variable name + integer , intent(in) :: xtype ! external type + character(len=*) , intent(in), optional :: dim1name ! dimension name + character(len=*) , intent(in), optional :: dim2name ! dimension name + character(len=*) , intent(in), optional :: dim3name ! dimension name + character(len=*) , intent(in), optional :: dim4name ! dimension name + character(len=*) , intent(in), optional :: dim5name ! dimension name + character(len=*) , intent(in), optional :: long_name ! attribute + character(len=*) , intent(in), optional :: units ! attribute + character(len=*) , intent(in), optional :: cell_method ! attribute + character(len=*) , intent(in), optional :: comment ! attribute + character(len=*) , intent(in), optional :: flag_meanings(:) ! attribute + real(r8) , intent(in), optional :: missing_value ! attribute for real + real(r8) , intent(in), optional :: fill_value ! attribute for real + integer , intent(in), optional :: imissing_value ! attribute for int + integer , intent(in), optional :: ifill_value ! attribute for int + logical , intent(in), optional :: switchdim ! true=> permute dim1 and dim2 for output + integer , intent(in), optional :: flag_values(:) ! attribute for int + integer , intent(in), optional :: nvalid_range(2) ! attribute for int + ! + ! !LOCAL VARIABLES: + integer :: n ! indices + integer :: ndims ! dimension counter + integer :: dimid(5) ! dimension ids + integer :: varid ! variable id + integer :: itmp ! temporary + character(len=256) :: str ! temporary + character(len=*),parameter :: subname='ncd_defvar_bygrid' ! subroutine name + !----------------------------------------------------------------------- + + dimid(:) = 0 + + ! Determine dimension ids for variable + + if (present(dim1name)) call ncd_inqdid(ncid, dim1name, dimid(1)) + if (present(dim2name)) call ncd_inqdid(ncid, dim2name, dimid(2)) + if (present(dim3name)) call ncd_inqdid(ncid, dim3name, dimid(3)) + if (present(dim4name)) call ncd_inqdid(ncid, dim4name, dimid(4)) + if (present(dim5name)) call ncd_inqdid(ncid, dim5name, dimid(5)) + + ! Permute dim1 and dim2 if necessary + + if (present(switchdim)) then + itmp = dimid(2) + dimid(2) = dimid(1) + dimid(1) = itmp + end if + + ! Define variable + + ndims = 0 + if (present(dim1name)) then + do n = 1, size(dimid) + if (dimid(n) /= 0) ndims = ndims + 1 + end do + end if + + call ncd_defvar_bynf(ncid,varname,xtype,ndims,dimid,varid, & + long_name=long_name, units=units, cell_method=cell_method, & + missing_value=missing_value, fill_value=fill_value, & + imissing_value=imissing_value, ifill_value=ifill_value, & + comment=comment, flag_meanings=flag_meanings, & + flag_values=flag_values, nvalid_range=nvalid_range ) + + end subroutine ncd_defvar_bygrid + + !------------------------------------------------------------------------ + subroutine ncd_io_char_var0_start_glob(vardesc, data, flag, ncid, start ) + ! + ! !DESCRIPTION: + ! netcdf I/O of global character array with start indices input + ! + ! !ARGUMENTS: + class(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + type(var_desc_t) , intent(in) :: vardesc ! local vardesc pointer + character(len=*) , intent(inout) :: data ! raw data for this index + integer , intent(in) :: start(:) ! output bounds + ! + ! !LOCAL VARIABLES: + integer :: status ! error code + character(len=*),parameter :: subname='ncd_io_char_var0_start_glob' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + status = pio_get_var(ncid, vardesc, start, data ) + + elseif (flag == 'write') then + + status = pio_put_var(ncid, vardesc, start, data ) + + endif + + end subroutine ncd_io_char_var0_start_glob + + !------------------------------------------------------------------------ + !DIMS 0,1 + subroutine ncd_io_{DIMS}d_log_glob(varname, data, flag, ncid, readvar, nt, posNOTonfile) + ! + ! !DESCRIPTION: + ! netcdf I/O of global logical variable + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + logical , intent(inout) :: data{DIMSTR} ! raw data + logical, optional , intent(out) :: readvar ! was var read? + integer, optional , intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + ! + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start(2), count(2) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + logical :: found ! if true, found lat/lon dims on file + integer :: idata + integer, pointer :: idata1d(:) ! Temporary integer data to send to file + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + integer :: ndims + character(len=*),parameter :: subname='ncd_io_{DIMS}d_log_glob' + !----------------------------------------------------------------------- + + start(:) = 0 + count(:) = 0 + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) +#if ({DIMS}==0) + if (varpresent) then + status = pio_get_var(ncid, vardesc, idata) + if (single_column .and. present(posNOTonfile) ) then + if ( .not. posNOTonfile )then + call shr_sys_abort(' ERROR: scalar var is NOT compatable with posNOTonfile = .false.'//& + errMsg(sourcefile, __LINE__)) + end if + endif + if ( status /= PIO_NOERR )then + call shr_sys_abort(' ERROR: reading variable: '//trim(varname)//' ' & + // errMsg(sourcefile, __LINE__)) + end if + if ( idata == 0 )then + data = .false. + else if ( idata == 1 )then + data = .true. + else + call shr_sys_abort(' ERROR: bad integer value for logical data'//errMsg(sourcefile, __LINE__)) + end if + end if +#else + if (varpresent) then + allocate(idata1d(size(data))) + if (single_column) then + call scam_field_offsets(ncid,'undefined', vardesc,& + start, count, found=found, posNOTonfile=posNOTonfile) + if ( found )then + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_get_var(ncid, varid, start(1:ndims), count(1:ndims), idata1d) + else + status = pio_get_var(ncid, varid, idata1d) + end if + else + status = pio_get_var(ncid, varid, idata1d) + endif + if ( status /= PIO_NOERR )then + call shr_sys_abort(' ERROR: reading variable: '//trim(varname)//' ' & + // errMsg(sourcefile, __LINE__)) + end if + if ( any(idata1d /= 0 .and. idata1d /= 1) )then + call shr_sys_abort(' ERROR: read in bad integer value(s) for logical data'//errMsg(sourcefile, __LINE__)) + end if + data = (idata1d == 1) + deallocate(idata1d) + endif +#endif + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + ndims = {DIMS} + if(present(nt)) ndims=ndims+1 + call ncd_inqvid (ncid, varname, varid, vardesc) +#if ({DIMS}==0) + allocate(idata1d(1)) + if ( data )then + idata1d(1) = 1 + else + idata1d(1) = 0 + end if + if (present(nt)) then + start(1) = nt + count(1) = 1 + status = pio_put_var(ncid, varid, start(1:1), count(1:1), idata1d) + else + status = pio_put_var(ncid, varid, idata1d) + end if + deallocate(idata1d) +#elif ({DIMS}==1) + start(1) = 1 ; count(1) = size(data) + start(2) = 1 ; count(2) = 1 + if (present(nt)) start(2) = nt + allocate(idata1d(size(data))) + where( data ) + idata1d = 1 + elsewhere + idata1d = 0 + end where + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), idata1d) + deallocate( idata1d ) +#endif + + endif ! flag + + end subroutine ncd_io_{DIMS}d_log_glob + + !------------------------------------------------------------------------ + !DIMS 0,1,2,3 + !TYPE int,double + subroutine ncd_io_{DIMS}d_{TYPE}_glob(varname, data, flag, ncid, readvar, nt, posNOTonfile) + ! + ! !DESCRIPTION: + ! netcdf I/O of global variable + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + {VTYPE} , intent(inout) :: data{DIMSTR} ! raw data + logical , optional, intent(out) :: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + ! + ! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: start({DIMS}+1), count({DIMS}+1) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + logical :: found ! if true, found lat/lon dims on file + character(len=32) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + integer :: ndims + {VTYPE} :: temp(1) + character(len=*),parameter :: subname='ncd_io_{DIMS}d_{TYPE}_glob' + !----------------------------------------------------------------------- + + start(:) = 0 + count(:) = 0 + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) +#if ({DIMS}==0) + if (varpresent) then + status = pio_get_var(ncid, vardesc, data) + if (single_column .and. present(posNOTonfile) ) then + if ( .not. posNOTonfile )then + call shr_sys_abort(' ERROR: scalar var is NOT compatable with posNOTonfile = .false.'//& + errMsg(sourcefile, __LINE__)) + end if + endif + if ( status /= PIO_NOERR )then + call shr_sys_abort(' ERROR: reading variable: '//trim(varname)//' ' & + // errMsg(sourcefile, __LINE__)) + end if + end if +#else + if (varpresent) then + if (single_column) then + call scam_field_offsets(ncid,'undefined', vardesc,& + start, count, found=found, posNOTonfile=posNOTonfile) + if ( found )then + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_get_var(ncid, varid, start(1:ndims), count(1:ndims), data) + else + status = pio_get_var(ncid, varid, data) + end if + else + status = pio_get_var(ncid, varid, data) + endif + if ( status /= PIO_NOERR )then + call shr_sys_abort(' ERROR: reading variable: '//trim(varname)//' ' & + // errMsg(sourcefile, __LINE__)) + end if + endif +#endif + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + ndims = {DIMS} + if(present(nt)) ndims=ndims+1 + call ncd_inqvid (ncid, varname, varid, vardesc) +#if ({DIMS}==0) + if (present(nt)) then + temp(1) = data + start(1) = nt + count(1) = 1 + status = pio_put_var(ncid, varid, start(1:1), count(1:1), temp) + else + status = pio_put_var(ncid, varid, data) + end if +#elif ({DIMS}==1) + start(1) = 1 ; count(1) = size(data) + start(2) = 1 ; count(2) = 1 + if (present(nt)) start(2) = nt + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) +#elif ({DIMS}==2) + start(1) = 1 ; count(1) = size(data, dim=1) + start(2) = 1 ; count(2) = size(data, dim=2) + start(3) = 1 ; count(3) = 1 + if (present(nt)) start(3) = nt + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) +#elif ({DIMS}==3) + if (present(nt)) then + start(1) = 1 ; count(1) = size(data,dim=1) + start(2) = 1 ; count(2) = size(data,dim=2) + start(3) = 1 ; count(3) = size(data,dim=3) + start(4) = nt ; count(4) = 1 + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) + else + status = pio_put_var(ncid, varid, data) + end if +#endif + + endif ! flag + + end subroutine ncd_io_{DIMS}d_{TYPE}_glob + + !------------------------------------------------------------------------ + !DIMS 0,1,2 + !TYPE text + subroutine ncd_io_{DIMS}d_{TYPE}_glob(varname, data, flag, ncid, readvar, nt, posNOTonfile) + ! + ! !DESCRIPTION: + ! netcdf I/O of global variable + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + {VTYPE} , intent(inout) :: data{DIMSTR} ! raw data + logical , optional, intent(out) :: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(in) :: posNOTonfile ! position is NOT on this file + ! + ! !LOCAL VARIABLES: + integer :: m + integer :: varid ! netCDF variable id + integer :: start(4), count(4) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=1) :: tmpString(199) ! temp for manipulating output string + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_{DIMS}d_{TYPE}_glob' + integer :: ndims + !----------------------------------------------------------------------- + + start(:) = 0 + count(:) = 0 + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + + if (varpresent) then + data = ' ' + status = pio_get_var(ncid, varid, data) + end if + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + ndims = {DIMS} + if(present(nt)) ndims=ndims+1 + call ncd_inqvid (ncid, varname, varid, vardesc) + +#if ({DIMS}==0) + start(1) = 1 ; count(1) = len(data) + do m = 1,len(data) + tmpString(m:m) = data(m:m) + end do + if (present(nt)) then + start(2) = nt; count(2) = 1 + if ( count(1) > size(tmpString) )then + call shr_sys_abort( subname//' ERROR: input string size is too large:'//& + errMsg(sourcefile, __LINE__)) + end if + end if + status = pio_put_var(ncid, varid, start, count, ival=tmpString(1:count(1))) +#elif ({DIMS}==1) + start(1) = 1 ; count(1) = len(data) + start(2) = 1 ; count(2) = size(data) + if (present(nt)) then + start(3) = nt; count(3) = 1 + status = pio_put_var(ncid, varid, start, count, data) + else + status = pio_put_var(ncid, varid, start, count, data) + end if +#elif ({DIMS}==2) + start(1) = 1 ; count(1) = len(data) + start(2) = 1 ; count(2) = size(data,dim=1) + start(3) = 1 ; count(3) = size(data,dim=2) + if (present(nt)) then + start(4) = nt ; count(4) = 1 + status = pio_put_var(ncid, varid, start, count, data) + else + status = pio_put_var(ncid, varid, start, count, data) + end if +#endif + + endif + + end subroutine ncd_io_{DIMS}d_{TYPE}_glob + + !----------------------------------------------------------------------- + + !TYPE int,double,logical + subroutine ncd_io_1d_{TYPE}(varname, data, dim1name, flag, ncid, nt, readvar, cnvrtnan2fill) + ! + ! !DESCRIPTION: + ! netcdf I/O for 1d + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + {VTYPE} , pointer :: data(:) ! local decomposition data + character(len=*) , intent(in) :: dim1name ! dimension name + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(out) :: readvar ! true => variable is on initial dataset (read only) + logical , optional, intent(in) :: cnvrtnan2fill ! true => convert any NaN's to _FillValue (spval) + ! + ! Local Variables + character(len=8) :: clmlevel ! clmlevel + character(len=32) :: dimname ! temporary + integer :: n ! index + integer :: iodnum ! iodesc num in list + integer :: varid ! varid + integer :: ndims ! ndims for var + integer :: ndims_iod ! ndims iodesc for var + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: start(3) ! netcdf start index + integer :: count(3) ! netcdf count index + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + integer :: xtype ! type of var in file + integer , pointer :: idata(:) ! Temporary integer data to send to file + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + integer :: oldhandle ! previous value of pio_error_handle + character(len=*),parameter :: subname='ncd_io_1d_{TYPE}' ! subroutine name + !----------------------------------------------------------------------- + + start(:) = 0 + count(:) = 0 + + clmlevel = dim1name + + if (masterproc .and. debug > 1) then + write(iulog,*) subname//' ',trim(flag),' ',trim(varname),' ',trim(clmlevel) + end if + +#if ({ITYPE}==TYPEDOUBLE) + if ( present(cnvrtnan2fill) )then + if (.not. cnvrtnan2fill) then + call shr_sys_abort(' ERROR: cnvrtnan2fill present but NOT set to true -- MUST set it to TRUE if used'//& + errMsg(sourcefile, __LINE__)) + endif + end if +#endif + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + if (single_column) then + start(:) = 1 ; count(:) = 1 + call scam_field_offsets(ncid,clmlevel,vardesc,start,count) + if (trim(clmlevel) == grlnd) then + n=2 + if (present(nt)) then + start(3) = nt ; count(3) = 1 + n=3 + end if + else + n=1 + if (present(nt)) then + n=2 + start(2) = nt ; count(2) = 1 + end if + end if + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldhandle) +#if ({ITYPE}==TYPELOGICAL) + allocate(idata(size(data))) + status = pio_get_var(ncid, varid, start(1:n), count(1:n), idata) + data = (idata == 1) + if ( any(idata /= 0 .and. idata /= 1) )then + call shr_sys_abort(' ERROR: read in bad integer value(s) for logical data'//errMsg(sourcefile, __LINE__)) + end if + deallocate( idata ) +#else + status = pio_get_var(ncid, varid, start(1:n), count(1:n), data) +#endif + if ( status /= PIO_NOERR )then + call shr_sys_abort(' ERROR: reading in variable: '// trim(varname) & + // errMsg(sourcefile, __LINE__)) + end if + call pio_seterrorhandling(ncid, oldhandle) + + else + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids(1:ndims)) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + status = pio_inq_vartype(ncid, vardesc, xtype) + + call ncd_getiodesc(ncid, clmlevel, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=Pio_Offset_Kind)) + end if + call read_darray_dispatcher(ncid, vardesc, iodesc_plus%iodesc, varname, xtype, data) + + end if + end if + + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids(1:ndims)) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + status = pio_inq_vartype(ncid, vardesc, xtype) + call ncd_getiodesc(ncid, clmlevel, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=Pio_Offset_Kind)) + end if +#if ({ITYPE}==TYPELOGICAL) + allocate( idata(size(data)) ) + where( data ) + idata = 1 + elsewhere + idata = 0 + end where + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status, fillval=0) + deallocate( idata ) +#elif ({ITYPE}==TYPEINT) + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=ispval) +#elif ({ITYPE}==TYPEDOUBLE) + if (iodesc_plus%type == pio_double) then + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=spval) + else + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, real(data,kind=r4), status, fillval=real(spval,kind=r4)) + endif +#endif + else + + if (masterproc) then + write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + endif + + endif + + end subroutine ncd_io_1d_{TYPE} + + !----------------------------------------------------------------------- + + !TYPE int,double + subroutine ncd_io_2d_{TYPE}(varname, data, dim1name, lowerb2, upperb2, & + flag, ncid, nt, readvar, switchdim, cnvrtnan2fill) + ! + ! !DESCRIPTION: + ! Netcdf i/o of 2d + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + {VTYPE} , pointer :: data(:,:) ! local decomposition input data + character(len=*) , intent(in) :: dim1name ! dimension 1 name + integer, optional, intent(in) :: nt ! time sample index + integer, optional, intent(in) :: lowerb2,upperb2 ! lower and upper bounds of second dimension + logical, optional, intent(out) :: readvar ! true => variable is on initial dataset (read only) + logical, optional, intent(in) :: switchdim ! true=> permute dim1 and dim2 for output + logical, optional, intent(in) :: cnvrtnan2fill ! true => convert any NaN's to _FillValue (spval) + ! + ! !LOCAL VARIABLES: +#if ({ITYPE}==TYPEINT) + integer , pointer :: temp(:,:) +#else + real(r8), pointer :: temp(:,:) +#endif + integer :: ndim1,ndim2 + character(len=8) :: clmlevel ! clmlevel + character(len=32) :: dimname ! temporary + integer :: status ! error status + integer :: ndims ! ndims total for var + integer :: ndims_iod ! ndims iodesc for var + integer :: varid ! varid + integer :: n,i,j ! indices + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: iodnum ! iodesc num in list + integer :: start(4) ! netcdf start index + integer :: count(4) ! netcdf count index + logical :: varpresent ! if true, variable is on tape + integer :: lb1,lb2 + integer :: ub1,ub2 + integer :: xtype ! netcdf type of variable on file + + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + character(len=*),parameter :: subname='ncd_io_2d_{TYPE}' ! subroutine name + !----------------------------------------------------------------------- + + start(:)=0 + count(:)=0 + + clmlevel = dim1name + + if (masterproc .and. debug > 1) then + write(iulog,*) trim(subname),' ',trim(flag),' ',trim(varname),' ',trim(clmlevel) + end if + +#if ({ITYPE}==TYPEDOUBLE) + if ( present(cnvrtnan2fill) )then + if (.not. cnvrtnan2fill) then + call shr_sys_abort( ' ERROR: cnvrtnan2fill present but NOT set to true -- MUST set it to TRUE if used'//& + errMsg(sourcefile, __LINE__)) + endif + end if +#endif + + lb1 = lbound(data, dim=1) + ub1 = ubound(data, dim=1) + lb2 = lbound(data, dim=2) + ub2 = ubound(data, dim=2) + + if (present(switchdim)) then + if (present(lowerb2)) lb2 = lowerb2 + if (present(upperb2)) ub2 = upperb2 + allocate(temp(lb2:ub2,lb1:ub1)) + end if + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + if (single_column) then + start(:) = 1 ; count(:) = 1 + call scam_field_offsets(ncid, clmlevel, vardesc, start, count) + if (trim(clmlevel) == grlnd) then + count(3) = size(data,dim=2) + n=3 + if (present(nt)) then + start(4) = nt; count(4) = 1 + n=4 + end if + else + count(2) = size(data,dim=2) + n=2 + if (present(nt)) then + start(3) = nt ; count(3) = 1 + n=3 + end if + end if + if (present(switchdim)) then + status = pio_get_var(ncid, vardesc, start(1:n), count(1:n), temp) + do j = lb2,ub2 + do i = lb1,ub1 + data(i,j) = temp(j,i) + end do + end do + else + status = pio_get_var(ncid, vardesc, start(1:n), count(1:n), data) + endif + else + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid,vardesc, dids(1:ndims)) + status = pio_inq_dimname(ncid, dids(ndims), dimname) + if (ndims == 0) then + write(iulog,*) trim(subname),' ERROR: ndims must be greater than 0' + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + end if + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + status = pio_inq_vartype(ncid, vardesc, xtype) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=Pio_Offset_Kind)) + end if + if (present(switchdim)) then + call ncd_getiodesc(ncid, clmlevel, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum, switchdim=.true.) + iodesc_plus => iodesc_list(iodnum) + call read_darray_dispatcher(ncid, vardesc, iodesc_plus%iodesc, varname, xtype, temp) + do j = lb2,ub2 + do i = lb1,ub1 + data(i,j) = temp(j,i) + end do + end do + else + call ncd_getiodesc(ncid, clmlevel, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + call read_darray_dispatcher(ncid, vardesc, iodesc_plus%iodesc, varname, xtype, data) + + end if + end if +#if ({ITYPE}==TYPEDOUBLE) + if ( present(cnvrtnan2fill) )then + do j = lb2,ub2 + do i = lb1,ub1 + if ( data(i,j) == spval )then + data(i,j) = nan + end if + end do + end do + end if +#endif + end if + if (present(readvar)) readvar = varpresent + + else if (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc , dids(1:ndims)) + if (ndims == 0) then + write(iulog,*) trim(subname),' ERROR: ndims must be greater than 0' + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + end if + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + status = pio_inq_vartype(ncid, vardesc, xtype) + if (present(switchdim)) then + call ncd_getiodesc(ncid, clmlevel, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum, switchdim=.true.) + else + call ncd_getiodesc(ncid, clmlevel, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + end if + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=Pio_Offset_Kind)) + end if + if (present(switchdim)) then + do j = lb2,ub2 + do i = lb1,ub1 + temp(j,i) = data(i,j) + end do + end do + end if +#if ({ITYPE}==TYPEINT) + if (present(switchdim)) then + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, temp, status, fillval=ispval) + else + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=ispval) + end if +#else + if (iodesc_plus%type == pio_double) then + if (present(switchdim)) then + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, temp, status, fillval=spval) + else + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=spval) + end if + else + if (present(switchdim)) then + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, real(temp, kind=r4), status, fillval=real(spval, kind=r4)) + else + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, real(data, kind=r4), status, fillval=real(spval, kind=r4)) + end if + endif + if ( present(cnvrtnan2fill) )then + do j = lb2,ub2 + do i = lb1,ub1 + if ( isnan(data(i,j)) )then + data(i,j) = spval + end if + end do + end do + end if +#endif + + else + + if (masterproc) then + write(iulog,*) subname,' error: unsupported flag ',trim(flag) + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + endif + + endif + + if (present(switchdim)) then + deallocate(temp) + end if + + end subroutine ncd_io_2d_{TYPE} + !----------------------------------------------------------------------- + + !TYPE int,double + subroutine ncd_io_3d_{TYPE}(varname, data, dim1name, flag, ncid, nt, readvar) + ! + ! !DESCRIPTION: + ! Netcdf i/o of 3d + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + {VTYPE} , pointer :: data(:,:,:) ! local decomposition input data + character(len=*) , intent(in) :: dim1name ! dimension 1 name + integer, optional, intent(in) :: nt ! time sample index + logical, optional, intent(out) :: readvar ! true => variable is on initial dataset (read only) + ! + ! !LOCAL VARIABLES: + integer :: ndim1,ndim2 + character(len=8) :: clmlevel ! clmlevel + character(len=32) :: dimname ! temporary + integer :: status ! error status + integer :: ndims ! ndims total for var + integer :: ndims_iod ! ndims iodesc for var + integer :: varid ! varid + integer :: n ! index + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: iodnum ! iodesc num in list + integer :: start(5) ! netcdf start index + integer :: count(5) ! netcdf count index + integer :: xtype ! netcdf type of variable on file + logical :: varpresent ! if true, variable is on tape + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + character(len=*),parameter :: subname='ncd_io_3d_{TYPE}' ! subroutine name + !----------------------------------------------------------------------- + + clmlevel = dim1name + + if (masterproc .and. debug > 1) then + write(iulog,*) trim(subname),' ',trim(flag),' ',trim(varname),' ',trim(clmlevel) + end if + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + if (single_column) then + start(:) = 1 + count(:) = 1 + call scam_field_offsets(ncid, clmlevel, vardesc, start, count) + if (trim(clmlevel) == grlnd) then + count(3) = size(data,dim=2); + count(4) = size(data,dim=3) + n=4 + if (present(nt)) then + start(5) = nt + count(5) = 1 + n=5 + end if + else + count(2) = size(data,dim=2) + count(3) = size(data,dim=3) + n=3 + if (present(nt)) then + start(4) = nt + count(4) = 1 + n=4 + end if + end if + status = pio_get_var(ncid, vardesc, start(1:n), count(1:n), data) + else + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid,vardesc, dids(1:ndims)) + status = pio_inq_dimname(ncid, dids(ndims), dimname) + if (ndims == 0) then + write(iulog,*) trim(subname),' ERROR: ndims must be greater than 0' + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + end if + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + status = pio_inq_vartype(ncid, vardesc, xtype) + call ncd_getiodesc(ncid, clmlevel, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=Pio_Offset_Kind)) + end if + call read_darray_dispatcher(ncid, vardesc, iodesc_plus%iodesc, varname, xtype, data) + + end if + end if + if (present(readvar)) readvar = varpresent + + else if (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc , dids(1:ndims)) + if (ndims == 0) then + write(iulog,*) trim(subname),' ERROR: ndims must be greater than 0' + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + end if + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + status = pio_inq_vartype(ncid, vardesc, xtype) + call ncd_getiodesc(ncid, clmlevel, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=Pio_Offset_Kind)) + end if + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) + + else + + if (masterproc) then + write(iulog,*) subname,' error: unsupported flag ',trim(flag) + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + endif + + endif + + end subroutine ncd_io_3d_{TYPE} + + !----------------------------------------------------------------------- + !TYPE int,double,logical + !DIMS 1,2,3 + subroutine read_darray_{TYPE}_dispatcher_{DIMS}(ncid, vardesc, iodesc, varname, xtype, data) + ! + ! !DESCRIPTION: + ! Dispatch to the appropriate read_darray routine based on xtype (the type of var in file) + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid + type(var_desc_t), intent(inout) :: vardesc + type(io_desc_t), intent(inout) :: iodesc + character(len=*), intent(in) :: varname + integer, intent(in) :: xtype + {VTYPE}, pointer :: data{DIMSTR} + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'read_darray_{TYPE}_dispatcher_{DIMS}' + !----------------------------------------------------------------------- + + select case (xtype) + case (PIO_INT) + call read_darray_{TYPE}_from_int_{DIMS}(ncid, vardesc, iodesc, varname, data) + case (PIO_REAL) + call read_darray_{TYPE}_from_real_{DIMS}(ncid, vardesc, iodesc, varname, data) + case (PIO_DOUBLE) + call read_darray_{TYPE}_from_double_{DIMS}(ncid, vardesc, iodesc, varname, data) + case default + write(iulog,*) subname//' ERROR: unrecognized type in read: ', xtype + call shr_sys_abort(' ERROR: unrecognized type in read '//errMsg(sourcefile, __LINE__)) + end select + + end subroutine read_darray_{TYPE}_dispatcher_{DIMS} + + + !------------------------------------------------------------------------ + !TYPE int,double,logical + !DIMS 1,2,3 + subroutine read_darray_{TYPE}_from_double_{DIMS}(ncid, vardesc, iodesc, varname, data) + class(file_desc_t), intent(inout) :: ncid + type(var_desc_t), intent(inout) :: vardesc + type(io_desc_t), intent(inout) :: iodesc + {VTYPE}, pointer :: data{DIMSTR} + character(len=*), intent(in) :: varname + integer :: status + + real(R8), allocatable :: ddata{DIMSTR} + integer :: oldhandle + + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldhandle) +#if({ITYPE}==TYPEDOUBLE) + call pio_read_darray(ncid, vardesc, iodesc, data, status) + if ( status /= PIO_NOERR ) then + call shr_sys_abort(' ERROR: reading in variable: '// trim(varname) & + // errMsg(sourcefile, __LINE__)) + end if +#else + allocate(ddata({REPEAT: size(data,#)})) + call pio_read_darray(ncid, vardesc, iodesc, ddata, status) + if ( status /= PIO_NOERR ) then + call shr_sys_abort(' ERROR: reading in variable: '// trim(varname) & + // errMsg(sourcefile, __LINE__)) + end if +#if({ITYPE}==TYPEINT) + data = int(ddata) +#elif({ITYPE}==TYPELOGICAL) + call convert_to_logical(ddata, data) +#else + call shr_sys_abort(' ERROR: unhandled type'//errMsg(sourcefile, __LINE__)) +#endif + deallocate(ddata) +#endif + call pio_seterrorhandling(ncid, oldhandle) + end subroutine read_darray_{TYPE}_from_double_{DIMS} + + !------------------------------------------------------------------------ + !TYPE int,double,logical + !DIMS 1,2,3 + subroutine read_darray_{TYPE}_from_int_{DIMS}(ncid, vardesc, iodesc, varname, data) + class(file_desc_t), intent(inout) :: ncid + type(var_desc_t), intent(inout) :: vardesc + type(io_desc_t), intent(inout) :: iodesc + character(len=*), intent(in) :: varname + {VTYPE}, pointer :: data{DIMSTR} + integer :: status + + integer, allocatable :: idata{DIMSTR} + integer :: oldhandle + + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldhandle) +#if({ITYPE}==TYPEINT) + call pio_read_darray(ncid, vardesc, iodesc, data, status) + if ( status /= PIO_NOERR ) then + call shr_sys_abort(' ERROR: reading in variable: '// trim(varname) & + // errMsg(sourcefile, __LINE__)) + end if +#else + allocate(idata({REPEAT: size(data,#)})) + call pio_read_darray(ncid, vardesc, iodesc, idata, status) + if ( status /= PIO_NOERR ) then + call shr_sys_abort(' ERROR: reading in variable: '// trim(varname) & + // errMsg(sourcefile, __LINE__)) + end if +#if({ITYPE}==TYPEDOUBLE) + data = real(idata, kind=R8) +#elif({ITYPE}==TYPELOGICAL) + call convert_to_logical(idata, data) +#else + call shr_sys_abort(' ERROR: unhandled type'//errMsg(sourcefile, __LINE__)) +#endif + deallocate(idata) +#endif + call pio_seterrorhandling(ncid, oldhandle) + end subroutine read_darray_{TYPE}_from_int_{DIMS} + + !------------------------------------------------------------------------ + !TYPE int,double,logical + !DIMS 1,2,3 + subroutine read_darray_{TYPE}_from_real_{DIMS}(ncid, vardesc, iodesc, varname, data) + class(file_desc_t), intent(inout) :: ncid + type(var_desc_t), intent(inout) :: vardesc + type(io_desc_t), intent(inout) :: iodesc + character(len=*), intent(in) :: varname + {VTYPE}, pointer :: data{DIMSTR} + + integer :: status + real(r4), allocatable :: rdata{DIMSTR} + integer :: oldhandle + + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldhandle) + + allocate(rdata({REPEAT: size(data,#)})) + call pio_read_darray(ncid, vardesc, iodesc, rdata, status) + if ( status /= PIO_NOERR ) then + call shr_sys_abort(' ERROR: reading in variable: '// trim(varname) & + // errMsg(sourcefile, __LINE__)) + end if +#if({ITYPE}==TYPEDOUBLE) + data = real(rdata, kind=R8) +#elif({ITYPE}==TYPEINT) + data = int(rdata) +#elif({ITYPE}==TYPELOGICAL) + call convert_to_logical(rdata, data) +#else + call shr_sys_abort(' ERROR: unhandled type'//errMsg(sourcefile, __LINE__)) +#endif + deallocate(rdata) + call pio_seterrorhandling(ncid, oldhandle) + + end subroutine read_darray_{TYPE}_from_real_{DIMS} + + !------------------------------------------------------------------------ + + subroutine scam_field_offsets( ncid, dim1name, vardesc, start, count, & + found, posNOTonfile) + ! + ! !DESCRIPTION: + ! Read/Write initial data from/to netCDF instantaneous initial data file + ! + ! !USES: + use clm_varctl, only: scmlon,scmlat,single_column + use shr_scam_mod, only: shr_scam_getCloseLatLon + use shr_string_mod, only: shr_string_toLower + ! + ! !ARGUMENTS: + class(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: dim1name ! dimension 1 name + type(Var_desc_t) , intent(inout) :: vardesc ! variable descriptor + integer , intent(out) :: start(:) ! start index + integer , intent(out) :: count(:) ! count to retrieve + logical, optional , intent(out) :: found ! if present return true if found + ! dimensions on file else false if NOT present abort if can't find + logical, optional , intent(in) :: posNOTonfile ! Position is NOT on this file + ! + ! !LOCAL VARIABLES: + integer :: cc,i,ii ! index variable + integer :: data_offset ! offset into land array 1st column + integer :: ndata ! number of column (or pft points to read) + real(r8) , pointer :: cols1dlon(:) ! holds cols1d_ixy var + real(r8) , pointer :: cols1dlat(:) ! holds cols1d_jxy var + real(r8) , pointer :: pfts1dlon(:) ! holds pfts1d_ixy var + real(r8) , pointer :: pfts1dlat(:) ! holds pfts1d_jxy var + real(r8) , pointer :: land1dlon(:) ! holds land1d_ixy var + real(r8) , pointer :: land1dlat(:) ! holds land1d_jxy var + integer, allocatable :: cols(:) ! grid cell columns for scam + integer, allocatable :: pfts(:) ! grid cell pfts for scam + integer, allocatable :: landunits(:) ! grid cell landunits for scam + integer, allocatable :: dids(:) ! dim ids + integer :: varid ! netCDF variable id + integer :: status ! return code + integer :: latidx,lonidx ! latitude/longitude indices + real(r8) :: closelat,closelon ! closest latitude and longitude indices + integer :: ndims,dimlen ! number of dimensions in desired variable + character(len=32) :: dimname ! dimension name + character(len=32) :: subname = 'scam_field_offsets' + !------------------------------------------------------------------------ + + start(:)=1 + count(:)=1 + + if ( present(posNOTonfile) )then + if ( posNOTonfile )then + if ( .not. present(found) )then + call shr_sys_abort('ERROR: Bad subroutine calling structure posNOTonfile sent, but found was NOT!'//& + errMsg(sourcefile, __LINE__)) + end if + found = .false. + return + end if + end if + + ! find closest land grid cell for this point + + if ( present(found) )then + call shr_scam_getCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,latidx,lonidx,found) + if ( .not. found ) return + else + call shr_scam_getCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,latidx,lonidx) + end if + + call ncd_inqvdims(ncid,ndims,vardesc) + + allocate(dids(ndims)) + status = pio_inq_vardimid(ncid, vardesc, dids) + do i = 1,ndims + status = pio_inq_dimname(ncid,dids(i),dimname) + dimname=shr_string_toLower(dimname) + status = pio_inq_dimlen(ncid,dids(i),dimlen) + if ( trim(dimname)=='nj'.or. trim(dimname)=='lat'.or. trim(dimname)=='lsmlat') then + start(i)=latidx + count(i)=1 + else if ( trim(dimname)=='ni'.or. trim(dimname)=='lon'.or. trim(dimname)=='lsmlon') then + start(i)=lonidx + count(i)=1 + else if ( trim(dimname)=='column') then + + allocate (cols1dlon(dimlen)) + allocate (cols1dlat(dimlen)) + allocate (cols(dimlen)) + + status = pio_inq_varid(ncid, 'cols1d_lon', varid) + status = pio_get_var(ncid, varid, cols1dlon) + status = pio_inq_varid(ncid, 'cols1d_lat', varid) + status = pio_get_var(ncid, varid, cols1dlat) + + cols(:) = huge(1) + data_offset = huge(1) + ii = 1 + ndata = 0 + do cc = 1, dimlen + if (cols1dlon(cc) == closelon.and.cols1dlat(cc) == closelat) then + cols(ii)=cc + ndata =ii + ii=ii+1 + end if + end do + if (ndata == 0) then + write(iulog,*)'couldnt find any columns for this latitude ',latidx,' and longitude ',lonidx + call shr_sys_abort('ERROR:: no columns for this position'//errMsg(sourcefile, __LINE__)) + else + data_offset=cols(1) + end if + + deallocate (cols1dlon) + deallocate (cols1dlat) + deallocate (cols) + + start(i) = data_offset + count(i) = ndata + else if ( trim(dimname)=='pft') then + + allocate (pfts1dlon(dimlen)) + allocate (pfts1dlat(dimlen)) + allocate (pfts(dimlen)) + + status = pio_inq_varid(ncid, 'pfts1d_lon', varid) + status = pio_get_var(ncid, varid, pfts1dlon) + + status = pio_inq_varid(ncid, 'pfts1d_lat', varid) + status = pio_get_var(ncid, varid, pfts1dlat) + + pfts(:) = huge(1) + data_offset = huge(1) + ii = 1 + ndata = 0 + do cc = 1, dimlen + if (pfts1dlon(cc) == closelon.and.pfts1dlat(cc) == closelat) then + pfts(ii)=cc + ndata =ii + ii=ii+1 + end if + end do + if (ndata == 0) then + write(iulog,*)'couldnt find any pfts for this latitude ',closelat,' and longitude ',closelon + call shr_sys_abort('ERROR:: no PFTs for this position'//errMsg(sourcefile, __LINE__)) + else + data_offset=pfts(1) + end if + + deallocate (pfts1dlon) + deallocate (pfts1dlat) + deallocate (pfts) + + start(i) = data_offset + count(i) = ndata + else if ( trim(dimname)=='landunit') then + + allocate (land1dlon(dimlen)) + allocate (land1dlat(dimlen)) + allocate (landunits(dimlen)) + + status = pio_inq_varid(ncid, 'land1d_lon', varid) + status = pio_get_var(ncid, varid, land1dlon) + + status = pio_inq_varid(ncid, 'land1d_lat', varid) + status = pio_get_var(ncid, varid, land1dlat) + + landunits(:) = huge(1) + data_offset = huge(1) + ii = 1 + ndata = 0 + do cc = 1, dimlen + if (land1dlon(cc) == closelon.and.land1dlat(cc) == closelat) then + landunits(ii)=cc + ndata =ii + ii=ii+1 + end if + end do + if (ndata == 0) then + write(iulog,*)'couldnt find any landunits for this latitude ',closelat,' and longitude ',closelon + call shr_sys_abort('ERROR:: no landunits for this position'//errMsg(sourcefile, __LINE__)) + else + data_offset=landunits(1) + end if + + deallocate (land1dlon) + deallocate (land1dlat) + deallocate (landunits) + + start(i) = data_offset + count(i) = ndata + else + start(i)=1 + count(i)=dimlen + end if + enddo + deallocate(dids) + + end subroutine scam_field_offsets + + !------------------------------------------------------------------------ + + subroutine ncd_getiodesc(ncid, clmlevel, ndims, dims, dimids, & + xtype, iodnum, switchdim) + ! + ! !DESCRIPTION: + ! Returns an index to an io descriptor + ! + ! !ARGUMENTS: + class(file_desc_t) , intent(inout) :: ncid ! PIO file descriptor + character(len=8) , intent(in) :: clmlevel ! clmlevel + integer , intent(in) :: ndims ! ndims for var + integer , intent(in) :: dims(:) ! dim sizes + integer , intent(in) :: dimids(:) ! dim ids + integer , intent(in) :: xtype ! file external type + integer , intent(out) :: iodnum ! iodesc num in list + logical,optional , intent(in) :: switchdim ! switch level dimension and first dim + ! + ! !LOCAL VARIABLES: + integer :: k,m,n,cnt ! indices + integer :: basetype ! pio basetype + integer :: gsmap_lsize ! local size of gsmap + integer :: gsmap_gsize ! global size of gsmap + integer :: fullsize ! size of entire array on cdf + integer :: gsize ! global size of clmlevel + integer :: vsize ! other dimensions + integer :: vsize1, vsize2 ! other dimensions + integer :: status ! error status + logical :: found ! true => found created iodescriptor + integer :: ndims_file ! temporary + character(len=64) dimname_file ! dimension name on file + character(len=64) dimname_iodesc ! dimension name from io descriptor + type(mct_gsMap),pointer :: gsmap ! global seg map + integer, pointer,dimension(:) :: gsmOP ! gsmap ordered points + integer(pio_offset_kind), pointer :: compDOF(:) + character(len=32) :: subname = 'ncd_getiodesc' + !------------------------------------------------------------------------ + + ! Determining if need to create a new io descriptor + n = 1 + found = .false. + do while (n <= num_iodesc .and. .not.found) + if (ndims == iodesc_list(n)%ndims .and. xtype == iodesc_list(n)%type) then + found = .true. + ! First found implies that dimension sizes are the same + do m = 1,ndims + if (dims(m) /= iodesc_list(n)%dims(m)) then + found = .false. + endif + enddo + ! If found - then also check that dimension names are equal - + ! dimension ids in iodescriptor are only used to query dimension + ! names associated with that iodescriptor + if (found) then + status = PIO_inquire(ncid, ndimensions=ndims_file) + do m = 1,ndims + status = PIO_inq_dimname(ncid,dimids(m),dimname_file) + if (iodesc_list(n)%dimids(m) > ndims_file) then + found = .false. + exit + else + status = PIO_inq_dimname(ncid,iodesc_list(n)%dimids(m),dimname_iodesc) + if (trim(dimname_file) /= trim(dimname_iodesc)) then + found = .false. + exit + end if + end if + end do + end if + if (found) then + iodnum = n + if (iodnum > num_iodesc) then + write(iulog,*) trim(subname),' ERROR: iodnum out of range ',iodnum,num_iodesc + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + endif + RETURN + endif + endif + n = n + 1 + enddo + + ! Creating a new io descriptor + + if (ndims > 0) then + num_iodesc = num_iodesc + 1 + if (num_iodesc > max_iodesc) then + write(iulog,*) trim(subname),' ERROR num_iodesc gt max_iodesc ',max_iodesc + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + endif + iodnum = num_iodesc + if (masterproc .and. debug > 1) then + write(iulog,*) trim(subname),' creating iodesc at iodnum,ndims,dims(1:ndims),xtype',& + iodnum,ndims,dims(1:ndims),xtype + endif + end if + + if (xtype == pio_double ) then + basetype = PIO_DOUBLE + else if (xtype == pio_real) then + basetype = PIO_DOUBLE + else if (xtype == pio_int) then + basetype = PIO_INT + else + write(iulog,*) trim(subname),'ERROR: no match for xtype = ',xtype + call shr_sys_abort(errMsg(sourcefile,__LINE__)) + end if + + call get_clmlevel_gsmap(clmlevel,gsmap) + gsize = get_clmlevel_gsize(clmlevel) + gsmap_lsize = mct_gsmap_lsize(gsmap,mpicom) + gsmap_gsize = mct_gsmap_gsize(gsmap) + + call mct_gsMap_orderedPoints(gsmap,iam,gsmOP) + + fullsize = 1 + do n = 1,ndims + fullsize = fullsize*dims(n) + enddo + + vsize = fullsize / gsize + if (mod(fullsize,gsize) /= 0) then + write(iulog,*) subname,' ERROR in vsize ',fullsize,gsize,vsize + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + endif + + allocate(compDOF(gsmap_lsize*vsize)) + + if (present(switchdim)) then + if (switchdim) then + cnt = 0 + do m = 1,gsmap_lsize + do n = 1,vsize + cnt = cnt + 1 + compDOF(cnt) = (gsmOP(m)-1)*vsize + n + enddo + enddo + else + write(iulog,*) subname,' ERROR switch dims present must have switchdim true' + call shr_sys_abort(errMsg(sourcefile, __LINE__)) + end if + else ! currently allow for up to two vertical dimensions + if (vsize /= 1 .and. vsize /= dims(ndims)) then + vsize1 = vsize/dims(ndims) + vsize2 = dims(ndims) + if (vsize1*vsize2 /= vsize) then + write(iulog,*)'vsize1= ',vsize1,' vsize2= ',vsize2,' vsize= ',vsize + call shr_sys_abort('error in vsize1 and vsize2 computation'//errMsg(sourcefile, __LINE__)) + end if + cnt = 0 + do k = 1,vsize2 + do n = 1,vsize1 + do m = 1,gsmap_lsize + cnt = cnt + 1 + compDOF(cnt) = (k-1)*vsize1*gsmap_gsize + (n-1)*gsmap_gsize + gsmOP(m) + enddo + enddo + end do + else + cnt = 0 + do n = 1,vsize + do m = 1,gsmap_lsize + cnt = cnt + 1 + compDOF(cnt) = (n-1)*gsmap_gsize + gsmOP(m) + enddo + enddo + end if + end if + + if (debug > 1) then + do m = 0,npes-1 + if (iam == m) then + write(iulog,*) trim(subname),' sizes1 = ',iam,gsize,gsmap_gsize,gsmap_lsize + write(iulog,*) trim(subname),' sizes2 = ',iam,fullsize,npes,vsize + write(iulog,*) trim(subname),' compDOF = ',iam,size(compDOF),minval(compDOF),maxval(compDOF) + call shr_sys_flush(iulog) + endif + call mpi_barrier(mpicom,status) + enddo + endif + + deallocate(gsmOP) + + call pio_initdecomp(pio_subsystem, xTYPE, dims(1:ndims), compDOF, iodesc_list(iodnum)%iodesc) + + deallocate(compDOF) + iodesc_list(iodnum)%type = xtype + iodesc_list(iodnum)%ndims = ndims + iodesc_list(iodnum)%dims = 0 + iodesc_list(iodnum)%dims(1:ndims) = dims(1:ndims) + iodesc_list(iodnum)%dimids(1:ndims) = dimids(1:ndims) + + end subroutine ncd_getiodesc + +end module ncdio_pio diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/paramUtilMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/paramUtilMod.F90 new file mode 100644 index 000000000..ac6845fc0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/paramUtilMod.F90 @@ -0,0 +1,291 @@ +module paramUtilMod + ! + ! module that deals with reading parameter files + ! + use shr_kind_mod , only: r8 => shr_kind_r8 + 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_orig_files/perf_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/perf_mod.F90 new file mode 100644 index 000000000..8f7e531ca --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/perf_mod.F90 @@ -0,0 +1,1767 @@ +module perf_mod + +!----------------------------------------------------------------------- +! +! Purpose: This module is responsible for controlling the performance +! timer logic. +! +! Author: P. Worley, January 2007 +! +! $Id$ +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!- Uses ---------------------------------------------------------------- +!----------------------------------------------------------------------- +#ifdef NUOPC_INTERFACE +#define TIMERSTART call ESMF_TraceRegionEnter +#define TIMERSTOP call ESMF_TraceRegionExit + use ESMF, only: ESMF_TraceRegionEnter, ESMF_TraceRegionExit +#else +#define TIMERSTART ierr = GPTLstart +#define TIMERSTOP ierr = GPTLstop +#endif + +#ifndef USE_CSM_SHARE + use perf_utils +#else + 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 + use shr_mpi_mod, only: shr_mpi_barrier, shr_mpi_bcast + use shr_file_mod, only: shr_file_getUnit, shr_file_freeUnit + use namelist_utils, only: find_group_name +#endif + use mpi +#if ( defined _OPENMP ) + use omp_lib, only : omp_in_parallel +#endif +!!----------------------------------------------------------------------- +!- module boilerplate -------------------------------------------------- +!----------------------------------------------------------------------- + implicit none + private ! Make the default access private + save + +!----------------------------------------------------------------------- +! Public interfaces ---------------------------------------------------- +!----------------------------------------------------------------------- + public t_initf + public t_setLogUnit + public t_getLogUnit + public t_profile_onf + public t_barrier_onf + public t_single_filef + public t_set_prefixf + public t_unset_prefixf + public t_stampf + public t_startf + public t_stopf + public t_startstop_valsf + public t_enablef + public t_disablef + public t_adj_detailf + public t_barrierf + public t_prf + public t_finalizef + +!----------------------------------------------------------------------- +! Private interfaces (local) ------------------------------------------- +!----------------------------------------------------------------------- + private perf_defaultopts + private perf_setopts + private papi_defaultopts + private papi_setopts + +!----------------------------------------------------------------------- +!- include statements -------------------------------------------------- +!----------------------------------------------------------------------- +#include "gptl.inc" + +!----------------------------------------------------------------------- +! Private data --------------------------------------------------------- +!----------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! perf_mod options + !---------------------------------------------------------------------------- + integer, parameter :: def_p_logunit = 6 ! default + integer, private :: p_logunit = def_p_logunit + ! unit number for log output + + logical, parameter :: def_timing_initialized = .false. ! default + logical, private :: timing_initialized = def_timing_initialized + ! flag indicating whether timing library has + ! been initialized + + logical, parameter :: def_timing_disable = .false. ! default + logical, private :: timing_disable = def_timing_disable + ! flag indicating whether timers are disabled + + logical, parameter :: def_timing_barrier = .false. ! default + logical, private :: timing_barrier = def_timing_barrier + ! flag indicating whether the mpi_barrier in + ! t_barrierf should be called + + integer, parameter :: def_timer_depth_limit = 99999 ! default + integer, private :: timer_depth_limit = def_timer_depth_limit + ! integer indicating maximum number of levels of + ! timer nesting + + integer, parameter :: def_timing_detail_limit = 1 ! default + integer, private :: timing_detail_limit = def_timing_detail_limit + ! integer indicating maximum detail level to + ! profile + + integer, parameter :: init_timing_disable_depth = 0 ! init + integer, private :: timing_disable_depth = init_timing_disable_depth + ! integer indicating depth of t_disablef calls + + integer, parameter :: init_timing_detail = 0 ! init + integer, private :: cur_timing_detail = init_timing_detail + ! current timing detail level +#ifdef NUOPC_INTERFACE + integer, private :: cur_timing_depth = 0 +#endif + + integer, parameter :: init_num_threads = 1 ! init + integer, private :: num_threads = init_num_threads + ! current maximum number of threads per process + + logical, parameter :: def_perf_single_file = .false. ! default + logical, private :: perf_single_file = def_perf_single_file + ! flag indicating whether the performance timer + ! output should be written to a single file + ! (per component communicator) or to a + ! separate file for each process + + integer, parameter :: def_perf_outpe_num = 0 ! default + integer, private :: perf_outpe_num = def_perf_outpe_num + ! maximum number of processes writing out + ! timing data (for this component communicator) + + integer, parameter :: def_perf_outpe_stride = 1 ! default + integer, private :: perf_outpe_stride = def_perf_outpe_stride + ! separation between process ids for processes + ! that are writing out timing data + ! (for this component communicator) + + logical, parameter :: def_perf_global_stats = .true. ! default + logical, private :: perf_global_stats = def_perf_global_stats + ! collect and print out global performance statistics + ! (for this component communicator) + + logical, parameter :: def_perf_ovhd_measurement = .false. ! default + logical, private :: perf_ovhd_measurement = def_perf_ovhd_measurement + ! measure overhead of profiling directly + + real(shr_kind_r8), private :: perf_timing_ovhd = 0.0 ! start/stop overhead + + logical, parameter :: def_perf_add_detail = .false. ! default + logical, private :: perf_add_detail = def_perf_add_detail + ! flag indicating whether to add the current + ! detail level as a suffix to the timer name. + ! This requires that even t_startf/t_stopf + ! calls do not cross detail level changes +#ifdef HAVE_MPI + integer, parameter :: def_perf_timer = GPTLmpiwtime ! default +#else +#ifdef HAVE_NANOTIME + integer, parameter :: def_perf_timer = GPTLnanotime ! default +#else +#ifdef CPRIBM + integer,parameter :: def_perf_timer = GPTLread_real_time +#else + integer,parameter :: def_perf_timer = GPTLgettimeofday +#endif +#endif +#endif + + + integer, private :: perf_timer = def_perf_timer ! default + ! integer indicating which timer to use + ! (as defined in gptl.inc) + +#ifdef HAVE_PAPI + logical, parameter :: def_perf_papi_enable = .false. ! default +#else + logical, parameter :: def_perf_papi_enable = .false. ! default +#endif + logical, private :: perf_papi_enable = def_perf_papi_enable + ! flag indicating whether the PAPI namelist + ! should be read and HW performance counters + ! used in profiling + + ! PAPI counter ids + integer, parameter :: PAPI_NULL = -1 + + integer, parameter :: def_papi_ctr1 = PAPI_NULL ! default + integer, private :: papi_ctr1 = def_papi_ctr1 + + integer, parameter :: def_papi_ctr2 = PAPI_NULL ! default + integer, private :: papi_ctr2 = def_papi_ctr2 + + integer, parameter :: def_papi_ctr3 = PAPI_NULL ! default + integer, private :: papi_ctr3 = def_papi_ctr3 + + integer, parameter :: def_papi_ctr4 = PAPI_NULL ! default + integer, private :: papi_ctr4 = def_papi_ctr4 + +!======================================================================= +contains +!======================================================================= + +! +!======================================================================== +! + subroutine t_getLogUnit(LogUnit) +!----------------------------------------------------------------------- +! Purpose: Get log unit number. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + integer(SHR_KIND_IN), intent(OUT) :: LogUnit ! Unit number for log output +!----------------------------------------------------------------------- + + LogUnit = p_logunit + + return + end subroutine t_getLogUnit +! +!======================================================================== +! + subroutine t_setLogUnit(LogUnit) +!----------------------------------------------------------------------- +! Purpose: Set log unit number. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + integer(SHR_KIND_IN), intent(IN) :: LogUnit ! Unit number for log output +!----------------------------------------------------------------------- + + p_logunit = LogUnit +#ifndef USE_CSM_SHARE + call perfutils_setunit(p_logunit) +#endif + + return + end subroutine t_setLogUnit +! +!======================================================================== +! + subroutine perf_defaultopts(timing_disable_out, & + perf_timer_out, & + timer_depth_limit_out, & + timing_detail_limit_out, & + timing_barrier_out, & + perf_outpe_num_out, & + perf_outpe_stride_out, & + perf_single_file_out, & + perf_global_stats_out, & + perf_papi_enable_out, & + perf_ovhd_measurement_out, & + perf_add_detail_out ) +!----------------------------------------------------------------------- +! Purpose: Return default runtime options +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- + ! timers disable/enable option + logical, intent(out), optional :: timing_disable_out + ! performance timer option + integer, intent(out), optional :: perf_timer_out + ! timer depth limit option + integer, intent(out), optional :: timer_depth_limit_out + ! timer detail limit option + integer, intent(out), optional :: timing_detail_limit_out + ! timing barrier enable/disable option + logical, intent(out), optional :: timing_barrier_out + ! number of processes writing out timing data + integer, intent(out), optional :: perf_outpe_num_out + ! separation between process ids for processes that are writing out timing data + integer, intent(out), optional :: perf_outpe_stride_out + ! timing single / multple output file option + logical, intent(out), optional :: perf_single_file_out + ! collect and output global performance statistics option + logical, intent(out), optional :: perf_global_stats_out + ! calling PAPI to read HW performance counters option + logical, intent(out), optional :: perf_papi_enable_out + ! measure overhead of profiling directly + logical, intent(out), optional :: perf_ovhd_measurement_out + ! 'suffix' timer name with current detail level + logical, intent(out), optional :: perf_add_detail_out +!----------------------------------------------------------------------- + if ( present(timing_disable_out) ) then + timing_disable_out = def_timing_disable + endif + if ( present(perf_timer_out) ) then + perf_timer_out = def_perf_timer + endif + if ( present(timer_depth_limit_out) ) then + timer_depth_limit_out = def_timer_depth_limit + endif + if ( present(timing_detail_limit_out) ) then + timing_detail_limit_out = def_timing_detail_limit + endif + if ( present(timing_barrier_out) ) then + timing_barrier_out = def_timing_barrier + endif + if ( present(perf_outpe_num_out) ) then + perf_outpe_num_out = def_perf_outpe_num + endif + if ( present(perf_outpe_stride_out) ) then + perf_outpe_stride_out = def_perf_outpe_stride + endif + if ( present(perf_single_file_out) ) then + perf_single_file_out = def_perf_single_file + endif + if ( present(perf_global_stats_out) ) then + perf_global_stats_out = def_perf_global_stats + endif + if ( present(perf_papi_enable_out) ) then + perf_papi_enable_out = def_perf_papi_enable + endif + if ( present(perf_ovhd_measurement_out) ) then + perf_ovhd_measurement_out = def_perf_ovhd_measurement + endif + if ( present(perf_add_detail_out) ) then + perf_add_detail_out = def_perf_add_detail + endif +! + return + end subroutine perf_defaultopts +! +!======================================================================== +! + subroutine perf_setopts(mastertask, & + LogPrint, & + timing_disable_in, & + perf_timer_in, & + timer_depth_limit_in, & + timing_detail_limit_in, & + timing_barrier_in, & + perf_outpe_num_in, & + perf_outpe_stride_in, & + perf_single_file_in, & + perf_global_stats_in, & + perf_papi_enable_in, & + perf_ovhd_measurement_in, & + perf_add_detail_in ) +!----------------------------------------------------------------------- +! Purpose: Set runtime options +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments---------------------------- +! + ! master process? + logical, intent(in) :: mastertask + ! Print out to log file? + logical, intent(IN) :: LogPrint + ! timers disable/enable option + logical, intent(in), optional :: timing_disable_in + ! performance timer option + integer, intent(in), optional :: perf_timer_in + ! timer depth limit option + integer, intent(in), optional :: timer_depth_limit_in + ! timer detail limit option + integer, intent(in), optional :: timing_detail_limit_in + ! timing barrier enable/disable option + logical, intent(in), optional :: timing_barrier_in + ! number of processes writing out timing data + integer, intent(in), optional :: perf_outpe_num_in + ! separation between process ids for processes that are writing out timing data + integer, intent(in), optional :: perf_outpe_stride_in + ! timing single / multple output file option + logical, intent(in), optional :: perf_single_file_in + ! collect and output global performance statistics option + logical, intent(in), optional :: perf_global_stats_in + ! calling PAPI to read HW performance counters option + logical, intent(in), optional :: perf_papi_enable_in + ! measure overhead of profiling directly + logical, intent(in), optional :: perf_ovhd_measurement_in + ! 'suffix' timer name with current detail level + logical, intent(in), optional :: perf_add_detail_in +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! error return +!----------------------------------------------------------------------- + if ( .not. timing_initialized ) then + + if ( present(timing_disable_in) ) then + timing_disable = timing_disable_in + if (timing_disable) then + ierr = GPTLdisable() + else + ierr = GPTLenable() + endif + endif + if ( present(perf_timer_in) ) then + if ((perf_timer_in .eq. GPTLgettimeofday) .or. & + (perf_timer_in .eq. GPTLnanotime) .or. & + (perf_timer_in .eq. GPTLread_real_time) .or. & + (perf_timer_in .eq. GPTLmpiwtime) .or. & + (perf_timer_in .eq. GPTLclockgettime) .or. & + (perf_timer_in .eq. GPTLpapitime)) then + perf_timer = perf_timer_in + else + if (mastertask) then + write(p_logunit,*) 'PERF_SETOPTS: illegal timer requested=',& + perf_timer_in, '. Request ignored.' + endif + endif + endif + if ( present(timer_depth_limit_in) ) then + timer_depth_limit = timer_depth_limit_in + endif + if ( present(timing_detail_limit_in) ) then + timing_detail_limit = timing_detail_limit_in + endif + if ( present(timing_barrier_in) ) then + timing_barrier = timing_barrier_in + endif + if ( present(perf_outpe_num_in) ) then + perf_outpe_num = perf_outpe_num_in + endif + if ( present(perf_outpe_stride_in) ) then + perf_outpe_stride = perf_outpe_stride_in + endif + if ( present(perf_single_file_in) ) then + perf_single_file = perf_single_file_in + endif + if ( present(perf_global_stats_in) ) then + perf_global_stats = perf_global_stats_in + endif + if ( present(perf_papi_enable_in) ) then +#ifdef HAVE_PAPI + perf_papi_enable = perf_papi_enable_in +#else + if (perf_papi_enable_in) then + if (mastertask) then + write(p_logunit,*) 'PERF_SETOPTS: PAPI library not linked in. ',& + 'Request to enable PAPI ignored.' + endif + endif + perf_papi_enable = .false. +#endif + endif + if ( present(perf_ovhd_measurement_in) ) then + perf_ovhd_measurement = perf_ovhd_measurement_in + endif + if ( present(perf_add_detail_in) ) then + perf_add_detail = perf_add_detail_in + endif +! + if (mastertask .and. LogPrint) then + write(p_logunit,*) '(t_initf) Using profile_disable= ', timing_disable + write(p_logunit,*) '(t_initf) profile_timer= ', perf_timer + write(p_logunit,*) '(t_initf) profile_depth_limit= ', timer_depth_limit + write(p_logunit,*) '(t_initf) profile_detail_limit= ', timing_detail_limit + write(p_logunit,*) '(t_initf) profile_barrier= ', timing_barrier + write(p_logunit,*) '(t_initf) profile_outpe_num= ', perf_outpe_num + write(p_logunit,*) '(t_initf) profile_outpe_stride= ', perf_outpe_stride + write(p_logunit,*) '(t_initf) profile_single_file= ', perf_single_file + write(p_logunit,*) '(t_initf) profile_global_stats= ', perf_global_stats + write(p_logunit,*) '(t_initf) profile_ovhd_measurement=', perf_ovhd_measurement + write(p_logunit,*) '(t_initf) profile_add_detail= ', perf_add_detail + write(p_logunit,*) '(t_initf) profile_papi_enable= ', perf_papi_enable + endif +! +#ifdef DEBUG + else + write(p_logunit,*) 'PERF_SETOPTS: timing library already initialized. Request ignored.' +#endif + endif +! + return + end subroutine perf_setopts + +! +!======================================================================== +! + subroutine papi_defaultopts(papi_ctr1_out, & + papi_ctr2_out, & + papi_ctr3_out, & + papi_ctr4_out ) +!----------------------------------------------------------------------- +! Purpose: Return default runtime PAPI counter options +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- + ! PAPI counter option #1 + integer, intent(out), optional :: papi_ctr1_out + ! PAPI counter option #2 + integer, intent(out), optional :: papi_ctr2_out + ! PAPI counter option #3 + integer, intent(out), optional :: papi_ctr3_out + ! PAPI counter option #4 + integer, intent(out), optional :: papi_ctr4_out +!----------------------------------------------------------------------- + if ( present(papi_ctr1_out) ) then + papi_ctr1_out = def_papi_ctr1 + endif + if ( present(papi_ctr2_out) ) then + papi_ctr2_out = def_papi_ctr2 + endif + if ( present(papi_ctr3_out) ) then + papi_ctr3_out = def_papi_ctr3 + endif + if ( present(papi_ctr4_out) ) then + papi_ctr4_out = def_papi_ctr4 + endif +! + return + end subroutine papi_defaultopts +! +!======================================================================== +! + subroutine papi_setopts(papi_ctr1_in, & + papi_ctr2_in, & + papi_ctr3_in, & + papi_ctr4_in ) +!----------------------------------------------------------------------- +! Purpose: Set runtime PAPI counter options +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments---------------------------- +! + ! performance counter option + integer, intent(in), optional :: papi_ctr1_in + ! performance counter option + integer, intent(in), optional :: papi_ctr2_in + ! performance counter option + integer, intent(in), optional :: papi_ctr3_in + ! performance counter option + integer, intent(in), optional :: papi_ctr4_in +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! error return +!----------------------------------------------------------------------- + if ( .not. timing_initialized ) then + + if ( present(papi_ctr1_in) ) then + papi_ctr1 = papi_ctr1_in + endif + if ( present(papi_ctr2_in) ) then + papi_ctr2 = papi_ctr2_in + endif + if ( present(papi_ctr3_in) ) then + papi_ctr3 = papi_ctr3_in + endif + if ( present(papi_ctr4_in) ) then + papi_ctr4 = papi_ctr4_in + endif +! +#ifdef DEBUG + else + write(p_logunit,*) 'PAPI_SETOPTS: timing library already initialized. Request ignored.' +#endif + endif +! + return + end subroutine papi_setopts +! +!======================================================================== +! + logical function t_profile_onf() +!----------------------------------------------------------------------- +! Purpose: Return flag indicating whether profiling is currently active. +! Part of workaround to implement FVbarrierclock before +! communicators exposed in Pilgrim. Does not check level of +! event nesting. +! Author: P. Worley +!----------------------------------------------------------------------- + + if ((.not. timing_initialized) .or. & + (timing_disable_depth > 0)) then + t_profile_onf = .false. + else + t_profile_onf = .true. + endif + + end function t_profile_onf +! +!======================================================================== +! + logical function t_barrier_onf() +!----------------------------------------------------------------------- +! Purpose: Return timing_barrier. Part of workaround to implement +! FVbarrierclock before communicators exposed in Pilgrim. +! Author: P. Worley +!----------------------------------------------------------------------- + + t_barrier_onf = timing_barrier + + end function t_barrier_onf +! +!======================================================================== +! + logical function t_single_filef() +!----------------------------------------------------------------------- +! Purpose: Return perf_single_file. Used to control output of other +! performance data, only spmdstats currently. +! Author: P. Worley +!----------------------------------------------------------------------- + + t_single_filef = perf_single_file + + end function t_single_filef +! +!======================================================================== +! + subroutine t_set_prefixf(prefix_string) +!----------------------------------------------------------------------- +! Purpose: Set prefix for subsequent time event names. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer event name prefix + character(len=*), intent(in) :: prefix_string +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return + integer i ! loop index +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + + ierr = GPTLprefix_set(trim(prefix_string)) + + end subroutine t_set_prefixf +! +!======================================================================== +! + subroutine t_unset_prefixf() +!----------------------------------------------------------------------- +! Purpose: Unset prefix for subsequent time event names. +! Ignored in threaded regions. +! Author: P. Worley +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + + ierr = GPTLprefix_unset() + + end subroutine t_unset_prefixf +! +!======================================================================== +! + subroutine t_stampf(wall, usr, sys) +!----------------------------------------------------------------------- +! Purpose: Record wallclock, user, and system times (seconds). +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Output arguments----------------------------- +! + real(shr_kind_r8), intent(out) :: wall ! wallclock time + real(shr_kind_r8), intent(out) :: usr ! user time + real(shr_kind_r8), intent(out) :: sys ! system time +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!----------------------------------------------------------------------- +! + if ((.not. timing_initialized) .or. & + (timing_disable_depth > 0)) then + wall = 0.0 + usr = 0.0 + sys = 0.0 + else + ierr = GPTLstamp(wall, usr, sys) + endif + + return + end subroutine t_stampf +! +!======================================================================== +! + 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 suffix + character(len=2) cdetail ! char variable for detail + real(shr_kind_r8) ovhd_start, ovhd_stop, usr, sys + ! for overhead calculation +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + if (timing_disable_depth > 0) return +#ifdef NUOPC_INTERFACE +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + cur_timing_depth = cur_timing_depth + 1 + if(cur_timing_depth > timer_depth_limit) return +#ifdef DEBUG +! print *, 'start timer ',trim(event), cur_timing_depth, timer_depth_limit +#endif +#endif + +!$OMP MASTER + if (perf_ovhd_measurement) then +#ifdef HAVE_MPI + ovhd_start = mpi_wtime() +#else + usr = 0.0 + sys = 0.0 + ierr = GPTLstamp(ovhd_start, usr, sys) +#endif + perf_timing_ovhd = perf_timing_ovhd - ovhd_start + endif +#ifndef NUOPC_INTERFACE +!$OMP END MASTER +#endif + if ((perf_add_detail) .AND. (cur_timing_detail < 100)) then + write(cdetail,'(i2.2)') cur_timing_detail + str_length = min(SHR_KIND_CM-3,len_trim(event)) + TIMERSTART(event(1:str_length)//'_'//cdetail) + else + str_length = min(SHR_KIND_CM,len_trim(event)) + TIMERSTART(event(1:str_length)) + endif +#ifndef NUOPC_INTERFACE +!$OMP MASTER +#endif + if (perf_ovhd_measurement) then +#ifdef HAVE_MPI + ovhd_stop = mpi_wtime() +#else + ierr = GPTLstamp(ovhd_stop, usr, sys) +#endif + perf_timing_ovhd = perf_timing_ovhd + ovhd_stop + endif +!$OMP END MASTER + 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 suffix + character(len=2) cdetail ! char variable for detail + real(shr_kind_r8) ovhd_start, ovhd_stop, usr, sys + ! for overhead calculation +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + if (timing_disable_depth > 0) return +#ifdef NUOPC_INTERFACE +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif +#endif +!$OMP MASTER + if (perf_ovhd_measurement) then +#ifdef HAVE_MPI + ovhd_start = mpi_wtime() +#else + usr = 0.0 + sys = 0.0 + ierr = GPTLstamp(ovhd_start, usr, sys) +#endif + perf_timing_ovhd = perf_timing_ovhd - ovhd_start + endif +#ifdef NUOPC_INTERFACE + cur_timing_depth = cur_timing_depth - 1 + if(cur_timing_depth >= timer_depth_limit) return +#else +!$OMP END MASTER +#endif + if ((perf_add_detail) .AND. (cur_timing_detail < 100)) then + write(cdetail,'(i2.2)') cur_timing_detail + str_length = min(SHR_KIND_CM-3,len_trim(event)) + TIMERSTOP(event(1:str_length)//'_'//cdetail) + else + str_length = min(SHR_KIND_CM,len_trim(event)) + TIMERSTOP(event(1:str_length)) + endif +#ifndef NUOPC_INTERFACE +!$OMP MASTER +#endif + if (perf_ovhd_measurement) then +#ifdef HAVE_MPI + ovhd_stop = mpi_wtime() +#else + ierr = GPTLstamp(ovhd_stop, usr, sys) +#endif + perf_timing_ovhd = perf_timing_ovhd + ovhd_stop + endif +!$OMP END MASTER + return + end subroutine t_stopf +! +!======================================================================== +! + subroutine t_startstop_valsf(event, walltime, callcount, handle) +!----------------------------------------------------------------------- +! Purpose: Create/add walltime and call count to an event timer +! Author: P. Worley (based on J. Rosinski GPTL routine) +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer event name + character(len=*), intent(in) :: event + ! walltime (seconds) associated with this start/stop pair + ! If not set, default is 0.0 . If < 0.0, set to 0.0 . + real(shr_kind_r8), intent(in), optional :: walltime + ! call count associated with this start/stop pair + ! If not set, default is 1. If < 0, set to 0. + integer, intent(in), optional :: callcount +! +!---------------------------Input/Output arguments---------------------- +! + ! GPTL event handle + integer, optional :: handle +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return + + integer str_length, i ! support for adding + ! detail suffix + character(len=2) cdetail ! char variable for detail + integer callcnt ! call count increment + real(shr_kind_r8) wtime ! walltime increment (seconds) + real(shr_kind_r8) ovhd_start, ovhd_stop, usr, sys + ! for overhead calculation +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + if (timing_disable_depth > 0) return + +!$OMP MASTER + if (perf_ovhd_measurement) then +#ifdef HAVE_MPI + ovhd_start = mpi_wtime() +#else + usr = 0.0 + sys = 0.0 + ierr = GPTLstamp(ovhd_start, usr, sys) +#endif + perf_timing_ovhd = perf_timing_ovhd - ovhd_start + endif +!$OMP END MASTER + + wtime = 0.0_shr_kind_r8 + if ( present(walltime) ) then + if (walltime > 0.0) then + wtime = walltime + endif + endif + + callcnt = 1 + if ( present(callcount) ) then + if (callcount > 0) then + callcnt = callcount + else + callcnt = 0 + endif + endif + + if ((perf_add_detail) .AND. (cur_timing_detail < 100)) then + + write(cdetail,'(i2.2)') cur_timing_detail + str_length = min(SHR_KIND_CM-3,len_trim(event)) + ierr = GPTLstartstop_vals( & + event(1:str_length)//'_'//cdetail, wtime, callcnt) + + else + + str_length = min(SHR_KIND_CM,len_trim(event)) + ierr = GPTLstartstop_vals(trim(event), wtime, callcnt) + + endif + +!$OMP MASTER + if (perf_ovhd_measurement) then +#ifdef HAVE_MPI + ovhd_stop = mpi_wtime() +#else + ierr = GPTLstamp(ovhd_stop, usr, sys) +#endif + perf_timing_ovhd = perf_timing_ovhd + ovhd_stop + endif +!$OMP END MASTER + return + end subroutine t_startstop_valsf +! +!======================================================================== +! + subroutine t_enablef() +!----------------------------------------------------------------------- +! Purpose: Enable t_startf, t_stopf, t_stampf, and t_barrierf. Ignored +! in threaded regions. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!---------------------------Externals----------------------------------- +! + +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + + if (timing_disable_depth > 0) then + if (timing_disable_depth .eq. 1) then + ierr = GPTLenable() + endif + timing_disable_depth = timing_disable_depth - 1 + endif + + return + end subroutine t_enablef +! +!======================================================================== +! + subroutine t_disablef() +!----------------------------------------------------------------------- +! Purpose: Disable t_startf, t_stopf, t_stampf, and t_barrierf. Ignored +! in threaded regions. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + + if (timing_disable_depth .eq. 0) then + ierr = GPTLdisable() + endif + timing_disable_depth = timing_disable_depth + 1 + + return + end subroutine t_disablef +! +!======================================================================== +! + subroutine t_adj_detailf(detail_adjustment) +!----------------------------------------------------------------------- +! Purpose: Modify current detail level. Ignored in threaded regions. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + integer, intent(in) :: detail_adjustment ! user defined increase or + ! decrease in detail level +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + +! using disable/enable to implement timing_detail logic so also control +! direct GPTL calls (such as occur in Trilinos library) + if ((cur_timing_detail <= timing_detail_limit) .and. & + (cur_timing_detail + detail_adjustment > timing_detail_limit)) then + call t_disablef() + elseif ((cur_timing_detail > timing_detail_limit) .and. & + (cur_timing_detail + detail_adjustment <= timing_detail_limit)) then + call t_enablef() + endif + + cur_timing_detail = cur_timing_detail + detail_adjustment + + return + end subroutine t_adj_detailf +! +!======================================================================== +! + subroutine t_barrierf(event, mpicom) +!----------------------------------------------------------------------- +! Purpose: Call (and time) mpi_barrier. Ignored inside OpenMP +! threaded regions. Note that barrier executed even if +! event not recorded because of level of timer event nesting. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- + ! mpi communicator id + integer, intent(in), optional :: mpicom + ! performance timer event name + character(len=*), intent(in), optional :: event +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! + if (timing_barrier) then + +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + if (.not. timing_initialized) return + if (timing_disable_depth > 0) return + + if ( present (event) ) then + call t_startf(event) + endif + + if ( present (mpicom) ) then + call shr_mpi_barrier(mpicom, 'T_BARRIERF: bad mpi communicator') + else + call shr_mpi_barrier(MPI_COMM_WORLD, 'T_BARRIERF: bad mpi communicator') + endif + + if ( present (event) ) then + call t_stopf(event) + endif + + endif + + return + end subroutine t_barrierf +! +!======================================================================== +! + subroutine t_prf(filename, mpicom, num_outpe, stride_outpe, & + single_file, global_stats, output_thispe) +!----------------------------------------------------------------------- +! Purpose: Write out performance timer data +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer output file name + character(len=*), intent(in), optional :: filename + ! mpi communicator id + integer, intent(in), optional :: mpicom + ! maximum number of processes writing out timing data + integer, intent(in), optional :: num_outpe + ! separation between process ids for processes writing out data + integer, intent(in), optional :: stride_outpe + ! enable/disable the writing of data to a single file + logical, intent(in), optional :: single_file + ! enable/disable the collection of global statistics + logical, intent(in), optional :: global_stats + ! output timing data for this process + logical, intent(in), optional :: output_thispe +! +!---------------------------Local workspace----------------------------- +! + logical one_file ! flag indicting whether to write + ! all data to a single file + logical glb_stats ! flag indicting whether to compute + ! global statistics + logical pr_write ! flag indicating whether the current + ! GPTL output mode is write + logical write_data ! flag indicating whether this process + ! should output its timing data + integer i ! loop index + integer mpicom2 ! local copy of MPI communicator + integer me ! communicator local process id + integer npes ! local communicator group size + integer gme ! global process id + integer ierr ! MPI error return + integer outpe_num ! max number of processes writing out + ! timing data (excluding output_thispe) + integer outpe_stride ! separation between process ids for + ! processes writing out timing data + integer max_outpe ! max process id for processes + ! writing out timing data + integer signal ! send/recv variable for single + ! output file logic + integer str_length ! string length + integer unitn ! file unit number + integer cme_adj ! length of filename suffix + integer status (MPI_STATUS_SIZE) ! Status of message + character(len=7) cme ! string representation of process id + character(len=SHR_KIND_CX+14) fname ! timing output filename +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return +#ifdef NUOPC_INTERFACE + return +#endif + + call t_startf("t_prf") +!$OMP MASTER + call mpi_comm_rank(MPI_COMM_WORLD, gme, ierr) + if ( present(mpicom) ) then + mpicom2 = mpicom + call mpi_comm_size(mpicom2, npes, ierr) + if (ierr .eq. MPI_ERR_COMM) then + call shr_sys_abort('T_PRF: bad mpi communicator') + endif + call mpi_comm_rank(mpicom2, me, ierr) + else + call mpi_comm_size(MPI_COMM_WORLD, npes, ierr) + mpicom2 = MPI_COMM_WORLD + me = gme + endif + + do i=1,SHR_KIND_CX+14 + fname(i:i) = " " + enddo + + unitn = shr_file_getUnit() + + ! determine what the current output mode is (append or write) + if (GPTLprint_mode_query() == GPTLprint_write) then + pr_write = .true. + ierr = GPTLprint_mode_set(GPTLprint_append) + else + pr_write = .false. + endif + + ! Determine whether to write all data to a single fie + if (present(single_file)) then + one_file = single_file + else + one_file = perf_single_file + endif + + ! Determine whether to compute global statistics + if (present(global_stats)) then + glb_stats = global_stats + else + glb_stats = perf_global_stats + endif + + ! Determine which processes are writing out timing data + write_data = .false. + + if (present(num_outpe)) then + if (num_outpe < 0) then + outpe_num = npes + else + outpe_num = num_outpe + endif + else + if (perf_outpe_num < 0) then + outpe_num = npes + else + outpe_num = perf_outpe_num + endif + endif + + if (present(stride_outpe)) then + if (stride_outpe < 1) then + outpe_stride = 1 + else + outpe_stride = stride_outpe + endif + else + if (perf_outpe_stride < 1) then + outpe_stride = 1 + else + outpe_stride = perf_outpe_stride + endif + endif + + max_outpe = min(outpe_num*outpe_stride, npes) - 1 + + if ((mod(me, outpe_stride) .eq. 0) .and. (me .le. max_outpe)) & + write_data = .true. + + if (present(output_thispe)) then + write_data = output_thispe + endif + + ! If a single timing output file, take turns writing to it. + if (one_file) then + + if ( present(filename) ) then + str_length = min(SHR_KIND_CX,len_trim(filename)) + fname(1:str_length) = filename(1:str_length) + else + fname(1:10) = "timing_all" + endif + + signal = 0 + if (me .eq. 0) then + + if (glb_stats) then + open( unitn, file=trim(fname), status='UNKNOWN', access='SEQUENTIAL' ) + write( unitn, 100) npes + 100 format(/,"***** GLOBAL STATISTICS (",I6," MPI TASKS) *****",/) + close( unitn ) + + ierr = GPTLpr_summary_file(mpicom2, trim(fname)) + endif + + if (write_data) then + if (glb_stats) then + open( unitn, file=trim(fname), status='OLD', access='SEQUENTIAL', position='APPEND' ) + else + open( unitn, file=trim(fname), status='UNKNOWN', access='SEQUENTIAL' ) + endif + + if (perf_ovhd_measurement) then + write( unitn, 101) me, gme + 101 format(/,"************ PROCESS ",I6," (",I6,") ************") + write( unitn, 102) perf_timing_ovhd + 102 format("** TIMING OVERHEAD ",E20.10," SECONDS *",/) + else + write( unitn, 103) me, gme + 103 format(/,"************ PROCESS ",I6," (",I6,") ************",/) + endif + + close( unitn ) + + ierr = GPTLpr_file(trim(fname)) + endif + + else + + if (glb_stats) then + ierr = GPTLpr_summary_file(mpicom2, trim(fname)) + endif + + call mpi_recv (signal, 1, mpi_integer, me-1, me-1, mpicom2, status, ierr) + if (ierr /= mpi_success) then + write(p_logunit,*) 'T_PRF: mpi_recv failed ierr=',ierr + call shr_sys_abort() + end if + + if (write_data) then + open( unitn, file=trim(fname), status='OLD', access='SEQUENTIAL', position='APPEND' ) + if (perf_ovhd_measurement) then + write( unitn, 101) me, gme + write( unitn, 102) perf_timing_ovhd + else + write( unitn, 103) me, gme + endif + close( unitn ) + + ierr = GPTLpr_file(trim(fname)) + endif + + endif + + if (me+1 < npes) & + call mpi_send (signal, 1, mpi_integer, me+1, me, mpicom2, ierr) + + else + + if (glb_stats) then + if ( present(filename) ) then + str_length = min(SHR_KIND_CX-6,len_trim(filename)) + fname(1:str_length) = filename(1:str_length) + else + str_length = 6 + fname(1:10) = "timing" + endif + fname(str_length+1:str_length+6) = '_stats' + + if (me .eq. 0) then + open( unitn, file=trim(fname), status='UNKNOWN', access='SEQUENTIAL' ) + write( unitn, 100) npes + close( unitn ) + endif + + ierr = GPTLpr_summary_file(mpicom2, trim(fname)) + fname(str_length+1:str_length+6) = ' ' + endif + + if (write_data) then + if (npes .le. 10) then + write(cme,'(i1.1)') me + cme_adj = 2 + elseif (npes .le. 100) then + write(cme,'(i2.2)') me + cme_adj = 3 + elseif (npes .le. 1000) then + write(cme,'(i3.3)') me + cme_adj = 4 + elseif (npes .le. 10000) then + write(cme,'(i4.4)') me + cme_adj = 5 + elseif (npes .le. 100000) then + write(cme,'(i5.5)') me + cme_adj = 6 + else + write(cme,'(i6.6)') me + cme_adj = 7 + endif + + if ( present(filename) ) then + str_length = min(SHR_KIND_CX-cme_adj,len_trim(filename)) + fname(1:str_length) = filename(1:str_length) + else + str_length = 6 + fname(1:10) = "timing" + endif + fname(str_length+1:str_length+1) = '.' + fname(str_length+2:str_length+cme_adj) = cme + + open( unitn, file=trim(fname), status='UNKNOWN', access='SEQUENTIAL' ) + if (perf_ovhd_measurement) then + write( unitn, 101) me, gme + write( unitn, 102) perf_timing_ovhd + else + write( unitn, 103) me, gme + endif + close( unitn ) + + ierr = GPTLpr_file(trim(fname)) + endif + + endif + + call shr_file_freeUnit( unitn ) + + ! reset GPTL output mode + if (pr_write) then + ierr = GPTLprint_mode_set(GPTLprint_write) + endif + +!$OMP END MASTER + call t_stopf("t_prf") + + return + end subroutine t_prf +! +!======================================================================== +! + subroutine t_initf(NLFilename, LogPrint, LogUnit, mpicom, MasterTask, & + MaxThreads) +!----------------------------------------------------------------------- +! Purpose: Set default values of runtime timing options +! before namelists prof_inparm and papi_inparm are read, +! read namelists (and broadcast, if SPMD), +! then initialize timing library. +! Author: P. Worley (based on shr_inputinfo_mod and runtime_opts) +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + character(len=*), intent(IN) :: NLFilename ! Name-list filename + logical, optional, intent(IN) :: LogPrint ! If print out to log file + integer, optional, intent(IN) :: LogUnit ! Unit number for log output + integer, optional, intent(IN) :: mpicom ! MPI communicator + logical, optional, intent(IN) :: MasterTask ! If MPI master task + integer, optional, intent(IN) :: MaxThreads ! maximum number of threads + ! used by components +! +!---------------------------Local workspace----------------------------- +! + character(len=*), parameter :: subname = '(T_INITF) ' + logical :: MasterTask2 ! If MPI master task + logical :: LogPrint2 ! If print to log + + integer me ! communicator local process id + integer ierr ! error return + integer unitn ! file unit number + integer papi_ctr1_id ! PAPI counter id + integer papi_ctr2_id ! PAPI counter id + integer papi_ctr3_id ! PAPI counter id + integer papi_ctr4_id ! PAPI counter id +! +!---------------------------Namelists ---------------------------------- +! + logical profile_disable + logical profile_barrier + logical profile_single_file + logical profile_global_stats + integer profile_depth_limit + integer profile_detail_limit + integer profile_outpe_num + integer profile_outpe_stride + integer profile_timer + logical profile_papi_enable + logical profile_ovhd_measurement + logical profile_add_detail + namelist /prof_inparm/ profile_disable, profile_barrier, & + profile_single_file, profile_global_stats, & + profile_depth_limit, & + profile_detail_limit, profile_outpe_num, & + profile_outpe_stride, profile_timer, & + profile_papi_enable, profile_ovhd_measurement, & + profile_add_detail + + character(len=16) papi_ctr1_str + character(len=16) papi_ctr2_str + character(len=16) papi_ctr3_str + character(len=16) papi_ctr4_str + namelist /papi_inparm/ papi_ctr1_str, papi_ctr2_str, & + papi_ctr3_str, papi_ctr4_str +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + integer omp_get_max_threads + external omp_get_max_threads +#endif +!----------------------------------------------------------------------- + if ( timing_initialized ) then +#ifdef DEBUG + write(p_logunit,*) 'T_INITF: timing library already initialized. Request ignored.' +#endif + return + endif + +!$OMP MASTER + if ( present(MaxThreads) ) then + num_threads = MaxThreads + else +#ifdef _OPENMP +!$omp parallel + num_threads = omp_get_max_threads() +!$omp end parallel +#else + num_threads = 1 +#endif + endif + + if ( present(LogUnit) ) then + call t_setLogUnit(LogUnit) + else + call t_setLogUnit(def_p_logunit) + endif + + if ( present(MasterTask) .and. present(mpicom) )then + call mpi_comm_rank(mpicom, me, ierr) + if (ierr .eq. MPI_ERR_COMM) then + call shr_sys_abort('T_INITF: bad mpi communicator') + endif + if (me .eq. 0) then + MasterTask2 = .true. + else + MasterTask2 = .false. + endif + else + MasterTask2 = .true. + end if + + if ( present(LogPrint) ) then + LogPrint2 = LogPrint + else + LogPrint2 = .true. + endif + + ! Set PERF defaults, then override with user-specified input + call perf_defaultopts(timing_disable_out=profile_disable, & + perf_timer_out=profile_timer, & + timer_depth_limit_out=profile_depth_limit, & + timing_detail_limit_out=profile_detail_limit, & + timing_barrier_out=profile_barrier, & + perf_outpe_num_out = profile_outpe_num, & + perf_outpe_stride_out = profile_outpe_stride, & + perf_single_file_out=profile_single_file, & + perf_global_stats_out=profile_global_stats, & + perf_papi_enable_out=profile_papi_enable, & + perf_ovhd_measurement_out=profile_ovhd_measurement, & + perf_add_detail_out=profile_add_detail ) + if ( MasterTask2 ) then + + ! Read in the prof_inparm namelist from NLFilename if it exists + + write(p_logunit,*) '(t_initf) Read in prof_inparm namelist from: '//trim(NLFilename) + unitn = shr_file_getUnit() + + ierr = 1 + open( unitn, file=trim(NLFilename), status="OLD", form="FORMATTED", access="SEQUENTIAL", iostat=ierr ) + if (ierr .eq. 0) then + + ! Look for prof_inparm group name in the input file. + ! If found, leave the file positioned at that namelist group. + call find_group_name(unitn, 'prof_inparm', status=ierr) + + if (ierr == 0) then ! found prof_inparm + read(unitn, nml=prof_inparm, iostat=ierr) + if (ierr /= 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' error condition for prof_inparm' ) + end if + end if + + close(unitn) + + endif + call shr_file_freeUnit( unitn ) + + endif + + ! This logic assumes that there will be only one MasterTask + ! per communicator, and that this MasterTask is process 0. + if ( present(MasterTask) .and. present(mpicom) )then + call shr_mpi_bcast( profile_disable, MPICom ) + call shr_mpi_bcast( profile_barrier, MPICom ) + call shr_mpi_bcast( profile_single_file, MPICom ) + call shr_mpi_bcast( profile_global_stats, MPICom ) + call shr_mpi_bcast( profile_papi_enable, MPICom ) + call shr_mpi_bcast( profile_ovhd_measurement, MPICom ) + call shr_mpi_bcast( profile_add_detail, MPICom ) + call shr_mpi_bcast( profile_depth_limit, MPICom ) + call shr_mpi_bcast( profile_detail_limit, MPICom ) + call shr_mpi_bcast( profile_outpe_num, MPICom ) + call shr_mpi_bcast( profile_outpe_stride, MPICom ) + call shr_mpi_bcast( profile_timer, MPICom ) + end if + call perf_setopts (MasterTask2, LogPrint2, & + timing_disable_in=profile_disable, & + perf_timer_in=profile_timer, & + timer_depth_limit_in=profile_depth_limit, & + timing_detail_limit_in=profile_detail_limit, & + timing_barrier_in=profile_barrier, & + perf_outpe_num_in=profile_outpe_num, & + perf_outpe_stride_in=profile_outpe_stride, & + perf_single_file_in=profile_single_file, & + perf_global_stats_in=profile_global_stats, & + perf_papi_enable_in=profile_papi_enable, & + perf_ovhd_measurement_in=profile_ovhd_measurement, & + perf_add_detail_in=profile_add_detail ) + + ! Set PAPI defaults, then override with user-specified input + if (perf_papi_enable) then + call papi_defaultopts(papi_ctr1_out=papi_ctr1_id, & + papi_ctr2_out=papi_ctr2_id, & + papi_ctr3_out=papi_ctr3_id, & + papi_ctr4_out=papi_ctr4_id ) + + if ( MasterTask2 ) then + papi_ctr1_str = "PAPI_NO_CTR" + papi_ctr2_str = "PAPI_NO_CTR" + papi_ctr3_str = "PAPI_NO_CTR" + papi_ctr4_str = "PAPI_NO_CTR" + + + ! Read in the papi_inparm namelist from NLFilename if it exists + + write(p_logunit,*) '(t_initf) Read in papi_inparm namelist from: '//trim(NLFilename) + unitn = shr_file_getUnit() + + ierr = 1 + open( unitn, file=trim(NLFilename), status="OLD", form="FORMATTED", access="SEQUENTIAL", iostat=ierr ) + if (ierr .eq. 0) then + ! Look for papi_inparm group name in the input file. + ! If found, leave the file positioned at that namelist group. + call find_group_name(unitn, 'papi_inparm', status=ierr) + + if (ierr == 0) then ! found papi_inparm + read(unitn, nml=papi_inparm, iostat=ierr) + if (ierr /= 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' error condition for papi_inparm' ) + end if + end if + + close(unitn) + + endif + call shr_file_freeUnit( unitn ) + + ! if enabled and nothing set, use "defaults" + if ((papi_ctr1_str(1:11) .eq. "PAPI_NO_CTR") .and. & + (papi_ctr2_str(1:11) .eq. "PAPI_NO_CTR") .and. & + (papi_ctr3_str(1:11) .eq. "PAPI_NO_CTR") .and. & + (papi_ctr4_str(1:11) .eq. "PAPI_NO_CTR")) then + papi_ctr1_str = "PAPI_FP_OPS" + endif + + if (papi_ctr1_str(1:11) /= "PAPI_NO_CTR") then + ierr = gptlevent_name_to_code(trim(papi_ctr1_str), papi_ctr1_id) + endif + if (papi_ctr2_str(1:11) /= "PAPI_NO_CTR") then + ierr = gptlevent_name_to_code(trim(papi_ctr2_str), papi_ctr2_id) + endif + if (papi_ctr3_str(1:11) /= "PAPI_NO_CTR") then + ierr = gptlevent_name_to_code(trim(papi_ctr3_str), papi_ctr3_id) + endif + if (papi_ctr4_str(1:11) /= "PAPI_NO_CTR") then + ierr = gptlevent_name_to_code(trim(papi_ctr4_str), papi_ctr4_id) + endif + + endif + ! This logic assumes that there will be only one MasterTask + ! per communicator, and that this MasterTask is process 0. + if ( present(MasterTask) .and. present(mpicom) )then + call shr_mpi_bcast( papi_ctr1_id, MPICom ) + call shr_mpi_bcast( papi_ctr2_id, MPICom ) + call shr_mpi_bcast( papi_ctr3_id, MPICom ) + call shr_mpi_bcast( papi_ctr4_id, MPICom ) + end if + + call papi_setopts (papi_ctr1_in=papi_ctr1_id, & + papi_ctr2_in=papi_ctr2_id, & + papi_ctr3_in=papi_ctr3_id, & + papi_ctr4_in=papi_ctr4_id ) + endif +!$OMP END MASTER +!$OMP BARRIER + + if (timing_disable) return + +!$OMP MASTER + ! + ! Set options and initialize timing library. + ! + ! Set timer + if (gptlsetutr (perf_timer) < 0) call shr_sys_abort (subname//':: gptlsetutr') + ! + ! For logical settings, 2nd arg 0 + ! to gptlsetoption means disable, non-zero means enable + ! + ! Turn off CPU timing (expensive) + ! + if (gptlsetoption (gptlcpu, 0) < 0) call shr_sys_abort (subname//':: gptlsetoption') + ! + ! Enable addition of double quotes to the output of timer names + ! + if (gptlsetoption (gptldopr_quotes, 1) < 0) & + call shr_sys_abort (subname//':: gptlsetoption') + ! + ! Set maximum number of threads + ! + if ( present(MaxThreads) ) then + if (gptlsetoption (gptlmaxthreads, MaxThreads) < 0) & + call shr_sys_abort (subname//':: gptlsetoption') + endif + ! + ! Set max timer depth + ! + if (gptlsetoption (gptldepthlimit, timer_depth_limit) < 0) & + call shr_sys_abort (subname//':: gptlsetoption') + ! + ! Set profile ovhd measurement (default is false) + ! + if (perf_ovhd_measurement) then + if (gptlsetoption (gptlprofile_ovhd, 1) < 0) & + call shr_sys_abort (subname//':: gptlsetoption') + endif + ! + ! Next 2 calls only work if PAPI is enabled. These examples enable counting + ! of total cycles and floating point ops, respectively + ! + if (perf_papi_enable) then + if (papi_ctr1 /= PAPI_NULL) then + if (gptlsetoption (papi_ctr1, 1) < 0) call shr_sys_abort (subname//':: gptlsetoption') + endif + if (papi_ctr2 /= PAPI_NULL) then + if (gptlsetoption (papi_ctr2, 1) < 0) call shr_sys_abort (subname//':: gptlsetoption') + endif + if (papi_ctr3 /= PAPI_NULL) then + if (gptlsetoption (papi_ctr3, 1) < 0) call shr_sys_abort (subname//':: gptlsetoption') + endif + if (papi_ctr4 /= PAPI_NULL) then + if (gptlsetoption (papi_ctr4, 1) < 0) call shr_sys_abort (subname//':: gptlsetoption') + endif + endif + ! + ! Initialize the timing lib. This call must occur after all gptlsetoption + ! calls and before all other timing lib calls. + ! + if (gptlinitialize () < 0) call shr_sys_abort (subname//':: gptlinitialize') + timing_initialized = .true. +!$OMP END MASTER +!$OMP BARRIER + + return + end subroutine t_initf +! +!======================================================================== +! + subroutine t_finalizef() +!----------------------------------------------------------------------- +! Purpose: shut down timing library +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + +!$OMP MASTER + ierr = GPTLfinalize() + timing_initialized = .false. +!$OMP END MASTER +!$OMP BARRIER + + return + end subroutine t_finalizef + +!=============================================================================== + +end module perf_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/pftconMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/pftconMod.F90 new file mode 100644 index 000000000..6bc45a5a9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/pftconMod.F90 @@ -0,0 +1,1495 @@ +module pftconMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing vegetation constants and method to + ! read and initialize vegetation (PFT) constants. + ! + ! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use abortutils , only : endrun + use clm_varpar , only : mxpft, numrad, ivis, inir, cft_lb, cft_ub + use clm_varctl , only : iulog, use_cndv, use_vertsoilc, use_crop + ! + ! !PUBLIC TYPES: + implicit none + private + ! + ! Vegetation type constants + ! + integer, public :: noveg ! value for not vegetated + integer, public :: ndllf_evr_tmp_tree ! value for Needleleaf evergreen temperate tree + integer, public :: ndllf_evr_brl_tree ! value for Needleleaf evergreen boreal tree + integer, public :: ndllf_dcd_brl_tree ! value for Needleleaf deciduous boreal tree + integer, public :: nbrdlf_evr_trp_tree ! value for Broadleaf evergreen tropical tree + integer, public :: nbrdlf_evr_tmp_tree ! value for Broadleaf evergreen temperate tree + integer, public :: nbrdlf_dcd_trp_tree ! value for Broadleaf deciduous tropical tree + integer, public :: nbrdlf_dcd_tmp_tree ! value for Broadleaf deciduous temperate tree + integer, public :: nbrdlf_dcd_brl_tree ! value for Broadleaf deciduous boreal tree + integer, public :: nbrdlf_evr_shrub ! value for Broadleaf evergreen shrub + integer, public :: nbrdlf_dcd_tmp_shrub ! value for Broadleaf deciduous temperate shrub + integer, public :: nbrdlf_dcd_brl_shrub ! value for Broadleaf deciduous boreal shrub + integer, public :: nc3_arctic_grass ! value for C3 arctic grass + integer, public :: nc3_nonarctic_grass ! value for C3 non-arctic grass + integer, public :: nc4_grass ! value for C4 grass + integer, public :: npcropmin ! value for first crop + 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 :: nc3crop ! value for generic crop (rf) + integer, public :: nc3irrig ! value for irrigated generic crop (ir) + + ! Number of crop functional types actually used in the model. This includes each CFT for + ! which is_pft_known_to_model is true. Note that this includes irrigated crops even if + ! irrigation is turned off in this run: it just excludes crop types that aren't handled + ! at all, as given by the mergetoclmpft list. + integer, public :: num_cfts_known_to_model + + ! !PUBLIC TYPES: + 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 + procedure, public :: InitForTesting ! version of Init meant for unit testing + procedure, public :: Clean + procedure, private :: InitAllocate + procedure, private :: InitRead + procedure, private :: set_is_pft_known_to_model ! Set is_pft_known_to_model based on mergetoclmpft + procedure, private :: set_num_cfts_known_to_model ! Set the module-level variable, num_cfts_known_to_model + + end type pftcon_type + + type(pftcon_type), public :: pftcon ! pft type constants structure + + 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(this) + + class(pftcon_type) :: this + + call this%InitAllocate() + call this%InitRead() + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitForTesting(this) + ! Version of Init meant for unit testing + ! + ! Allocate arrays, but don't try to read from file. + ! + ! Values can then be set by tests as needed + + class(pftcon_type) :: this + + call this%InitAllocate() + + end subroutine InitForTesting + + !----------------------------------------------------------------------- + subroutine InitAllocate (this) + ! + ! !DESCRIPTION: + ! Read and initialize vegetation (PFT) constants + ! + ! !USES: + use clm_varpar , only: nvariants + implicit none + ! + ! !ARGUMENTS: + class(pftcon_type) :: this + !----------------------------------------------------------------------- + + 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) ) + allocate( this%c3psn (0:mxpft) ) + allocate( this%xl (0:mxpft) ) + allocate( this%rhol (0:mxpft,numrad) ) + allocate( this%rhos (0:mxpft,numrad) ) + allocate( this%taul (0:mxpft,numrad) ) + allocate( this%taus (0:mxpft,numrad) ) + allocate( this%z0mr (0:mxpft) ) + allocate( this%displar (0:mxpft) ) + allocate( this%roota_par (0:mxpft) ) + allocate( this%rootb_par (0:mxpft) ) + allocate( this%crop (0:mxpft) ) + allocate( this%mergetoclmpft (0:mxpft) ) + allocate( this%is_pft_known_to_model (0:mxpft) ) + allocate( this%irrigated (0:mxpft) ) + allocate( this%smpso (0:mxpft) ) + allocate( this%smpsc (0:mxpft) ) + allocate( this%fnitr (0:mxpft) ) + allocate( this%slatop (0:mxpft) ) + allocate( this%dsladlai (0:mxpft) ) + allocate( this%leafcn (0:mxpft) ) + allocate( this%biofuel_harvfrac (0:mxpft) ) + allocate( this%flnr (0:mxpft) ) + allocate( this%woody (0:mxpft) ) + allocate( this%lflitcn (0:mxpft) ) + allocate( this%frootcn (0:mxpft) ) + allocate( this%livewdcn (0:mxpft) ) + allocate( this%deadwdcn (0:mxpft) ) + allocate( this%grperc (0:mxpft) ) + allocate( this%grpnow (0:mxpft) ) + allocate( this%rootprof_beta (0:mxpft,nvariants) ) + allocate( this%graincn (0:mxpft) ) + allocate( this%mxtmp (0:mxpft) ) + allocate( this%baset (0:mxpft) ) + allocate( this%declfact (0:mxpft) ) + allocate( this%bfact (0:mxpft) ) + allocate( this%aleaff (0:mxpft) ) + allocate( this%arootf (0:mxpft) ) + allocate( this%astemf (0:mxpft) ) + allocate( this%arooti (0:mxpft) ) + allocate( this%fleafi (0:mxpft) ) + allocate( this%allconsl (0:mxpft) ) + allocate( this%allconss (0:mxpft) ) + allocate( this%ztopmx (0:mxpft) ) + allocate( this%laimx (0:mxpft) ) + allocate( this%gddmin (0:mxpft) ) + allocate( this%hybgdd (0:mxpft) ) + allocate( this%lfemerg (0:mxpft) ) + allocate( this%grnfill (0:mxpft) ) + allocate( this%mbbopt (0:mxpft) ) + allocate( this%medlynslope (0:mxpft) ) + allocate( this%medlynintercept(0:mxpft) ) + allocate( this%mxmat (0:mxpft) ) + allocate( this%mnNHplantdate (0:mxpft) ) + allocate( this%mxNHplantdate (0:mxpft) ) + allocate( this%mnSHplantdate (0:mxpft) ) + allocate( this%mxSHplantdate (0:mxpft) ) + allocate( this%planttemp (0:mxpft) ) + allocate( this%minplanttemp (0:mxpft) ) + allocate( this%froot_leaf (0:mxpft) ) + allocate( this%stem_leaf (0:mxpft) ) + allocate( this%croot_stem (0:mxpft) ) + allocate( this%flivewd (0:mxpft) ) + allocate( this%fcur (0:mxpft) ) + allocate( this%fcurdv (0:mxpft) ) + allocate( this%lf_flab (0:mxpft) ) + allocate( this%lf_fcel (0:mxpft) ) + allocate( this%lf_flig (0:mxpft) ) + allocate( this%fr_flab (0:mxpft) ) + allocate( this%fr_fcel (0:mxpft) ) + allocate( this%fr_flig (0:mxpft) ) + allocate( this%leaf_long (0:mxpft) ) + allocate( this%evergreen (0:mxpft) ) + allocate( this%stress_decid (0:mxpft) ) + allocate( this%season_decid (0:mxpft) ) +!KO + allocate( this%season_decid_temperate (0:mxpft) ) +!KO + allocate( this%dwood (0:mxpft) ) + allocate( this%root_density (0:mxpft) ) + allocate( this%root_radius (0:mxpft) ) + allocate( this%pconv (0:mxpft) ) + allocate( this%pprod10 (0:mxpft) ) + allocate( this%pprod100 (0:mxpft) ) + allocate( this%pprodharv10 (0:mxpft) ) + allocate( this%cc_leaf (0:mxpft) ) + allocate( this%cc_lstem (0:mxpft) ) + allocate( this%cc_dstem (0:mxpft) ) + allocate( this%cc_other (0:mxpft) ) + allocate( this%fm_leaf (0:mxpft) ) + allocate( this%fm_lstem (0:mxpft) ) + allocate( this%fm_dstem (0:mxpft) ) + allocate( this%fm_other (0:mxpft) ) + allocate( this%fm_root (0:mxpft) ) + allocate( this%fm_lroot (0:mxpft) ) + allocate( this%fm_droot (0:mxpft) ) + allocate( this%fsr_pft (0:mxpft) ) + allocate( this%fd_pft (0:mxpft) ) + allocate( this%rswf_max (0:mxpft) ) + allocate( this%rswf_min (0:mxpft) ) + allocate( this%manunitro (0:mxpft) ) + allocate( this%fleafcn (0:mxpft) ) + allocate( this%ffrootcn (0:mxpft) ) + allocate( this%fstemcn (0:mxpft) ) + allocate( this%i_vcad (0:mxpft) ) + allocate( this%s_vcad (0:mxpft) ) + allocate( this%i_flnr (0:mxpft) ) + allocate( this%s_flnr (0:mxpft) ) + allocate( this%pftpar20 (0:mxpft) ) + allocate( this%pftpar28 (0:mxpft) ) + allocate( this%pftpar29 (0:mxpft) ) + allocate( this%pftpar30 (0:mxpft) ) + allocate( this%pftpar31 (0:mxpft) ) + allocate( this%a_fix (0:mxpft) ) + allocate( this%b_fix (0:mxpft) ) + allocate( this%c_fix (0:mxpft) ) + allocate( this%s_fix (0:mxpft) ) + allocate( this%akc_active (0:mxpft) ) + allocate( this%akn_active (0:mxpft) ) + allocate( this%ekc_active (0:mxpft) ) + allocate( this%ekn_active (0:mxpft) ) + allocate( this%kc_nonmyc (0:mxpft) ) + allocate( this%kn_nonmyc (0:mxpft) ) + allocate( this%kr_resorb (0:mxpft) ) + allocate( this%perecm (0:mxpft) ) + allocate( this%root_dmx (0:mxpft) ) + allocate( this%fun_cn_flex_a (0:mxpft) ) + allocate( this%fun_cn_flex_b (0:mxpft) ) + allocate( this%fun_cn_flex_c (0:mxpft) ) + allocate( this%FUN_fracfixers(0:mxpft) ) + + allocate( this%dbh (0:mxpft) ) + allocate( this%fbw (0:mxpft) ) + allocate( this%nstem (0:mxpft) ) + allocate( this%taper (0:mxpft) ) + allocate( this%rstem_per_dbh (0:mxpft) ) + allocate( this%wood_density (0:mxpft) ) + + end subroutine InitAllocate + + !----------------------------------------------------------------------- + subroutine InitRead(this) + ! + ! !DESCRIPTION: + ! Read and initialize vegetation (PFT) constants + ! + ! !USES: + use shr_log_mod , only : errMsg => shr_log_errMsg + use fileutils , only : getfil + use ncdio_pio , only : ncd_io, ncd_pio_closefile, ncd_pio_openfile, file_desc_t + use ncdio_pio , only : ncd_inqdid, ncd_inqdlen + use clm_varctl , only : + use spmdMod , only : masterproc + use CLMFatesParamInterfaceMod, only : FatesReadPFTs + ! + ! !ARGUMENTS: + class(pftcon_type) :: this + ! + ! !LOCAL VARIABLES: + character(len=256) :: locfn ! local file name + integer :: i,n,m ! loop indices + integer :: ier ! error code + type(file_desc_t) :: ncid ! pio netCDF file id + integer :: dimid ! netCDF dimension id + integer :: npft ! number of pfts on pft-physiology file + logical :: readv ! read variable in or not + character(len=32) :: subname = 'InitRead' ! subroutine name + character(len=pftname_len) :: expected_pftnames(0:mxpft) + character(len=512) :: msg + !----------------------------------------------------------------------- + ! + ! Expected PFT names: The names expected on the paramfile file and the order they are expected to be in. + ! NOTE: similar types are assumed to be together, first trees (ending with broadleaf_deciduous_boreal_tree + ! then shrubs, ending with broadleaf_deciduous_boreal_shrub, then grasses starting with c3_arctic_grass + ! and finally crops, ending with irrigated_tropical_soybean + ! DO NOT CHANGE THE ORDER -- WITHOUT MODIFYING OTHER PARTS OF THE CODE WHERE THE ORDER MATTERS! + + expected_pftnames( 0) = 'not_vegetated ' + expected_pftnames( 1) = 'needleleaf_evergreen_temperate_tree' + expected_pftnames( 2) = 'needleleaf_evergreen_boreal_tree ' + expected_pftnames( 3) = 'needleleaf_deciduous_boreal_tree ' + expected_pftnames( 4) = 'broadleaf_evergreen_tropical_tree ' + expected_pftnames( 5) = 'broadleaf_evergreen_temperate_tree ' + expected_pftnames( 6) = 'broadleaf_deciduous_tropical_tree ' + expected_pftnames( 7) = 'broadleaf_deciduous_temperate_tree ' + expected_pftnames( 8) = 'broadleaf_deciduous_boreal_tree ' + expected_pftnames( 9) = 'broadleaf_evergreen_shrub ' + expected_pftnames(10) = 'broadleaf_deciduous_temperate_shrub' + expected_pftnames(11) = 'broadleaf_deciduous_boreal_shrub ' + expected_pftnames(12) = 'c3_arctic_grass ' + expected_pftnames(13) = 'c3_non-arctic_grass ' + expected_pftnames(14) = 'c4_grass ' + expected_pftnames(15) = 'c3_crop ' + expected_pftnames(16) = 'c3_irrigated ' + expected_pftnames(17) = 'temperate_corn ' + expected_pftnames(18) = 'irrigated_temperate_corn ' + expected_pftnames(19) = 'spring_wheat ' + expected_pftnames(20) = 'irrigated_spring_wheat ' + expected_pftnames(21) = 'winter_wheat ' + expected_pftnames(22) = 'irrigated_winter_wheat ' + expected_pftnames(23) = 'temperate_soybean ' + expected_pftnames(24) = 'irrigated_temperate_soybean ' + expected_pftnames(25) = 'barley ' + expected_pftnames(26) = 'irrigated_barley ' + expected_pftnames(27) = 'winter_barley ' + expected_pftnames(28) = 'irrigated_winter_barley ' + expected_pftnames(29) = 'rye ' + expected_pftnames(30) = 'irrigated_rye ' + expected_pftnames(31) = 'winter_rye ' + expected_pftnames(32) = 'irrigated_winter_rye ' + expected_pftnames(33) = 'cassava ' + expected_pftnames(34) = 'irrigated_cassava ' + expected_pftnames(35) = 'citrus ' + expected_pftnames(36) = 'irrigated_citrus ' + expected_pftnames(37) = 'cocoa ' + expected_pftnames(38) = 'irrigated_cocoa ' + expected_pftnames(39) = 'coffee ' + expected_pftnames(40) = 'irrigated_coffee ' + expected_pftnames(41) = 'cotton ' + expected_pftnames(42) = 'irrigated_cotton ' + expected_pftnames(43) = 'datepalm ' + expected_pftnames(44) = 'irrigated_datepalm ' + expected_pftnames(45) = 'foddergrass ' + expected_pftnames(46) = 'irrigated_foddergrass ' + expected_pftnames(47) = 'grapes ' + expected_pftnames(48) = 'irrigated_grapes ' + expected_pftnames(49) = 'groundnuts ' + expected_pftnames(50) = 'irrigated_groundnuts ' + expected_pftnames(51) = 'millet ' + expected_pftnames(52) = 'irrigated_millet ' + expected_pftnames(53) = 'oilpalm ' + expected_pftnames(54) = 'irrigated_oilpalm ' + expected_pftnames(55) = 'potatoes ' + expected_pftnames(56) = 'irrigated_potatoes ' + expected_pftnames(57) = 'pulses ' + expected_pftnames(58) = 'irrigated_pulses ' + expected_pftnames(59) = 'rapeseed ' + expected_pftnames(60) = 'irrigated_rapeseed ' + expected_pftnames(61) = 'rice ' + expected_pftnames(62) = 'irrigated_rice ' + expected_pftnames(63) = 'sorghum ' + expected_pftnames(64) = 'irrigated_sorghum ' + expected_pftnames(65) = 'sugarbeet ' + expected_pftnames(66) = 'irrigated_sugarbeet ' + expected_pftnames(67) = 'sugarcane ' + expected_pftnames(68) = 'irrigated_sugarcane ' + expected_pftnames(69) = 'sunflower ' + expected_pftnames(70) = 'irrigated_sunflower ' + expected_pftnames(71) = 'miscanthus ' + expected_pftnames(72) = 'irrigated_miscanthus ' + expected_pftnames(73) = 'switchgrass ' + expected_pftnames(74) = 'irrigated_switchgrass ' + expected_pftnames(75) = 'tropical_corn ' + expected_pftnames(76) = 'irrigated_tropical_corn ' + expected_pftnames(77) = 'tropical_soybean ' + expected_pftnames(78) = 'irrigated_tropical_soybean ' + + ! Set specific vegetation type values + + if (masterproc) then + write(iulog,*) 'Attempting to read PFT physiological data .....' + end if + call getfil (paramfile, locfn, 0) + call ncd_pio_openfile (ncid, trim(locfn), 0) + call ncd_inqdid(ncid, 'pft', dimid) + call ncd_inqdlen(ncid, dimid, npft) + + if (npft - 1 /= mxpft) then + ! NOTE(bja, 201503) need to subtract 1 because of indexing. + ! NOTE(bja, 201503) fail early because one of the io libs + ! throws a useless abort error message deep inside the stack + ! instead of returning readv so we can get a useful line + ! number. + write(msg, '(a, i4, a, i4, a)') "ERROR: The number of pfts in the input netcdf file (", & + npft, ") does not equal the expected number of pfts (", mxpft, "). " + call endrun(msg=trim(msg)//errMsg(sourcefile, __LINE__)) + end if + + 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__)) + + 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__)) + + 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__)) + + ! + ! Constants + ! + !MV (10-08-14) TODO is this right - used to be maxveg - is it okay to set it to mxpft? + 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 + + ! + ! Dynamic Root variables for crops + ! + if ( use_crop .and. use_dynroot )then + call ncd_io('root_dmx', this%root_dmx, '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__)) + ! + ! Biomass heat storage variables + ! + if (use_biomass_heat_storage ) then + ! + ! These variables are used for stem biomass and only for tree and shrub + ! (They are effectively unused for other veg types) + ! + call ncd_io('dbh',this%dbh, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + call ncd_io('fbw',this%fbw, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + call ncd_io('rstem',this%rstem_per_dbh, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + call ncd_io('wood_density',this%wood_density, 'read', ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=' ERROR: error in reading in pft data'//errMsg(sourcefile, __LINE__)) + else + this%dbh = 0.0_r8 + this%fbw = 0.0_r8 + this%rstem_per_dbh = 0.0_r8 + this%wood_density = 0.0_r8 + end if + + call ncd_pio_closefile(ncid) + + call FatesReadPFTs() + + do i = 0, mxpft + if (.not. use_fates)then + if ( trim(adjustl(pftname(i))) /= trim(expected_pftnames(i)) )then + write(iulog,*)'pftconrd: pftname is NOT what is expected, name = ', & + trim(pftname(i)), ', expected name = ', trim(expected_pftnames(i)) + call endrun(msg='pftconrd: bad name for pft on paramfile dataset'//errMsg(sourcefile, __LINE__)) + end if + end if + + if ( trim(pftname(i)) == 'not_vegetated' ) noveg = i + if ( trim(pftname(i)) == 'needleleaf_evergreen_temperate_tree' ) ndllf_evr_tmp_tree = i + if ( trim(pftname(i)) == 'needleleaf_evergreen_boreal_tree' ) ndllf_evr_brl_tree = i + if ( trim(pftname(i)) == 'needleleaf_deciduous_boreal_tree' ) ndllf_dcd_brl_tree = i + if ( trim(pftname(i)) == 'broadleaf_evergreen_tropical_tree' ) nbrdlf_evr_trp_tree = i + if ( trim(pftname(i)) == 'broadleaf_evergreen_temperate_tree' ) nbrdlf_evr_tmp_tree = i + if ( trim(pftname(i)) == 'broadleaf_deciduous_tropical_tree' ) nbrdlf_dcd_trp_tree = i + if ( trim(pftname(i)) == 'broadleaf_deciduous_temperate_tree' ) nbrdlf_dcd_tmp_tree = i + if ( trim(pftname(i)) == 'broadleaf_deciduous_boreal_tree' ) nbrdlf_dcd_brl_tree = i + if ( trim(pftname(i)) == 'broadleaf_evergreen_shrub' ) nbrdlf_evr_shrub = i + if ( trim(pftname(i)) == 'broadleaf_deciduous_temperate_shrub' ) nbrdlf_dcd_tmp_shrub = i + if ( trim(pftname(i)) == 'broadleaf_deciduous_boreal_shrub' ) nbrdlf_dcd_brl_shrub = i + if ( trim(pftname(i)) == 'c3_arctic_grass' ) nc3_arctic_grass = i + if ( trim(pftname(i)) == 'c3_non-arctic_grass' ) nc3_nonarctic_grass = i + if ( trim(pftname(i)) == 'c4_grass' ) nc4_grass = i + if ( trim(pftname(i)) == 'c3_crop' ) nc3crop = i + if ( trim(pftname(i)) == 'c3_irrigated' ) nc3irrig = i + if ( trim(pftname(i)) == 'temperate_corn' ) ntmp_corn = i + if ( trim(pftname(i)) == 'irrigated_temperate_corn' ) nirrig_tmp_corn = i + if ( trim(pftname(i)) == 'spring_wheat' ) nswheat = i + if ( trim(pftname(i)) == 'irrigated_spring_wheat' ) nirrig_swheat = i + if ( trim(pftname(i)) == 'winter_wheat' ) nwwheat = i + if ( trim(pftname(i)) == 'irrigated_winter_wheat' ) nirrig_wwheat = i + if ( trim(pftname(i)) == 'temperate_soybean' ) ntmp_soybean = i + if ( trim(pftname(i)) == 'irrigated_temperate_soybean' ) nirrig_tmp_soybean = i + if ( trim(pftname(i)) == 'barley' ) nbarley = i + if ( trim(pftname(i)) == 'irrigated_barley' ) nirrig_barley = i + if ( trim(pftname(i)) == 'winter_barley' ) nwbarley = i + if ( trim(pftname(i)) == 'irrigated_winter_barley' ) nirrig_wbarley = i + if ( trim(pftname(i)) == 'rye' ) nrye = i + if ( trim(pftname(i)) == 'irrigated_rye' ) nirrig_rye = i + if ( trim(pftname(i)) == 'winter_rye' ) nwrye = i + if ( trim(pftname(i)) == 'irrigated_winter_rye' ) nirrig_wrye = i + if ( trim(pftname(i)) == 'cassava' ) ncassava = i + if ( trim(pftname(i)) == 'irrigated_cassava' ) nirrig_cassava = i + if ( trim(pftname(i)) == 'citrus' ) ncitrus = i + if ( trim(pftname(i)) == 'irrigated_citrus' ) nirrig_citrus = i + if ( trim(pftname(i)) == 'cocoa' ) ncocoa = i + if ( trim(pftname(i)) == 'irrigated_cocoa' ) nirrig_cocoa = i + if ( trim(pftname(i)) == 'coffee' ) ncoffee = i + if ( trim(pftname(i)) == 'irrigated_coffee' ) nirrig_coffee = i + if ( trim(pftname(i)) == 'cotton' ) ncotton = i + if ( trim(pftname(i)) == 'irrigated_cotton' ) nirrig_cotton = i + if ( trim(pftname(i)) == 'datepalm' ) ndatepalm = i + if ( trim(pftname(i)) == 'irrigated_datepalm' ) nirrig_datepalm = i + if ( trim(pftname(i)) == 'foddergrass' ) nfoddergrass = i + if ( trim(pftname(i)) == 'irrigated_foddergrass' ) nirrig_foddergrass = i + if ( trim(pftname(i)) == 'grapes' ) ngrapes = i + if ( trim(pftname(i)) == 'irrigated_grapes' ) nirrig_grapes = i + if ( trim(pftname(i)) == 'groundnuts' ) ngroundnuts = i + if ( trim(pftname(i)) == 'irrigated_groundnuts' ) nirrig_groundnuts = i + if ( trim(pftname(i)) == 'millet' ) nmillet = i + if ( trim(pftname(i)) == 'irrigated_millet' ) nirrig_millet = i + if ( trim(pftname(i)) == 'oilpalm' ) noilpalm = i + if ( trim(pftname(i)) == 'irrigated_oilpalm' ) nirrig_oilpalm = i + if ( trim(pftname(i)) == 'potatoes' ) npotatoes = i + if ( trim(pftname(i)) == 'irrigated_potatoes' ) nirrig_potatoes = i + if ( trim(pftname(i)) == 'pulses' ) npulses = i + if ( trim(pftname(i)) == 'irrigated_pulses' ) nirrig_pulses = i + if ( trim(pftname(i)) == 'rapeseed' ) nrapeseed = i + if ( trim(pftname(i)) == 'irrigated_rapeseed' ) nirrig_rapeseed = i + if ( trim(pftname(i)) == 'rice' ) nrice = i + if ( trim(pftname(i)) == 'irrigated_rice' ) nirrig_rice = i + if ( trim(pftname(i)) == 'sorghum' ) nsorghum = i + if ( trim(pftname(i)) == 'irrigated_sorghum' ) nirrig_sorghum = i + if ( trim(pftname(i)) == 'sugarbeet' ) nsugarbeet = i + if ( trim(pftname(i)) == 'irrigated_sugarbeet' ) nirrig_sugarbeet = i + if ( trim(pftname(i)) == 'sugarcane' ) nsugarcane = i + if ( trim(pftname(i)) == 'irrigated_sugarcane' ) nirrig_sugarcane = i + if ( trim(pftname(i)) == 'sunflower' ) nsunflower = i + if ( trim(pftname(i)) == 'irrigated_sunflower' ) nirrig_sunflower = i + if ( trim(pftname(i)) == 'miscanthus' ) nmiscanthus = i + if ( trim(pftname(i)) == 'irrigated_miscanthus' ) nirrig_miscanthus = i + if ( trim(pftname(i)) == 'switchgrass' ) nswitchgrass = i + if ( trim(pftname(i)) == 'irrigated_switchgrass' ) nirrig_switchgrass = i + if ( trim(pftname(i)) == 'tropical_corn' ) ntrp_corn = i + if ( trim(pftname(i)) == 'irrigated_tropical_corn' ) nirrig_trp_corn = i + if ( trim(pftname(i)) == 'tropical_soybean' ) ntrp_soybean = i + if ( trim(pftname(i)) == 'irrigated_tropical_soybean' ) nirrig_trp_soybean = i + end do + + npcropmin = ntmp_corn ! first prognostic crop + npcropmax = mxpft ! last prognostic crop in list + + call this%set_is_pft_known_to_model() + call this%set_num_cfts_known_to_model() + + ! 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 + ! When crop is not on, merge prognostic crop types into either the rainfed + ! or irrigated C3 generic crop types + if ( .not. use_crop )then + do i = npcropmin, ntrp_soybean, 2 + this%mergetoclmpft(i) = nc3crop + end do + do i = nirrig_tmp_corn, npcropmax, 2 + this%mergetoclmpft(i) = nc3irrig + end do + end if + ! + ! Do some error checking, but not if fates is on. + ! + ! FIX(SPM,032414) double check if some of these should be on... + + if( .not. use_fates ) then + if ( npcropmax /= mxpft )then + call endrun(msg=' ERROR: npcropmax is NOT the last value'//errMsg(sourcefile, __LINE__)) + end if + do i = 0, mxpft + if ( this%irrigated(i) == 1.0_r8 .and. & + (i == nc3irrig .or. & + i == nirrig_tmp_corn .or. & + i == nirrig_swheat .or. i == nirrig_wwheat .or. & + i == nirrig_tmp_soybean .or. & + i == nirrig_barley .or. i == nirrig_wbarley .or. & + i == nirrig_rye .or. i == nirrig_wrye .or. & + i == nirrig_cassava .or. & + i == nirrig_citrus .or. & + i == nirrig_cocoa .or. i == nirrig_coffee .or. & + i == nirrig_cotton .or. & + i == nirrig_datepalm .or. & + i == nirrig_foddergrass .or. & + i == nirrig_grapes .or. i == nirrig_groundnuts .or. & + i == nirrig_millet .or. & + i == nirrig_oilpalm .or. & + i == nirrig_potatoes .or. i == nirrig_pulses .or. & + i == nirrig_rapeseed .or. i == nirrig_rice .or. & + i == nirrig_sorghum .or. & + i == nirrig_sugarbeet .or. i == nirrig_sugarcane .or. & + i == nirrig_sunflower .or. & + i == nirrig_miscanthus .or. i == nirrig_switchgrass .or. & + i == nirrig_trp_corn .or. & + i == nirrig_trp_soybean) )then + ! correct + else if ( this%irrigated(i) == 0.0_r8 )then + ! correct + else + call endrun(msg=' ERROR: irrigated has wrong values'//errMsg(sourcefile, __LINE__)) + end if + if ( this%crop(i) == 1.0_r8 .and. (i >= nc3crop .and. i <= npcropmax) )then + ! correct + else if ( this%crop(i) == 0.0_r8 )then + ! correct + else + call endrun(msg=' ERROR: crop has wrong values'//errMsg(sourcefile, __LINE__)) + end if + if ( (i /= noveg) .and. (i < npcropmin) .and. & + abs(this%pconv(i) + this%pprod10(i) + this%pprod100(i) - 1.0_r8) > 1.e-7_r8 )then + call endrun(msg=' ERROR: pconv+pprod10+pprod100 do NOT sum to one.'//errMsg(sourcefile, __LINE__)) + end if + if ( this%pprodharv10(i) > 1.0_r8 .or. this%pprodharv10(i) < 0.0_r8 )then + call endrun(msg=' ERROR: pprodharv10 outside of range.'//errMsg(sourcefile, __LINE__)) + end if + if (i < npcropmin .and. this%biofuel_harvfrac(i) /= 0._r8) then + call endrun(msg=' ERROR: biofuel_harvfrac non-zero for a non-prognostic crop PFT.'//& + errMsg(sourcefile, __LINE__)) + end if + end do + end if + + if (masterproc) then + write(iulog,*) 'Successfully read PFT physiological data' + write(iulog,*) + end if + + end subroutine InitRead + + !----------------------------------------------------------------------- + subroutine set_is_pft_known_to_model(this) + ! + ! !DESCRIPTION: + ! Set is_pft_known_to_model based on mergetoclmpft + ! + ! !USES: + ! + ! !ARGUMENTS: + class(pftcon_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + integer :: m, merge_type + + character(len=*), parameter :: subname = 'set_is_pft_known_to_model' + !----------------------------------------------------------------------- + + this%is_pft_known_to_model(:) = .false. + + ! NOTE(wjs, 2015-10-04) Currently, type 0 has mergetoclmpft = _FillValue in the file, + ! so we can't handle it in the general loop below. But CLM always uses type 0, so + ! handle it specially here. + this%is_pft_known_to_model(0) = .true. + + ! NOTE(wjs, 2015-10-04) Currently, mergetoclmpft is only used for crop types. + ! However, we handle it more generally here (treating ALL pft types), in case its use + ! is ever extended to work with non-crop types as well. + do m = 1, mxpft + merge_type = this%mergetoclmpft(m) + this%is_pft_known_to_model(merge_type) = .true. + end do + + end subroutine set_is_pft_known_to_model + + !----------------------------------------------------------------------- + subroutine set_num_cfts_known_to_model(this) + ! + ! !DESCRIPTION: + ! Set the module-level variable, num_cfts_known_to_model + ! + ! !USES: + ! + ! !ARGUMENTS: + class(pftcon_type), intent(in) :: this + ! + ! !LOCAL VARIABLES: + integer :: m + + character(len=*), parameter :: subname = 'set_num_cfts_known_to_model' + !----------------------------------------------------------------------- + + num_cfts_known_to_model = 0 + do m = cft_lb, cft_ub + if (this%is_pft_known_to_model(m)) then + num_cfts_known_to_model = num_cfts_known_to_model + 1 + end if + end do + + end subroutine set_num_cfts_known_to_model + + !----------------------------------------------------------------------- + subroutine Clean(this) + ! + ! !DESCRIPTION: + ! Deallocate memory + ! + ! !USES: + ! + ! !ARGUMENTS: + class(pftcon_type), intent(inout) :: this + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'Clean' + !----------------------------------------------------------------------- + + deallocate( this%noveg) + deallocate( this%is_tree) + deallocate( this%is_shrub) + deallocate( this%is_grass) + + deallocate( this%dleaf) + deallocate( this%c3psn) + deallocate( this%xl) + deallocate( this%rhol) + deallocate( this%rhos) + deallocate( this%taul) + deallocate( this%taus) + deallocate( this%z0mr) + deallocate( this%displar) + deallocate( this%roota_par) + deallocate( this%rootb_par) + deallocate( this%crop) + deallocate( this%mergetoclmpft) + deallocate( this%is_pft_known_to_model) + deallocate( this%irrigated) + deallocate( this%smpso) + deallocate( this%smpsc) + deallocate( this%fnitr) + deallocate( this%slatop) + deallocate( this%dsladlai) + deallocate( this%leafcn) + deallocate( this%biofuel_harvfrac) + deallocate( this%flnr) + deallocate( this%woody) + deallocate( this%lflitcn) + deallocate( this%frootcn) + deallocate( this%livewdcn) + deallocate( this%deadwdcn) + deallocate( this%grperc) + deallocate( this%grpnow) + deallocate( this%rootprof_beta) + deallocate( this%graincn) + deallocate( this%mxtmp) + deallocate( this%baset) + deallocate( this%declfact) + deallocate( this%bfact) + deallocate( this%aleaff) + deallocate( this%arootf) + deallocate( this%astemf) + deallocate( this%arooti) + deallocate( this%fleafi) + deallocate( this%allconsl) + deallocate( this%allconss) + deallocate( this%ztopmx) + deallocate( this%laimx) + deallocate( this%gddmin) + deallocate( this%hybgdd) + deallocate( this%lfemerg) + deallocate( this%grnfill) + deallocate( this%mbbopt) + deallocate( this%medlynslope) + deallocate( this%medlynintercept) + deallocate( this%mxmat) + deallocate( this%mnNHplantdate) + deallocate( this%mxNHplantdate) + deallocate( this%mnSHplantdate) + deallocate( this%mxSHplantdate) + deallocate( this%planttemp) + deallocate( this%minplanttemp) + deallocate( this%froot_leaf) + deallocate( this%stem_leaf) + deallocate( this%croot_stem) + deallocate( this%flivewd) + deallocate( this%fcur) + deallocate( this%fcurdv) + deallocate( this%lf_flab) + deallocate( this%lf_fcel) + deallocate( this%lf_flig) + deallocate( this%fr_flab) + deallocate( this%fr_fcel) + deallocate( this%fr_flig) + deallocate( this%leaf_long) + deallocate( this%evergreen) + deallocate( this%stress_decid) + deallocate( this%season_decid) +!KO + deallocate( this%season_decid_temperate) +!KO + deallocate( this%dwood) + deallocate( this%root_density) + deallocate( this%root_radius) + deallocate( this%pconv) + deallocate( this%pprod10) + deallocate( this%pprod100) + deallocate( this%pprodharv10) + deallocate( this%cc_leaf) + deallocate( this%cc_lstem) + deallocate( this%cc_dstem) + deallocate( this%cc_other) + deallocate( this%fm_leaf) + deallocate( this%fm_lstem) + deallocate( this%fm_dstem) + deallocate( this%fm_other) + deallocate( this%fm_root) + deallocate( this%fm_lroot) + deallocate( this%fm_droot) + deallocate( this%fsr_pft) + deallocate( this%fd_pft) + deallocate( this%rswf_min) + deallocate( this%rswf_max) + deallocate( this%manunitro) + deallocate( this%fleafcn) + deallocate( this%ffrootcn) + deallocate( this%fstemcn) + deallocate( this%i_vcad) + deallocate( this%s_vcad) + deallocate( this%i_flnr) + deallocate( this%s_flnr) + deallocate( this%pftpar20) + deallocate( this%pftpar28) + deallocate( this%pftpar29) + deallocate( this%pftpar30) + deallocate( this%pftpar31) + deallocate( this%a_fix) + deallocate( this%b_fix) + deallocate( this%c_fix) + deallocate( this%s_fix) + deallocate( this%akc_active) + deallocate( this%akn_active) + deallocate( this%ekc_active) + deallocate( this%ekn_active) + deallocate( this%kc_nonmyc) + deallocate( this%kn_nonmyc) + deallocate( this%kr_resorb) + deallocate( this%perecm) + deallocate( this%root_dmx) + deallocate( this%fun_cn_flex_a) + deallocate( this%fun_cn_flex_b) + deallocate( this%fun_cn_flex_c) + deallocate( this%FUN_fracfixers) + + deallocate( this%dbh) + deallocate( this%fbw) + deallocate( this%nstem) + deallocate( this%rstem_per_dbh) + deallocate( this%wood_density) + deallocate( this%taper) + end subroutine Clean + +end module pftconMod + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/quadraticMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/quadraticMod.F90 new file mode 100644 index 000000000..87bb25094 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/shr_abort_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_abort_mod.F90 new file mode 100644 index 000000000..9e4de5bd0 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_abort_mod.F90 @@ -0,0 +1,164 @@ +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 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,rc) + ! Consistent stopping mechanism + + !----- arguments ----- + character(len=*) , intent(in), optional :: string ! error message string + integer(shr_kind_in), intent(in), 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 (flag) then + if (present(rc)) then + call shr_mpi_abort(trim(local_string),rc) + else + call shr_mpi_abort(trim(local_string)) + endif + 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_orig_files/shr_assert.h b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_assert.h new file mode 100644 index 000000000..b09e0d127 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_assert.h @@ -0,0 +1,22 @@ +#ifdef NDEBUG +#define SHR_ASSERT(assert, msg) +#define SHR_ASSERT_FL(assert, file, line) +#define SHR_ASSERT_MFL(assert, msg, file, line) +#define SHR_ASSERT_ALL(assert, msg) +#define SHR_ASSERT_ALL_FL(assert, file, line) +#define SHR_ASSERT_ALL_MFL(assert, msg, file, line) +#define SHR_ASSERT_ANY(assert, msg) +#define SHR_ASSERT_ANY_FL(assert, file, line) +#define SHR_ASSERT_ANY_MFL(assert, msg, file, line) +#else +#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) +#endif +use shr_assert_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_assert_mod.F90.in b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_assert_mod.F90.in new file mode 100644 index 000000000..fc62d64ba --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_assert_mod.F90.in @@ -0,0 +1,435 @@ +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=:), 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 + full_msg = full_msg // ' at line ' // toString(line) + 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_orig_files/shr_const_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_const_mod.F90 new file mode 100644 index 000000000..8437190c7 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_const_mod.F90 @@ -0,0 +1,105 @@ +!=============================================================================== +! SVN $Id: shr_const_mod.F90 61510 2014-06-26 21:58:56Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_const_mod.F90 $ +!=============================================================================== + +MODULE shr_const_mod + + use shr_kind_mod, only : R8 => shr_kind_r8 + + !---------------------------------------------------------------------------- + ! physical constants (all data public) + !---------------------------------------------------------------------------- + private :: R8 + public + + real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 ! pi + real(R8),parameter :: SHR_CONST_CDAY = 86400.0_R8 ! sec in calendar day ~ sec + real(R8),parameter :: SHR_CONST_SDAY = 86164.0_R8 ! sec in siderial day ~ sec + real(R8),parameter :: SHR_CONST_OMEGA = 2.0_R8*SHR_CONST_PI/SHR_CONST_SDAY ! earth rot ~ rad/sec + real(R8),parameter :: SHR_CONST_REARTH = 6.37122e6_R8 ! radius of earth ~ m + real(R8),parameter :: SHR_CONST_G = 9.80616_R8 ! acceleration of gravity ~ m/s^2 + + real(R8),parameter :: SHR_CONST_STEBOL = 5.67e-8_R8 ! Stefan-Boltzmann constant ~ W/m^2/K^4 + real(R8),parameter :: SHR_CONST_BOLTZ = 1.38065e-23_R8 ! Boltzmann's constant ~ J/K/molecule + real(R8),parameter :: SHR_CONST_AVOGAD = 6.02214e26_R8 ! Avogadro's number ~ molecules/kmole + real(R8),parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ ! Universal gas constant ~ J/K/kmole + real(R8),parameter :: SHR_CONST_MWDAIR = 28.966_R8 ! molecular weight dry air ~ kg/kmole + real(R8),parameter :: SHR_CONST_MWWV = 18.016_R8 ! molecular weight water vapor + real(R8),parameter :: SHR_CONST_RDAIR = SHR_CONST_RGAS/SHR_CONST_MWDAIR ! Dry air gas constant ~ J/K/kg + real(R8),parameter :: SHR_CONST_RWV = SHR_CONST_RGAS/SHR_CONST_MWWV ! Water vapor gas constant ~ J/K/kg + real(R8),parameter :: SHR_CONST_ZVIR = (SHR_CONST_RWV/SHR_CONST_RDAIR)-1.0_R8 ! RWV/RDAIR - 1.0 + real(R8),parameter :: SHR_CONST_KARMAN = 0.4_R8 ! Von Karman constant + real(R8),parameter :: SHR_CONST_PSTD = 101325.0_R8 ! standard pressure ~ pascals + real(R8),parameter :: SHR_CONST_PDB = 0.0112372_R8 ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) + + real(R8),parameter :: SHR_CONST_TKTRIP = 273.16_R8 ! triple point of fresh water ~ K + real(R8),parameter :: SHR_CONST_TKFRZ = 273.15_R8 ! freezing T of fresh water ~ K + real(R8),parameter :: SHR_CONST_TKFRZSW = SHR_CONST_TKFRZ - 1.8_R8 ! freezing T of salt water ~ K + real(R8),parameter :: SHR_CONST_ZSRFLYR = 3.0_R8 ! ocn surf layer depth for diurnal SST cal ~ m + + real(R8),parameter :: SHR_CONST_RHODAIR = & ! density of dry air at STP ~ kg/m^3 + SHR_CONST_PSTD/(SHR_CONST_RDAIR*SHR_CONST_TKFRZ) + real(R8),parameter :: SHR_CONST_RHOFW = 1.000e3_R8 ! density of fresh water ~ kg/m^3 + real(R8),parameter :: SHR_CONST_RHOSW = 1.026e3_R8 ! density of sea water ~ kg/m^3 + real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice ~ kg/m^3 + real(R8),parameter :: SHR_CONST_CPDAIR = 1.00464e3_R8 ! specific heat of dry air ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPWV = 1.810e3_R8 ! specific heat of water vap ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPVIR = (SHR_CONST_CPWV/SHR_CONST_CPDAIR)-1.0_R8 ! CPWV/CPDAIR - 1.0 + real(R8),parameter :: SHR_CONST_CPFW = 4.188e3_R8 ! specific heat of fresh h2o ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPSW = 3.996e3_R8 ! specific heat of sea h2o ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPICE = 2.11727e3_R8 ! specific heat of fresh ice ~ J/kg/K + real(R8),parameter :: SHR_CONST_LATICE = 3.337e5_R8 ! latent heat of fusion ~ J/kg + real(R8),parameter :: SHR_CONST_LATVAP = 2.501e6_R8 ! latent heat of evaporation ~ J/kg + real(R8),parameter :: SHR_CONST_LATSUB = & ! latent heat of sublimation ~ J/kg + SHR_CONST_LATICE + SHR_CONST_LATVAP + real(R8),parameter :: SHR_CONST_CONDICE = 2.1_R8 ! thermal conductivity of ice ~ W/m/K + real(R8),parameter :: SHR_CONST_KAPPA_LAND_ICE = & ! Diffusivity of heat in land ice ~ + SHR_CONST_CONDICE / (SHR_CONST_RHOICE*SHR_CONST_CPICE) + real(R8),parameter :: SHR_CONST_TF0 = 6.22e-2_R8 ! The freezing temperature at zero pressure in + ! sub-ice-shelf ocean cavities ~ C + real(R8),parameter :: SHR_CONST_DTF_DP = -7.43e-8_R8 ! The coefficient for the term proportional to the (limited) + ! pressure in the freezing temperature in sub-ice-shelf ocean cavities. ~ C Pa^{-1} + real(R8),parameter :: SHR_CONST_DTF_DS = -5.63e-2_R8 !The coefficient for the term proportional to salinity in + ! the freezing temperature in sub-ice-ice ocean cavities ~ C PSU^{-1} + real(R8),parameter :: SHR_CONST_DTF_DPDS = -1.74e-10_R8 ! The coefficient for the term proportional to salinity times + ! pressure in the freezing temperature in sub-ice-shelf ocean cavities ~ C PSU^{-1} Pa^{-1} + real(R8),parameter :: SHR_CONST_OCN_REF_SAL = 34.7_R8 ! ocn ref salinity (psu) + real(R8),parameter :: SHR_CONST_ICE_REF_SAL = 4.0_R8 ! ice ref salinity (psu) + + real(R8),parameter :: SHR_CONST_SPVAL = 1.0e30_R8 ! special missing value + real(R8),parameter :: SHR_CONST_SPVAL_TOLMIN = 0.99_R8 * SHR_CONST_SPVAL ! min spval tolerance + real(R8),parameter :: SHR_CONST_SPVAL_TOLMAX = 1.01_R8 * SHR_CONST_SPVAL ! max spval tolerance + real(R8),parameter :: SHR_CONST_SPVAL_AERODEP= 1.e29_r8 ! special aerosol deposition + + !Water Isotope Ratios in Vienna Standard Mean Ocean Water (VSMOW): + real(R8),parameter :: SHR_CONST_VSMOW_18O = 2005.2e-6_R8 ! 18O/16O in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_17O = 379.e-6_R8 ! 18O/16O in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_16O = 0.997628_R8 ! 16O/Tot in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_D = 155.76e-6_R8 ! 2H/1H in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_T = 1.85e-6_R8 ! 3H/1H in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_H = 0.99984426_R8 ! 1H/Tot in VMSOW + ! For best numerics in CAM5 + real(R8),parameter :: SHR_CONST_RSTD_H2ODEV = 1.0_R8 ! Rstd Dev Use + +contains + +!----------------------------------------------------------------------------- + + elemental logical function shr_const_isspval(rval) +!$omp declare simd(shr_const_isspval) + + real(r8), intent(in) :: rval + + if (rval > SHR_CONST_SPVAL_TOLMIN .and. & + rval < SHR_CONST_SPVAL_TOLMAX) then + shr_const_isspval = .true. + else + shr_const_isspval = .false. + endif + + end function shr_const_isspval + +!----------------------------------------------------------------------------- + +END MODULE shr_const_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_file_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_file_mod.F90 new file mode 100644 index 000000000..167d67978 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/shr_fire_emis_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_fire_emis_mod.F90 new file mode 100644 index 000000000..30931271e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_fire_emis_mod.F90 @@ -0,0 +1,297 @@ +module shr_fire_emis_mod + + !================================================================================ + ! 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. + !================================================================================ + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_kind_mod , only : r8 => shr_kind_r8, 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 : logunit => shr_log_Unit + use shr_mpi_mod , only : shr_mpi_bcast + use shr_nl_mod , only : shr_nl_find_group_name + use shr_expr_parser_mod , only : shr_exp_parse, shr_exp_item_t, shr_exp_list_destroy + + implicit none + 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 :: fire_emis_initialized = .false. ! true => shr_fire_emis_readnl alreay called + logical :: shr_fire_emis_elevated = .true. + + 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=16) :: 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 +!------------------------------------------------------------------------- + + subroutine shr_fire_emis_readnl( NLFileName, emis_nflds ) + + !------------------------------------------------------------------------- + ! + ! 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. + ! + !------------------------------------------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: NLFileName ! name of namelist file + integer , intent(out) :: emis_nflds + + ! local variables + type(ESMF_VM) :: vm + integer :: localPet + integer :: mpicom + integer :: rc + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer, parameter :: maxspc = 100 + character(len=2*CX) :: fire_emis_specifier(maxspc) = ' ' + character(len=CL) :: fire_emis_factors_file = ' ' + logical :: fire_emis_elevated = .true. + integer :: i, tmp(1) + character(*),parameter :: F00 = "('(shr_fire_emis_readnl) ',2a)" + character(len=*), parameter :: subname='(shr_fire_emis_readnl)' + !------------------------------------------------------------------ + + namelist /fire_emis_nl/ fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated + + rc = ESMF_SUCCESS + + ! If other processes have already initialized megan - then the info will just be re-initialized + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Note the following still needs to be called on all processors since the mpi_bcast is a collective + ! call on all the pes of mpicom + if (localPet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + 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 ) + 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 - only if it has not been initialized + if (.not. fire_emis_initialized) then + call shr_fire_emis_init( fire_emis_specifier ) + end if + emis_nflds = shr_fire_emis_mechcomps_n + + end subroutine shr_fire_emis_readnl + +!------------------------------------------------------------------------- +! private methods... +!------------------------------------------------------------------------- + + subroutine shr_fire_emis_init( specifier ) + + !-------------------------------------------------- + ! module data initializer + !-------------------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: specifier(:) + + ! local variables + integer :: n_entries + integer :: i, j, k + type(shr_exp_item_t), pointer :: items_list, item + !------------------------------------------------------ + + 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 + + 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 + + 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 + + fire_emis_initialized = .true. + + end subroutine shr_fire_emis_init + + !------------------------------------------------------------------------- + + 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_orig_files/shr_infnan_mod.F90.in b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_infnan_mod.F90.in new file mode 100644 index 000000000..992c46fc9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/shr_kind_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_kind_mod.F90 new file mode 100644 index 000000000..be988e541 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_kind_mod.F90 @@ -0,0 +1,20 @@ +MODULE shr_kind_mod + + !---------------------------------------------------------------------------- + ! precision/kind constants add data public + !---------------------------------------------------------------------------- + public + integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real + integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real + integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real + integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer + integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer + integer,parameter :: SHR_KIND_I2 = selected_int_kind ( 4) ! 2 byte integer + integer,parameter :: SHR_KIND_IN = kind(1) ! 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_orig_files/shr_log_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_log_mod.F90 new file mode 100644 index 000000000..244314a8d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_log_mod.F90 @@ -0,0 +1,13 @@ +MODULE shr_log_mod + + use shr_kind_mod + + !---------------------------------------------------------------------------- + ! low-level shared variables for logging, these may not be parameters + !---------------------------------------------------------------------------- + public + + integer(SHR_KIND_IN) :: shr_log_Level = 1 + integer(SHR_KIND_IN) :: shr_log_Unit = 6 + +END MODULE shr_log_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_mpi_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_mpi_mod.F90 new file mode 100644 index 000000000..ab872a270 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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 + + !=============================================================================== +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_orig_files/shr_nl_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_nl_mod.F90 new file mode 100644 index 000000000..f06f2185c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_nl_mod.F90 @@ -0,0 +1,88 @@ +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 + +contains + +! This routine probably discards more error code information than it needs to. + +subroutine shr_nl_find_group_name(unit, group, status) + + use shr_string_mod, only: shr_string_toLower + +!--------------------------------------------------------------------------------------- +! 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 + +end module shr_nl_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_sys_mod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/shr_sys_mod.F90 new file mode 100644 index 000000000..b89df7488 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/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_orig_files/spmdMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/spmdMod.F90 new file mode 100644 index 000000000..6983b9628 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/spmdMod.F90 @@ -0,0 +1,142 @@ + +module spmdMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: spmdMod +! +! !DESCRIPTION: +! SPMD initialization +! +! !REVISION HISTORY: +! Author: Mariana Vertenstein +! +!EOP +!----------------------------------------------------------------------- + + 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( clm_mpicom, LNDID ) +! +! !DESCRIPTION: +! MPI initialization (number of cpus, processes, tids, etc) +! +! !USES +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: clm_mpicom + integer, intent(in) :: LNDID +! +! !REVISION HISTORY: +! Author: Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: i,j ! indices + integer :: ier ! return error status + integer :: mylength ! my processor length + logical :: mpi_running ! temporary + integer, allocatable :: length(:) + integer, allocatable :: displ(:) + character*(MPI_MAX_PROCESSOR_NAME), allocatable :: procname(:) + character*(MPI_MAX_PROCESSOR_NAME) :: myprocname +!----------------------------------------------------------------------- + + ! Initialize mpi communicator group + + mpicom = clm_mpicom + + comp_id = LNDID + + ! Get my processor id + + call mpi_comm_rank(mpicom, iam, ier) + if (iam==0) then + masterproc = .true. + else + masterproc = .false. + end if + + ! Get number of processors + + call mpi_comm_size(mpicom, npes, ier) + + ! Get my processor names + + allocate (length(0:npes-1), displ(0:npes-1), procname(0:npes-1)) + + call mpi_get_processor_name (myprocname, mylength, ier) + call mpi_allgather(mylength,1,MPI_INTEGER,length,1,MPI_INTEGER,mpicom,ier) + + do i = 0,npes-1 + displ(i)=i*MPI_MAX_PROCESSOR_NAME + end do + call mpi_gatherv (myprocname,mylength,MPI_CHARACTER, & + procname,length,displ,MPI_CHARACTER,0,mpicom,ier) + if (masterproc) then + write(iulog,100)npes + write(iulog,200) + write(iulog,220) + do i=0,npes-1 + write(iulog,250)i,(procname((i))(j:j),j=1,length(i)) + end do + endif + + deallocate (length, displ, procname) + +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_orig_files/subgridAveMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/subgridAveMod.F90 new file mode 100644 index 000000000..36c7a0874 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CLM51_orig_files/subgridAveMod.F90 @@ -0,0 +1,1362 @@ +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_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/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CMakeLists.txt new file mode 100644 index 000000000..9077e9c95 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CMakeLists.txt @@ -0,0 +1,26 @@ +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::ESMF NetCDF::NetCDF_Fortran + TYPE SHARED) + +if (is_openmp) + target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) +endif () + +file(GLOB nml_files CN_CLM51.nml ) + +install( + FILES ${nml_files} + DESTINATION etc + ) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CN_CLM51.nml b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CN_CLM51.nml new file mode 100644 index 000000000..4f320caec --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/CN_CLM51.nml @@ -0,0 +1,356 @@ +! +! namelist of CLM configuration inputs +! +! jkolassa, 19 Jan 2023 +! -------------------------------------------------------------------- + +&cnphenology +!---------- +! PHENOLOGY +!---------- +! ---------------------------------------------------------------------- +! initial_seed_at_planting +! +! CLM defaults: +! 3.d00 +! 3.d00 +! 1.d00 + +initial_seed_at_planting = 3.d00 + +!----------------------------------------------------------------------- +! onset_thresh_depends_on_veg +! +! CLM defaults: +! .true. +! .false. + +onset_thresh_depends_on_veg = .false. + +!----------------------------------------------------------------------- +! min_crtical_dayl_depends_on_lat +! +! CLM defaults: +! .true. +! .false. + +min_crtical_dayl_depends_on_lat = .false. + +!----------------------------------------------------------------------- +/ +&cnfire_inparm +!-------- +! FIRE +!-------- +!----------------------------------------------------------------------- +! fire_method +! +! OPTIONS: +! +! +! No Fire : nofire +! Li et al, 2014 : li2014qianfrc +! Li et al, 2016 : li2016crufrc +! Li et al, 2021 : li2021gswpfrc + +fire_method = 'li2021gswpfrc' + +!----------------------------------------------------------------------- +/ +&lifire_inparm +!-------- +! FIRE +!-------- +!----------------------------------------------------------------------- +! fire_method +! +! CLM DEFAULTS: +! +!30.0d00 +!80.0d00 +!0.3d00 +!0.7d00 +!0.035d00 +!4.2d-5 +!0.0035d00 +!0.001d00 +!0.3d00 +!0.39d00 +!75.d00 +!1050.d00 +!0.5d00 +!0.25d00 +! +!30.0d00 +!30.0d00 +!20.0d00 +!80.0d00 +!0.85d00 +!0.98d00 +!0.033d00 +!0.09d-4 +!0.010d00 +!0.010d00 +!0.008d00 +!0.17d-3 +!1.6d-4 +!0.33d00 +!105.d00 +!1050.d00 +!0.5d00 +!0.28d00 +! +!30.0d00 +!80.0d00 +!0.85d00 +!0.98d00 +!0.025d00 +!0.09d-4 +!0.010d00 +!0.17d-3 +!1.6d-4 +!0.33d00 +!75.d00 +!1050.d00 +!0.5d00 +!0.28d00 + +! +cli_scale = 0.033d00 +boreal_peatfire_c = 0.09d-4 +pot_hmn_ign_counts_alpha = 0.010d00 +non_boreal_peatfire_c = 0.17d-3 +cropfire_a1 = 1.6d-4 +rh_low = 30.0d00 +rh_hgh = 80.0d00 +bt_min = 0.85d00 +bt_max = 0.98d00 +occur_hi_gdp_tree = 0.33d00 +lfuel = 105.d00 +ufuel = 1050.d00 +cmb_cmplt_fact_litter = 0.5d00 +cmb_cmplt_fact_cwd = 0.28d00 + + + +! -------------------------------------------------------------------- +/ +&mineral_nitrogen_dynamics +!-------- +! CN NITROGEN DYNAMICS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +!0.0117d00 +!0.0006d00 +! + +freelivfix_intercept = 0.0117d00 +freelivfix_slope_wET = 0.0006d00 + +! -------------------------------------------------------------------- +/ +&photosyns_inparm +!-------- +! PHOTOSYNTHESIS PARAMETERS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +! +!.false. +!.false. +!.false. +! +! +!.true. +!.true. +!.false. +! +! +!2 +!2 +!1 +!0 +! +! +!.true. +!.true. +!.false. +! +! +!Medlyn2011 +!Ball-Berry1987 +!Medlyn2011 +!Ball-Berry1987 +!Ball-Berry1987 + + +rootstem_acc = .false. +light_inhibit = .true. +leafresp_method = 2 +stomatalcond_method = 'Medlyn2011' +modifyphoto_and_lmr_forcrop = .true. + +! -------------------------------------------------------------------- +/ +&clm_canopy_inparm +!-------- +! CANOPY STATE PARAMETERS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +! +!0.015d00 +!0.015d00 +!0.015d00 + +leaf_mr_vcm = 0.015d00 + + +! -------------------------------------------------------------------- +/ +&CENTURY_soilBGCDecompCascade +!-------- +! PARAMETER FOR BGC SOIL DECOMPOSITION CASCADE +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +! +!20.0d00, 20.0d00, 20.0d00 +!200.0d00, 200.0d00, 200.0d00 +!200.0d00, 200.0d00, 200.0d00 +!20.0d00, 20.0d00, 20.0d00 +!200.0d00, 200.0d00, 200.0d00 +!200.0d00, 200.0d00, 200.0d00 +! +!1.50d00 +!1.50d00 +!0.3 +!1.50d00 +!1.50d00 +!0.3 + + +initial_cstocks = 200.0d00, 200.0d00, 200.0d00 +initial_cstocks_depth = 1.50d00 + +! -------------------------------------------------------------------- +/ +&cnmresp_inparm +!-------- +! RESPIRATION PARAMETERS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +!0.83d-06 + +br_root = 0.83d-06 + +! -------------------------------------------------------------------- +/ + +&cnvegcarbonstate +!-------- +! RESPIRATION PARAMETERS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +!100.d00 +!100.d00 +!20.d00 +!1.d00 +!1.d00 +!1.d00 + + +initial_vegC = 100.d00 + +! -------------------------------------------------------------------- +/ +&surfacealbedo_inparm +!-------- +! SURFACE ALBEDO PARAMETERS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +!snowveg_affects_radiation>.true. + +snowveg_affects_radiation = .true. + +! -------------------------------------------------------------------- +/ +&rooting_profile_inparm +!-------- +! ROOT PROFILE PARAMETERS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +! +!1 +!1 +!0 +! +!1 +!1 +!1 + +rooting_profile_method_water = 1 +rooting_profile_method_carbon = 1 + +! -------------------------------------------------------------------- +/ +&bgc_shared +!-------- +! BGC PARAMETERS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +! +!0.5 +!10.0 +!10.0 +! +! +!.false. +!.true. +!.true. + +decomp_depth_efolding = 10.0 +constrain_stress_deciduous_onset = .true. + +! -------------------------------------------------------------------- +/ +&clm_soilstate_inparm +!-------- +! SOIL STATE PARAMETERS +!-------- +!----------------------------------------------------------------------- +! +! CLM DEFAULTS: +! +!.true. +!.false. +!.false. + +organic_frac_squared = .false. + +! -------------------------------------------------------------------- +/ + + +! =========================== EOF ======================================= 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/GEOScatchCNCLM51_GridComp/GEOS_CatchCNCLM51GridComp.F90 similarity index 81% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/GEOS_CatchCNCLM51GridComp.F90 index 1d87167a4..feab6070f 100644 --- 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/GEOScatchCNCLM51_GridComp/GEOS_CatchCNCLM51GridComp.F90 @@ -4,7 +4,7 @@ #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_CatchCNCLM45GridCompMod +module GEOS_CatchCNCLM51GridCompMod !BOP ! !MODULE: GEOS_CatchCN --- ESMF gridded component implementing CatchmentCN LSM @@ -28,14 +28,16 @@ module GEOS_CatchCNCLM45GridCompMod ! ! !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 compute_rc_mod - use CN_DriverMod + use CNCLM_DriverMod + use CNCLM_Photosynthesis + use CNCLM_initMod USE STIEGLITZSNOW, ONLY : & StieglitzSnow_snow_albedo, & StieglitzSnow_calc_tpsnow, & @@ -47,28 +49,30 @@ module GEOS_CatchCNCLM45GridCompMod 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, & + USE CATCH_CONSTANTS, ONLY : & + N_SNOW => CATCH_N_SNOW, & + N_GT => CATCH_N_GT, & + DZGT => CATCH_DZGT, & + DZTSURF => CATCH_DZTSURF, & + 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, & + 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 - use pftvarcon, only: noveg - USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, & - catch_calc_zbar, catch_calc_peatclsm_waterlevel, irrigation_rate, & - gndtmp + use MAPL_ConstantsMod,only: Tzero => MAPL_TICE, pi => MAPL_PI, MAPL_RHOWTR + 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_peatclsm_waterlevel, catch_calc_zbar, gndtmp, get_Z0_FORMULATION_params use update_model_para4cn, only : upd_curr_date_time + use WaterType + use CNVegetationFacade use catch_wrap_stateMod implicit none @@ -105,11 +109,10 @@ module GEOS_CatchCNCLM45GridCompMod ! 7: BARE SOIL ! 8: DESERT -integer :: NUM_ENSEMBLE integer,parameter :: NTYPS = MAPL_NUMVEGTYPES +real, parameter :: SAI4ZVG(NTYPS) = (/ 0.60653, 0.60653, 0.60653, 1.0, 1.0, 1.0 /) 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 @@ -167,7 +170,6 @@ module GEOS_CatchCNCLM45GridCompMod ! index map for CLM PFTs --> catchment veg types - contains !BOP @@ -198,9 +200,10 @@ subroutine SetServices ( GC, RC ) ! Local Variables type(MAPL_MetaComp), pointer :: MAPL=>null() - integer :: OFFLINE_MODE, RUN_IRRIG, ATM_CO2, N_CONST_LAND4SNWALB - integer :: RESTART, SNOW_ALBEDO_INFO + integer :: OFFLINE_MODE, ATM_CO2, SNOW_ALBEDO_INFO, MOSFC_EXTRA_DERIVS_OFFL_LAND, N_CONST_LAND4SNWALB + integer :: RESTART + ! Begin... ! -------- @@ -216,16 +219,20 @@ subroutine SetServices ( GC, RC ) ! 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 - + + ! resource variables for offline GEOSldas; for documentation, see GEOSldas/src/Applications/LDAS_App/GEOSldas_LDAS.rc + ! + ! NOTE: In SetServices(), the internal state ("catchcn_internal") has not yet been passed down from the parent (CatchCN), + ! so it should not be used. + 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) + call MAPL_GetResource ( MAPL, OFFLINE_MODE, Label="CATCHMENT_OFFLINE:", DEFAULT=0, _RC) + call MAPL_GetResource ( MAPL, ATM_CO2, Label="ATM_CO2:", DEFAULT=2, _RC) + call MAPL_GetResource ( MAPL, N_CONST_LAND4SNWALB, Label="N_CONST_LAND4SNWALB:", DEFAULT=0, _RC) + call MAPL_GetResource ( MAPL, SNOW_ALBEDO_INFO, Label="SNOW_ALBEDO_INFO:", DEFAULT=0, _RC) + call MAPL_GetResource ( MAPL, MOSFC_EXTRA_DERIVS_OFFL_LAND, Label="MOSFC_EXTRA_DERIVS_OFFL_LAND:", DEFAULT=0, _RC) ! 0 is default for GCM only! ! Set the Run entry points ! ------------------------ @@ -347,7 +354,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'surface_downwelling_par_beam_flux',& + LONG_NAME = 'surface_downwelling_PAR_beam_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DRPAR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -356,7 +363,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'surface_downwelling_par_diffuse_flux',& + LONG_NAME = 'surface_downwelling_PAR_diffuse_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DFPAR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -428,7 +435,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) IF (ATM_CO2 == 4) THEN - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & SHORT_NAME = 'CO2SC', & LONG_NAME = 'CO2 Surface Concentration Bin 001', & UNITS = '1e-6', & @@ -448,7 +455,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& - LONG_NAME = 'greeness_fraction' ,& + LONG_NAME = 'vegetation_greenness_fraction' ,& UNITS = '1' ,& SHORT_NAME = 'GRN' ,& DIMS = MAPL_DimsTileOnly ,& @@ -842,7 +849,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'max_soil_water_content_above_wilting_point' ,& + LONG_NAME = 'maximum_soil_water_content_above_wilting_point' ,& UNITS = 'kg m-2' ,& SHORT_NAME = 'CDCR2' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -876,7 +883,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddInternalSpec(GC ,& LONG_NAME = 'soil_porosity' ,& - UNITS = '1' ,& + UNITS = 'm3 m-3' ,& SHORT_NAME = 'POROS' ,& FRIENDLYTO = trim(COMP_NAME) ,& DIMS = MAPL_DimsTileOnly ,& @@ -886,7 +893,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'wetness_at_wilting_point' ,& + LONG_NAME = 'soil_wilting_point_in_degree_of_saturation_units' ,& UNITS = '1' ,& SHORT_NAME = 'WPWET' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -1152,7 +1159,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'ground_temperature' ,& + LONG_NAME = 'surface_layer_soil_temperature',& UNITS = '1' ,& SHORT_NAME = 'TG' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -1164,7 +1171,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'interception_reservoir_capac',& + LONG_NAME = 'vegetation_interception_water_storage',& UNITS = 'kg m-2' ,& SHORT_NAME = 'CAPAC' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -1276,7 +1283,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddInternalSpec(GC ,& LONG_NAME = 'mean_catchment_temp_incl_snw',& UNITS = 'K' ,& - SHORT_NAME = 'TSURF' ,& + SHORT_NAME = 'TSURF' ,& ! legacy (and obsolete) internal spec w/ bad name; see ExportSpec TPSURF DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RESTART = RESTART ,& @@ -1382,9 +1389,9 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - if (SNOW_ALBEDO_INFO == 1) then + if (SNOW_ALBEDO_INFO == 1) then call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'effective_snow_albedo' ,& + LONG_NAME = 'effective_snow_reflectivity',& UNITS = '1' ,& SHORT_NAME = 'SNOWALB' ,& FRIENDLYTO = trim(COMP_NAME) ,& @@ -1418,7 +1425,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'surface_moisture_exchange_coffiecient',& + LONG_NAME = 'surface_moisture_exchange_coefficient',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'CQ' ,& DIMS = MAPL_DimsTileTile ,& @@ -1450,27 +1457,59 @@ subroutine SetServices ( GC, RC ) 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) + if (MOSFC_EXTRA_DERIVS_OFFL_LAND == 1) then + + ! for *analytical* extra derivatives in louissurface + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'delCH_delTVA', & + LONG_NAME = 'partial_derivative_of_CH_wrt_virtual_Tair', & + 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 = 'delCQ_delTVA', & + LONG_NAME = 'partial_derivative_of_CQ_wrt_virtual_Tair', & + 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) + elseif (MOSFC_EXTRA_DERIVS_OFFL_LAND >= 2) then + + ! for *numerical* extra derivatives in helfsurface and louissurface + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'partial_derivative_of_CH_wrt_canopy_temperature', & + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'delCH_delTC' ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartSkip ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = 'partial_derivative_of_CQ_wrt_canopy_specific_humidity', & + UNITS = 'kg m-2 s-1' ,& + SHORT_NAME = 'delCQ_delQC' ,& + DIMS = MAPL_DimsTileTile ,& + NUM_SUBTILES = NUM_SUBTILES ,& + VLOCATION = MAPL_VLocationNone ,& + RESTART = MAPL_RestartSkip ,& + RC=STATUS ) + VERIFY_(STATUS) + + end if call MAPL_AddInternalSpec(GC ,& LONG_NAME = 'catchment_tile_id' ,& @@ -1615,7 +1654,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'CN sum for ground temp' ,& + LONG_NAME = 'CN sum for surface layer soil temperature',& UNITS = 'K' ,& SHORT_NAME = 'TGWM' ,& DIMS = MAPL_DimsTileOnly ,& @@ -1778,16 +1817,16 @@ subroutine SetServices ( GC, RC ) 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 ,& + DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - UNGRIDDED_DIMS = (/NUM_VEG,NUM_ZON/) ,& + UNGRIDDED_DIMS = (/NUM_VEG,NUM_ZON/) ,& RESTART = MAPL_RestartOptional ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC ,& @@ -1797,10 +1836,33 @@ subroutine SetServices ( GC, RC ) 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 ) + 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' ,& @@ -1810,6 +1872,16 @@ subroutine SetServices ( GC, RC ) 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',& @@ -1830,6 +1902,37 @@ subroutine SetServices ( GC, RC ) RESTART = MAPL_RestartOptional ,& RC=STATUS ) VERIFY_(STATUS) + + call MAPL_AddInternalSpec(GC ,& + LONG_NAME = '10-day running mean of surface layer soil 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',& @@ -1850,7 +1953,18 @@ subroutine SetServices ( GC, RC ) 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' ,& @@ -1859,9 +1973,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RESTART = MAPL_RestartOptional ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + !---------- GOSWIM snow impurity related variables ---------- if (N_CONST_LAND4SNWALB /= 0) then @@ -1976,116 +2090,9 @@ subroutine SetServices ( GC, RC ) 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' ,& @@ -2115,7 +2122,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'runoff_flux' ,& + LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2124,7 +2131,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'interception_loss_energy_flux',& + LONG_NAME = 'interception_loss_latent_heat_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'EVPINT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2133,7 +2140,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'baresoil_evap_energy_flux' ,& + LONG_NAME = 'baresoil_evaporation_latent_heat_flux' ,& UNITS = 'W m-2' ,& SHORT_NAME = 'EVPSOI' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2142,7 +2149,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transpiration_energy_flux' ,& + LONG_NAME = 'transpiration_latent_heat_flux' ,& UNITS = 'W m-2' ,& SHORT_NAME = 'EVPVEG' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2151,7 +2158,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_ice_evaporation_energy_flux',& + LONG_NAME = 'snowpack_evaporation_latent_heat_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'EVPICE' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2170,7 +2177,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'totoal soil moisture' ,& + LONG_NAME = 'total_soil_moisture' ,& UNITS = 'kg m-2' ,& SHORT_NAME = 'WATSOI' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2188,7 +2195,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snowpack_evaporation_energy_flux',& + LONG_NAME = 'snowpack_evaporation_latent_heat_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'EVPSNO' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2196,7 +2203,7 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'baseflow_flux' ,& + LONG_NAME = 'baseflow_flux_land' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'BASEFLOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2204,7 +2211,6 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & LONG_NAME = 'snowmelt_flux' ,& UNITS = 'kg m-2 s-1' ,& @@ -2270,7 +2276,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'total_latent_energy_flux' ,& + LONG_NAME = 'total_latent_heat_flux_consistent_with_evaporation_from_turbulence' ,& UNITS = 'W m-2' ,& SHORT_NAME = 'HLATN' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2324,7 +2330,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_catchment_temp_incl_snw',& + LONG_NAME = 'surface_temperature_of_land_incl_snow',& UNITS = 'K' ,& SHORT_NAME = 'TPSURF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2333,7 +2339,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_top_snow_layer',& + LONG_NAME = 'surface_temperature_of_snow_on_land',& UNITS = 'K' ,& SHORT_NAME = 'TPSNOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2342,7 +2348,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_unsaturated_zone',& + LONG_NAME = 'surface_temperature_of_unsaturated_zone',& UNITS = 'K' ,& SHORT_NAME = 'TPUNST' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2351,7 +2357,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_saturated_zone',& + LONG_NAME = 'surface_temperature_of_saturated_zone',& UNITS = 'K' ,& SHORT_NAME = 'TPSAT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2360,7 +2366,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'temperature_wilted_zone' ,& + LONG_NAME = 'surface_temperature_of_wilting_zone' ,& UNITS = 'K' ,& SHORT_NAME = 'TPWLT' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2369,7 +2375,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'fractional_area_of_land_snowcover',& + LONG_NAME = 'fractional_area_of_snow_on_land',& UNITS = '1' ,& SHORT_NAME = 'ASNOW' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2432,7 +2438,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'snow_depth_within_snow_covered_area_fraction' ,& + LONG_NAME = 'snow_depth_within_snow_covered_area_fraction_on_land' ,& UNITS = 'm' ,& SHORT_NAME = 'SNOWDP' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2441,7 +2447,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_soil_wetness' ,& + LONG_NAME = 'soil_wetness_surface' ,& UNITS = '1' ,& SHORT_NAME = 'WET1' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2450,7 +2456,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'root_zone_soil_wetness' ,& + LONG_NAME = 'soil_wetness_rootzone' ,& UNITS = '1' ,& SHORT_NAME = 'WET2' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2459,7 +2465,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'ave_prof_soil__moisture' ,& + LONG_NAME = 'soil_wetness_profile' ,& UNITS = '1' ,& SHORT_NAME = 'WET3' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2468,7 +2474,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_surface_layer' ,& + LONG_NAME = 'soil_moisture_surface' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCSF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2477,7 +2483,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_root_zone' ,& + LONG_NAME = 'soil_moisture_rootzone' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCRZ' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2486,7 +2492,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'water_ave_prof' ,& + LONG_NAME = 'soil_moisture_profile' ,& UNITS = 'm3 m-3' ,& SHORT_NAME = 'WCPR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2495,7 +2501,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_1' ,& + LONG_NAME = 'soil_temperature_layer_1' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP1' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2504,7 +2510,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_2' ,& + LONG_NAME = 'soil_temperature_layer_2' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP2' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2513,7 +2519,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_3' ,& + LONG_NAME = 'soil_temperature_layer_3' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP3' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2522,7 +2528,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_4' ,& + LONG_NAME = 'soil_temperature_layer_4' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP4' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2531,7 +2537,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_5' ,& + LONG_NAME = 'soil_temperature_layer_5' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP5' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2540,7 +2546,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'soil_temperatures_layer_6' ,& + LONG_NAME = 'soil_temperature_layer_6' ,& UNITS = 'K' ,& ! units now K, rreichle & borescan, 6 Nov 2020 SHORT_NAME = 'TP6' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2558,7 +2564,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_visible_beam',& + LONG_NAME = 'surface_reflectivity_visible_beam',& UNITS = '1' ,& SHORT_NAME = 'ALBVR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2567,7 +2573,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_visible_diffuse',& + LONG_NAME = 'surface_reflectivity_visible_diffuse',& UNITS = '1' ,& SHORT_NAME = 'ALBVF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2576,7 +2582,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_near_infrared_beam',& + LONG_NAME = 'surface_reflectivity_near_infrared_beam',& UNITS = '1' ,& SHORT_NAME = 'ALBNR' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2585,7 +2591,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'surface_albedo_near_infrared_diffuse',& + LONG_NAME = 'surface_reflectivity_near_infrared_diffuse',& UNITS = '1' ,& SHORT_NAME = 'ALBNF' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2621,7 +2627,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - LONG_NAME = 'change_upward_sensible_energy_flux',& + LONG_NAME = 'change_upward_sensible_heat_flux',& UNITS = 'W m-2' ,& SHORT_NAME = 'DELSH' ,& DIMS = MAPL_DimsTileOnly ,& @@ -2854,20 +2860,18 @@ subroutine SetServices ( GC, RC ) 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 = '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', & + LONG_NAME = 'total_evapotranspiration_land', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2894,7 +2898,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DRPARLAND', & - LONG_NAME = 'surface_downwelling_par_beam_flux', & + LONG_NAME = 'surface_downwelling_PAR_beam_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2903,7 +2907,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DFPARLAND', & - LONG_NAME = 'surface_downwelling_par_diffuse_flux', & + LONG_NAME = 'surface_downwelling_PAR_diffuse_flux', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -2922,7 +2926,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWNETSNOW', & - LONG_NAME = 'Net_shortwave_snow', & + LONG_NAME = 'Net_shortwave_flux_snow', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3006,7 +3010,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWLAND', & - LONG_NAME = 'Net_shortwave_land', & + LONG_NAME = 'Net_shortwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3015,7 +3019,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SWDOWNLAND', & - LONG_NAME = 'Incident_shortwave_land', & + LONG_NAME = 'Incident_shortwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3025,7 +3029,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'LWLAND', & - LONG_NAME = 'Net_longwave_land', & + LONG_NAME = 'Net_longwave_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3035,7 +3039,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHLAND', & - LONG_NAME = 'Ground_heating_land', & + LONG_NAME = 'Ground_heating_flux_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3044,7 +3048,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'GHTSKIN', & - LONG_NAME = 'Ground_heating_skin_temp', & + LONG_NAME = 'Ground_heating_flux_for_skin_temp_land', & UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3063,7 +3067,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'TWLAND', & - LONG_NAME = 'Avail_water_storage_land', & + LONG_NAME = 'total_water_storage_land', & UNITS = 'kg m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3108,8 +3112,17 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SPLAND', & - LONG_NAME = 'rate_of_spurious_land_energy_source',& + SHORT_NAME = 'SPLAND', & ! a.k.a. SPSHLAND + LONG_NAME = 'Spurious_sensible_heat_flux_land',& + UNITS = 'W m-2', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'SPLH', & + LONG_NAME = 'Spurious_latent_heat_flux_land',& UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3117,8 +3130,8 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'SPWATR', & - LONG_NAME = 'rate_of_spurious_land_water_source',& + SHORT_NAME = 'SPWATR', & ! a.k.a. SPEVLAND + LONG_NAME = 'Spurious_evapotranspiration_flux_land',& UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3127,7 +3140,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'SPSNOW', & - LONG_NAME = 'rate_of_spurious_snow_energy',& + LONG_NAME = 'Spurious_snow_energy_flux_land',& UNITS = 'W m-2', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & @@ -3224,6 +3237,25 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'CN_total_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_total_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' ,& @@ -3567,7 +3599,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddExportSpec(GC ,& LONG_NAME = 'solar induced fluorescence',& UNITS = 'umol m-2 sm s-1' ,& - SHORT_NAME = 'SIF' ,& + SHORT_NAME = 'SIF' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RC=STATUS ) @@ -3681,31 +3713,139 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_TSOIL1',& + UNITS = 'm' ,& + SHORT_NAME = 'DZGT1' ,& + 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="-CATCHCNCLM45" ,RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="-ALBEDO" ,RC=STATUS) - VERIFY_(STATUS) + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_TSOIL2',& + UNITS = 'm' ,& + SHORT_NAME = 'DZGT2' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) -! Set generic init and final method -! --------------------------------- + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_TSOIL3',& + UNITS = 'm' ,& + SHORT_NAME = 'DZGT3' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) - call MAPL_GenericSetServices ( GC, RC=STATUS ) - VERIFY_(STATUS) + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_TSOIL4',& + UNITS = 'm' ,& + SHORT_NAME = 'DZGT4' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) - RETURN_(ESMF_SUCCESS) + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_TSOIL5',& + UNITS = 'm' ,& + SHORT_NAME = 'DZGT5' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_TSOIL6',& + UNITS = 'm' ,& + SHORT_NAME = 'DZGT6' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_PRMC_and_GWETPROF',& + UNITS = 'm' ,& + SHORT_NAME = 'DZPR' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_RZMC_and_GWETROOT',& + UNITS = 'm' ,& + SHORT_NAME = 'DZRZ' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_SFMC_and_GWETTOP',& + UNITS = 'm' ,& + SHORT_NAME = 'DZSF' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'thickness_of_soil_layer_associated_with_TSATLAND_TUNSTLAND_and_TWLTLAND',& + UNITS = 'm' ,& + SHORT_NAME = 'DZTS' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'soil_wilting_point_in_equivalent_mass_of_total_profile_water',& + UNITS = 'kg m-2' ,& + SHORT_NAME = 'WPEMW' ,& + DIMS = MAPL_DimsTileOnly ,& + VLOCATION = MAPL_VLocationNone ,& + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC ,& + LONG_NAME = 'soil_wilting_point_in_volumetric_units',& + UNITS = 'm3 m-3' ,& + SHORT_NAME = 'WPMC' ,& + 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 @@ -3724,7 +3864,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Clock), intent(inout) :: CLOCK !The clock integer,optional, intent(out ) :: RC !Error code: -! !DESCRIPTION: Does the cds computation and roughness length +! !DESCRIPTION: Compute roughness length and exchange coefficients ("cds"), incl. derivatives !EOP ! ErrLog Variables @@ -3771,10 +3911,19 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, dimension(:,:), pointer :: CQ real, dimension(:,:), pointer :: FR real, dimension(:,:), pointer :: WW + + ! for analytical extra derivatives (louissurface) + + real, dimension(:,:), pointer :: delCH_delTVA + real, dimension(:,:), pointer :: delCQ_delTVA + + ! for numerical extra derivatives (louissurface, helfsurface) + + real, dimension(:,:), pointer :: delCH_delTC + real, dimension(:,:), pointer :: delCQ_delQC + real, dimension(:,:), pointer :: cncol real, dimension(:,:), pointer :: cnpft - real, dimension(:,:), pointer :: DCH - real, dimension(:,:), pointer :: DCQ ! ----------------------------------------------------- ! EXPORT Pointers @@ -3854,7 +4003,26 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, allocatable :: PSMB(:) real, allocatable :: PSL(:) integer :: niter + + integer :: CHOOSEZ0 real :: SCALE4Z0 + real :: SCALE4ZVG + real :: MIN_VEG_HEIGHT + + ! ------------------------------------- + ! + ! for numerical extra derivatives (louissurface, helfsurface) + + real, parameter :: MOSFC_pert_fac = 0.001 ! size of multiplicative pert for numerical derivatives + + ! Louis needs 2d arrays; Helfand would work with 1d arrays but use 2d arrays to avoid "if" statements + + real, dimension(:,:), allocatable :: DeltaTC, CHpert + real, dimension(:,:), allocatable :: DeltaQC, CQpert + + real, dimension(:,:), allocatable :: DummyZ0T, DummyCM + + ! ------------------------------------- ! gkw: for CN model ! ----------------- @@ -3864,16 +4032,22 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) 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*8, save :: istep_cn = 1 ! gkw: legacy variable from offline + integer(INT64), save :: istep_cn = 0 ! gkw: legacy variable from offline + real :: ndt + integer(INT64) :: nstep_cn + character(len=ESMF_MAXSTR) :: cnclm51_paramfile ! Offline mode type(CATCHCN_WRAP) :: wrap type(T_CATCHCN_STATE), pointer :: catchcn_internal - integer :: OFFLINE_MODE, CHOOSEZ0 + integer :: OFFLINE_MODE !============================================================================= ! Begin... @@ -3891,8 +4065,8 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! 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 + catchcn_internal => wrap%ptr + OFFLINE_MODE = catchcn_internal%CATCH_OFFLINE ! shorthand call ESMF_VMGetCurrent ( VM, RC=STATUS ) ! if (MAPL_AM_I_Root(VM)) print *, trim(Iam)//'::OFFLINE mode: ', is_OFFLINE @@ -3912,17 +4086,18 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get parameters from generic state ! --------------------------------- - call MAPL_Get ( MAPL ,& - INTERNAL_ESMF_STATE=INTERNAL ,& - RC=STATUS ) + call MAPL_Get ( MAPL ,& + TILELATS = LATS ,& ! [radians] + TILELONS = LONS ,& ! [radians] + 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) - + VERIFY_(STATUS) + call ESMF_VMGetCurrent(VM, rc=STATUS) + VERIFY_(STATUS) + ! Pointers to inputs !------------------- @@ -3972,14 +4147,27 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,WW , 'WW' , RC=STATUS) VERIFY_(STATUS) + + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND == 1) then + + call MAPL_GetPointer(INTERNAL,delCH_delTVA , 'delCH_delTVA' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,delCQ_delTVA , 'delCQ_delTVA' , RC=STATUS) + VERIFY_(STATUS) + + elseif (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND >= 2) then + + call MAPL_GetPointer(INTERNAL,delCQ_delQC , 'delCQ_delQC' , RC=STATUS) + VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,delCH_delTC , 'delCH_delTC' , RC=STATUS) + VERIFY_(STATUS) + + end if + 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 !-------------------- @@ -4120,6 +4308,21 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) allocate(IWATER(NT),STAT=STATUS) VERIFY_(STATUS) + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND>=2) then + + ! allocate variables for numerical extra derivatives (louissurface, helfsurface) + + allocate(DeltaTC( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + allocate(DeltaQC( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + + allocate(CHpert( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + allocate(CQpert( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + + allocate(DummyZ0T(NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + allocate(DummyCM( NT,NUM_SUBTILES),STAT=STATUS); VERIFY_(STATUS) + + end if + allocate( ityp(nt,nveg,nzone) ) allocate( fveg(nt,nveg,nzone) ) allocate( wtzone(nt,nzone) ) @@ -4136,13 +4339,9 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) 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 - elsewhere - VEG1 = map_cat(nint(ITY(:,2))) ! gkw: primary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 endwhere - where(ITY(:,3) > 0.) - VEG2 = map_cat(nint(ITY(:,3))) ! gkw: secondary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 - elsewhere - VEG2 = map_cat(nint(ITY(:,4))) ! gkw: secondary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 + 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') @@ -4166,8 +4365,8 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) END DO - FVG1 = fvg(:,1) + fvg(:,2) ! gkw: primary vegetation fraction - FVG2 = fvg(:,3) + fvg(:,4) ! gkw: secondary vegetation fraction + FVG1 = fvg(:,1) + FVG2 = fvg(:,2) ! set CLM CN PFT & fraction, set carbon zone weights ! -------------------------------------------------- @@ -4177,11 +4376,26 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) 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) + +! read CNCLM51 parameter file +!----------------------------- + + call MAPL_GetResource (MAPL, cnclm51_paramfile, label = 'CNCLM51_PARAM_FILE:', default = 'ctsm51_params.c210923_forCNCLM.nc', RC=STATUS ) + VERIFY_(STATUS) + ! initialize CN model and transfer restart variables on startup ! ------------------------------------------------------------- if(first) then - call CN_init(istep_cn,nt,nveg,nzone,ityp,fveg,var_col,var_pft,cncol=cncol,cnpft=cnpft) - call get_CN_LAI(nt,nveg,nzone,ityp,fveg,elai,esai=esai) + call CN_init(catchcn_internal%CN_CLM51_NML_FILE,nt,ityp,fveg,cncol,cnpft,lats,lons,catchcn_internal%DTCN,cnclm51_paramfile,water_inst,bgc_vegetation_inst,.true.) + call get_CN_LAI(nt,ityp,fveg,elai,esai=esai) first = .false. endif @@ -4195,25 +4409,23 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! obtain LAI from previous time step (from CN model) ! -------------------------------------------------- - call get_CN_LAI(nt,nveg,nzone,ityp,fveg,elai,esai=esai,tlai=tlai) - + call get_CN_LAI(nt,ityp,fveg,elai,esai=esai,tlai=tlai) + lai1 = 0. wght = 0. do nz = 1,nzone - do nv = 1,2 - lai1(:) = lai1(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) - wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) - end do + 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 - do nv = 3,4 - lai2(:) = lai2(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) - wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) - end do + 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 @@ -4251,82 +4463,229 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated( MOU2M)) MOU2M = 0.0 if(associated( MOV2M)) MOV2M = 0.0 + call get_Z0_FORMULATION_params( CATCHCN_INTERNAL%Z0_FORMULATION, & + MIN_VEG_HEIGHT, SCALE4ZVG, SCALE4Z0 ) + SUBTILES: do N=1,NUM_SUBTILES + + ! jkolassa Jul 2025: For Z0-formulation == 4 use old (6-class) veg type + ! and mix two veg types + ! Consider updating to a 15-PFT resolution in the future + if (CATCHCN_INTERNAL%Z0_FORMULATION == 4) then + ! make canopy height >= min veg height: + Z2CH = max(Z2CH,MIN_VEG_HEIGHT) + ZVG = fvg1*(Z2CH - SAI4ZVG(VEG1)*SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI1)) + & + fvg2*(Z2CH - SAI4ZVG(VEG2)*SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI2)) + else + ZVG = fvg1*(Z2CH - SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI1)) + & + fvg2*(Z2CH - SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI2)) + endif + + ! For now roughnesses and displacement heights are the same for all subtiles. + + Z0T(:,N) = Z0_BY_ZVEG*ZVG*SCALE4Z0 + + IF (catchcn_internal%USE_ASCATZ0 == 1) THEN + WHERE (NDVI <= 0.2) + Z0T(:,N) = ASCATZ0 + END WHERE + ENDIF + + D0T = D0_BY_ZVEG*ZVG -! 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.) + 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) +! Compute surface exchange coefficients +!--------------------------------------- + + call MAPL_TimerOn(MAPL,"-SURF") ! timer for computation of MOSFC exchange coeffs and derivs (Louis or Helfand) + + if (CATCHCN_INTERNAL%CHOOSEMOSFC.eq.0) then - 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. + ! Louis surface turbulence + + WW(:,N) = 0. + CM(:,N) = 0. + + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND==1) then + + ! analytical extra derivatives (default for Louis) + + 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,delCH_delTVA,delCQ_delTVA) + + else + + ! none .or. numerical extra derivatives + + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND>=2) then + + ! Prep calculation of numerical extra derivatives. Start with calling louissurface with perturbed inputs and + ! save only the perturbed exchange coeffs. The final call with nominal inputs produces the unperturbed + ! exchange coeffs and other outputs (CN, RIB, ZT, ZQ, etc). + ! Must use properly initialized dummmies for Z0T and CM because these are intent(inout). + + ! perturb TC: send in (TC+DeltaTC), get back CHpert + + DeltaTC = MOSFC_pert_fac*TC + + DummyZ0T = Z0T + DummyCM = CM + + call louissurface( 3,N,UU,WW,PS,TA,TC+DeltaTC,QA,QC ,PCU,LAI,DummyZ0T,DZE,DummyCM,CN,RIB,ZT,ZQ,CHpert,CQ ,UUU,UCN,RE) + + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND==2) then + + ! perturb QC: send in (QC+DeltaQC), get back CQpert + + DeltaQC = MOSFC_pert_fac*QC + + DummyZ0T = Z0T + DummyCM = CM + + call louissurface(3,N,UU,WW,PS,TA,TC ,QA,QC+DeltaQC,PCU,LAI,DummyZ0T,DZE,DummyCM,CN,RIB,ZT,ZQ,CH ,CQpert,UUU,UCN,RE) + + end if + + end if + + ! Call with nominal inputs [after calls with perturbed inputs to obtain correct outputs (CN, RIB, ZT, ZQ, etc.)] + + 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) + + end if ! MOSFC_EXTRA_DERIVS_OFFL_LAND + + elseif (CATCHCN_INTERNAL%CHOOSEMOSFC.eq.1)then + + ! Helfand surface turbulence + + 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)) ) ) + + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND==2) then + + ! Prep calculation of numerical extra derivatives. Start with calling louissurface with perturbed inputs and + ! save only the perturbed exchange coeffs. The final call with nominal inputs produces the unperturbed + ! exchange coeffs and other outputs (CN, RIB, ZT, ZQ, etc). + ! Must use properly initialized dummmies for Z0T and CM because these are intent(inout). + + ! perturb TC: send in (TC+DeltaTC), get back CHpert + + DeltaTC( :,N) = MOSFC_pert_fac*TC(:,N) + + DummyZ0T(:,N) = Z0T(:,N) + + CALL helfsurface(UWINDLMTILE,VWINDLMTILE,TA,TC(:,N)+DeltaTC(:,N),QA,QC(:,N) ,PSL,PSMB,DummyZ0T(:,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) + + CHpert( :,N) = VKH + + ! perturb QC: send in (QC+DeltaQC), get back CQpert + + DeltaQC( :,N) = MOSFC_pert_fac*QC(:,N) + + DummyZ0T(:,N) = Z0T(:,N) + + CALL helfsurface(UWINDLMTILE,VWINDLMTILE,TA,TC(:,N) ,QA,QC(:,N)+DeltaQC(:,N),PSL,PSMB,DummyZ0T(:,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) + + CQpert( :,N) = VKH + + end if ! MOSFC_EXTRA_DERIVS_OFFL_LAND==2 + + ! Call with nominal inputs [after calls with perturbed inputs to obtain correct outputs (Z0T, [*]2m, [*]10m, etc.)] + + 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) - + 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 ! CHOOSEMOSFC + + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND==2) then + + ! finalize numerical derivatives + + delCH_delTC(:,N) = (CHpert(:,N) - CH(:,N)) / DeltaTC(:,N) + delCQ_delQC(:,N) = (CQpert(:,N) - CQ(:,N)) / DeltaQC(:,N) + + elseif (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND==3) then + + ! finalize numerical derivatives (valid for Louis only!) + + ! For Louis, the exchange coeffs depend only on the *virtual* temperature (not true for Helfand). + ! + ! This lets us compute the derivatives of the exchange coefficients w.r.t. both TC and QC from + ! just one additional call to louissurface() with perturbed TC. + ! + ! In the following, "del" indicates a derivative and "Delta" indicates a difference term. + ! + ! We have: + ! + ! (1) CH = CQ + ! + ! (2) TVC = TC*(1 + eps*QC) (virtual temperature; eps = MAPL_VIREPS) + ! + ! (2a) ==> delTVC_delQC = eps*TC + ! + ! (2b) ==> DeltaTVC = (TVCpert - TVC) = TCpert*(1 + eps*QC) - TC*(1 + eps*QC) = DeltaTC*(1 + eps*QC) + ! + ! (3) delCH_delTC = (CHpert - CH)/DeltaTC + ! + ! (4) delCH_delTVC = (CHpert - CH)/DeltaTVC = (CHpert - CH)/(DeltaTC*(1 + eps*QC)) + ! + ! Using (1)-(4), we have: + ! + ! delCQ_delQC = delCH_delQC using (1) + ! + ! = delCH_delTVC * delTVC_delQC using chain rule + ! + ! = (CHpert - CH)/(DeltaTC*(1 + eps*QC)) * delTVC_delQC using (4) + ! + ! = (CHpert - CH)/DeltaTC * 1/(1+eps*QC) * eps*TC using (2a) + ! + ! = delCH_delTC * 1/(1+eps*QC) * eps*TC using (3) + + delCH_delTC(:,N) = (CHpert(:,N) - CH(:,N)) / DeltaTC(:,N) + + delCQ_delQC(:,N) = delCH_delTC(:,N) * MAPL_VIREPS*TC(:,N)/(1.+MAPL_VIREPS*QC(:,N)) + endif + call MAPL_TimerOff(MAPL,"-SURF") ! Aggregate to tile @@ -4403,7 +4762,15 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) deallocate(IWATER) deallocate(PSMB) deallocate(PSL) - + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND>=2) then + deallocate(DeltaTC ) + deallocate(DeltaQC ) + deallocate(CHpert ) + deallocate(CQpert ) + deallocate(dummyZ0T) + deallocate(dummyCM ) + end if + ! All done ! ------------------------------------------------------------------------------ @@ -4442,12 +4809,18 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Local derived type aliases ! ------------------------------------------------------------------------------ - type(MAPL_MetaComp),pointer :: MAPL - type(ESMF_Alarm) :: ALARM - integer :: IM,JM + type(MAPL_MetaComp),pointer :: MAPL + type(ESMF_Alarm) :: ALARM + + integer :: IM,JM - real :: SCALE4Z0 + real :: SCALE4ZVG + real :: SCALE4Z0 + real :: MIN_VEG_HEIGHT + type(ESMF_VM) :: VM + type (T_CATCHCN_STATE), pointer :: CATCHCN_INTERNAL + type (CATCHCN_WRAP) :: wrap ! ------------------------------------------------------------------------------ ! Begin: Get the target components name and ! set-up traceback handle. @@ -4463,14 +4836,21 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) + ! Get component's private internal state + call ESMF_UserCompGetInternalState(gc, 'CatchcnInternal', wrap, status) + VERIFY_(status) + CATCHCN_INTERNAL=>wrap%ptr + ! Get parameters from generic state. !----------------------------------- call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS) VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, SCALE4Z0, Label="SCALE4Z0:", DEFAULT=0.5, RC=STATUS) - VERIFY_(STATUS) + call ESMF_VMGetCurrent(VM, rc=STATUS) + + call get_Z0_FORMULATION_params( CATCHCN_INTERNAL%Z0_FORMULATION, & + MIN_VEG_HEIGHT, SCALE4ZVG, SCALE4Z0 ) ! ------------------------------------------------------------------------------ ! If its time, recalculate the LSM tile routine @@ -4634,8 +5014,10 @@ subroutine Driver ( RC ) real, dimension(:,:), pointer :: cm real, dimension(:,:), pointer :: cq real, dimension(:,:), pointer :: fr - real, dimension(:,:), pointer :: dcq - real, dimension(:,:), pointer :: dch + real, dimension(:,:), pointer :: delCQ_delTVA + real, dimension(:,:), pointer :: delCH_delTVA + real, dimension(:,:), pointer :: delCH_delTC + real, dimension(:,:), pointer :: delCQ_delQC real, dimension(:), pointer :: tile_id real, dimension(:), pointer :: ndep real, dimension(:), pointer :: abm @@ -4668,7 +5050,10 @@ subroutine Driver ( RC ) 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 @@ -4679,17 +5064,14 @@ subroutine Driver ( RC ) 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 @@ -4784,6 +5166,7 @@ subroutine Driver ( RC ) real, dimension(:), pointer :: DWLAND real, dimension(:), pointer :: DHLAND real, dimension(:), pointer :: SPLAND + real, dimension(:), pointer :: SPLH real, dimension(:), pointer :: SPWATR real, dimension(:), pointer :: SPSNOW @@ -4796,6 +5179,8 @@ subroutine Driver ( RC ) 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 @@ -4842,25 +5227,39 @@ subroutine Driver ( RC ) 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 + + real, dimension(:), pointer :: RMELTDU001 + real, dimension(:), pointer :: RMELTDU002 + real, dimension(:), pointer :: RMELTDU003 + real, dimension(:), pointer :: RMELTDU004 + real, dimension(:), pointer :: RMELTDU005 + real, dimension(:), pointer :: RMELTBC001 + real, dimension(:), pointer :: RMELTBC002 + real, dimension(:), pointer :: RMELTOC001 + real, dimension(:), pointer :: RMELTOC002 + + real, dimension(:), pointer :: PEATCLSM_WATERLEVEL + real, dimension(:), pointer :: PEATCLSM_FSWCHANGE + + real, dimension(:), pointer :: DZGT1 + real, dimension(:), pointer :: DZGT2 + real, dimension(:), pointer :: DZGT3 + real, dimension(:), pointer :: DZGT4 + real, dimension(:), pointer :: DZGT5 + real, dimension(:), pointer :: DZGT6 + real, dimension(:), pointer :: DZPR + real, dimension(:), pointer :: DZRZ + real, dimension(:), pointer :: DZSF + real, dimension(:), pointer :: DZTS + real, dimension(:), pointer :: WPEMW + real, dimension(:), pointer :: WPMC ! -------------------------------------------------------------------------- ! Local pointers for tile variables ! -------------------------------------------------------------------------- INTEGER,pointer,dimension(:) :: CAT_ID - real,pointer,dimension(:) :: dzsf + real,pointer,dimension(:) :: DZSF_in_mm real,pointer,dimension(:) :: swnetfree real,pointer,dimension(:) :: swnetsnow real,pointer,dimension(:) :: qa1 @@ -4883,11 +5282,10 @@ subroutine Driver ( RC ) 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(:) :: WCHANGE, ECHANGE, HSNACC, LHOUT, EVACC, LHACC, 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 @@ -4904,7 +5302,7 @@ subroutine Driver ( RC ) real,pointer,dimension(:,:) :: evsbt real,pointer,dimension(:,:) :: devsbt real,pointer,dimension(:,:) :: DEDTC - real,pointer,dimension(:,:) :: DHSDQA + real,pointer,dimension(:,:) :: DHSDQC real,pointer,dimension(:,:) :: CFT real,pointer,dimension(:,:) :: RA real,pointer,dimension(:,:) :: CFQ @@ -4996,8 +5394,7 @@ subroutine Driver ( RC ) ! 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 @@ -5026,29 +5423,26 @@ subroutine Driver ( RC ) integer, parameter :: nveg = num_veg ! number of vegetation types integer, parameter :: nzone = num_zon ! number of stress zones - real, allocatable, dimension(:) :: btran, wgt, bt1, bt2, bt4, wpp, fwet - real, allocatable, dimension(:) :: sm1, sm2, sm4 ! soil water as frac of WHC for the 3 dydrological zones at root depth + 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(:) :: btran1, btran2, btran3, tcx, qax - real, allocatable, dimension(:) :: rcx, rcxdt, rcxdq, tx1, tx2, tx3, qx1, qx2, qx3 - real, allocatable, dimension(:,:) :: tgw, rzm, sfm, rc00, rcdt,rcdq, totcolc, wtzone - real, allocatable, dimension(:,:,:) :: elai,esai,fveg,tlai,psnsun,psnsha,laisun,laisha,lmrsun,lmrsha + 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, & + sifsun, sifsha 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, padd, frootc, vegc, xsmr,burn, closs + 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 - real, allocatable, dimension(:) :: bt1_sf, bt2_sf, bt4_sf - real, allocatable, dimension(:) :: btran1_sf, btran2_sf, btran3_sf - real, allocatable, dimension(:,:) :: btran_fire_rz ! root zone soil wetness, used to compute btran2 for CNFireMod - real, allocatable, dimension(:,:) :: btran_fire_sf ! surface soil wetness, used to compute btran2 for CNFireMod - real, allocatable, dimension(:) :: lats_degree, lons_degree ! *************************************************************************************************************************************************************** ! Begin Carbon Tracker variables @@ -5101,11 +5495,10 @@ subroutine Driver ( RC ) real, allocatable, dimension(:) :: Qair_relative ! relative humidity (%) integer :: nz, iv - real :: cn1, cn2, cn3, cn12, cn23, ar, f1, f2, f3, f4, ax1, ax2, ax4 + real :: cn1, cn2, cn3, cn12, cn23, ar, ax1, ax2, ax4 + real, dimension(fsat:fwlt) :: f1, f2, f3, f4 - real, allocatable, dimension(:,:) :: psnsunx,psnshax,sifsunx,sifshax,laisunx,laishax, lmrsunx, lmrshax - real, allocatable, dimension(:,:) :: elaz,esaz,fvez, tlaz, albdir, albdif - integer, allocatable, dimension(:,:) :: ityz + real, allocatable, dimension(:,:,:,:) :: albdir, albdif integer, allocatable, dimension(:) :: ityp_tmp ! static summing arrays for CN @@ -5122,21 +5515,29 @@ subroutine Driver ( RC ) 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 = .false.! Always set to .FALSE.!! Will spin up and discard at least 2 years anyways. fzeng, July 2017 + logical, parameter :: init_accum = .false.! jkolassa May 2023: needs to be set to true if no CNCLM51 restart is available + logical, parameter :: init_accum_365 = .false.! 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*8, save :: istep_cn = 1 ! gkw: legacy variable from offline + integer(INT64), save :: istep_cn = 1 ! gkw: legacy variable from offline ! solar declination related real :: ob, declin, zs, zc, max_decl, max_dayl @@ -5155,8 +5556,10 @@ subroutine Driver ( RC ) type(ESMF_Alarm) :: RecordAlarm ! Variables for FPAR - ! -------------------------- - real , allocatable, dimension (:,:) :: parzone + real , allocatable, dimension (:,:,:) :: parzone + + integer :: cn_count = 0 + logical :: first_cn IAm=trim(COMP_NAME)//"::RUN2::Driver" @@ -5191,10 +5594,11 @@ subroutine Driver ( RC ) call ESMF_UserCompGetInternalState(gc, 'CatchcnInternal', wrap, status) VERIFY_(status) catchcn_internal => wrap%ptr - OFFLINE_MODE = catchcn_internal%CATCH_OFFLINE + OFFLINE_MODE = catchcn_internal%CATCH_OFFLINE ! shorthand ! if (MAPL_AM_I_Root(VM)) print *, trim(Iam)//'::OFFLINE mode: ', is_OFFLINE call ESMF_VMGetCurrent ( VM, RC=STATUS ) + ! -------------------------------------------------------------------------- ! Get parameters from generic state. ! -------------------------------------------------------------------------- @@ -5241,7 +5645,8 @@ subroutine Driver ( RC ) 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) + 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) @@ -5331,8 +5736,19 @@ subroutine Driver ( RC ) 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) + + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND == 1) then + + call MAPL_GetPointer(INTERNAL,delCQ_delTVA ,'delCQ_delTVA' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,delCH_delTVA ,'delCH_delTVA' ,RC=STATUS); VERIFY_(STATUS) + + elseif (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND >= 2) then + + call MAPL_GetPointer(INTERNAL,delCH_delTC ,'delCH_delTC' ,RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(INTERNAL,delCQ_delQC ,'delCQ_delQC' ,RC=STATUS); VERIFY_(STATUS) + + end if + 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) @@ -5365,11 +5781,18 @@ subroutine Driver ( RC ) 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 @@ -5384,17 +5807,6 @@ subroutine Driver ( RC ) 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 ! ----------------------------------------------------- @@ -5488,6 +5900,7 @@ subroutine Driver ( RC ) 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,SPLH , 'SPLH' , 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) @@ -5499,6 +5912,8 @@ subroutine Driver ( RC ) 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) @@ -5539,19 +5954,29 @@ subroutine Driver ( RC ) 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) + 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) + call MAPL_GetPointer(EXPORT,DZGT1 , 'DZGT1' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZGT2 , 'DZGT2' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZGT3 , 'DZGT3' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZGT4 , 'DZGT4' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZGT5 , 'DZGT5' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZGT6 , 'DZGT6' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZPR , 'DZPR' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZRZ , 'DZRZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZSF , 'DZSF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,DZTS , 'DZTS' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WPEMW , 'WPEMW' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,WPMC , 'WPMC' , RC=STATUS); VERIFY_(STATUS) NTILES = size(PS) @@ -5568,23 +5993,37 @@ subroutine Driver ( RC ) ! 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,n60d/)) ! otherwise, set model time step index to the maximum of these nXX + 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) ) - - !lmrsunm = 0. - !lmrsham = 0. +! allocate( lmrsunm(ntiles,nveg,nzone) ) +! allocate( lmrsham(ntiles,nveg,nzone) ) +! allocate( runsrf(ntiles) ) +! +! lmrsunm = 0. +! lmrsham = 0. +! runsrf = 0. first = .false. @@ -5600,7 +6039,7 @@ subroutine Driver ( RC ) ! obtain LAI from previous time step (from CN model) ! -------------------------------------------------- - call get_CN_LAI(ntiles,nveg,nzone,ityp,fveg,elai,esai=esai,tlai = tlai) + call get_CN_LAI(ntiles,ityp,fveg,elai,esai=esai,tlai = tlai) ! OPTIONAL IMPOSE MONTHLY MEAN DIURNAL CYCLE FROM NOAA CARBON TRACKER ! ------------------------------------------------------------------- @@ -5661,7 +6100,8 @@ subroutine Driver ( RC ) 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) + VERIFY_(STATUS) + STATUS = NF_OPEN (trim(CO2_CycleFile), NF_NOWRITE, CTfile); VERIFY_(status) allocate (CT_CO2V (1: NUNQ, 1:12, 1:8)) @@ -5699,7 +6139,7 @@ subroutine Driver ( RC ) allocate(FICESOUT(N_SNOW,NTILES)) allocate(TILEZERO (NTILES)) - allocate(DZSF (NTILES)) + allocate(DZSF_in_mm(NTILES)) allocate(SWNETFREE(NTILES)) allocate(SWNETSNOW(NTILES)) allocate(VEG1 (NTILES)) @@ -5734,9 +6174,11 @@ subroutine Driver ( RC ) allocate(WTOT (NTILES)) allocate(WCHANGE (NTILES)) allocate(ECHANGE (NTILES)) - allocate(HSNACC (NTILES)) + allocate(HSNACC (NTILES)) + allocate(LHOUT (NTILES)) allocate(EVACC (NTILES)) - allocate(SHACC (NTILES)) + allocate(LHACC (NTILES)) + allocate(SHACC (NTILES)) allocate(VSUVR (NTILES)) allocate(VSUVF (NTILES)) allocate(SNOVR (NTILES)) @@ -5758,12 +6200,10 @@ subroutine Driver ( RC ) 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(SLDTOT (NTILES)) ! total solid precip allocate(FSW_CHANGE(NTILES)) allocate(SHSBT (NTILES,NUM_SUBTILES)) @@ -5771,7 +6211,7 @@ subroutine Driver ( RC ) allocate(EVSBT (NTILES,NUM_SUBTILES)) allocate(DEVSBT (NTILES,NUM_SUBTILES)) allocate(DEDTC (NTILES,NUM_SUBTILES)) - allocate(DHSDQA (NTILES,NUM_SUBTILES)) + allocate(DHSDQC (NTILES,NUM_SUBTILES)) allocate(CFT (NTILES,NUM_SUBTILES)) allocate(CFQ (NTILES,NUM_SUBTILES)) allocate(TCO (NTILES,NUM_SUBTILES)) @@ -5779,27 +6219,30 @@ subroutine Driver ( RC ) 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(RCONSTIT (NTILES,N_SNOW,N_constit)) + allocate(TOTDEPOS (NTILES,N_constit)) + allocate(RMELT (NTILES,N_constit)) + + 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 @@ -5810,22 +6253,22 @@ subroutine Driver ( RC ) ! -------------------------------------------------------------------------- ! 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) + 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. @@ -5835,13 +6278,13 @@ subroutine Driver ( RC ) SNDZN1 = 0. SNDZN2 = 0. SNDZN3 = 0. - + end where - + else if (CurrMonth==2) then - + where ( LATS < 0. ) ! [radians] - + WESNN1 = 0. WESNN2 = 0. WESNN3 = 0. @@ -5851,34 +6294,30 @@ subroutine Driver ( RC ) SNDZN1 = 0. SNDZN2 = 0. SNDZN3 = 0. - + end where - - end if - + + 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.) ! gkw: account for "split" types + where(ITY(:,1) > 0.) VEG1 = map_cat(nint(ITY(:,1))) ! map primary CN PFT to catchment type - elsewhere - VEG1 = map_cat(nint(ITY(:,2))) ! map primary CN PFT to catchment type endwhere - where(ITY(:,3) > 0.) - VEG2 = map_cat(nint(ITY(:,3))) ! map secondary CN PFT to catchment type - elsewhere - VEG2 = map_cat(nint(ITY(:,4))) ! map secondary CN PFT to catchment type + where(ITY(:,2) > 0.) + VEG2 = map_cat(nint(ITY(:,2))) ! map secondary CN PFT to catchment type endwhere - fveg1(:) = fvg(:,1) + fvg(:,2) ! sum veg fractions (primary) gkw: NVEG specific - fveg2(:) = fvg(:,3) + fvg(:,4) ! sum veg fractions (secondary) gkw: fveg1+fveg2=1 + fveg1(:) = fvg(:,1) + fveg2(:) = fvg(:,2) allocate ( lai1(ntiles) ) allocate ( lai2(ntiles) ) @@ -5887,20 +6326,18 @@ subroutine Driver ( RC ) lai1 = 0. wght = 0. do nz = 1,nzone - do nv = 1,2 - lai1(:) = lai1(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) - wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) - end do + 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 - do nv = 3,4 - lai2(:) = lai2(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) - wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) - end do + 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 @@ -5912,7 +6349,7 @@ subroutine Driver ( RC ) ! surface layer depth for soil moisture ! -------------------------------------------------------------------------- - DZSF( :) = catchcn_internal%SURFLAY + DZSF_in_mm(:) = catchcn_internal%SURFLAY ! same as DZSF but in units of [mm] ! -------------------------------------------------------------------------- ! build arrays from internal state @@ -5995,28 +6432,35 @@ subroutine Driver ( RC ) 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)) + if (CATCHCN_INTERNAL%Z0_FORMULATION == 4) then + ! make canopy height >= min veg height: + Z2CH = max(Z2CH,MIN_VEG_HEIGHT) + ZVG = fveg1*(Z2CH - SAI4ZVG(VEG1)*SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI1)) + & + fveg2*(Z2CH - SAI4ZVG(VEG2)*SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI2)) + else + ZVG = fveg1*(Z2CH - SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI1)) + & + fveg2*(Z2CH - SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI2)) + endif - ! For now roughnesses and displacement heights - ! are the same for all subtiles. - !--------------------------------------------------- + ! For now roughnesses and displacement heights are the same for all subtiles. + + Z0 = Z0_BY_ZVEG*ZVG*SCALE4Z0 - 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 + ! Initialization + if (N_CONSTIT > 0) then RCONSTIT(:,:,:) = 0.0 TOTDEPOS(:,:) = 0.0 RMELT(:,:) = 0.0 - end if + endif !------------------------------------------------------------------ ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: @@ -6056,7 +6500,7 @@ subroutine Driver ( RC ) end select - if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then + if (CATCHCN_INTERNAL%N_CONST_LAND4SNWALB /= 0) then ! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 ! Note: Explanations of each variable @@ -6077,15 +6521,16 @@ subroutine Driver ( RC ) ! 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) - 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) + 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) + !============================= Possible future applications ==================================== ! TOTDEPOS(:,10) = SUDP(:,1) + SUSV(:,1) + SUWT(:,1) + SUSD(:,1) ! TOTDEPOS(:,11) = SSDP(:,1) + SSSV(:,1) + SSWT(:,1) + SSSD(:,1) @@ -6116,15 +6561,15 @@ subroutine Driver ( RC ) ! 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 - 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(:,:) + 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(:,:) !============================= Possible future applications ==================================== ! RCONSTIT(:,:,10) = RSU003(:,:) @@ -6167,46 +6612,156 @@ subroutine Driver ( RC ) RHO = PS/(MAPL_RGAS*(TA*(1+MAPL_VIREPS*QA))) - DEDTC=0.0 - DHSDQA=0.0 + !-------------------------------------------------------------------------------------------------------- + ! + ! MOSFC variable names and description: + ! + !-------------------------------------------------------------------------------------------------------- + ! GEOS_CatchGridComp.F90 | catchment.F90 | dimension | Description + !-------------------------------------------------------------------------------------------------------- + ! TA | TM | NT | surface (lowest model level) air temperature + ! QA | QM | NT | surface (lowest model level) air spec humidity + !-------------------------------------------------------------------------------------------------------- + ! TC | TC | NT-by-NSBT | canopy (air) temperature + ! QC | QA (!) | NT-by-NSBT | canopy (air) specific humidity + ! CH | - | NT-by-NSBT | exchange coeff for heat + ! CQ | - | NT-by-NSBT | exchange coeff for humidity + ! EVSBT | ETURB | NT-by-NSBT | evaporation + ! DEVSBT | DEDQA | NT-by-NSBT | deriv of evap w.r.t. canopy spec humidity + ! DEDTC | DEDTC | NT-by-NSBT | deriv of evap w.r.t. canopy temperature + ! SHSBT | HSTURB | NT-by-NSBT | sensible heat flux (SH) + ! DHSDQC (formerly DHSDQA) | DHSDQA | NT-by-NSBT | deriv of SH w.r.t. canopy spec humidity + ! DSHSBT | DHSDTC | NT-by-NSBT | deriv of SH w.r.t. canopy temperature + !-------------------------------------------------------------------------------------------------------- + ! *SBT = sub-tile (?) + ! NT = number of tiles + ! NSBT = number of subtiles (per tile) + ! + ! For land, CH = CQ in Helfand and Louis. + ! + ! + ! MOSFC equations: + ! + ! EVSBT = CQ * (QC - QA) + ! SHSBT = Cp * CH * (TC - TA) [ Cp = MAPL_CP ] + ! + ! Derivatives obtained via product rule. See equations below. + ! + ! For analytical derivatives, additionally use the following identities: + ! + ! virtual TC: TVC = TC*(1 + eps)*QC [ eps = MAPL_VIREPS ] + ! virtual TA: TVA = TA*(1 + eps)*QA + ! + ! delTVC_delQC = TC*eps + ! delTVC_delTC = (1 + eps) + ! + ! delCQ_delQC = delCQ_delTVC * delTVC_delQC + ! delCH_delTC = delCH_delTVC * delTVC_delTC + ! + ! CQ=CQ(Ri) where Ri is proportional to deltaTVA=TVA-TVC --> produces a minus sign + ! + ! delCQ_delTVC = -1*delCQ_delTVA + ! delCH_delTVC = -1*delCH_delTVA + ! + !-------------------------------------------------------------------------------------------------- + ! reichle, 9/9/2024 + !-------------------------------------------------------------------------------------------------- + + ! initialize derivatives that may not be filled later + + DEDTC =0.0 + DHSDQC=0.0 if(OFFLINE_MODE /=0) then + + ! Catchment in offline (land-only) mode + 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. catchcn_internal%MOSFC_EXTRA_DERIVS_OFFL_LAND==1) then + + select case (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND) + + case (0) ! ignore derivatives of exchange coeffs w.r.t. canopy temp and specific humidity + 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 + DEVSBT(:,N) = CQ(:,N) + DSHSBT(:,N) = MAPL_CP* CH(:,N) + end do + + case (1) ! Louis only: analytical derivatives of exchange coeffs w.r.t. canopy temp and specific humidity + + _ASSERT( CATCHCN_INTERNAL%CHOOSEMOSFC==0, 'must use Louis scheme for MOSFC analytical derivatives' ) + + do N=1,NUM_SUBTILES + DEVSBT(:,N) = CQ(:,N) + max( 0.0, -delCQ_delTVA(:,N)* MAPL_VIREPS*TC(:,N) *(QC(:,N)-QA) ) + DEDTC( :,N) = max( 0.0, -delCQ_delTVA(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(QC(:,N)-QA) ) + DSHSBT(:,N) = MAPL_CP*( CH(:,N) + max( 0.0, -delCH_delTVA(:,N)*(1.+MAPL_VIREPS*QC(:,N))*(TC(:,N)-TA) ) ) + DHSDQC(:,N) = max( 0.0, -MAPL_CP*delCH_delTVA(:,N)* MAPL_VIREPS*TC(:,N) *(TC(:,N)-TA) ) + end do + + case (2,3) ! numerical derivatives of exchange coeffs w.r.t. canopy temp and specific humidity + + do N=1,NUM_SUBTILES + DEVSBT(:,N) = CQ(:,N) + max( 0.0, delCQ_delQC( :,N)* (QC(:,N)-QA) ) + DEDTC( :,N) = max( 0.0, delCH_delTC( :,N)* (QC(:,N)-QA) ) + DSHSBT(:,N) = MAPL_CP*( CH(:,N) + max( 0.0, delCH_delTC( :,N)* (TC(:,N)-TA) ) ) + DHSDQC(:,N) = max( 0.0, MAPL_CP*delCQ_delQC( :,N)* (TC(:,N)-TA) ) + end do + + case default + + _ASSERT(.false., 'unknown MOSFC_EXTRA_DERIVS_OFFL_LAND') + + end select + else + + ! GCM: Catchment coupled to atmosphere + 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 + + end if ! Catchment offline ! 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. + ! + ! reichle, 9/9/2024: + ! + ! WHY IS QC RESET *AFTER* IT WAS USED TO CALCULATE THE EXCHANGE COEFFS (AND DERIVS) ABOVE??? + ! + ! For reference, the following comment was copied from from LDASsa m3-16, specifically, from + ! reichle-LDASsa_m3-16_6/src/Components/GEOSlana_GridComp/process_cat.F90 (Lines 330-333): + ! + ! ! compute surface exchange coefficients etc BEFORE possibly resetting + ! ! profile of Qair-QAx-Qsat(surf) -- for consistency with two-stage + ! ! run-method in GEOS_CatchGridComp.F90 + ! ! reichle+qliu, 9 Oct 2008 do N=1,NUM_SUBTILES DQS(:,N) = GEOS_DQSAT ( TC(:,N), PS, QSAT=QSAT(:,N), PASCALS=.true., RAMP=0.0 ) @@ -6215,7 +6770,6 @@ subroutine Driver ( RC ) RA (:,N) = RHO/CH(:,N) end do - QC(:,FSNW) = QSAT(:,FSNW) ! -------------------------------------------------------------------------- @@ -6235,15 +6789,15 @@ subroutine Driver ( RC ) ! include FRZR and PCU+PLS=RAIN+FRZR (TO BE CONFIRMED!). ! ! - reichle, 6/6/2025 - + ! -------------------------------------------------------------------------- ! 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) + _ASSERT(count(PLS<0.) ==0, 'encountered neg precip value (PLS)' ) + _ASSERT(count(PCU<0.) ==0, 'encountered neg precip value (PCU)' ) + _ASSERT(count(SLDTOT<0.)==0, 'encountered neg precip value (SLDTOT)') LAI0 = max(0.0001 , LAI) GRN0 = max(0.0001 , GRN) @@ -6258,48 +6812,39 @@ subroutine Driver ( RC ) TILEZERO = 0.0 - call MAPL_TimerOn ( MAPL, "-CATCHCNCLM45" ) + call MAPL_TimerOn ( MAPL, "-CATCHCNCLM51" ) ! ---------------------------------------------------------------------------------------- ! gkw: start on main CN block - allocate( btran(ntiles) ) + allocate( btran(ntiles,nveg,nzone) ) + allocate( btran_fire(ntiles,nzone) ) allocate( wgt(ntiles) ) - allocate( bt1(ntiles) ) - allocate( bt2(ntiles) ) - allocate( bt4(ntiles) ) allocate( wpp(ntiles) ) allocate( fwet(ntiles) ) - allocate( sm1(ntiles) ) - allocate( sm2(ntiles) ) - allocate( sm4(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( btran1(ntiles) ) - allocate( btran2(ntiles) ) - allocate( btran3(ntiles) ) - allocate( tcx(ntiles) ) - allocate( qax(ntiles) ) - allocate( rcx(ntiles) ) + allocate( tcx(ntiles,nzone) ) + allocate( qax(ntiles,nzone) ) allocate( rcxdt(ntiles) ) allocate( rcxdq(ntiles) ) - allocate( tx1(ntiles) ) - allocate( tx2(ntiles) ) - allocate( tx3(ntiles) ) - allocate( qx1(ntiles) ) - allocate( qx2(ntiles) ) - allocate( qx3(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) ) @@ -6341,8 +6886,6 @@ subroutine Driver ( RC ) allocate( totlitc(ntiles) ) allocate( cwdc(ntiles) ) allocate( rootc(ntiles) ) - allocate( lats_degree(ntiles) ) - allocate( lons_degree(ntiles) ) allocate( lnfm(ntiles) ) allocate( tgw(ntiles,nzone) ) @@ -6352,31 +6895,9 @@ subroutine Driver ( RC ) allocate( rcdq(ntiles,nzone) ) allocate( totcolc(ntiles,nzone) ) allocate( sfm(ntiles,nzone) ) - allocate( bt1_sf(ntiles) ) - allocate( bt2_sf(ntiles) ) - allocate( bt4_sf(ntiles) ) - allocate( btran1_sf(ntiles) ) - allocate( btran2_sf(ntiles) ) - allocate( btran3_sf(ntiles) ) - allocate( btran_fire_rz(ntiles,nzone) ) - allocate( btran_fire_sf(ntiles,nzone) ) - - allocate( psnsunx(ntiles,nveg) ) - allocate( psnshax(ntiles,nveg) ) - allocate( sifsunx(ntiles,nveg) ) - allocate( parzone(ntiles,nveg) ) - allocate( sifshax(ntiles,nveg) ) - allocate( laisunx(ntiles,nveg) ) - allocate( laishax(ntiles,nveg) ) - allocate( elaz(ntiles,nveg) ) - allocate( esaz(ntiles,nveg) ) - allocate( fvez(ntiles,nveg) ) - allocate( ityz(ntiles,nveg) ) - allocate( lmrsunx(ntiles,nveg) ) - allocate( lmrshax(ntiles,nveg) ) - allocate( tlaz(ntiles,nveg) ) - allocate( albdir(ntiles,nveg) ) - allocate( albdif(ntiles,nveg) ) + + allocate( albdir(ntiles,nveg,nzone,2) ) + allocate( albdif(ntiles,nveg,nzone,2) ) allocate( psnsun(ntiles,nveg,nzone) ) allocate( psnsha(ntiles,nveg,nzone) ) @@ -6384,6 +6905,8 @@ subroutine Driver ( RC ) allocate( laisha(ntiles,nveg,nzone) ) allocate( lmrsun(ntiles,nveg,nzone) ) allocate( lmrsha(ntiles,nveg,nzone) ) + allocate( sifsun(ntiles,nveg,nzone) ) + allocate( sifsha(ntiles,nveg,nzone) ) allocate( ht(N_gt) ) allocate( tp(N_gt) ) allocate( soilice(N_gt) ) @@ -6441,7 +6964,7 @@ subroutine Driver ( RC ) ! gkw: obtain catchment area fractions and soil moisture ! ------------------------------------------------------ - call catch_calc_soil_moist( ntiles, dzsf, vgwmax, cdcr1, cdcr2, psis, bee, poros, wpwet, & + call catch_calc_soil_moist( ntiles, DZSF_in_mm, 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 ) @@ -6455,43 +6978,33 @@ subroutine Driver ( RC ) ! "btran" in the catchment zones; map into CN zones ! ------------------------------------------------- - sm1 = 1.0 - bt1 = 1.0 ! saturated area - bt1_sf = 1.0 + sm(:,fsat) = 1.0 ! gkw: bt2 is unstressed region only (subtract saturated and wilting areas) do n = 1,ntiles if(car2(n) > 0.) then - sm2(n)=(rzmc(n)/poros(n) - car1(n) - car4(n)*wpwet(n))/car2(n) + sm(n,ftrn)=(rzmc(n)/poros(n) - car1(n) - car4(n)*wpwet(n))/car2(n) else - sm2(n)= rzmc(n)/poros(n) + sm(n,ftrn)= rzmc(n)/poros(n) endif - sm2(n) = max(sm2(n),wpwet(n)) - sm2(n) = min(sm2(n),1.) - end do - - bt2 = sm2**(-bee) - bt2_sf = SWSRF2**(-bee) - - wpp = wpwet ** (-bee) ! soil water potential at wilting point - bt2 = (bt2-wpp)/(1.-wpp) ! unstressed area (using soil water potential; PSIS common to all terms) - bt2_sf = (bt2_sf-wpp)/(1.-wpp) - -! sm4 = wpwet - 1.e-7 ! wilting point minus epsilon (to account for truncation) + sm(n,ftrn) = max(sm(n,ftrn),wpwet(n)) + sm(n,ftrn) = min(sm(n,ftrn),1.) - do n = 1,ntiles if(car4(n) > 0.) then - sm4(n)=(rzmc(n)/poros(n) - car1(n) - car2(n)*sm2(n))/car4(n) + sm(n,fwlt)=(rzmc(n)/poros(n) - car1(n) - car2(n)*sm(n,ftrn))/car4(n) else - sm4(n)= wpwet(n) + sm(n,fwlt)= wpwet(n) endif - sm4(n) = max(sm4(n),1.e-3) - sm4(n) = min(sm4(n),wpwet(n)-1.e-7) + sm(n,fwlt) = max(sm(n,fwlt),1.e-3) + sm(n,fwlt) = min(sm(n,fwlt),wpwet(n)-1.e-7) end do - - bt4 = 0.0 ! stressed area - bt4_sf = 0.0 + 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) @@ -6504,83 +7017,61 @@ subroutine Driver ( RC ) ! CN zone 1 if(ax1 .gt. cn1) then - f1 = cn1 ; f2 = 0. ; f4 = 0. + f1(1) = cn1 ; f2(1) = 0. ; f4(1) = 0. else if((ax1+ax2) .gt. cn1) then - f1 = ax1 ; f2 = cn1-ax1 ; f4 = 0. + f1(1) = ax1 ; f2(1) = cn1-ax1 ; f4(1) = 0. else - f1 = ax1 ; f2 = ax2 ; f4 = cn1-ax1-ax2 + f1(1) = ax1 ; f2(1) = ax2 ; f4(1) = cn1-ax1-ax2 endif endif - btran1(n) = (f1*bt1(n) + f2*bt2(n) + f4*bt4(n) )/cn1 - tgw(n,1) = (f1*tg(n,fsat) + f2*tg(n,ftrn) + f4*tg(n,fwlt))/cn1 - tx1(n) = (f1*tc(n,fsat) + f2*tc(n,ftrn) + f4*tc(n,fwlt))/cn1 - qx1(n) = (f1*qc(n,fsat) + f2*qc(n,ftrn) + f4*qc(n,fwlt))/cn1 - rzm(n,1) = (f1*sm1(n) + f2*sm2(n) + f4*sm4(n) )/cn1 - sfm(n,1) = (f1*SWSRF1(n) + f2*SWSRF2(n) + f4*SWSRF4(n) )/cn1 - btran1_sf(n) = (f1*bt1_sf(n) + f2*bt2_sf(n) + f4*bt4_sf(n))/cn1 - ! CN zone 2 if(ax1 .gt. cn1) then cn12 = cn1 + cn2 if(car1(n) .gt. cn12) then - f1 = cn2 ; f2 = 0. ; f4 = 0. + f1(2) = cn2 ; f2(2) = 0. ; f4(2) = 0. else if((ax1+ax2) .lt. cn12) then - f1 = ax1-cn1 ; f2 = ax2 ; f4 = cn12-ax1-ax2 + f1(2) = ax1-cn1 ; f2(2) = ax2 ; f4(2) = cn12-ax1-ax2 else - f1 = ax1-cn1 ; f2 = cn12-ax1 ; f4 = 0. + f1(2) = ax1-cn1 ; f2(2) = cn12-ax1 ; f4(2) = 0. endif endif else cn23 = cn2 + cn3 if(ax4 .gt. cn23) then - f1 = 0. ; f2 = 0. ; f4 = cn2 + f1(2) = 0. ; f2(2) = 0. ; f4(2) = cn2 else if(ax4 .lt. cn3) then - f1 = 0. ; f2 = cn2 ; f4 = 0. + f1(2) = 0. ; f2(2) = cn2 ; f4(2) = 0. else - f1 = 0. ; f2 = cn23-ax4 ; f4 = ax4-cn3 + f1(2) = 0. ; f2(2) = cn23-ax4 ; f4(2) = ax4-cn3 endif endif endif - btran2(n) = (f1*bt1(n) + f2*bt2(n) + f4*bt4(n) )/cn2 - tgw(n,2) = (f1*tg(n,fsat) + f2*tg(n,ftrn) + f4*tg(n,fwlt))/cn2 - tx2(n) = (f1*tc(n,fsat) + f2*tc(n,ftrn) + f4*tc(n,fwlt))/cn2 - qx2(n) = (f1*qc(n,fsat) + f2*qc(n,ftrn) + f4*qc(n,fwlt))/cn2 - rzm(n,2) = (f1*sm1(n) + f2*sm2(n) + f4*sm4(n) )/cn2 - sfm(n,2) = (f1*SWSRF1(n) + f2*SWSRF2(n) + f4*SWSRF4(n) )/cn2 - btran2_sf(n) = (f1*bt1_sf(n) + f2*bt2_sf(n) + f4*bt4_sf(n))/cn2 ! CN zone 3 if(ax4 .gt. cn3) then - f1 = 0. ; f2 = 0. ; f4 = cn3 + f1(3) = 0. ; f2(3) = 0. ; f4(3) = cn3 else if((ax4+ax2) .gt. cn3) then - f1 = 0. ; f2 = cn3-ax4 ; f4 = ax4 + f1(3) = 0. ; f2(3) = cn3-ax4 ; f4(3) = ax4 else - f1 = cn3-ax4-ax2 ; f2 = ax2 ; f4 = ax4 + f1(3) = cn3-ax4-ax2 ; f2(3) = ax2 ; f4(3) = ax4 endif endif - btran3(n) = (f1*bt1(n) + f2*bt2(n) + f4*bt4(n) )/cn3 - tgw(n,3) = (f1*tg(n,fsat) + f2*tg(n,ftrn) + f4*tg(n,fwlt))/cn3 - tx3(n) = (f1*tc(n,fsat) + f2*tc(n,ftrn) + f4*tc(n,fwlt))/cn3 - qx3(n) = (f1*qc(n,fsat) + f2*qc(n,ftrn) + f4*qc(n,fwlt))/cn3 - rzm(n,3) = (f1*sm1(n) + f2*sm2(n) + f4*sm4(n) )/cn3 - sfm(n,3) = (f1*SWSRF1(n) + f2*SWSRF2(n) + f4*SWSRF4(n) )/cn3 - btran3_sf(n) = (f1*bt1_sf(n) + f2*bt2_sf(n) + f4*bt4_sf(n))/cn3 + 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 - ! btran_fire_rz and btran_fire_sf: btran2 in CNFireMod, make it the same as btran, fzeng, 9 Mar 2017 - btran_fire_rz(n,1) = btran1(n) - btran_fire_rz(n,2) = btran2(n) - btran_fire_rz(n,3) = btran3(n) - btran_fire_sf(n,1) = btran1_sf(n) - btran_fire_sf(n,2) = btran2_sf(n) - btran_fire_sf(n,3) = btran3_sf(n) - - end do + end do !n ! soil temperature and hydrologic state ! ------------------------------------- @@ -6617,11 +7108,22 @@ subroutine Driver ( RC ) 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 @@ -6631,23 +7133,65 @@ subroutine Driver ( RC ) ! --------------------------------------------------------------------------------- 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 + 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 ! ------- @@ -6691,53 +7235,6 @@ subroutine Driver ( RC ) ENDIF CALC_CTCO2_SF - if(associated(BTRANT)) btrant = 0. - if(associated(SIF)) sif = 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 - - para(:) = 0. ! zero out absorbed PAR summing array - - do nz = 1,nzone - - if(nz == 1) then - btran = btran1 - tcx = tx1 - qax = qx1 - endif - - if(nz == 2) then - btran = btran2 - tcx = tx2 - qax = qx2 - endif - - if(nz == 3) then - btran = btran3 - tcx = tx3 - qax = qx3 - endif - - do nv = 1,nveg - elaz(:,nv) = elai(:,nv,nz) - esaz(:,nv) = esai(:,nv,nz) - tlaz(:,nv) = tlai(:,nv,nz) - ityz(:,nv) = ityp(:,nv,nz) - fvez(:,nv) = fveg(:,nv,nz) - end do - - do n = 1,ntiles - if(tp1(n) < (Tzero-0.01)) btran(n) = 0. ! no photosynthesis if ground fully frozen - end do - USE_CT_CO2: IF((catchcn_internal%ATM_CO2 == 1).OR.(catchcn_internal%ATM_CO2 == 2)) THEN IF(AGCM_DD < 16) THEN @@ -6785,21 +7282,40 @@ subroutine Driver ( RC ) ENDIF USE_CT_CO2 + if(associated(BTRANT)) btrant = 0. + if(associated(SIF)) sif = 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(ityz(:,nv)) + 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, elaz(:,nv), 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 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 + ! Get TPSN1OUT1 for SNOW_ALBEDO parameterization + + call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSNNN(1,:), WESNN(1,:), TPSN1OUT1, FICE1TMP ) + TPSN1OUT1 = TPSN1OUT1 + MAPL_TICE + call StieglitzSnow_snow_albedo(ntiles, N_snow, catchcn_internal%N_CONST_LAND4SNWALB, ityp_tmp, & - elaz(:,nv), ZTH, & + elai(:,nv,nz), ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -6809,49 +7325,47 @@ subroutine Driver ( RC ) ! fsnow: pft-level; asnow: grid-level ! ----------------------------------- - where(tlaz(:,nv) > 0.) - fsnow(:) = 1. - elaz(:,nv)/tlaz(:,nv) + where(tlai(:,nv,nz) > 0.) + fsnow(:) = 1. - elai(:,nv,nz)/tlai(:,nv,nz) fsnow(:) = min(max(fsnow(:),0.),1.) elsewhere fsnow(:) = 0. endwhere - albdir(:,nv) = albvr(:)*(1.-fsnow(:)) + snovr(:)*fsnow(:) - albdif(:,nv) = albvf(:)*(1.-fsnow(:)) + snovf(:)*fsnow(:) - - end do - - call compute_rc(ntiles,nveg,TCx,QAx,T2M10D,TA,PS,ZTH,DRPAR,DFPAR, & - albdir,albdif,elaz,esaz,ityz,fvez,btran,fwet, & - RCx,RCxDT,RCxDQ,psnsunx,psnshax,laisunx,laishax, & - dayl_fac,co2v,dtc,dea,parzone,sifsunx,sifshax, & - lmrsunx,lmrshax) - - rc00(:,nz) = rcx(:) - rcdt(:,nz) = rcxdt(:) - rcdq(:,nz) = rcxdq(:) + ! 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(:) - psnsun(:,:,nz) = psnsunx(:,:) - psnsha(:,:,nz) = psnshax(:,:) - laisun(:,:,nz) = laisunx(:,:) - laisha(:,:,nz) = laishax(:,:) - lmrsun(:,:,nz) = lmrsunx(:,:) - lmrsha(:,:,nz) = lmrshax(:,:) + end do ! nv + end do ! nz - do nv = 1,nveg - para(:) = para(:) + parzone(:,nv)*wtzone(:,nz)*fvez(:,nv) + 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,sifsun,sifsha) + + 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) + sif(n) = sif(n) + wtzone(n,nz)*fveg(n,nv,nz)*(sifsun(n,nv,nz)*laisun(n,nv,nz) + sifsha(n,nv,nz)*laisha(n,nv,nz)) + end if + end if + end do + end do end do - if(associated(BTRANT)) btrant(:) = btrant(:) + btran(:)*wtzone(:,nz) ! NOTE: btran here doesn't reflect the modification to btran for soybean (and nbrdlf_dcd_tmp_shrub if CNDV is on) in subroutine Photosynthesis. - if(associated(SIF)) then - do nv = 1,nveg - sif(:) = sif(:) + wtzone(:,nz)*fvez(:,nv)*(sifsunx(:,nv)*laisunx(:,nv) + sifshax(:,nv)*laishax(:,nv)) - end do - endif - - end do - - if(associated(CNCO2)) CNCO2 = CO2V * 1e6 deallocate (co2v) @@ -6875,11 +7389,12 @@ subroutine Driver ( RC ) 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 ) + ! Get TPSN1OUT1 for SNOW_ALBEDO parameterization + + 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, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -6891,8 +7406,7 @@ subroutine Driver ( RC ) 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, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -6909,7 +7423,7 @@ subroutine Driver ( RC ) 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) @@ -6922,7 +7436,7 @@ subroutine Driver ( RC ) SNOVR = SNOWALB SNONR = SNOWALB SNOVF = SNOWALB - SNONF = SNOWALB + SNONF = SNOWALB endif @@ -6945,22 +7459,11 @@ subroutine Driver ( RC ) year_prev = AGCM_YY endif -! 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.) - ! 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' - ndt = get_step_size( nint(catchcn_internal%DTCN) ) ! gkw: get_step_size must be called here to set CN model time step - ! sum over interval for CN ! ------------------------ @@ -6978,10 +7481,12 @@ subroutine Driver ( RC ) snowfm = snowfm + SNO runsrfm = runsrfm + RUNSURF ar1m = ar1m + car1 - psnsunm = psnsunm + psnsun*laisun - psnsham = psnsham + psnsha*laisha - lmrsunm = lmrsunm + lmrsun*laisun - lmrsham = lmrsham + lmrsha*laisha + 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 @@ -6993,6 +7498,15 @@ subroutine Driver ( RC ) 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 ) @@ -7007,7 +7521,9 @@ subroutine Driver ( RC ) 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(:) + 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 @@ -7022,28 +7538,27 @@ subroutine Driver ( RC ) ar1m = ar1m / cnsum sndzm = sndzm / cnsum asnowm = asnowm / cnsum - - laisun = 1. - laisha = 1. - - lats_degree = lats / MAPL_PI * 180. - lons_degree = lons / MAPL_PI * 180. - - call CN_Driver(istep_cn,ntiles,nveg,nzone,dayl, & - tgwm,tpm,tp2,tp3,tp4,tp5,tp6,sfmm,rzmm,wpwet, & - psis,bee,poros,vgwmax,bflowm,totwatm,runsrfm, & - tairm,rhm,windm,rainfm,snowfm,TPREC10D,TPREC60D,T2M10D, & - psnsunm,psnsham,lmrsunm,lmrsham,laisun,laisha, & - ar1m,btran_fire_rz,btran_fire_sf,lats_degree,lons_degree, & - ityp,fveg,wtzone,sndzm,asnowm,ndep,abm,peatf,gdp,hdm,fieldcap,lnfm, & - elai,esai,tlai,totcolc,cat_id,cli_t2m, & - npp,gpp,sr,nee,frootc,padd,vegc,xsmr,burn,closs, & - nfire,som_closs,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) - + 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 @@ -7130,7 +7645,9 @@ subroutine Driver ( RC ) psnsunm = 0. psnsham = 0. lmrsunm = 0. - lmrsham = 0. + lmrsham = 0. + laisunm = 0. + laisham = 0. sndzm = 0. asnowm = 0. cnsum = 0. @@ -7180,6 +7697,8 @@ subroutine Driver ( RC ) 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 @@ -7188,16 +7707,16 @@ subroutine Driver ( RC ) ! copy CN_restart vars to catch_internal_rst gkw: only do if stopping ! ------------------------------------------ - record = .false. + 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 + if(NextTime == StopTime .or. record) then - call CN_exit(ntiles,nveg,nzone,ityp,fveg,cncol,var_col,cnpft,var_pft) + call CN_exit(ntiles,ityp,fveg,cncol,cnpft) i = 1 do iv = 1,VAR_PFT do nv = 1,NUM_VEG @@ -7217,20 +7736,18 @@ subroutine Driver ( RC ) lai1 = 0. wght = 0. do nz = 1,nzone - do nv = 1,2 - lai1(:) = lai1(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) - wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) - end do + 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 - do nv = 3,4 - lai2(:) = lai2(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) - wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) - end do + 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 @@ -7252,19 +7769,19 @@ subroutine Driver ( RC ) ! catchment: saturated area if(ax1 .lt. cn1) then - f1 = ax1 ; f2 = 0. ; f3 = 0. + f1(1) = ax1 ; f2(1) = 0. ; f3(1) = 0. else if(ax1 .lt. (cn1+cn2)) then - f1 = cn1 ; f2 = ax1-cn1 ; f3 = 0. + f1(1) = cn1 ; f2(1) = ax1-cn1 ; f3(1) = 0. else - f1 = cn1 ; f2 = cn2 ; f3 = ax1-cn1-cn2 + f1(1) = cn1 ; f2(1) = cn2 ; f3(1) = ax1-cn1-cn2 endif endif if(ax1 .gt. 0.) then - rcsat(n) = ax1/(f1/rc00(n,1)+f2/rc00(n,2)+f3/rc00(n,3)) - rcxdt(n) = ax1/(f1/rcdt(n,1)+f2/rcdt(n,2)+f3/rcdt(n,3)) - rcxdq(n) = ax1/(f1/rcdq(n,1)+f2/rcdq(n,2)+f3/rcdq(n,3)) + 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 @@ -7280,38 +7797,38 @@ subroutine Driver ( RC ) if(ax1 .lt. cn1) then ar = ax1 + ax2 if(ar .lt. cn1) then - f1 = ax2 ; f2 = 0. ; f3 = 0. + f1(2) = ax2 ; f2(2) = 0. ; f3(2) = 0. else if(ar .lt. (cn1+cn2)) then - f1 = cn1-ax1 ; f2 = ar-cn1 ; f3 = 0. + f1(2) = cn1-ax1 ; f2(2) = ar-cn1 ; f3(2) = 0. else - f1 = cn1-ax1 ; f2 = cn2 ; f3 = ar-cn1-cn2 + f1(2) = cn1-ax1 ; f2(2) = cn2 ; f3(2) = ar-cn1-cn2 endif endif else ar = ax2 + ax4 if(ar .lt. cn3) then - f1 = 0. ; f2 = 0. ; f3 = ax2 + f1(2) = 0. ; f2(2) = 0. ; f3(2) = ax2 else if(ax4 .gt. cn3) then - f1 = 0. ; f2 = ax2 ; f3 = 0. + f1(2) = 0. ; f2(2) = ax2 ; f3(2) = 0. else - f1 = 0. ; f2 = ar-cn3 ; f3 = cn3-ax4 + f1(2) = 0. ; f2(2) = ar-cn3 ; f3(2) = cn3-ax4 endif endif endif if(ax2 .gt. 0.) then - rcuns(n) = ax2/(f1/rc00(n,1)+f2/rc00(n,2)+f3/rc00(n,3)) - rcxdt(n) = ax2/(f1/rcdt(n,1)+f2/rcdt(n,2)+f3/rcdt(n,3)) - rcxdq(n) = ax2/(f1/rcdq(n,1)+f2/rcdq(n,2)+f3/rcdq(n,3)) + 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 +! compute derivatives drcudt(n) = (rcxdt(n) - rcuns(n)) / dtc drcudq(n) = (rcxdq(n) - rcuns(n)) / (0.622*dea/PS(n)) @@ -7324,28 +7841,6 @@ subroutine Driver ( RC ) ! 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) @@ -7356,7 +7851,7 @@ subroutine Driver ( RC ) VERIFY_(STATUS) if (UNIT_i == 0) then - unit_i = GETFILE( "catchcnclm45_inputs.data", form="unformatted", RC=STATUS ) + unit_i = GETFILE( "catchcnclm51_inputs.data", form="unformatted", RC=STATUS ) VERIFY_(STATUS) endif unit = unit_i @@ -7374,25 +7869,25 @@ subroutine Driver ( RC ) 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, DHSDQC(:,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, DHSDQC(:,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, DHSDQC(:,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, DHSDQC(:,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) @@ -7439,7 +7934,7 @@ subroutine Driver ( RC ) ! params if (firsttime) then firsttime = .false. - unit = GETFILE( "catchcnclm45_params.data", form="unformatted", RC=STATUS ) + unit = GETFILE( "catchcnclm51_params.data", form="unformatted", RC=STATUS ) VERIFY_(STATUS) call WRITE_PARALLEL(NT_GLOBAL, UNIT) @@ -7451,7 +7946,7 @@ subroutine Driver ( RC ) 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, DZSF_in_mm, 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) @@ -7486,7 +7981,7 @@ subroutine Driver ( RC ) VERIFY_(STATUS) ! Updates - unit = GETFILE( "catchcnclm45_updates.data", form="unformatted", RC=STATUS ) + unit = GETFILE( "catchcnclm51_updates.data", form="unformatted", RC=STATUS ) VERIFY_(STATUS) call MAPL_VarWrite(unit, tilegrid, TG(:,FSAT), mask=mask, rc=status); VERIFY_(STATUS) @@ -7529,25 +8024,25 @@ subroutine Driver ( RC ) ! ----------------------- if (ntiles > 0) then - call CATCHCN ( NTILES, LONS, LATS, DT,catchcn_internal%USE_FWET_FOR_RUNOFF, & ! LONS, LATS are in [radians] !!! - catchcn_internal%FWETC, catchcn_internal%FWETL, cat_id, VEG1,VEG2,FVEG1,FVEG2,DZSF ,& - PCU , PLSIN , SNO, ICE, FRZR ,& + call CATCHCN ( NTILES, LONS, LATS, DT,catchcn_internal%USE_FWET_FOR_RUNOFF, & ! LONS, LATS are in [radians] !!! + catchcn_internal%FWETC, catchcn_internal%FWETL, cat_id, VEG1,VEG2,FVEG1,FVEG2,DZSF_in_mm,& + PCU , PLS , SNO, ICE, FRZR ,& UUU ,& EVSBT(:,FSAT), DEVSBT(:,FSAT), DEDTC(:,FSAT) ,& - SHSBT(:,FSAT), DHSDQA(:,FSAT), DSHSBT(:,FSAT),& + SHSBT(:,FSAT), DHSDQC(:,FSAT), DSHSBT(:,FSAT),& EVSBT(:,FTRN), DEVSBT(:,FTRN), DEDTC(:,FTRN) ,& - SHSBT(:,FTRN), DHSDQA(:,FTRN), DSHSBT(:,FTRN),& + SHSBT(:,FTRN), DHSDQC(:,FTRN), DSHSBT(:,FTRN),& EVSBT(:,FWLT), DEVSBT(:,FWLT), DEDTC(:,FWLT) ,& - SHSBT(:,FWLT), DHSDQA(:,FWLT), DSHSBT(:,FWLT),& + SHSBT(:,FWLT), DHSDQC(:,FWLT), DSHSBT(:,FWLT),& EVSBT(:,FSNW), DEVSBT(:,FSNW), DEDTC(:,FSNW) ,& - SHSBT(:,FSNW), DHSDQA(:,FSNW), DSHSBT(:,FSNW),& + SHSBT(:,FSNW), DHSDQC(:,FSNW), DSHSBT(:,FSNW),& TA , QA ,& RA(:,FSAT), RA(:,FTRN), RA(:,FWLT), RA(:,FSNW) ,& - ZTH, SWNETFREE, SWNETSNOW, LWDNSRF ,& ! LWDNSRF = *absorbed* longwave only (excl reflected) + ZTH, SWNETFREE, SWNETSNOW, LWDNSRF ,& ! LWDNSRF = *absorbed* longwave only (excl reflected) PS*.01 ,& @@ -7558,7 +8053,7 @@ subroutine Driver ( RC ) QSAT(:,FWLT) , DQS(:,FWLT) , ALWN(:,3), BLWN(:,3) ,& QSAT(:,FSNW) , DQS(:,FSNW) , ALWN(:,4), BLWN(:,4) ,& - RCSAT,DRCSDT,DRCSDQ, RCUNS,DRCUDT,DRCUDQ, & + 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 ,& @@ -7572,14 +8067,14 @@ subroutine Driver ( RC ) CAPAC, CATDEF, RZEXC, SRFEXC, GHTCNT ,& WESNN, HTSNNN, SNDZN ,& - EVAPOUT, SHOUT, RUNOFF, EVPINT, EVPSOI, EVPVEG ,& - EVPICE ,& + EVAPOUT, SHOUT, RUNOFF ,& ! EVAPOUT: kg/m2/s + EVPINT, EVPSOI, EVPVEG, EVPICE ,& ! EVPINT, EVPSOI, EVPVEG, EVPICE: W/m2 BFLOW ,& RUNSURF ,& SMELT ,& HLWUP ,& ! *emitted* longwave only (excl reflected) SWNDSRF ,& - HLATN ,& + LHOUT ,& ! renamed from HLATN to avoid confusion w/ HLATN=LHFX in SurfaceGC QINFIL ,& AR1 ,& AR2 ,& @@ -7590,14 +8085,16 @@ subroutine Driver ( RC ) TC(:,FSNW) ,& ASNOW ,& TP1, TP2, TP3, TP4, TP5, TP6, SFMC, RZMC, PRMC ,& - ENTOT,WTOT, WCHANGE, ECHANGE, HSNACC, EVACC, SHACC ,& + ENTOT,WTOT, WCHANGE, ECHANGE, HSNACC ,& + EVACC ,& ! kg/m2/ + LHACC, SHACC ,& ! W/m2 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) + RCONSTIT=RCONSTIT, RMELT=RMELT, TOTDEPOS=TOTDEPOS) ! Change units of TP1, TP2, .., TP6 export variables from Celsius to Kelvin. ! This used to be done at the level the Surface GridComp. @@ -7614,15 +8111,31 @@ subroutine Driver ( RC ) 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 + + ! in offline mode, disregard the GCM-specific TC/QC modifications and the + ! accounting terms for turbulent fluxes (but not snow heat accounting term) + 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 + LHACC = 0.0 SHACC = 0.0 + endif QC(:,FSNW) = GEOS_QSAT ( TC(:,FSNW), PS, PASCALS=.true., RAMP=0.0 ) @@ -7650,16 +8163,15 @@ subroutine Driver ( RC ) ! -------------------------------------------------------------------------- call MAPL_TimerOn(MAPL,"-ALBEDO") - if(ntiles > 0) then + 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 ) + 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, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG1, LAI1, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -7672,7 +8184,7 @@ subroutine Driver ( RC ) 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, & + call StieglitzSnow_snow_albedo(NTILES,N_snow, catchcn_internal%N_CONST_LAND4SNWALB, VEG2, LAI2, ZTH, & RHOFS, & SNWALB_VISMAX, SNWALB_NIRMAX, SLOPE, & WESNN, HTSNNN, SNDZN, & @@ -7691,18 +8203,18 @@ subroutine Driver ( RC ) 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 + + endif ALBVR = ALBVR *(1.-ASNOW) + SNOVR *ASNOW ALBVF = ALBVF *(1.-ASNOW) + SNOVF *ASNOW @@ -7739,20 +8251,6 @@ subroutine Driver ( RC ) 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) @@ -7766,13 +8264,81 @@ subroutine Driver ( RC ) 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 + + + ! ----------------------------------------------------------------------------------------- + ! + ! IMPORTANT: Surface turbulent fluxes in [*]LAND exports are returned as calculated by Catchment! + ! + ! For completeness, also return the "accounting" terms that represent the difference between + ! the flux calculated by Catchment and the flux calculated by the atmosphere (Turbulence GC). + ! + ! EVAP__calculated_by_atmosphere = EVLAND - EVACC kg/m2/s + ! EFLUX_calculated_by_atmosphere = LHLAND - LHACC W/m2 + ! HFLUX_calculated_by_atmosphere = SHLAND - SHACC W/m2 + ! + ! Note: LHACC added for completeness and consistency with the mass flux term (EVACC); + ! strictly speaking, the atmosphere only receives the evap mass flux and the sensible + ! heat flux, but not the latent heat flux. + ! + ! In previous model versions, the [*]ACC accouting terms were subtracted from the + ! Catchment-calculated fluxes, thus returning the turbulent fluxes as calculated by + ! the atmosphere. + ! + ! Note: In offline mode, the [*]ACC accounting terms are zeroed out above. + ! + ! - reichle, 17 July 2024 + + if(associated(EVLAND)) EVLAND = EVAPOUT ! EVLAND is what Catchment thinks it should be + if(associated(LHLAND)) LHLAND = LHOUT ! LHLAND is what Catchment thinks it should be + if(associated(SHLAND)) SHLAND = SHOUT ! SHLAND is what Catchment thinks it should be + + if(associated(SPWATR)) SPWATR = EVACC + if(associated(SPLH )) SPLH = LHACC + if(associated(SPLAND)) SPLAND = SHACC + + ! Compute latent heat flux that is consistent with the evap mass flux as calculated + ! by the atmosphere (Turbulence GC). In the "flx" HISTORY collection, EFLUX is + ! the all-surface latent heat flux, with HLATN (as below) being the land contribution. + + HLATN = LHOUT - LHACC + + ! In previous model versions, the evap mass flux EVAPOUT and the sensible heat flux SHOUT + ! were returned as calculated by Catchment. These diagnostic are not written in MERRA-2. + ! In FP and GEOSIT, they are only included in ocean ("ocn") Collections. They appear to + ! be used also in the "gmichem" and "S2S" collections. + ! For consistency with previous model versions, keep returning EVAPOUT and SHOUT as + ! calculated by Catchment. + + ! Overview of surface turbulent flux variables in subroutine catchment(), the Catch, Land, and Surface Gridded Components, and the M21 "lnd" HISTORY collection + ! + !-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| + ! Description | Units | catchment() | Catch[CN]GC | LandGC | SurfaceGC | HISTORY | Notes | + ! | | ArgName | VarName | export | export | export | averaged | M21C | | + ! | | | | (tile) | (tile) | (grid) | over | "lnd" | | + !=========================================================================================================================================================================================| + ! evap mass flux | kg/m2/s | EVAP | EVAPOUT | EVLAND | EVLAND | EVLAND | land | EVLAND | | + ! evap mass flux | kg/m2/s | - | - | EVAPOUT | EVAPOUT | EVAPOUT | all surfaces | n/a | | + ! EV accounting term | kg/m2/s | EVACC | EVACC | SPWATR | SPWATR | SPWATR | land | SPEVLAND | EVLAND-SPEVLAND = EVAP_from_TurbGC [100% land] | + !-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| + ! latent heat flux | W/m2 | LHFLUX | LHOUT | LHLAND | LHLAND | LHLAND | land | LHLAND | | + ! latent heat flux | W/m2 | - | - | HLATN=LHOUT-LHACC | HLATN | LHFX | all surfaces | n/a | consistent w/ EVAP_from_TurbGC [100% land] | + ! LH accounting term | W/m2 | LHACC | LHACC | SPLH | SPLH | SPLH | land | SPLHLAND | (LHLAND-SPLHLAND) consistent w/ EVAP_from_TurbGC [100% land] | + ! LH component | W/m2 | EINT | EVPINT | EVPINT | EVPINT | EVPINT | land | LHLANDINTR | | + ! LH component | W/m2 | ESOI | EVPSOI | EVPSOI | EVPSOI | EVPSOI | land | LHLANDSOIL | | + ! LH component | W/m2 | EVEG | EVPVEG | EVPVEG | EVPVEG | EVPVEG | land | LHLANDTRNS | | + ! LH component | W/m2 | ESNO | EVPICE | EVPICE | EVPICE | EVPICE | land | LHLANDSBLN | | + !-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| + ! sensible heat flux | W/m2 | SHFLUX | SHOUT | SHLAND | SHLAND | SHLAND | land | SHLAND | | + ! sensible heat flux | W/m2 | - | - | SHOUT | SHOUT | SHOUT | all surfaces | n/a | | + ! SH accounting term | W/m2 | SHACC | SHACC | SPLAND | SPLAND | SPLAND | land | SPSHLAND | SHLAND-SPSHLAND = SH_from_TurbGC [for 100% land] | + !-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------| + + if(associated(SWLAND)) SWLAND = SWNDSRF if(associated(LWLAND)) LWLAND = LWNDSRF if(associated(GHLAND)) GHLAND = GHFLX @@ -7796,8 +8362,6 @@ subroutine Driver ( RC ) 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 ) @@ -7811,7 +8375,7 @@ subroutine Driver ( RC ) 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 (N_CONSTIT > 0) then if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) @@ -7823,7 +8387,22 @@ subroutine Driver ( RC ) if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) end if - if(associated(PEATCLSM_FSWCHANGE )) then + if(associated(DZGT1 )) DZGT1 = DZGT(1) ! [m] + if(associated(DZGT2 )) DZGT2 = DZGT(2) ! [m] + if(associated(DZGT3 )) DZGT3 = DZGT(3) ! [m] + if(associated(DZGT4 )) DZGT4 = DZGT(4) ! [m] + if(associated(DZGT5 )) DZGT5 = DZGT(5) ! [m] + if(associated(DZGT6 )) DZGT6 = DZGT(6) ! [m] + + if(associated(DZPR )) DZPR = CDCR2/(1.-WPWET)/POROS/MAPL_RHOWTR ! [m] + if(associated(DZRZ )) DZRZ = VGWMAX/POROS/MAPL_RHOWTR ! [m] + if(associated(DZSF )) DZSF = DZSF_in_mm/1000. ! [m] + if(associated(DZTS )) DZTS = DZTSURF ! [m] + + if(associated(WPEMW )) WPEMW = WPWET*POROS*DZPR*MAPL_RHOWTR ! [kg/m2] + if(associated(WPMC )) WPMC = WPWET*POROS ! [m3/m3] + + if(associated(PEATCLSM_FSWCHANGE)) then where (POROS >= PEATCLSM_POROS_THRESHOLD) PEATCLSM_FSWCHANGE = FSW_CHANGE elsewhere @@ -7899,7 +8478,7 @@ subroutine Driver ( RC ) SNDZN2 = SNDZN (2,:) SNDZN3 = SNDZN (3,:) - if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then + if (catchcn_internal%N_CONST_LAND4SNWALB /= 0 ) then RDU001(:,:) = RCONSTIT(:,:,1) RDU002(:,:) = RCONSTIT(:,:,2) RDU003(:,:) = RCONSTIT(:,:,3) @@ -7931,7 +8510,7 @@ subroutine Driver ( RC ) deallocate(SNDZN ) deallocate(FICESOUT ) deallocate(TILEZERO ) - deallocate(DZSF ) + deallocate(DZSF_in_mm) deallocate(SWNETFREE) deallocate(SWNETSNOW) deallocate(VEG1 ) @@ -7973,15 +8552,15 @@ subroutine Driver ( RC ) deallocate(LWDNSNOW1) deallocate(NETSWSNOW) deallocate(TCSORIG1 ) - deallocate(LHACC ) - deallocate(SUMEV ) deallocate(TPSN1IN1 ) deallocate(TPSN1OUT1) deallocate(GHFLXTSKIN) deallocate(WCHANGE ) deallocate(ECHANGE ) deallocate(HSNACC ) + deallocate(LHOUT ) deallocate(EVACC ) + deallocate(LHACC ) deallocate(SHACC ) deallocate(VSUVR ) deallocate(VSUVF ) @@ -7994,7 +8573,7 @@ subroutine Driver ( RC ) deallocate(EVSBT ) deallocate(DEVSBT ) deallocate(DEDTC ) - deallocate(DHSDQA ) + deallocate(DHSDQC ) deallocate(CFT ) deallocate(CFQ ) deallocate(TCO ) @@ -8023,34 +8602,21 @@ subroutine Driver ( RC ) deallocate(FSW_CHANGE) deallocate( btran ) deallocate( wgt ) - deallocate( bt1 ) - deallocate( bt2 ) - deallocate( bt4 ) deallocate( wpp ) deallocate( fwet ) - deallocate( sm1 ) - deallocate( sm2 ) - deallocate( sm4 ) + deallocate( wet_in ) + deallocate( sm ) deallocate( SWSRF1 ) deallocate( SWSRF2 ) deallocate( SWSRF4 ) - deallocate( btran1 ) - deallocate( btran2 ) - deallocate( btran3 ) deallocate( tcx ) deallocate( qax ) - deallocate( rcx ) deallocate( rcxdt ) deallocate( rcxdq ) - deallocate( tx1 ) - deallocate( tx2 ) - deallocate( tx3 ) - deallocate( qx1 ) - deallocate( qx2 ) - deallocate( qx3 ) deallocate( car1 ) deallocate( car2 ) deallocate( car4 ) + deallocate( parzone ) deallocate( para ) deallocate( totwat ) deallocate( nfire ) @@ -8085,8 +8651,6 @@ subroutine Driver ( RC ) deallocate( totlitc ) deallocate( cwdc ) deallocate( rootc ) - deallocate( lats_degree ) - deallocate( lons_degree ) deallocate( lnfm ) deallocate( tgw ) @@ -8097,28 +8661,8 @@ subroutine Driver ( RC ) deallocate( totcolc ) deallocate( wtzone ) deallocate( sfm ) - deallocate( bt1_sf ) - deallocate( bt2_sf ) - deallocate( bt4_sf ) - deallocate( btran1_sf ) - deallocate( btran2_sf ) - deallocate( btran3_sf ) - deallocate( btran_fire_rz ) - deallocate( btran_fire_sf ) - deallocate( psnsunx ) - deallocate( psnshax ) - deallocate( sifsunx ) - deallocate( parzone ) - deallocate( sifshax ) - deallocate( laisunx ) - deallocate( laishax ) - deallocate( elaz ) - deallocate( esaz ) - deallocate( fvez ) - deallocate( ityz ) - deallocate( lmrsunx ) - deallocate( lmrshax ) - deallocate( tlaz ) + deallocate( bt ) + deallocate( btran_fire ) deallocate( albdir ) deallocate( albdif ) deallocate( elai ) @@ -8132,118 +8676,122 @@ subroutine Driver ( RC ) deallocate( ityp ) deallocate( lmrsun ) deallocate( lmrsha ) + deallocate( sifsun ) + deallocate( sifsha ) deallocate( ht ) deallocate( tp ) deallocate( soilice ) - deallocate (PLSIN) - call MAPL_TimerOff ( MAPL, "-CATCHCNCLM45" ) + 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 +! +! ! --------------------------------------------------------- +! +! FUNCTION betai(a,b,x) +! REAL betai,a,b,x +! REAL bt +! !external gammln +! +! if (x < 0.0125) x = 0.0125 +! if (x > 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 ! -------------------------------------------------------------- @@ -8291,15 +8839,18 @@ subroutine RUN0(gc, import, export, clock, rc) real, pointer :: ps (:)=>null() !! INTERNAL pointers - !! -asnow-emis-ww-fr- + !! -asnow-emis-ww-fr-D[xx] 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() + real, pointer :: delCQ_delTVA(:,:)=>null() + real, pointer :: delCH_delTVA(:,:)=>null() + real, pointer :: delCH_delTC(:,:)=>null() + real, pointer :: delCQ_delQC(:,:)=>null() + !! -prognostic-variables- real, pointer :: tc(:,:)=>null() real, pointer :: qc(:,:)=>null() @@ -8335,7 +8886,7 @@ subroutine RUN0(gc, import, export, clock, rc) !! Miscellaneous integer :: ntiles, nv, nz real, allocatable :: dummy(:) - real, allocatable :: dzsf(:), ar1(:), ar2(:), wesnn(:,:) + real, allocatable :: DZSF_in_mm(:), ar1(:), ar2(:), wesnn(:,:) real, allocatable :: catdefcp(:), srfexccp(:), rzexccp(:) real, allocatable :: VEG1(:), VEG2(:) integer, allocatable :: ityp(:,:,:) @@ -8362,7 +8913,7 @@ subroutine RUN0(gc, import, export, clock, rc) call ESMF_UserCompGetInternalState(gc, 'CatchcnInternal', wrap, status) VERIFY_(status) - catchcn_internal => wrap%ptr + catchcn_internal => wrap%ptr ! Pointers to IMPORTs call MAPL_GetPointer(import, ps, 'PS', rc=status) VERIFY_(status) @@ -8382,10 +8933,23 @@ subroutine RUN0(gc, import, export, clock, rc) 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) + + if (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND == 1) then + + call MAPL_GetPointer(INTERNAL, delCQ_delTVA, 'delCQ_delTVA', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, delCH_delTVA, 'delCH_delTVA', rc=status) + VERIFY_(status) + + elseif (CATCHCN_INTERNAL%MOSFC_EXTRA_DERIVS_OFFL_LAND >= 2) then + + call MAPL_GetPointer(INTERNAL, delCH_delTC, 'delCH_delTC', rc=status) + VERIFY_(status) + call MAPL_GetPointer(INTERNAL, delCQ_delQC, 'delCQ_delQC', rc=status) + VERIFY_(status) + + end if + call MAPL_GetPointer(INTERNAL, tc, 'TC', rc=status) VERIFY_(status) call MAPL_GetPointer(INTERNAL, qc, 'QC', rc=status) @@ -8478,25 +9042,23 @@ subroutine RUN0(gc, import, export, clock, rc) wtzone(:,nz) = CN_zone_weight(nz) end do - call get_CN_LAI(ntiles,num_veg,num_zon,ityp,fveg,elai,esai=esai) + call get_CN_LAI(ntiles,ityp,fveg,elai,esai=esai) lai1 = 0. wght = 0. do nz = 1,num_zon - do nv = 1,2 - lai1(:) = lai1(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) - wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) - end do + 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 - do nv = 3,4 - lai2(:) = lai2(:) + max(elai(:,nv,nz),0.)*fveg(:,nv,nz)*wtzone(:,nz) - wght(:) = wght(:) + fveg(:,nv,nz)*wtzone(:,nz) - end do + 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 @@ -8511,18 +9073,14 @@ subroutine RUN0(gc, import, export, clock, rc) 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 - elsewhere - VEG1 = map_cat(nint(ITY(:,2))) ! gkw: primary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 endwhere - where(ITY(:,3) > 0.) - VEG2 = map_cat(nint(ITY(:,3))) ! gkw: secondary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 - elsewhere - VEG2 = map_cat(nint(ITY(:,4))) ! gkw: secondary CN PFT type mapped to catchment type; ITY should be > 0 even if FVEG=0 + 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) + fvg(:,2) ! sum veg fractions (primary) gkw: NUM_VEG specific - fveg2(:) = fvg(:,3) + fvg(:,4) ! sum veg fractions (secondary) gkw: fveg1+fveg2=1 + fveg1(:) = fvg(:,1) + fveg2(:) = fvg(:,2) ! Compute ASNOW and EMIS allocate(wesnn(3,ntiles), stat=status) @@ -8543,9 +9101,9 @@ subroutine RUN0(gc, import, export, clock, rc) ! Step 3: compute fr ! -step-1- - allocate(dzsf(ntiles), stat=status) + allocate(DZSF_in_mm(ntiles), stat=status) VERIFY_(status) - dzsf = catchcn_internal%SURFLAY + DZSF_in_mm = catchcn_internal%SURFLAY ! -step-2- allocate(ar1(ntiles), stat=status) @@ -8564,18 +9122,12 @@ subroutine RUN0(gc, import, export, clock, rc) srfexccp = srfexc rzexccp = rzexc call catch_calc_soil_moist( & - ! intent(in) - ntiles, dzsf, vgwmax, cdcr1, cdcr2, & + ntiles, DZSF_in_mm, 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 & ) @@ -8594,33 +9146,34 @@ subroutine RUN0(gc, import, export, clock, rc) 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) + if (allocated(catdefcp)) deallocate(catdefcp) + if (allocated(srfexccp)) deallocate(srfexccp) + if (allocated(rzexccp)) deallocate(rzexccp) + if (allocated(dummy)) deallocate(dummy) + if (allocated(DZSF_in_mm)) deallocate(DZSF_in_mm) + 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_CatchCNCLM45GridCompMod +end module GEOS_CatchCNCLM51GridCompMod subroutine SetServices(gc, rc) use ESMF - use GEOS_CatchCNCLM45GridCompMod, only : mySetservices=>SetServices + 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/GEOScatchCNCLM51_GridComp/README_CN51.md b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/README_CN51.md new file mode 100644 index 000000000..17c2405a3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM51_GridComp/README_CN51.md @@ -0,0 +1,306 @@ +# Catchment-CN5.1 + +Jana Kolassa, Rolf H. Reichle, and Randal D. Koster + +August 2025 + +## 1 Introduction + +Catchment-CN is a hybrid land surface model that incorporates routines from the Community Terrestrial System Model (CTSM) into the NASA Catchment land surface model. While water and energy balance calculations are handled by Catchment, CTSM routines are used for carbon and nitrogen dynamics, which include processes such as photosynthesis, phenology, decomposition, and wildfire. + +## 2 Catchment-CN5.1 + +Catchment-CN5.1 was constructed by merging the Catchment model with a pre-release of CTSM version 5.1 (tag: *branch_tags/PPE.n08_ctsm5.1.dev023*), which is available through the ESCOMP GitHub repository: + +- [https://github.com/ESCOMP/CTSM/tags?after=ctsm5.1.dev030](https://github.com/ESCOMP/CTSM/tags?after=ctsm5.1.dev030) +- [https://github.com/ESCOMP/CTSM/releases/tag/branch\_tags/PPE.n08\_ctsm5.1.dev023](https://github.com/ESCOMP/CTSM/releases/tag/branch_tags/PPE.n08_ctsm5.1.dev023) + +Information on the CTSM subroutines that are mentioned in this documentation is available through the [CLM50\_Tech\_Note](https://escomp.github.io/CTSM/release-clm5.0/tech_note/index.html). + +The initial version of Catchment-CN5.1 is consistent with the Catchment model of release v2.7.5 of the GEOSgcm\_GridComp repository: + +- [https://github.com/GEOS-ESM/GEOSgcm\_GridComp/releases/tag/v2.7.5](https://github.com/GEOS-ESM/GEOSgcm\_GridComp/releases/tag/v2.7.5) + +Catchment-CN5.1 will be updated along with the original version of Catchment with the continued development of the GEOSgcm\_GridComp repository and associated repositories. + +## 3 Structural implementation + +In Catchment-CN5.1, the 'split PFTs' used by previous versions of Catchment-CN have been removed. This means there are now a total of 15 PFTs (corresponding to the 15 CTSM non-crop-model PFTs) instead of the 19 PFTs used in previous Catchment-CN versions. This also means that each model tile only has up to 2 PFTs instead of up to 4 as before to accommodate PFT splitting. + +Catchment and CTSM are linked within the *GEOS_CatchCNCLM51GridComp.F90* module through three key connection points. + +1. *CN_init* initializes the CTSM variables used in Catchment-CN5.1. + +2. *catchcn_calc_rc* connects to the CTSM photosynthesis modules, executing at the GEOS model "heartbeat" time step (currently 5 or 7.5 minutes). The heartbeat time step allows for the provision of important heartbeat-scale variations in the canopy conductance to the Catchment energy balance calculations. + +3. *CN_Driver* links to all other CTSM modules (phenology, decomposition, wildfire, etc.) on a 90-minute cycle. + +Each connection operates through specialized "bridging modules" (section 3.1) that translate between the Catchment and CTSM spaces, handling variable mapping, unit conversions, and spatial translations between the Catchment tile space and the CTSM column/patch space (section 3.2). These bridging modules include *CNCLM_init_mod.F90*, *CNCLM_Photosynthesis.F90*, and *CNCLM_Driver.F90*, each responsible for different aspects of the Catchment-CN integration. Each of the bridging modules is discussed in detail below. + +### 3.1 Bridging modules + +**CNCLM_init_mod.F90:** This module handles the initialization of the CTSM variables, the reading of the CTSM configuration from the *CN_CLM51.nml* namelist file, and the reading of the CTSM parameter file. It contains the subroutine *CN_init*, which calls the CTSM initialization routines. These routines have in some cases been adapted to pass in the Catchment-CN restart variables CNCOL and CNPFT in order to initialize with values from the restart file. Modules that have been modified in this manner are listed in Table B1 in Appendix B. This module and the *CN_init* subroutine are called once during the initialization phase. + +**CNCLM_Photosynthesis.F90:** This module handles the call to the CTSM Photosynthesis module. It contains the subroutine *catchcn\_calc\_rc*, which is organized as follows: + +1. Perform the mapping of Catchment variables needed for the photosynthesis calculations to their CTSM equivalents. +2. Call CTSM subroutines that calculate the sunlit and shaded fraction of the canopy (*TwoStream* and *CanopySunShadeFracs*), information that is needed in the photosynthesis calculations. +3. Call the CTSM *PhotosynthesisHydraulicStress* routine, which performs the main photosynthesis calculations. +4. Map the CTSM photosynthesis outputs back into the Catchment space. + +The above steps are performed at the model "heartbeat" time step (currently 5 or 7.5 minutes). + +**CNCLM_DriverMod.F90:** This module handles the call to the non-photosynthesis CTSM routines and is engaged every 90 minutes. It contains the subroutine *CN_Driver*, which: + +1. maps Catchment variables to their CTSM equivalents, +2. calls the CTSM routines for the non-photosynthesis calculations (phenology, decomposition, wildfire, etc.) including the carbon and nitrogen balance checks, and +3. maps the CTSM outputs back to Catchment space. + +The module also contains the subroutine *CN_exit*, which maps CTSM variables into the arrays CNCOL and CNPFT that are written into the CNCLM restart file. + +**CN2CLMType.F90:** Defines a special type used to pass forcing data from Catchment into the nested CTSM fire data types. + +**update_model_para4cn.F90:** Utility module for updating current time. Introduced in previous versions of Catchment-CN. + +### 3.2 Catchment to CTSM mapping + +In addition to assigning the values of Catchment variables to their CTSM equivalents, three additional mapping steps are needed to use Catchment inputs within the CTSM modules. + +1. The first step only applies to the variables passed to *CN_Driver* and consists of computing 90-minute average states and fluxes from the 5- or 7.5-minute Catchment states and fluxes. (At present, these calculations are done before the call to subroutine *catchmentCN*, and as a result, extra model diagnostics calculations and restart variables are needed. To avoid this overhead and duplication of code segments, it is planned to calculate the averages after the call to catchment in future versions of Catchment-CN5.1.) + +2. The second step involves mapping hydrologic and temperature variables from the three dynamic hydrologic zones used in Catchment to the three static “carbon zones” used in Catchment-CN, which correspond to valley bottoms (10%), hillslopes (45%) and hilltops (45%). This mapping happens prior to the call to *CN_Driver* and uses an areal weighting approach (see Figure 2 of Koster et al. 2014). + +3. The third mapping step relates to the different organization of array variables in Catchment(-CN) and CTSM. PFT-level variables in Catchment-CN typically have the dimensions (ntiles, nveg, nzone), where ntiles is the number of tiles, nveg=2 is the maximum number of PFTs per tile, and nzone=3 is the number of carbon zones. In CTSM, the equivalent variable would have the dimension (1:ntiles\*maxpft\*nzones), where maxpft=15 is the total number of PFTs in the model. In a CTSM array, only the entries corresponding to PFTs that are present in a location have data values. Computations are only performed for the array entries that have data values, which is implemented through indices (called 'filters' in CTSM). This mapping from the Catchment-CN order to the CTSM order is handled by the bridging routines, which also handle the mapping of the CTSM outputs back into the Catchment-CN order. The layout of a CTSM variable array is schematically illustrated in Table B2 in Appendix B. + +## 4 Experiment setup and model configuration + +Configuring and setting up a Catchment-CN5.1 experiment is handled through ldas\_setup or gcm\_setup (to be implemented), the basic approach also used when running Catchment or previous versions of Catchment-CN. To choose Catchment-CN5.1, set LSM\_CHOICE = 4 and LAND\_PARAMS = CN\_CLM51. As with previous versions of Catchment-CN, it is also necessary to choose an option for the source of atmospheric CO2 by modifying the ATM\_CO2 setting. + +CTSM also offers a choice of multiple schemes for different parts of the model code, such as the wildfire calculations, the stomatal conductance scheme, or the decomposition model. These elements of the model configuration are controlled through the *CN_CLM51.nml* file, which can be modified in the ./run directory after setting up an experiment. Note, however, that configuration changes may require additional spinup of the hydrological or carbon states. For more permanent changes to the default configuration, the original file located in the ./GEOScatchCNCLM51\_GridComp directory needs to be modified. Changes made here will only take effect after re-compiling the model as the compilation moves the files to the ./install/etc/ directory, from where *ldas_setup* moves it to the ./run directory. + +Finally, the model configuration can be changed by modifying the CTSM parameters. These can be found in the *ctsm51_params.c210923_forCNCLM.nc* file in the ./input directory. For Catchment-CN5.1, a few parameters were changed from their original CTSM default values (section 5). + +A set of spun-up restart files for Catchment-CN5.1 will be available, and these can be used to initialize an experiment. If no restart file is available at the required resolution, use the GEOS *remap_restarts* functionality to map an existing restart file to the desired resolution. Note that remapping a Catchment[CN] restart to a different resolution generally requires additional model spin-up. + +## 5 Science changes from the original CTSM version + +A few science changes have been made to the original CTSM implementation to adapt the CTSM routines for use with Catchment. These include: + +**'fcur' parameter:** 'fcur' is the fraction of carbon allocation that goes to currently displayed growth. In previous versions of Catchment-CN, fcur was set to 0.5 for the PFTs that, in CLM4 or CLM4.5, have this parameter set to 0. This change was made to address problems with LAI overshoot in years following years with no freeze-related offset as well as to bring temporal phenological variations more in line with satellite-based estimates. This same modification has been adopted here. This change has been made directly in the parameter file (*ctsm51_params.c210923_forCNCLM.nc*). + +**'leaf_long' parameter:** The leaf longevity was set to be at least 1 year in previous versions of Catchment-CN. This modification has been adopted here for consistency. + +**Water stress threshold:** In the original CTSM, the water stress threshold is set through a global constant. In Catchment-CN5.1 the water stress threshold at a given location is set equal to the wilting point at that location. + +**Solar Induced Fluorescence:** The original CTSM does not compute solar induced fluorescence (SIF). In Catchment-CN, the capability to compute SIF was added by including the fluorescence routine developed by Jung-Eun Lee (Brown) using the approach of van der Tol and Berry (2012). This fluorescence routine was initially implemented for Catchment-CN by Greg Walker and has been adapted by Jana Kolassa for Catchment-CN5.1. The adaption to Catchment-CN5.1 accounts for the fact that photosynthesis calculations in CTSM5.1 are separated for the sunlit and shaded parts of the canopy and the number of canopy layers above snow. + +**Heterotrophic respiration calculations:** In the original CTSM tag that was used to develop Catchment-CN5.1 (section 2), the heterotrophic respiration (HR) is calculated as the sum of the litter HR and the soil organic matter HR only. That is, HR does not include the coarse woody debris HR, because the original model parameters were such that the coarse woody debris HR was always 0. The parameter file used for Catchment-CN5.1 (*ctsm51_params.c210923_forCNCLM.nc*) corresponds to a slightly newer version of CTSM, with the parameter values set such that the coarse woody debris HR is not always 0. Consequently, HR from coarse woody debris was added as an additional input to the total HR calculation, consistent with newer versions of CTSM. + +**Number of soil layers:** All versions of Catchment-CN assume only one soil layer for CLM/CTSM calculations. This contrasts with the standard CLM/CTSM framework, which supports multiple soil layer configurations and indeed requires a minimum of 5 layers. + +**Root-zone wetness in fire code:** Instead of calculating the root-zone wetness inside the fire code as is done in the original CTSM, we instead use the root-zone wetness calculated by Catchment. + +## Appendix A: Restarting Catchment-CN5.1 from a Catchment-CN4.5 restart file + +**IMPORTANT: The instructions in Appendix A are for developers only! They do NOT apply for setting up a science experiment.** + +If for some reason it becomes necessary to initialize an experiment from a Catchment-CN4.5 restart file, a few extra steps must be taken. + +First, the Catchment-CN4.5 restart file needs to be modified, such that it reflects the PFT-distribution of Catchment-CN5.1 and the fact that in Catchment-CN5.1 each tile only has up to 2 PFTs as opposed to 4 in previous Catchment-CN versions. The variables affected by this are the PFT (ITY), the PFT fraction (FVG), the array of PFT-level variables (CNPFT), and the sunlit and shaded photosynthesis (PSNSUNM and PSNSHAM). Additionally, the dimension on the CNPFT array needs to be padded with zeroes to reflect the larger number of variables saved to it in Catchment-CN5.1. + +Next, the toggles *init_accum* and *init_accum_365* need to be set to *.true.* in *GEOS_CatchCNCLM51GridComp.F90*. These toggles control how the multi-day average variables are computed before their nominal accumulation period is reached. *init_accum* needs to be set to *.false.* after one month and *init_accum_365* needs to be set to *.false.* after 365 days. Additionally, the toggle *no_cn51_rst* needs to be set to *.true.* when starting the experiment. This toggle allows initialization of the nitrate and ammonia variables from the total nitrogen content when using a Catchment-CN4.5 file. This toggle needs to be switched back to *.false.* after the first time that a restart file is written. + +## Appendix B: CN\_CLM51 files + +Files that are specific to Catchment-CN5.1 are in the ./GEOScatchCNCLM51\_GridComp/ directory. Within this directory, the CTSM files needed to build Catchment-CN5.1 are in the ./CLM51/ directory, which also contains the CLM-to-CN bridging modules (section 3.1). Most of the CTSM files used in Catchment-CN5.1 have been modified from their original CTSM version. For reference, the original, unaltered CTSM files are available in the ./CLM51\_orig\_files/ directory. The modifications can be grouped into the categories outlined below. Table B1 lists all the files in ./CLM51/ and the associated categories. + +### Modification Categories + +**C1:** The initialization of variables was modified to use the CNCOL or CNPFT for saving CTSM variables to the CNCLM restart files. And/or the initialization was simplified to combine the variable allocation and initialization in a single Init subroutine. And/or the subroutines to initialize from CTSM restart files were removed. These changes have no science impact. + +**C2:** The module was modified to load MAPL and/or ESMF types or variables (e.g., "MAPL\_R8" instead of CTSM's "r8"). These changes have no science impact. + +**C3:** **Code changes were made that have scientific impact.** + +**C4:** Unused parts of the CTSM code were commented out or removed. + +**C5:** Changes were made to use MAPL routines instead of CTSM routines (often for reading files), but there is no science impact from this change. + +**C6:** A new custom CLM-to-CN bridging module (section 3.1). + +**C7:** **Code changes were made to match Catchment-CN requirements or to be consistent with previous versions of Catchment-CN. These code changes often have a scientific impact** + +**C8:** External files. + +**Table B1: List of modules in the ./CLM51 directory** and information on how each module has been modified from its CTSM original (the original files are available in ./CLM51/CTSM\_originals). Files that have been modified with changes that have a scientific impact have been marked in bold face. + +| Module | Category | +|--------|----------| +| abortutils.F90 | C4 | +| ActiveLayerMod.F90 | C1, C4 | +| AnnualFluxDribbler.F90 | C4 | +| atm2lndType.F90 | C1, C2, C4 | +| CanopyStateType.F90 | C1, C2 | +| ch4Mod.F90 | C1, C2, C4 | +| **clm_time_manager.F90** | C2, C4, C7 | +| **clm_varcon.F90** | C2, C3, C4, C7 | +| **clm_varctl.F90** | C2, C4, C7 | +| **clm_varpar.F90** | C2, C4, C7 | +| cmake/genf90\_utils.cmake | C8 (from GitHub CESM-Development repository; tag: CMake\_Fortran\_utils\_150308) | +| CN2CLMType.F90 | C6 | +| CNAnnualUpdateMod.F90 | No changes | +| CNBalanceCheckMod.F90 | C1, C5 | +| CNCLM\_DriverMod.F90 | C6 | +| CNCLM\_init\_mod.F90 | C6 | +| CNCLM\_Photosynthesis.F90 | C6 | +| CNCStateUpdate1Mod.F90 | C4 | +| CNCStateUpdate2Mod.F90 | C4 | +| CNCStateUpdate3Mod.F90 | C4 | +| CNDriverMod.F90 | C4 | +| CNDVType.F90 | C1, C4 | +| CNFireBaseMod.F90 | C2, C4 | +| CNFireEmissionsMod.F90 | C1 | +| CNFireFactoryMod.F90 | No changes | +| **CNFireLi2014Mod.F90** | C3, C4, C7 | +| **CNFireLi2016Mod.F90** | C3, C4, C7 | +| **CNFireLi2021Mod.F90** | C3, C4, C7 | +| CNFireNoFireMod.F90 | C4 | +| CNFUNMod.F90 | C2, C4 | +| CNGapMortalityMod.F90 | C4 | +| CNGRespMod.F90 | No changes | +| CNMRespMod.F90 | C4 | +| CNNDynamicsMod.F90 | C4 | +| CNNStateUpdate1Mod.F90 | C4 | +| CNNStateUpdate2Mod.F90 | C4 | +| CNNStateUpdate3Mod.F90 | C4 | +| **CNPhenologyMod.F90** | C3, C4 | +| CNPrecisionControlMod.F90 | No changes | +| CNProductsMod.F90 | C1, C2, C4 | +| CNRootDynMod.F90 | No changes | +| **CNSharedParamsMod.F90** | C2, C5, C7 | +| CNVegCarbonFluxType.F90 | C1, C2, C4 | +| CNVegCarbonStateType.F90 | C1, C2, C4 | +| CNVegetationFacade.F90 | C1, C2, C4 | +| CNVegNitrogenFluxType.F90 | C1, C2, C4 | +| CNVegNitrogenStateType.F90 | C1, C2, C4 | +| CNVegStateType.F90 | C1, C2, C4 | +| CNVegStructUpdateMod.F90 | No changes | +| ColumnType.F90 | C1, C2, C4 | +| column\_varcon.F90 | C4 | +| CropType.F90 | C1, C2, C4 | +| decompMod.F90 | C1, C2, C4 | +| dynSubgridControlMod.F90 | C1, C4 | +| EnergyFluxType.F90 | C1, C4 | +| fileutils.F90 | No changes | +| filterColMod.F90 | No changes | +| filterMod.F90 | C1, C2, C4 | +| FireDataBaseType.F90 | C2, C4 | +| FireMethodType.F90 | C4 | +| FrictionVelocityMod.F90 | C1, C2, C4 | +| genf90.pl | C8 (from GitHub PARALLELIO repository; tag: unknown) | +| GridcellType.F90 | C1, C2, C4 | +| initSubgridMod.F90 | No changes | +| initVerticalMod.F90 | C4 | +| LandunitType.F90 | C1, C2, C4 | +| landunit\_varcon.F90 | No changes | +| ncdio\_pio.F90 | C2, C5 (CTSM original file name: ncdio\_pio.F90.in) | +| NutrientCompetitionCLM45defaultMod.F90 | C4 | +| NutrientCompetitionFactoryMod.F90 | No changes | +| NutrientCompetitionFlexibleCNMod.F90 | C1, C2, C4 | +| NutrientCompetitionMethodMod.F90 | No changes | +| OzoneBaseMod.F90 | C1, C2, C4 | +| paramUtilMod.F90 | C4, C5 | +| PatchType.F90 | C1, C2 | +| perf\_mod.F90 | C4 | +| **pftconMod.F90** | C1, C2, C7 | +| **PhotosynthesisMod.F90** | C1, C2, C3, C7 | +| QSatMod.F90 | No changes | +| quadraticMod.F90 | No changes | +| RootBiophysMod.F90 | C4 | +| SaturatedExcessRunoffMod.F90 | C2, C4 | +| shr\_abort\_mod.F90 | C2, C4, C5 | +| shr\_assert.h | C7 | +| shr\_assert\_mod.F90.in | C4 | +| shr\_const\_mod.F90 | C2, C5 | +| shr\_file\_mod.F90 | No changes | +| shr\_fire\_emis\_mod.F90 | C4 | +| shr\_infnan\_mod.F90.in | C4 | +| shr\_kind\_mod.F90 | C2, C5 | +| shr\_log\_mod.F90 | C7 | +| shr\_mpi\_mod.F90 | C4 | +| shr\_nl\_mod.F90 | C4 | +| shr\_sys\_mod.F90 | C4 | +| **SoilBiogeochemCarbonFluxType.F90** | C2, C3, C4 | +| SoilBiogeochemCarbonStateType.F90 | C1, C2, C4 | +| SoilBiogeochemCompetitionMod.F90 | C5 | +| SoilBiogeochemDecompCascadeBGCMod.F90 | C4 | +| SoilBiogeochemDecompCascadeCNMod.F90 | C4 | +| SoilBiogeochemDecompCascadeConType.F90 | C2, C4 | +| SoilBiogeochemDecompMod.F90 | C4 | +| SoilBiogeochemLittVertTranspMod.F90 | C4 | +| SoilBiogeochemNitrifDenitrifMod.F90 | No changes | +| SoilBiogeochemNitrogenFluxType.F90 | C1, C2, C4 | +| SoilBiogeochemNitrogenStateType.F90 | C1, C2, C4 | +| SoilBiogeochemNLeachingMod.F90 | No Changes | +| SoilBiogeochemNStateUpdate1Mod.F90 | No changes | +| SoilBiogeochemPotentialMod.F90 | No changes | +| SoilBiogeochemPrecisionControlMod.F90 | No changes | +| SoilBiogeochemStateType.F90 | C1, C2 | +| SoilBiogeochemVerticalProfileMod.F90 | No changes | +| SoilStateInitTimeConstMod.F90 | C4 | +| SoilStateType.F90 | C2, C4 | +| SoilWaterRetentionCurveMod.F90 | No changes | +| SolarAbsorbedType.F90 | C2, C4 | +| spmdMod.F90 | C7 | +| subgridAveMod.F90 | C4 | +| SurfaceAlbedoMod.F90 | C4 | +| SurfaceAlbedoType.F90 | C1, C2, C4 | +| SurfaceRadiationMod.F90 | C4 | +| TemperatureType.F90 | C1, C2, C4 | +| TridiagonalMod.F90 | No changes | +| update\_model\_para4cn.F90 | C6 | +| Wateratm2lndBulkType.F90 | C4 | +| Wateratm2lndType.F90 | C1, C4 | +| WaterDiagnosticBulkType.F90 | C1, C2, C4 | +| WaterDiagnosticType.F90 | C4 | +| WaterFluxBulkType.F90 | C1, C2, C4 | +| WaterFluxType.F90 | C1, C2, C4 | +| WaterStateBulkType.F90 | C1, C5 | +| WaterStateType.F90 | C1, C4 | +| WaterType.F90 | C1, C4 | + +**Table B2: Illustration of the layout of a CTSM variable array** In this example, tile 1 contains PFTs 7 and 10 and has data values for the corresponding entries. Only the gray shaded data is present in the CTSM variable array, the other columns of the table serve to illustrate the layout. + +| Array Index | Tile | Zone | PFT | Data | +|-------------|------|------|-----|------| +| 1 | 1 | 1 | 1 | NaN | +| 2 | 1 | 1 | 2 | NaN | +| 3 | 1 | 1 | 3 | NaN | +| 4 | 1 | 1 | 4 | NaN | +| 5 | 1 | 1 | 5 | NaN | +| 6 | 1 | 1 | 6 | NaN | +| 7 | 1 | 1 | 7 | Some data | +| 8 | 1 | 1 | 8 | NaN | +| 9 | 1 | 1 | 9 | NaN | +| 10 | 1 | 1 | 10 | Some data | +| 11 | 1 | 1 | 11 | NaN | +| 12 | 1 | 1 | 12 | NaN | +| 13 | 1 | 1 | 13 | NaN | +| 14 | 1 | 1 | 14 | NaN | +| 15 | 1 | 1 | 15 | NaN | +| 16 | 1 | 2 | 1 | NaN | +| 17 | 1 | 2 | 2 | NaN | +| 18 | 1 | 2 | 3 | NaN | +| 19 | 1 | 2 | 4 | NaN | +| 20 | 1 | 2 | 5 | NaN | +| 21 | 1 | 2 | 6 | NaN | +| 22 | 1 | 2 | 7 | Some data | +| 23 | 1 | 2 | 8 | NaN | +| 24 | 1 | 2 | 9 | NaN | +| 25 | 1 | 2 | 10 | Some data | +| 26 | 1 | 2 | 11 | NaN | +| 27 | 1 | 2 | 12 | NaN | +| 28 | 1 | 2 | 13 | NaN | +| 29 | 1 | 2 | 14 | NaN | +| 30 | 1 | 2 | 15 | NaN | +| ... | ... | ... | ... | ... | diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 old mode 100755 new mode 100644 index c1ddfded7..f455a6899 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/catchmentCN.F90 @@ -137,7 +137,7 @@ MODULE CATCHMENT_CN_MODEL SUBROUTINE CATCHCN ( & NCH, LONS, LATS, DTSTEP, UFW4RO, FWETC, FWETL, cat_id, & ! LONS, LATS are in [radians] !!! ITYP1,ITYP2,FVEG1,FVEG2, & - DZSF, TRAINC,TRAINL, TSNOW, TICE, TFRZR, UM, & ! TFRZR=0 as of Jun 2025; needs attention if ever TFRZR/=0 + DZSF, TRAINC,TRAINL, TSNOW, TICE, TFRZR, UM, & ! DZSF in [mm]!! TFRZR=0 as of Jun 2025; needs attention if ever TFRZR/=0 ETURB1, DEDQA1, DEDTC1, HSTURB1,DHSDQA1, DHSDTC1, & ETURB2, DEDQA2, DEDTC2, HSTURB2,DHSDQA2, DHSDTC2, & ETURB4, DEDQA4, DEDTC4, HSTURB4,DHSDQA4, DHSDTC4, & @@ -155,18 +155,21 @@ SUBROUTINE CATCHCN ( & TG1, TG2, TG4, & TC1, TC2, TC4, QA1, QA2, QA4, CAPAC, & CATDEF, RZEXC, srfexc, GHTCNT, & - WESNN, HTSNNN, SNDZN, EVAP, SHFLUX, RUNOFF, & - EINT, ESOI, EVEG, ESNO, BFLOW,RUNSRF,SMELT, & - HLWUP,SWLAND,HLATN,QINFIL,AR1, AR2, RZEQ, & ! HLWUP = *emitted* longwave only (excl reflected) + WESNN, HTSNNN, SNDZN, & + EVAP, SHFLUX, RUNOFF, & ! EVAP: kg/m2/s + EINT, ESOI, EVEG, ESNO, BFLOW,RUNSRF,SMELT, & ! EINT, ESOI, EVEG, ESNO: W/m2 + HLWUP,SWLAND,LHFLUX,QINFIL,AR1, AR2, RZEQ, & ! HLWUP = *emitted* longwave only (excl reflected) GHFLUX, GHFLUXSNO, GHTSKIN, TPSN1, ASNOW0, & TP1, TP2, TP3, TP4, TP5, TP6, & sfmc, rzmc, prmc, entot, wtot, WCHANGE, ECHANGE, HSNACC, & - EVACC, SHACC, TSURF, & + EVACC, & ! kg/m2/s + LHACC, SHACC, & ! W/m2 + TSURF, & SH_SNOW, AVET_SNOW, WAT_10CM, TOTWAT_SOIL, TOTICE_SOIL, & LH_SNOW, LWUP_SNOW, LWDOWN_SNOW, NETSW_SNOW, & TCSORIG, TPSN1IN, TPSN1OUT, FSW_CHANGE, FICESOUT, & TC1_0, TC2_0, TC4_0, QA1_0, QA2_0, QA4_0, EACC_0, & ! OPTIONAL - RCONSTIT, RMELT, TOTDEPOS, LHACC & ! OPTIONAL + RCONSTIT, RMELT, TOTDEPOS & ! OPTIONAL ) IMPLICIT NONE @@ -220,10 +223,10 @@ SUBROUTINE CATCHCN ( & REAL, INTENT(OUT), DIMENSION(:) :: EVAP, SHFLUX, RUNOFF, & EINT, ESOI, EVEG, ESNO, BFLOW,RUNSRF,SMELT, & - HLWUP,SWLAND,HLATN,QINFIL,AR1, AR2, RZEQ, & + HLWUP,SWLAND,LHFLUX,QINFIL,AR1, AR2, RZEQ, & GHFLUX, TPSN1, ASNOW0, TP1, TP2, TP3, TP4, TP5, TP6, & sfmc, rzmc, prmc, entot, wtot, tsurf, WCHANGE, ECHANGE, & - HSNACC, EVACC, SHACC + HSNACC, EVACC, LHACC, SHACC REAL, INTENT(OUT), DIMENSION(:) :: GHFLUXSNO, GHTSKIN REAL, INTENT(OUT), DIMENSION(:) :: SH_SNOW, AVET_SNOW, & @@ -235,8 +238,6 @@ SUBROUTINE CATCHCN ( & REAL, INTENT(OUT), DIMENSION(:, :) :: FICESOUT - REAL, INTENT(OUT), DIMENSION(:), OPTIONAL :: LHACC - REAL, INTENT(OUT), DIMENSION(:), OPTIONAL :: TC1_0,TC2_0,TC4_0 REAL, INTENT(OUT), DIMENSION(:), OPTIONAL :: QA1_0,QA2_0,QA4_0 REAL, INTENT(OUT), DIMENSION(:), OPTIONAL :: EACC_0 @@ -287,7 +288,8 @@ SUBROUTINE CATCHCN ( & SCLAI, tsn1, tsn2, tsn3, hold, hnew, dedtc0, & dhsdtc0, alhfsn, ADJ, raddn, zc1, tsnowsrf, dum, tsoil, & QA1X, QA2X, QA4X, TC1X, TC2X, TC4X, TCSX, & - EVAPX1,EVAPX2,EVAPX4,SHFLUXX1,SHFLUXX2,SHFLUXX4,EVEGFRC, & + EVAPX1,EVAPX2,EVAPX4,EVAPX124, & + SHFLUXX1,SHFLUXX2,SHFLUXX4,EVEGFRC, & EVAPXS,SHFLUXXS,DTC1SN,DTC2SN,DTC4SN,TCANOP, & ZLAI0, phi,rho_fs,sumdepth, & sndzsc, wesnprec, sndzprec, sndz1perc, & @@ -477,7 +479,7 @@ SUBROUTINE CATCHCN ( & write (*,*) RUNSRF(n_out) write (*,*) SMELT(n_out) write (*,*) HLWUP(n_out) - write (*,*) HLATN(n_out) + write (*,*) LHFLUX(n_out) write (*,*) QINFIL(n_out) write (*,*) AR1(n_out) write (*,*) AR2(n_out) @@ -568,8 +570,6 @@ SUBROUTINE CATCHCN ( & ! in the heat content of deposited snow. HSNACC(N)=0. - EVACC(N)=0. - SHACC(N)=0. RUNSRF(N)=0. @@ -999,7 +999,7 @@ SUBROUTINE CATCHCN ( & ENDIF DO N=1,NCH - HLATN(N)=(1.-ASNOW(N))* & + LHFLUX(N)=(1.-ASNOW(N))* & (EVAP1(N)*AR1(N)+EVAP2(N)*AR2(N)+EVAP4(N)*AR4(N))*ALHE & +ASNOW(N)*EVSNOW(N)*ALHS EVAP(N)=(1.-ASNOW(N))* & @@ -1095,12 +1095,19 @@ SUBROUTINE CATCHCN ( & ECORR & ) + ! NOTE: The following update of the sensible heat flux is intentionally specific to CatchCN() + ! and does not appear in Catchment(). This is because CatchCN() has separate ground and veg + ! temperatures and a more complex resistance network that does not allow for the simpler + ! calculations applied in Catchment(). Note also that WUPDAT() differs between CatchCN() and + ! Catchment(). + ! reichle, koster, kolassa - 24 July 2025 + !**** UPDATE SENSIBLE HEAT IF WATER LIMITATIONS WERE IMPOSED: DO N=1,NCH IF(ECORR(N) .GT. 0.) THEN SHFLUX(N)=SHFLUX(N)+ECORR(N)*ALHE EVAP(N)=EVAP(N)-ECORR(N) - HLATN(N)=ESOI(N)*ALHE + EVEG(N)*ALHE + EINT(N)*ALHE + ESNO(N)*ALHS + LHFLUX(N)=ESOI(N)*ALHE + EVEG(N)*ALHE + EINT(N)*ALHE + ESNO(N)*ALHS ENDIF ENDDO @@ -1211,7 +1218,7 @@ SUBROUTINE CATCHCN ( & if(werror(n) .gt. 0.) then edif=werror(n)/dtstep EVAP(N)=EVAP(N)-EDIF - HLATN(N)=HLATN(N)-EDIF*ALHE + LHFLUX(N)=LHFLUX(N)-EDIF*ALHE EVEGFRC=EVEG(N)/(EVEG(N)+ESOI(N)+1.E-20) EVEG(N)=EVEG(N)-EDIF*EVEGFRC ESOI(N)=ESOI(N)-EDIF*(1.-EVEGFRC) @@ -1425,28 +1432,26 @@ SUBROUTINE CATCHCN ( & ! fluxes, since the land model has to update those areas (based on the fluxes) ! as a matter of course. + ! evap (mass) flux (kg/m2/s) + EVAPX1=ETURB1(N)+DEDQA1(N)*(QA1(N)-QA1_ORIG(N)) EVAPX2=ETURB2(N)+DEDQA2(N)*(QA2(N)-QA2_ORIG(N)) EVAPX4=ETURB4(N)+DEDQA4(N)*(QA4(N)-QA4_ORIG(N)) EVAPXS=ETURBS(N)+DEDQAS(N)*DQSS(N)*(TPSN1(N)-TGS_ORIG(N)) - EVACC(N)= (1.-ASNOW0(N))* & - ( AR1(N)*EVAPX1+ & - AR2(N)*EVAPX2+ & - AR4(N)*EVAPX4 ) & - + ASNOW0(N)*EVAPXS - EVACC(N)=EVAP(N)-EVACC(N) + EVAPX124 = AR1(N)*EVAPX1 + AR2(N)*EVAPX2 + AR4(N)*EVAPX4 - ! added term for latent heat flux correction, reichle+qliu, 9 Oct 2008 + EVACC(N)=EVAP(N)-(1.-ASNOW0(N))*EVAPX124-ASNOW0(N)*EVAPXS + + ! latent heat (energy) flux (W/m2) + ! + ! Note: Strictly speaking, the atmosphere does not receive the latent heat flux, + ! only the evap mass flux and the sensible heat flux. For completeness, + ! however, we also calculate a corresponding "accounting" (or "error") term. + + LHACC(N) = LHFLUX(N) - (1.-ASNOW0(N))*ALHE*EVAPX124 - ASNOW0(N)*ALHS*EVAPXS - if(present(lhacc)) then - LHACC(N)= ALHE*(1.-ASNOW0(N))* & - ( AR1(N)*EVAPX1+ & - AR2(N)*EVAPX2+ & - AR4(N)*EVAPX4 ) & - + ALHS*ASNOW0(N)*EVAPXS - LHACC(N)=HLATN(N)-LHACC(N) - end if + ! sensible heat (energy) flux (W/m2) SHFLUXX1=HSTURB1(N)+DHSDTC1(N)*(TC1(N)-TC1_ORIG(N)) SHFLUXX2=HSTURB2(N)+DHSDTC2(N)*(TC2(N)-TC2_ORIG(N)) @@ -1624,7 +1629,7 @@ SUBROUTINE CATCHCN ( & write (*,*) RUNSRF(n_out) write (*,*) SMELT(n_out) write (*,*) HLWUP(n_out) - write (*,*) HLATN(n_out) + write (*,*) LHFLUX(n_out) write (*,*) QINFIL(n_out) write (*,*) AR1(n_out) write (*,*) AR2(n_out) 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 index c5d39f267..a5dc27f3a 100644 --- 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 @@ -6,24 +6,30 @@ module clm_varpar_shared ! !MODULE: clm_varpar_shared ! ! !DESCRIPTION: -! Module containing CLM parameters +! Module containing CNCLM parameters ! ! !USES: ! ! !PUBLIC TYPES: implicit none save -! -! Define number of levels - integer, parameter :: numpft_CN = 19 ! actual # of pfts (without bare), same as in Catchment-CN.clm4 + ! Define number of levels + + integer, parameter, PUBLIC :: NUM_PFT_CN_40 = 19 ! actual # of pfts (without bare) for Catchment-CN4.0 + integer, parameter, PUBLIC :: NUM_PFT_CN_51 = 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_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 :: 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 :: NUM_VEG_CN_40 = 4 ! number of CN PFTs per zone for Catchment-CN4.0 + integer, parameter, PUBLIC :: NUM_VEG_CN_51 = 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_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 + +! ============================ EOF =========================================================== diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/nanMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/Shared/nanMod.F90 old mode 100755 new mode 100644 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 index 107c31ecc..03bf6563d 100644 --- 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 @@ -11,6 +11,8 @@ PROGRAM dbg_cnlsm_offline ! reading input variables from catchcn_inputs.data at every timestep. ! - Sarith Mahanama (9-1-2018) ! +!THESE ROUTINES ARE SPECIFIC TO CATCHMENT-CN4.0 ONLY (jkolassa, Jul 2025) +! use ESMF use MAPL_ConstantsMod use MAPL_ExceptionHandling diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/m_dbg_routines.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/m_dbg_routines.F90 old mode 100755 new mode 100644 index 3b31753fd..0803e941e --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/m_dbg_routines.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/utils/m_dbg_routines.F90 @@ -1,4 +1,8 @@ MODULE DBG_ROUTINES + +!THESE ROUTINES ARE SPECIFIC TO CATCHMENT-CN4.0 ONLY (jkolassa, Jul 2025) +! + USE catch_constants, ONLY: & N_SNOW => CATCH_N_SNOW, & N_GT => CATCH_N_GT 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 index 17da8116a..d31bcbea8 100644 --- 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 @@ -55,7 +55,7 @@ module GEOS_CatchGridCompMod PEATCLSM_POROS_THRESHOLD - USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, catch_calc_peatclsm_waterlevel + USE lsm_routines, ONLY : sibalb, catch_calc_soil_moist, catch_calc_peatclsm_waterlevel, get_Z0_FORMULATION_params !#for_ldas_coupling use catch_incr @@ -187,11 +187,12 @@ subroutine SetServices ( GC, RC ) OFFLINE_MODE = CATCH_INTERNAL_STATE%CATCH_OFFLINE ! shorthand - ! resource variables from GEOS_SurfaceGridComp.rc + ! put resource variables from rc file into SCF config object (GCM: SURFRC=GEOS_SurfaceGridComp.rc, LDAS: SURFRC=LDAS.rc) call MAPL_GetResource (MAPL, SURFRC, label = 'SURFRC:', default = 'GEOS_SurfaceGridComp.rc', RC=STATUS) ; VERIFY_(STATUS) SCF = ESMF_ConfigCreate(rc=status) ; VERIFY_(STATUS) call ESMF_ConfigLoadFile(SCF,SURFRC,rc=status) ; VERIFY_(STATUS) + ! assemble internal state from SCF config object call surface_params_to_wrap_state(statePtr, SCF, _RC) call ESMF_ConfigDestroy(SCF, _RC) @@ -1225,7 +1226,7 @@ subroutine SetServices ( GC, RC ) call MAPL_AddInternalSpec(GC ,& LONG_NAME = 'mean_catchment_temp_incl_snw',& UNITS = 'K' ,& - SHORT_NAME = 'TSURF' ,& + SHORT_NAME = 'TSURF' ,& ! legacy (and obsolete) internal spec w/ bad name; see ExportSpec TPSURF DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& RESTART = RESTART ,& @@ -3245,7 +3246,6 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: CHOOSEZ0 real :: SCALE4Z0 real :: SCALE4ZVG - real :: SCALE4Z0_u real :: MIN_VEG_HEIGHT ! ------------------------------------- @@ -3559,35 +3559,10 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated( MOQ2M)) MOQ2M = 0.0 if(associated( MOU2M)) MOU2M = 0.0 if(associated( MOV2M)) MOV2M = 0.0 - - select case (CATCH_INTERNAL_STATE%Z0_FORMULATION) - case (0) ! no scaled at all - SCALE4ZVG = 1 - SCALE4Z0 = 1 - SCALE4Z0_u = 1 - MIN_VEG_HEIGHT = 0.01 - case (1) ! This case is bugged - SCALE4ZVG = 1 - SCALE4Z0 = 2 - SCALE4Z0_u = 1 - MIN_VEG_HEIGHT = 0.01 - case (2) - SCALE4ZVG = 1 - SCALE4Z0 = 2 - SCALE4Z0_u = 2 - MIN_VEG_HEIGHT = 0.01 - case (3) - SCALE4ZVG = 0.5 - SCALE4Z0 = 1 - SCALE4Z0_u = 1 - MIN_VEG_HEIGHT = 0.01 - case (4) - SCALE4ZVG = 1 - SCALE4Z0 = 2 - SCALE4Z0_u = 2 - MIN_VEG_HEIGHT = 0.1 - end select - + + call get_Z0_FORMULATION_params( CATCH_INTERNAL_STATE%Z0_FORMULATION, & + MIN_VEG_HEIGHT, SCALE4ZVG, SCALE4Z0 ) + SUBTILES: do N=1,NUM_SUBTILES ! Effective vegetation height. In catchment, LAI dependence @@ -3601,18 +3576,18 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ZVG = Z2CH - SAI4ZVG(VEG)*SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI) else ZVG = Z2CH - SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI) - !Z0T(:,N) = Z0_BY_ZVEG*ZVG*SCALE4Z0 endif - -! For now roughnesses and displacement heights -! are the same for all subtiles. - + + ! For now roughnesses and displacement heights are the same for all subtiles. + Z0T(:,N) = Z0_BY_ZVEG*ZVG*SCALE4Z0 + IF (CATCH_INTERNAL_STATE%USE_ASCATZ0 == 1) THEN WHERE (NDVI <= 0.2) Z0T(:,N) = ASCATZ0 END WHERE ENDIF + D0T = D0_BY_ZVEG*ZVG DZE = max(DZ - D0T, 10.) @@ -3929,7 +3904,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: IM,JM real :: SCALE4ZVG - real :: SCALE4Z0_u + real :: SCALE4Z0 real :: MIN_VEG_HEIGHT type(ESMF_VM) :: VM type (T_CATCH_STATE), pointer :: CATCH_INTERNAL_STATE @@ -3963,28 +3938,8 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_VMGetCurrent(VM, rc=STATUS) - select case (CATCH_INTERNAL_STATE%Z0_FORMULATION) - case (0) ! no scaled at all - SCALE4ZVG = 1 - SCALE4Z0_u = 1 - MIN_VEG_HEIGHT = 0.01 - case (1) ! This case is bugged - SCALE4ZVG = 1 - SCALE4Z0_u = 1 - MIN_VEG_HEIGHT = 0.01 - case (2) - SCALE4ZVG = 1 - SCALE4Z0_u = 2 - MIN_VEG_HEIGHT = 0.01 - case (3) - SCALE4ZVG = 0.5 - SCALE4Z0_u = 1 - MIN_VEG_HEIGHT = 0.01 - case (4) - SCALE4ZVG = 1 - SCALE4Z0_u = 2 - MIN_VEG_HEIGHT = 0.1 - end select + call get_Z0_FORMULATION_params( CATCH_INTERNAL_STATE%Z0_FORMULATION, & + MIN_VEG_HEIGHT, SCALE4ZVG, SCALE4Z0 ) ! ------------------------------------------------------------------------------ ! If its time, recalculate the LSM tile routine @@ -5131,13 +5086,12 @@ subroutine Driver ( RC ) ZVG = Z2CH - SCALE4ZVG*(Z2CH - MIN_VEG_HEIGHT)*exp(-LAI) endif - Z0 = Z0_BY_ZVEG*ZVG*SCALE4Z0_u + ! For now roughnesses and displacement heights are the same for all subtiles. - ! For now roughnesses and displacement heights - ! are the same for all subtiles. - !--------------------------------------------------- + Z0 = Z0_BY_ZVEG*ZVG*SCALE4Z0 IF (CATCH_INTERNAL_STATE%USE_ASCATZ0 == 1) WHERE (NDVI <= 0.2) Z0 = ASCATZ0 + D0 = D0_BY_ZVEG*ZVG UUU = max(UU,MAPL_USMIN) * (log((ZVG-D0+Z0)/Z0) & @@ -5533,9 +5487,9 @@ subroutine Driver ( RC ) ! driver ! -------------------------------------------------------------------------- - _ASSERT(count(PLS<0.)==0,'needs informative message') - _ASSERT(count(PCU<0.)==0,'needs informative message') - _ASSERT(count(SLDTOT<0.)==0,'needs informative message') + _ASSERT(count(PLS<0.) ==0, 'encountered neg precip value (PLS)' ) + _ASSERT(count(PCU<0.) ==0, 'encountered neg precip value (PCU)' ) + _ASSERT(count(SLDTOT<0.)==0, 'encountered neg precip value (SLDTOT)') LAI0 = max(0.0001 , LAI) GRN0 = max(0.0001 , GRN) @@ -6022,8 +5976,8 @@ subroutine Driver ( RC ) CAPAC, CATDEF, RZEXC, SRFEXC, GHTCNT, TSURF ,& WESNN, HTSNNN, SNDZN ,& - EVAPOUT, SHOUT, RUNOFF, EVPINT, EVPSOI, EVPVEG ,& ! EVAPOUT: kg/m2/s - EVPICE ,& ! EVPINT, EVPSOI, EVPVEG, EVPICE: W/m2 + EVAPOUT, SHOUT, RUNOFF ,& ! EVAPOUT: kg/m2/s + EVPINT, EVPSOI, EVPVEG, EVPICE ,& ! EVPINT, EVPSOI, EVPVEG, EVPICE: W/m2 BFLOW ,& RUNSURF ,& SMELT ,& 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 index 1e3fc38ec..e81e14c01 100644 --- 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 @@ -1106,6 +1106,13 @@ SUBROUTINE CATCHMENT ( & !**** !**** (FIRST CORRECT FOR EXCESSIVE INTERCEPTION LOSS) + ! NOTE: The following correction of the interception loss is specific to Catchment() + ! and does not appear in CatchCN(). This is because CatchCN() has separate ground and veg + ! temperatures and a more complex resistance network that does not allow for the simpler + ! calculations applied in Catchment(). Note also that WUPDAT() differs between Catchment() + ! and CatchCN(). + ! reichle, koster, kolassa - 24 July 2025 + DO N=1,NCH EINTX=EIRFRC(N)*EVAPFR(N)*DTSTEP IF(EINTX .GT. CAPAC(N)) THEN diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 index 4c50fedcd..e7e65073d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/Shared/catch_wrap_state.F90 @@ -39,11 +39,12 @@ module catch_wrap_stateMod end type CATCH_WRAP type, extends(T_CATCH_STATE) :: T_CATCHCN_STATE - ! resource parameters from GEOS_SurfaceGridComp.rc: - integer :: ATM_CO2, PRESCRIBE_DVG - real :: CO2 - integer :: CO2_YEAR_IN - real :: DTCN + ! resource parameters from GEOS_SurfaceGridComp.rc: + character(256) :: CN_CLM51_NML_FILE ! length of 256 for consistency with SHR_KIND_CL of CLM51/shr_kind_mod.F90 + integer :: ATM_CO2, PRESCRIBE_DVG + real :: CO2 + integer :: CO2_YEAR_IN + real :: DTCN end type T_CATCHCN_STATE type CATCHCN_WRAP @@ -67,9 +68,9 @@ subroutine surface_params_to_wrap_state(statePtr, scf, rc) ! For documentation, see GEOS_SurfaceGridComp.rc. ! ! ************************************************* ! - call MAPL_GetResource( SCF, statePtr%SURFLAY, label='SURFLAY:', DEFAULT=50., __RC__ ) - call MAPL_GetResource( SCF, statePtr%USE_ASCATZ0, label='USE_ASCATZ0:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%CHOOSEMOSFC, label='CHOOSEMOSFC:', DEFAULT=1, __RC__ ) + call MAPL_GetResource( SCF, statePtr%SURFLAY, label='SURFLAY:', DEFAULT=50., __RC__ ) + call MAPL_GetResource( SCF, statePtr%USE_ASCATZ0, label='USE_ASCATZ0:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%CHOOSEMOSFC, label='CHOOSEMOSFC:', DEFAULT=1, __RC__ ) ! MOSFC_EXTRA_DERIVS_OFFL_LAND: Resource parameter for *offline* (LDAS) mode. ! @@ -95,14 +96,14 @@ subroutine surface_params_to_wrap_state(statePtr, scf, rc) if (statePtr%CHOOSEMOSFC==0) then ! Louis - call MAPL_GetResource( SCF, statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND, label='MOSFC_EXTRA_DERIVS_OFFL_LAND:', DEFAULT=1, __RC__ ) + call MAPL_GetResource( SCF, statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND, label='MOSFC_EXTRA_DERIVS_OFFL_LAND:', DEFAULT=1, __RC__ ) ! make sure parameter value is allowed ii = statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND ; _ASSERT(ii>=0 .and. ii<=3, 'unknown MOSFC_EXTRA_DERIVS_OFFL_LAND for Louis ') elseif (statePtr%CHOOSEMOSFC==1) then ! Helfand - call MAPL_GetResource( SCF, statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND, label='MOSFC_EXTRA_DERIVS_OFFL_LAND:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND, label='MOSFC_EXTRA_DERIVS_OFFL_LAND:', DEFAULT=0, __RC__ ) ! make sure parameter value is allowed (analytical derivs not implemented for Helfand) ii = statePtr%MOSFC_EXTRA_DERIVS_OFFL_LAND ; _ASSERT(ii==0 .or. ii==2, 'unknown MOSFC_EXTRA_DERIVS_OFFL_LAND for Helfand') @@ -125,8 +126,8 @@ subroutine surface_params_to_wrap_state(statePtr, scf, rc) ! ------------------------- - call MAPL_GetResource( SCF, statePtr%USE_FWET_FOR_RUNOFF, label='USE_FWET_FOR_RUNOFF:', DEFAULT=.FALSE., __RC__ ) - call MAPL_GetResource( SCF, statePtr%Z0_FORMULATION, label='Z0_FORMULATION:', DEFAULT=4, __RC__ ) + call MAPL_GetResource( SCF, statePtr%USE_FWET_FOR_RUNOFF, label='USE_FWET_FOR_RUNOFF:', DEFAULT=.FALSE., __RC__ ) + call MAPL_GetResource( SCF, statePtr%Z0_FORMULATION, label='Z0_FORMULATION:', DEFAULT=4, __RC__ ) if (.NOT. statePtr%USE_FWET_FOR_RUNOFF) then FWETC_default = 0.02 @@ -136,22 +137,23 @@ subroutine surface_params_to_wrap_state(statePtr, scf, rc) FWETL_default = 0.025 ! NOT ready for science! endif - call MAPL_GetResource( SCF, statePtr%FWETC, label='FWETC:', DEFAULT=FWETC_default, __RC__ ) - call MAPL_GetResource( SCF, statePtr%FWETL, label='FWETL:', DEFAULT=FWETL_default, __RC__ ) - call MAPL_GetResource( SCF, statePtr%SNOW_ALBEDO_INFO, label='SNOW_ALBEDO_INFO:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%N_CONST_LAND4SNWALB, label='N_CONST_LAND4SNWALB:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%AEROSOL_DEPOSITION, label='AEROSOL_DEPOSITION:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%RUN_IRRIG, label='RUN_IRRIG:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%IRRIG_METHOD, label='IRRIG_METHOD:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%FWETC, label='FWETC:', DEFAULT=FWETC_default, __RC__ ) + call MAPL_GetResource( SCF, statePtr%FWETL, label='FWETL:', DEFAULT=FWETL_default, __RC__ ) + call MAPL_GetResource( SCF, statePtr%SNOW_ALBEDO_INFO, label='SNOW_ALBEDO_INFO:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%N_CONST_LAND4SNWALB, label='N_CONST_LAND4SNWALB:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%AEROSOL_DEPOSITION, label='AEROSOL_DEPOSITION:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%RUN_IRRIG, label='RUN_IRRIG:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%IRRIG_METHOD, label='IRRIG_METHOD:', DEFAULT=0, __RC__ ) select type (statePtr) type is (T_CATCHCN_STATE) ! CATCHCN - - call MAPL_GetResource( SCF, statePtr%DTCN, label='DTCN:', DEFAULT=5400., __RC__ ) - call MAPL_GetResource( SCF, statePtr%ATM_CO2, label='ATM_CO2:', DEFAULT=2, __RC__ ) - call MAPL_GetResource( SCF, statePtr%PRESCRIBE_DVG, label='PRESCRIBE_DVG:', DEFAULT=0, __RC__ ) - call MAPL_GetResource( SCF, statePtr%CO2, label='CO2:', DEFAULT=350.e-6, __RC__ ) - call MAPL_GetResource( SCF, statePtr%CO2_YEAR_IN, label='CO2_YEAR:', DEFAULT=-9999, __RC__ ) + + call MAPL_GetResource( SCF, statePtr%CN_CLM51_NML_FILE, label='CN_CLM51_NML_FILE:', DEFAULT='./CN_CLM51.nml', __RC__ ) + call MAPL_GetResource( SCF, statePtr%DTCN, label='DTCN:', DEFAULT=5400., __RC__ ) + call MAPL_GetResource( SCF, statePtr%ATM_CO2, label='ATM_CO2:', DEFAULT=2, __RC__ ) + call MAPL_GetResource( SCF, statePtr%PRESCRIBE_DVG, label='PRESCRIBE_DVG:', DEFAULT=0, __RC__ ) + call MAPL_GetResource( SCF, statePtr%CO2, label='CO2:', DEFAULT=350.e-6, __RC__ ) + call MAPL_GetResource( SCF, statePtr%CO2_YEAR_IN, label='CO2_YEAR:', DEFAULT=-9999, __RC__ ) end select 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 index aab31393d..9e54d9bb6 100644 --- 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 @@ -1,3 +1,5 @@ +#include "MAPL_Generic.h" + MODULE lsm_routines ! The module contains subroutines that are shared by Catchment and CatchmentCN. @@ -21,8 +23,7 @@ MODULE lsm_routines ! large-scale throughfalls. FWETC and FWETL are now passed through the resource file. ! reichle, 27 Jan 2022 - moved "public" constants & subroutine echo_catch_constants() to catch_constants.f90 - use MAPL, ONLY: & - MAPL_UNDEF + use MAPL USE MAPL_ConstantsMod, ONLY: & PIE => MAPL_PI, & ! - @@ -56,6 +57,7 @@ MODULE lsm_routines PUBLIC :: SIBALB, catch_calc_soil_moist, catch_calc_zbar, catch_calc_peatclsm_waterlevel PUBLIC :: catch_calc_subtile2tile PUBLIC :: gndtmp, catch_calc_tp, catch_calc_wtotl, catch_calc_ght, catch_calc_FT + PUBLIC :: get_Z0_FORMULATION_params PUBLIC :: dampen_tc_oscillations, irrigation_rate INTERFACE catch_calc_zbar @@ -2367,18 +2369,6 @@ subroutine gndtmp(phi,zbar,ht,xfice,tp,FICE,dts,thetaf,fh21) end subroutine gndtmp - ! ******************************************************************* - - - - - - - - - - - ! ******************************************************************* subroutine catch_calc_tp( NTILES, poros, ghtcnt, tp, fice ) @@ -2519,8 +2509,6 @@ end subroutine catch_calc_wtotl ! ******************************************************************* - ! ******************************************************************* - subroutine catch_calc_ght( dzgt, poros, tp, fice, ghtcnt ) ! Invert (model diagnostic) soil temperature and ice fraction @@ -2729,6 +2717,54 @@ subroutine dampen_tc_oscillations( dtstep, tair, tc_old, tc_new_in, & end subroutine dampen_tc_oscillations + ! ******************************************************************* + + subroutine get_Z0_FORMULATION_params( Z0_FORM, & + MIN_VEG_HEIGHT, SCALE4ZVG, SCALE4Z0, & + rc ) + + integer, intent(in) :: Z0_FORM + real, intent(out) :: MIN_VEG_HEIGHT, SCALE4ZVG, SCALE4Z0 + integer, intent(out), optional :: rc ! needed for ASSERT() + + ! ------------------------------------------------- + + select case (Z0_FORM) + + case (0) ! not scaled at all + SCALE4ZVG = 1 + SCALE4Z0 = 1 + MIN_VEG_HEIGHT = 0.01 + + !case (1) ! This case is bugged; was used in Ganymed-4_1, SMAP NRv4/NRv4.1; DISABLED 28 Aug 2025 + ! SCALE4ZVG = 1 + ! SCALE4Z0 = 2 ! was used in RUN1() + ! SCALE4Z0_u = 1 ! was used in RUN2(), inconsistent with RUN1() + ! MIN_VEG_HEIGHT = 0.01 + + case (2) + SCALE4ZVG = 1 + SCALE4Z0 = 2 + MIN_VEG_HEIGHT = 0.01 + + case (3) + SCALE4ZVG = 0.5 + SCALE4Z0 = 1 + MIN_VEG_HEIGHT = 0.01 + + case (4) + SCALE4ZVG = 1 + SCALE4Z0 = 2 + MIN_VEG_HEIGHT = 0.1 + + case default + + _ASSERT(.FALSE., 'unknown Z0_FORMULATION') + + end select + + end subroutine get_Z0_FORMULATION_params + ! ******************************************************************** SUBROUTINE irrigation_rate (IRRIG_METHOD, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc index 1ba28b70b..9266fac60 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -32,6 +32,7 @@ # # Note: For *offline* simulations, optional use of extra MO derivatives is supported # through rc parameter MOSFC_EXTRA_DERIVS_LAND (see catch_wrap_state.F90). +# (Not implemented for CatchCNCLM40.) # # GEOSagcm=>CHOOSEMOSFC: 1 # GEOSagcm=>MOSFC_EXTRA_DERIVS_OFFL_LAND: 0 @@ -65,12 +66,14 @@ # ---- Formulation for turbulent roughness length (z0) # +# For CatchCNCLM40, Z0_FORMULATION=3 is hardwired. +# # 0 : Fortuna, SMAP NRv3 -# 1 : Ganymed-4_1, SMAP NRv4/NRv4.1 +# [1 : Ganymed-4_1, SMAP NRv4/NRv4.1] --> DISABLED, 28 Aug 2025 # 2 : Heracles-4_3, Icarus (AGCM default) # 3 : SMAP NRv5/NRv7.2 # 4 : Icarus-NLv3 (f525_fp, f527_fp, f529_fp) -# SMAP NRv8.1, NRv9.1, NRv10.0 +# SMAP NRv8.1, NRv9.1, NRv10.0, NRv11.4 # # GEOSagcm=>Z0_FORMULATION: 4 # GEOSldas=>Z0_FORMULATION: 4 @@ -216,6 +219,13 @@ # GEOSagcm=>DTCN: 5400 # GEOSldas=>DTCN: 5400 +# ---- Name of nml file for Catchment-CN5.1 +# +# Include path (abs or relative) in string; './' is the "run" directory. String max length is 256 chars. +# +# GEOSagcm=>CN_CLM51_NML_FILE: './CN_CLM51.nml' +# GEOSldas=>CN_CLM51_NML_FILE: './CN_CLM51.nml' + # ---- Atmospheric CO2 # # 0: Use a fixed value defined by "CO2" resource parameter [ppm] @@ -238,6 +248,7 @@ # ---- Prescribe daily LAI and SAI data from an archived CATCHCN simulation # +# Implemented only for CatchCNCLM40. May not work! # # 0 : NO, run CN Model interactively (default) # 1 : YES, prescribe interannually varying LAI and SAI diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 index 2a7fdaf59..863f7f968 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/SurfParams.F90 @@ -54,6 +54,7 @@ subroutine SurfParams_init(LAND_PARAMS,LSM_CHOICE, rc) if (LSM_CHOICE==1) then select case (LAND_PARAMS) + case ("Icarus") ! "Old" LDASsa physics, current default for Icarus GCM LAND_FIX = .FALSE. CSOIL_2 = 200. @@ -94,6 +95,7 @@ subroutine SurfParams_init(LAND_PARAMS,LSM_CHOICE, rc) else if (LSM_CHOICE==2) then select case (LAND_PARAMS) + case ("CN_CLM40") ! parameters to reproduce Fanwei Zeng's Catchment-CN.4.0 runs (e0004s_transientCO2_05) done with build /gpfsm/dnb31/fzeng/LDASsa_m3-16_0_p2_CatchCatchCN_for_MERRA3 LAND_FIX = .TRUE. CSOIL_2 = 70000. ! Post H5_0 @@ -109,23 +111,24 @@ 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.04 + 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/Raster/makebcs/make_bcs_shared.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py index b5e651deb..20b3089d3 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py @@ -163,14 +163,22 @@ def get_script_mv(grid_type): /bin/rm -r {TMP_DIR} -# if necessary, copy resolution-independent CO2 file from MAKE_BCS_INPUT_DIR to bcs dir - -if(-f land/shared/CO2_MonthlyMean_DiurnalCycle.nc4) then - echo "CO2_MonthlyMean_DiurnalCycle.nc4 already present in bcs dir." -else - /bin/cp -p {MAKE_BCS_INPUT_DIR}/land/CO2/v1/CO2_MonthlyMean_DiurnalCycle.nc4 land/shared/CO2_MonthlyMean_DiurnalCycle.nc4 - echo "Successfully copied CO2_MonthlyMean_DiurnalCycle.nc4 to bcs dir." -endif +# if necessary, copy resolution-independent files to bcs dir + +set files = ( \\ + "CO2/v1/CO2_MonthlyMean_DiurnalCycle.nc4" \\ + "CLM/v1/ctsm51_params.c210923_forCNCLM.nc" \\ +) + +foreach f ($files) + set fname = `basename $f` + if (-f land/shared/$fname) then + echo "$fname already present in bcs dir." + else + /bin/cp -p {MAKE_BCS_INPUT_DIR}/land/$f land/shared/$fname + echo "Successfully copied $fname to bcs dir." + endif +end # adjust permissions 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 index fcafbf333..cda06459e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 @@ -739,7 +739,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 11: CatchCNCLM45 abm peatf gdp hdm fc parameters' + tmpstring = 'Step 11: CatchCNCLM[45,51] abm peatf gdp hdm fc parameters' fname_tmp = 'clsm/CLM4.5_abm_peatf_gdp_hdm_fc' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) @@ -755,7 +755,7 @@ PROGRAM mkCatchParam endif write (log_file,'(a)')' ' - tmpstring = 'Step 12: CatchCNCLM45 lightning frequency' + tmpstring = 'Step 12: CatchCNCLM[45,51] lightning frequency' fname_tmp = 'clsm/lnfm.dat' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) 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 index 6300fdebd..a5b8b0d0d 100644 --- 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 @@ -46,7 +46,8 @@ MODULE process_hres_data public :: modis_alb_on_tiles_high,modis_scale_para_high,hres_lai_no_gswp public :: histogram, create_mapping, esa2mosaic , esa2clm public :: grid2tile_ndep_t2m_alb, map_country_codes, get_country_codes - public :: CLM45_fixed_parameters, CLM45_clim_parameters, gimms_clim_ndvi, grid2tile_glass, open_landparam_nc4_files + public :: CLM45_fixed_parameters, CLM45_clim_parameters ! for CatchCNCLM45 and CatchCNCLM51 + public :: gimms_clim_ndvi, grid2tile_glass, open_landparam_nc4_files integer, parameter :: nc_esa = 129600 ! # columns in 10-arcsec GEOS5_10arcsec_mask* file integer, parameter :: nr_esa = 64800 ! # rows in 10-arcsec GEOS5_10arcsec_mask* file @@ -3862,7 +3863,7 @@ SUBROUTINE soil_para_hwsd (nx,ny, n_land, tile_pfs, tile_id) ! ---------------------------------------------------------------------------- - ! compute peat fraction on tile for CLM45+ (for fires?) + ! compute peat fraction on tile for CatchCNCLM[45,51] (for fires?) allocate(pmap (1:n_land)) !allocate(count_soil(1:n_land)) ! already allocated above @@ -5557,11 +5558,10 @@ end SUBROUTINE grid2tile_ndep_t2m_alb ! ------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE CLM45_fixed_parameters (nc,nr, ntiles, tile_id) - + implicit none - ! producing CLM4.5 fixed parameters : - + ! producing CLM4.5 & CTSM5.1 fixed parameters : ! 1) Population density /discover/nobackup/fzeng/clm4-to-clm4.5/data/firedata4.5/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc ! Use 2010 @@ -5721,6 +5721,8 @@ END SUBROUTINE CLM45_fixed_parameters SUBROUTINE CLM45_clim_parameters (nc,nr, ntiles, tile_id) + ! producing CLM4.5 & CTSM5.1 clim parameters : + implicit none ! Producing : lightening frequency HRMC_COM_FR /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/firedata4.5/LISOTD_HRMC_V2.3.2014.hdf ! 12 values per tile 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 index 43a16b7b9..1d9c6409d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CatchmentCNRst.F90 @@ -1,75 +1,111 @@ #include "MAPL_Generic.h" module CatchmentCNRstMod - use mk_restarts_getidsMod, ONLY: & - GetIds + + use mk_restarts_getidsMod, ONLY: GetIds use mpi use ESMF use MAPL - use CatchmentRstMod, only : CatchmentRst - use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg => NUM_VEG_CN, & - VAR_COL_40, VAR_PFT_40, VAR_COL_45, VAR_PFT_45, & - npft => numpft_CN - use nanMod , only : nan + use CatchmentRstMod, only : CatchmentRst + + use clm_varpar_shared , only : & + nzone => NUM_ZON_CN, & + nveg_40 => NUM_VEG_CN_40, & + nveg_51 => NUM_VEG_CN_51, & + VAR_COL_40, VAR_PFT_40, & + VAR_COL_51, VAR_PFT_51, & + npft_40 => NUM_PFT_CN_40, & + npft_51 => NUM_PFT_CN_51 + + 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/) + real, parameter :: fmin = 1.e-4 ! ignore vegetation fractions at or below this value + + integer :: iclass_40(npft_40) = (/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 :: isCLM40 + logical :: isCLM51 + integer :: VAR_COL integer :: VAR_PFT - real, allocatable :: cnity(:,:) - real, allocatable :: fvg(:,:) - real, allocatable :: tg(:,:) - real, allocatable :: tgwm(:,:) - real, allocatable :: rzmm(:,:) - real, allocatable :: sfmm(:,:) - real, allocatable :: TILE_ID(:) - real, allocatable :: ndep(:) - real, allocatable :: t2(:) - real, allocatable :: BGALBVR(:) - real, allocatable :: BGALBVF(:) - real, allocatable :: BGALBNR(:) - real, allocatable :: BGALBNF(:) + integer :: NVEG + + ! within each block, field names are in order of "MAPL_AddInternalSpec()" calls in GEOS_CatchCNCLM*GridComp.F90 + + ! common to CNCLM40 and CNCLM51 + + real, allocatable :: cnity(:,:) ! need 2-dim veg class for CatchCN + real, allocatable :: fvg(:,:) + real, allocatable :: tg(:,:) + real, allocatable :: TILE_ID(:) + real, allocatable :: ndep(:) + real, allocatable :: cli_t2m(:) ! changed from "t2" to "cli_t2m" for consistency with InternalSpec name + real, allocatable :: BGALBVR(:) + real, allocatable :: BGALBVF(:) + real, allocatable :: BGALBNR(:) + real, allocatable :: BGALBNF(:) real, allocatable :: CNCOL(:,:) real, allocatable :: CNPFT(:,:) - real, allocatable :: ABM (:) - real, allocatable :: FIELDCAP(:) - real, allocatable :: HDM (:) - real, allocatable :: GDP (:) - real, allocatable :: PEATF (:) - - real, allocatable :: bflowm(:) - real, allocatable :: totwatm(:) - real, allocatable :: tairm(:) - real, allocatable :: tpm(:) - real, allocatable :: cnsum(:) - real, allocatable :: sndzm(:) - real, allocatable :: asnowm(:) - real, allocatable :: ar1m(:) - real, allocatable :: rainfm(:) - real, allocatable :: rhm(:) - real, allocatable :: runsrfm(:) - real, allocatable :: snowfm(:) - real, allocatable :: windm(:) + real, allocatable :: tgwm(:,:) + real, allocatable :: rzmm(:,:) + real, allocatable :: bflowm(:) + real, allocatable :: totwatm(:) + real, allocatable :: tairm(:) + real, allocatable :: tpm(:) + real, allocatable :: cnsum(:) + real, allocatable :: psnsunm(:,:,:) + real, allocatable :: psnsham(:,:,:) + real, allocatable :: sndzm(:) + real, allocatable :: asnowm(:) + + ! CNCLM40 only + + real, allocatable :: sfmcm(:) ! 1-dim CN sum for sfc soil moist (CNCLM40) + + ! CNCLM51 only + + real, allocatable :: sfmm(:,:) ! 2-dim CN sum for sfc soil moist (CNCLM51) + real, allocatable :: ABM(:) + real, allocatable :: PEATF(:) + real, allocatable :: GDP(:) + real, allocatable :: HDM(:) + real, allocatable :: FIELDCAP(:) + real, allocatable :: rhm(:) + real, allocatable :: windm(:) + real, allocatable :: rainfm(:) + real, allocatable :: snowfm(:) + real, allocatable :: runsrfm(:) + real, allocatable :: ar1m(:) + real, allocatable :: lmrsunm(:,:,:) + real, allocatable :: lmrsham(:,:,:) + real, allocatable :: laisunm(:,:,:) + real, allocatable :: laisham(:,:,:) + real, allocatable :: sndzm5d(:) + real, allocatable :: t2m10d(:) + real, allocatable :: tg10d(:) + real, allocatable :: t2mmin5d(:) + real, allocatable :: rh30d(:) real, allocatable :: tprec10d(:) real, allocatable :: tprec60d(:) - real, allocatable :: t2m10d(:) - real, allocatable :: sfmcm(:) - real, allocatable :: psnsunm(:,:,:) - real, allocatable :: psnsham(:,:,:) + real, allocatable :: et365d(:) + real, allocatable :: runsurf(:) + + contains - contains procedure :: write_nc4 procedure :: allocate_cn procedure :: add_bcs_to_cnrst procedure :: re_tile + endtype CatchmentCNRst - + interface CatchmentCNRst module procedure CatchmentCNRst_Create end interface @@ -98,124 +134,147 @@ function CatchmentCNRst_create(filename, cnclm, time, rc) result (catch) call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - catch%isCLM45 = .false. catch%isCLM40 = .false. + catch%isCLM51 = .false. + call formatter%open(filename, pFIO_READ, __RC__) - meta = formatter%read(__RC__) - ntiles = meta%get_dimension('tile', __RC__) + + meta = formatter%read(__RC__) + ntiles = meta%get_dimension('tile', __RC__) catch%ntiles = ntiles - catch%meta = meta - catch%time = time + catch%meta = meta + catch%time = time + if (index(cnclm, '40') /=0) then 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 + + 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 - call catch%allocate_cn(__RC__) + + call catch%allocate_cn( __RC__) call catch%read_shared_nc4(formatter, __RC__) - call MAPL_VarRead(formatter,"ITY",catch%cnity, __RC__) - call MAPL_VarRead(formatter,"FVG",catch%fvg, __RC__) - - call MAPL_VarRead(formatter,"TG",catch%tg, __RC__) - call MAPL_VarRead(formatter,"TILE_ID",catch%TILE_ID, __RC__) - call MAPL_VarRead(formatter,"NDEP",catch%ndep, __RC__) - call MAPL_VarRead(formatter,"CLI_T2M",catch%t2, __RC__) - call MAPL_VarRead(formatter,"BGALBVR",catch%BGALBVR, __RC__) - call MAPL_VarRead(formatter,"BGALBVF",catch%BGALBVF, __RC__) - call MAPL_VarRead(formatter,"BGALBNR",catch%BGALBNR, __RC__) - call MAPL_VarRead(formatter,"BGALBNF",catch%BGALBNF, __RC__) + ! within each block, field names are in order of "MAPL_AddInternalSpec()" calls in GEOS_CatchCNCLM*GridComp.F90 + + ! common to CNCLM40 and CNCLM51 + + call MAPL_VarRead( formatter, "ITY", catch%cnity , __RC__) + call MAPL_VarRead( formatter, "FVG", catch%fvg , __RC__) + call MAPL_VarRead( formatter, "TG", catch%tg , __RC__) + call MAPL_VarRead( formatter, "TILE_ID", catch%TILE_ID , __RC__) + call MAPL_VarRead( formatter, "NDEP", catch%ndep , __RC__) + call MAPL_VarRead( formatter, "CLI_T2M", catch%cli_t2m , __RC__) + call MAPL_VarRead( formatter, "BGALBVR", catch%BGALBVR , __RC__) + call MAPL_VarRead( formatter, "BGALBVF", catch%BGALBVF , __RC__) + call MAPL_VarRead( formatter, "BGALBNR", catch%BGALBNR , __RC__) + call MAPL_VarRead( formatter, "BGALBNF", catch%BGALBNF , __RC__) + call MAPL_VarRead( formatter, "CNCOL", catch%CNCOL , __RC__) + call MAPL_VarRead( formatter, "CNPFT", catch%CNPFT , __RC__) + call MAPL_VarRead( formatter, "TGWM", catch%tgwm , __RC__) + call MAPL_VarRead( formatter, "RZMM", catch%rzmm , __RC__) + call MAPL_VarRead( formatter, "BFLOWM", catch%bflowm , __RC__) + call MAPL_VarRead( formatter, "TOTWATM", catch%totwatm , __RC__) + call MAPL_VarRead( formatter, "TAIRM", catch%tairm , __RC__) + call MAPL_VarRead( formatter, "TPM", catch%tpm , __RC__) + call MAPL_VarRead( formatter, "CNSUM", catch%cnsum , __RC__) + call MAPL_VarRead( formatter, "PSNSUNM", catch%psnsunm , __RC__) + call MAPL_VarRead( formatter, "PSNSHAM", catch%psnsham , __RC__) + call MAPL_VarRead( formatter, "SNDZM", catch%sndzm , __RC__) + call MAPL_VarRead( formatter, "ASNOWM", catch%asnowm , __RC__) + + ! specific to CNCLM40 or CNCLM51 + + if ( catch%isCLM40 ) then + + call MAPL_VarRead( formatter, "SFMCM", catch%sfmcm , __RC__) + + elseif( catch%isCLM51 ) then + + call MAPL_VarRead( formatter, "SFMM", catch%sfmm , __RC__) ! rreichle, bug fix 4 Aug 2025: added for CLM51 + call MAPL_VarRead( formatter, "ABM", catch%ABM , __RC__) + call MAPL_VarRead( formatter, "PEATF", catch%PEATF , __RC__) + call MAPL_VarRead( formatter, "GDP", catch%GDP , __RC__) + call MAPL_VarRead( formatter, "HDM", catch%HDM , __RC__) + call MAPL_VarRead( formatter, "FIELDCAP", catch%FIELDCAP, __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, "LMRSUNM", catch%lmrsunm , __RC__) + call MAPL_VarRead( formatter, "LMRSHAM", catch%lmrsham , __RC__) + call MAPL_VarRead( formatter, "LAISUNM", catch%laisunm , __RC__) + call MAPL_VarRead( formatter, "LAISHAM", catch%laisham , __RC__) + call MAPL_VarRead( formatter, "SNDZM5D", catch%SNDZM5D , __RC__) + call MAPL_VarRead( formatter, "T2M10D", catch%T2M10D , __RC__) + call MAPL_VarRead( formatter, "TG10D", catch%TG10D , __RC__) + call MAPL_VarRead( formatter, "T2MMIN5D", catch%T2MMIN5D, __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__) + call MAPL_VarRead( formatter, "ET365D", catch%ET365D , __RC__) ! rreichle, bug fix 4 Aug 2025: added for CLM51 + call MAPL_VarRead( formatter, "RUNSURF", catch%ET365D , __RC__) ! rreichle, bug fix 4 Aug 2025: added for CLM51 - if( catch%isCLM40 ) then - call MAPL_VarRead(formatter,"SFMCM", catch%sfmcm , __RC__) endif - if( catch%isCLM45 ) 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,"T2M10D", catch%T2M10D , __RC__) - call MAPL_VarRead(formatter,"TPREC10D", catch%TPREC10D , __RC__) - call MAPL_VarRead(formatter,"TPREC60D", catch%TPREC60D , __RC__) - call MAPL_VarRead(formatter,"SFMM", catch%sfmm , __RC__) - endif - call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL, __RC__) - - ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 - ! (to be merged into the "develop" branch in late 2020): - ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, - ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), - ! resulting in bad values in the "regridded" (re-tiled) restart file. - ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. - ! - reichle, 23 Nov 2020 - call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT, __RC__) - - ! more reading - call MAPL_VarRead(formatter, "BFLOWM", catch%bflowm ,_RC) - call MAPL_VarRead(formatter, "TOTWATM", catch%totwatm,_RC) - call MAPL_VarRead(formatter, "TAIRM", catch%tairm ,_RC) - call MAPL_VarRead(formatter, "TPM", catch%tpm ,_RC) - call MAPL_VarRead(formatter, "CNSUM", catch%cnsum ,_RC) - call MAPL_VarRead(formatter, "SNDZM", catch%sndzm ,_RC) - 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, "RZMM", catch%rzmm ,_RC) - call MAPL_VarRead(formatter, "TGWM", catch%tgwm ,_RC) endif call formatter%close() if (present(rc)) rc =0 + end function CatchmentCNRst_Create - function CatchmentCNRst_empty(meta, cnclm, time, rc) result (catch) - type(CatchmentCNRst) :: catch - type(FileMetadata), intent(in) :: meta - character(*), intent(in) :: cnclm - character(*), intent(in) :: time - integer, optional, intent(out) :: rc - integer :: status, myid, mpierr - character(len=256) :: Iam = "CatchmentCNRst_empty" + ! -------------------------------------------------------------------------------------------- + + function CatchmentCNRst_empty(meta, cnclm, time, rc) result (catch) + + type(CatchmentCNRst) :: catch + type(FileMetadata), intent(in) :: meta + character(*), intent(in) :: cnclm + character(*), intent(in) :: time + integer, optional, intent(out) :: rc + integer :: status, myid, mpierr + character(len=256) :: Iam = "CatchmentCNRst_empty" - catch%isCLM45 = .false. catch%isCLM40 = .false. - catch%ntiles = meta%get_dimension('tile', __RC__) - catch%time = time - catch%meta = meta + catch%isCLM51 = .false. + + catch%ntiles = meta%get_dimension('tile', __RC__) + catch%time = time + catch%meta = meta + if (index(cnclm, '40') /=0) then catch%isCLM40 = .true. catch%VAR_COL = VAR_COL_40 catch%VAR_PFT = VAR_PFT_40 endif - if (index(cnclm, '45') /=0) then - catch%isCLM45 = .true. - catch%VAR_COL = VAR_COL_45 - catch%VAR_PFT = VAR_PFT_45 + + 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__) if(present(rc)) rc = 0 + end function CatchmentCNRst_empty + ! -------------------------------------------------------------------------------------------- + subroutine write_nc4(this, filename, rc) class(CatchmentCNRst), intent(inout):: this character(*), intent(in) :: filename @@ -236,122 +295,156 @@ subroutine write_nc4(this, filename, rc) call this%write_shared_nc4(formatter, __RC__) - call MAPL_VarWrite(formatter,"ITY",this%cnity) - call MAPL_VarWrite(formatter,"FVG",this%fvg) - call MAPL_VarWrite(formatter,"TG",this%tg) - - call MAPL_VarWrite(formatter,"TILE_ID",this%TILE_ID) - call MAPL_VarWrite(formatter,"NDEP",this%NDEP) - call MAPL_VarWrite(formatter,"CLI_T2M",this%t2) - call MAPL_VarWrite(formatter,"BGALBVR",this%BGALBVR) - call MAPL_VarWrite(formatter,"BGALBVF",this%BGALBVF) - call MAPL_VarWrite(formatter,"BGALBNR",this%BGALBNR) - call MAPL_VarWrite(formatter,"BGALBNF",this%BGALBNF) - call MAPL_VarWrite(formatter,"CNCOL",this%CNCOL) - call MAPL_VarWrite(formatter,"CNPFT",this%CNPFT) - - call MAPL_VarWrite(formatter,"BFLOWM", this%bflowm ) - call MAPL_VarWrite(formatter,"TOTWATM",this%totwatm) - call MAPL_VarWrite(formatter,"TAIRM", this%tairm ) - call MAPL_VarWrite(formatter,"TPM", this%tpm ) - call MAPL_VarWrite(formatter,"CNSUM", this%cnsum ) - call MAPL_VarWrite(formatter,"SNDZM", this%sndzm ) - call MAPL_VarWrite(formatter,"ASNOWM", this%asnowm ) - call MAPL_VarWrite(formatter,"TGWM", this%tgwm) - call MAPL_VarWrite(formatter,"RZMM", this%rzmm) - - if (this%isCLM45) 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,"T2M10D", this%t2m10d ) - call MAPL_VarWrite(formatter,"TPREC10D",this%tprec10d ) - call MAPL_VarWrite(formatter,"TPREC60D",this%tprec60d ) - endif - - if (this%isCLM40) call MAPL_VarWrite(formatter,"SFMCM", this%sfmcm) - - call MAPL_VarWrite(formatter,"PSNSUNM", this%PSNSUNM ) - call MAPL_VarWrite(formatter,"PSNSHAM", this%PSNSHAM ) + ! within each block, field names are in order of "MAPL_AddInternalSpec()" calls in GEOS_CatchCNCLM*GridComp.F90 + + ! common to CNCLM40 and CNCLM51 + + call MAPL_VarWrite( formatter, "ITY", this%cnity , __RC__) + call MAPL_VarWrite( formatter, "FVG", this%fvg , __RC__) + call MAPL_VarWrite( formatter, "TG", this%tg , __RC__) + call MAPL_VarWrite( formatter, "TILE_ID", this%TILE_ID , __RC__) + call MAPL_VarWrite( formatter, "NDEP", this%ndep , __RC__) + call MAPL_VarWrite( formatter, "CLI_T2M", this%cli_t2m , __RC__) + call MAPL_VarWrite( formatter, "BGALBVR", this%BGALBVR , __RC__) + call MAPL_VarWrite( formatter, "BGALBVF", this%BGALBVF , __RC__) + call MAPL_VarWrite( formatter, "BGALBNR", this%BGALBNR , __RC__) + call MAPL_VarWrite( formatter, "BGALBNF", this%BGALBNF , __RC__) + call MAPL_VarWrite( formatter, "CNCOL", this%CNCOL , __RC__) + call MAPL_VarWrite( formatter, "CNPFT", this%CNPFT , __RC__) + call MAPL_VarWrite( formatter, "TGWM", this%tgwm , __RC__) + call MAPL_VarWrite( formatter, "RZMM", this%rzmm , __RC__) + call MAPL_VarWrite( formatter, "BFLOWM", this%bflowm , __RC__) + call MAPL_VarWrite( formatter, "TOTWATM", this%totwatm , __RC__) + call MAPL_VarWrite( formatter, "TAIRM", this%tairm , __RC__) + call MAPL_VarWrite( formatter, "TPM", this%tpm , __RC__) + call MAPL_VarWrite( formatter, "CNSUM", this%cnsum , __RC__) + call MAPL_VarWrite( formatter, "PSNSUNM", this%psnsunm , __RC__) + call MAPL_VarWrite( formatter, "PSNSHAM", this%psnsham , __RC__) + call MAPL_VarWrite( formatter, "SNDZM", this%sndzm , __RC__) + call MAPL_VarWrite( formatter, "ASNOWM", this%asnowm , __RC__) + + ! specific to CNCLM40 or CNCLM51 + + if ( this%isCLM40 ) then + + call MAPL_VarWrite(formatter, "SFMCM", this%sfmcm , __RC__) + + elseif( this%isCLM51 ) then + + call MAPL_VarWrite( formatter, "SFMM", this%sfmm , __RC__) + call MAPL_VarWrite( formatter, "ABM", this%ABM , __RC__) + call MAPL_VarWrite( formatter, "PEATF", this%PEATF , __RC__) + call MAPL_VarWrite( formatter, "GDP", this%GDP , __RC__) + call MAPL_VarWrite( formatter, "HDM", this%HDM , __RC__) + call MAPL_VarWrite( formatter, "FIELDCAP", this%FIELDCAP, __RC__) + call MAPL_VarWrite( formatter, "RHM", this%RHM , __RC__) + call MAPL_VarWrite( formatter, "WINDM", this%WINDM , __RC__) + call MAPL_VarWrite( formatter, "RAINFM", this%RAINFM , __RC__) + call MAPL_VarWrite( formatter, "SNOWFM", this%SNOWFM , __RC__) + call MAPL_VarWrite( formatter, "RUNSRFM", this%RUNSRFM , __RC__) + call MAPL_VarWrite( formatter, "AR1M", this%AR1M , __RC__) + call MAPL_VarWrite( formatter, "LMRSUNM", this%lmrsunm , __RC__) + call MAPL_VarWrite( formatter, "LMRSHAM", this%lmrsham , __RC__) + call MAPL_VarWrite( formatter, "LAISUNM", this%laisunm , __RC__) + call MAPL_VarWrite( formatter, "LAISHAM", this%laisham , __RC__) + call MAPL_VarWrite( formatter, "SNDZM5D", this%SNDZM5D , __RC__) + call MAPL_VarWrite( formatter, "T2M10D", this%T2M10D , __RC__) + call MAPL_VarWrite( formatter, "TG10D", this%TG10D , __RC__) + call MAPL_VarWrite( formatter, "T2MMIN5D", this%T2MMIN5D, __RC__) + call MAPL_VarWrite( formatter, "RH30D", this%RH30D , __RC__) + call MAPL_VarWrite( formatter, "TPREC10D", this%TPREC10D, __RC__) + call MAPL_VarWrite( formatter, "TPREC60D", this%TPREC60D, __RC__) + call MAPL_VarWrite( formatter, "ET365D", this%ET365D , __RC__) + call MAPL_VarWrite( formatter, "RUNSURF", this%ET365D , __RC__) - call formatter%close() + endif _RETURN(_SUCCESS) - end subroutine write_nc4 + end subroutine write_nc4 + + ! -------------------------------------------------------------------------------------------- + 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 + + ncol = nzone* this%VAR_COL + npft = nzone*nveg*this%VAR_PFT call this%CatchmentRst%allocate_catch(__RC__) ! W.Jiang notes : some varaiables are not allocated because they are set to zero directly during write - allocate(this%cnity(ntiles,nveg)) - allocate(this%fvg(ntiles,nveg)) - allocate(this%tg(ntiles,nveg)) - allocate(this%TILE_ID(ntiles)) - allocate(this%ndep(ntiles)) - allocate(this%t2(ntiles)) - allocate(this%BGALBVR(ntiles)) - allocate(this%BGALBVF(ntiles)) - allocate(this%BGALBNR(ntiles)) - allocate(this%BGALBNF(ntiles)) - allocate(this%CNCOL(ntiles,ncol)) - allocate(this%CNPFT(ntiles,npft)) - allocate(this%ABM(ntiles)) - allocate(this%FIELDCAP(ntiles)) - allocate(this%HDM(ntiles)) - allocate(this%GDP(ntiles)) - allocate(this%PEATF(ntiles)) - - allocate(this%bflowm (ntiles)) - allocate(this%totwatm (ntiles)) - allocate(this%tairm (ntiles)) - allocate(this%tpm (ntiles)) - allocate(this%cnsum (ntiles)) - allocate(this%sndzm (ntiles)) - allocate(this%asnowm (ntiles)) - allocate(this%psnsunm(ntiles,nveg,nzone)) - allocate(this%psnsham(ntiles,nveg,nzone)) - allocate(this%rzmm (ntiles,nzone)) - allocate(this%tgwm (ntiles,nzone)) - - - if (this%isCLM40) then + + allocate( this%cnity (ntiles,nveg)) + allocate( this%fvg (ntiles,nveg)) + allocate( this%tg (ntiles,nzone)) ! rreichle, bug fix 4 Aug 2025: "nveg" -> "nzone" + allocate( this%TILE_ID (ntiles)) + allocate( this%ndep (ntiles)) + allocate( this%cli_t2m (ntiles)) + allocate( this%BGALBVR (ntiles)) + allocate( this%BGALBVF (ntiles)) + allocate( this%BGALBNR (ntiles)) + allocate( this%BGALBNF (ntiles)) + allocate( this%CNCOL (ntiles,ncol)) + allocate( this%CNPFT (ntiles,npft)) + allocate( this%tgwm (ntiles,nzone)) + allocate( this%rzmm (ntiles,nzone)) + allocate( this%bflowm (ntiles)) + allocate( this%totwatm (ntiles)) + allocate( this%tairm (ntiles)) + allocate( this%tpm (ntiles)) + allocate( this%cnsum (ntiles)) + allocate( this%psnsunm (ntiles,nveg,nzone)) + allocate( this%psnsham (ntiles,nveg,nzone)) + allocate( this%sndzm (ntiles)) + allocate( this%asnowm (ntiles)) + + if (this%isCLM40) then + allocate(this%sfmcm (ntiles)) - endif - if (this%isCLM45) then - allocate(this%ar1m (ntiles)) - allocate(this%rainfm (ntiles)) + + else if (this%isCLM51) then + + allocate(this%sfmm (ntiles,nzone)) + allocate(this%ABM (ntiles)) + allocate(this%PEATF (ntiles)) + allocate(this%GDP (ntiles)) + allocate(this%HDM (ntiles)) + allocate(this%FIELDCAP(ntiles)) allocate(this%rhm (ntiles)) - allocate(this%runsrfm (ntiles)) - allocate(this%snowfm (ntiles)) allocate(this%windm (ntiles)) + allocate(this%rainfm (ntiles)) + allocate(this%snowfm (ntiles)) + allocate(this%runsrfm (ntiles)) + allocate(this%ar1m (ntiles)) + 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%sndzm5d (ntiles)) + allocate(this%t2m10d (ntiles)) + allocate(this%tg10d (ntiles)) + allocate(this%t2mmin5d(ntiles)) + allocate(this%rh30d (ntiles)) allocate(this%tprec10d(ntiles)) allocate(this%tprec60d(ntiles)) - allocate(this%t2m10d (ntiles)) - allocate(this%sfmm (ntiles,nzone)) + allocate(this%et365d (ntiles)) + allocate(this%runsurf (ntiles)) + endif _RETURN(_SUCCESS) + end subroutine allocate_cn + + ! -------------------------------------------------------------------------------------------- SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) class(CatchmentCNRst), intent(inout) :: this @@ -361,17 +454,20 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), hdm(:), fc(:), gdp(:), peatf(:) + real, allocatable :: CLI_T2M(:), 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_40) :: 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') @@ -380,7 +476,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) !call this%CatchmentRst%add_bcs_to_rst(surflay, OutBcsDir, __RC__) allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) + allocate (BNIRDF(ntiles), CLI_T2M(ntiles), NDEP(ntiles) ) allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) @@ -392,22 +488,26 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) _ASSERT(Newland, "catchcn should get bc from newland") if(file_exists) then - call CatchCNFmt%Open(trim(OutBcsDir)//'/clsm/catchcn_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 + + call CatchCNFmt%Open(trim(OutBcsDir)//'/clsm/catchcn_params.nc4', pFIO_READ, __RC__) + + call MAPL_VarRead( CatchCNFmt, 'BGALBNF', BNIRDF, __RC__) + call MAPL_VarRead( CatchCNFmt, 'BGALBNR', BNIRDR, __RC__) + call MAPL_VarRead( CatchCNFmt, 'BGALBVF', BVISDF, __RC__) + call MAPL_VarRead( CatchCNFmt, 'BGALBVR', BVISDR, __RC__) + call MAPL_VarRead( CatchCNFmt, 'NDEP', NDEP, __RC__) + call MAPL_VarRead( CatchCNFmt, 'T2_M', CLI_T2M, __RC__) + call MAPL_VarRead( CatchCNFmt, 'ITY', CLMC_pt1, offset1=1, __RC__) ! 30 + call MAPL_VarRead( CatchCNFmt, 'ITY', CLMC_pt2, offset1=2, __RC__) ! 31 + call MAPL_VarRead( CatchCNFmt, 'ITY', CLMC_st1, offset1=3, __RC__) ! 32 + call MAPL_VarRead( CatchCNFmt, 'ITY', CLMC_st2, offset1=4, __RC__) ! 33 + call MAPL_VarRead( CatchCNFmt, 'FVG', CLMC_pf1, offset1=1, __RC__) ! 34 + call MAPL_VarRead( CatchCNFmt, 'FVG', CLMC_pf2, offset1=2, __RC__) ! 35 + call MAPL_VarRead( CatchCNFmt, 'FVG', CLMC_sf1, offset1=3, __RC__) ! 36 + call MAPL_VarRead( CatchCNFmt, 'FVG', CLMC_sf2, offset1=4, __RC__) ! 37 + call CatchCNFmt%close() + else open(newunit=unit27, file=trim(OutBcsDir)//'/clsm/CLM_veg_typs_fracs' ,form='formatted') @@ -417,7 +517,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) read (unit27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - read (unit28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. + read (unit28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), CLI_T2M(n) ! MERRA-2 Annual Mean Temp is default. end do CLOSE (unit27, STATUS = 'KEEP') @@ -425,7 +525,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) endif - if (this%isCLM45 ) then + if (this%isCLM51) then open(newunit=unit30, file=trim(OutBcsDir)//'/clsm/CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') do n=1,ntiles @@ -436,6 +536,7 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) endif do n=1,ntiles + BVISDR(n) = amax1(1.e-6, BVISDR(n)) BVISDF(n) = amax1(1.e-6, BVISDF(n)) BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) @@ -512,17 +613,58 @@ 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) 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 + this%cli_t2m = CLI_T2M this%BGALBVR = BVISDR this%BGALBVF = BVISDF this%BGALBNR = BNIRDR this%BGALBNF = BNIRDF - if (this%isCLM45) then + if (this%isCLM51) then this%abm = real(abm) this%fieldcap = fc this%hdm = hdm @@ -531,21 +673,27 @@ SUBROUTINE add_bcs_to_cnrst (this, SURFLAY, OutBcsDir,rc) endif deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) + deallocate (BNIRDF, CLI_T2M, NDEP ) deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) deallocate (CLMC_st1,CLMC_st2) _RETURN(_SUCCESS) + end subroutine add_bcs_to_cnrst + ! ------------------------------------------------------------------------------------------------- + subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) + class(CatchmentCNRst), intent(inout) :: this - character(*), intent(in) :: InTileFile - character(*), intent(in) :: OutBcsDir - character(*), intent(in) :: OutTileFile - real, intent(in) :: surflay - integer, optional, intent(out) :: rc + character(*), intent(in) :: InTileFile + character(*), intent(in) :: OutBcsDir + character(*), intent(in) :: OutTileFile + real, intent(in) :: surflay + integer, optional, intent(out) :: rc + + ! local variables real , allocatable, dimension (:) :: DAYX integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local @@ -555,12 +703,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(:,:,:), & + real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:), var_out(:), var_tmp3d(:,:,:), & var_out_zone(:,:) - integer :: status, in_ntiles, out_ntiles, numprocs + 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, jj, var_col, var_pft, nveg real, allocatable, dimension(:) :: lat_tmp type(MAPL_SunOrbit) :: ORBIT type(ESMF_Time) :: CURRENT_TIME @@ -570,7 +719,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 @@ -636,12 +785,12 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) call ESMF_CalendarSetDefault ( ESMF_CALKIND_GREGORIAN, rc=status ) call ESMF_TimeSet ( CURRENT_TIME, YY = AGCM_YY, & - MM = AGCM_MM, & - DD = AGCM_DD, & - H = AGCM_HR, & - M = AGCM_MI, & - S = AGCM_S , & - rc=status ) + MM = AGCM_MM, & + DD = AGCM_DD, & + H = AGCM_HR, & + M = AGCM_MI, & + S = AGCM_S , & + rc=status ) VERIFY_(STATUS) !2) create a clock @@ -668,26 +817,44 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) ityp_offl = this%cnity fveg_offl = this%fvg + if (this%isCLM40) then + npft_int = npft_40 + elseif (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) 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 +870,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) 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) + elseif (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) 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) 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 +929,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) @@ -774,561 +962,647 @@ subroutine re_tile(this, InTileFile, OutBcsDir, OutTileFile, surflay, rc) end do if(root_proc) then - - allocate (var_off_col (1: in_ntiles, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: in_ntiles, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_out (out_ntiles)) - allocate (var_psn (out_ntiles, nveg, nzone)) - allocate (var_out_zone(out_ntiles, nzone)) - - this%tile_id = [(i*1.0, i=1, out_ntiles)] - - allocate (tg_tmp(out_ntiles, 4),source = 0.) - do i = 1, 3 + + ! this block zooms state (and forcing) variables into domain: id_glb(1:out_ntiles) [???] + ! + ! (excludes time-invariant or climatological parameters, which should come directly from bcs) + + allocate (var_off_col (1:in_ntiles, 1:nzone, 1:var_col )) + allocate (var_off_pft (1:in_ntiles, 1:nzone, 1:nveg, 1:var_pft )) + + allocate (var_out (out_ntiles )) + allocate (var_tmp3d (out_ntiles, nveg, nzone )) + allocate (var_out_zone(out_ntiles, nzone )) + + this%tile_id = [(i*1.0, i=1, out_ntiles)] + + ! in order of MAPL_AddInternalSpec() calls in GEOS_CatchCNCLM*GridComp.F90 + + ! cnity(:,:) ! done in subroutine regrid_carbon() + ! fvg(:,:) ! done in subroutine regrid_carbon() + + allocate (tg_tmp(out_ntiles, 4),source = 0.) + do i = 1, nzone ! rreichle, bug fix 4 Aug 2025: "3" -> "nzone" tg_tmp(:,i) = this%tg(this%id_glb(:),i) - enddo - 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(:)) - this%totwatm= var_out - var_out = this%tairm (this%id_glb(:)) - this%tairm = var_out - var_out = this%tpm (this%id_glb(:)) - this%tpm = var_out - var_out = this%cnsum (this%id_glb(:)) - this%cnsum = var_out - var_out = this%sndzm (this%id_glb(:)) - this%sndzm = var_out - var_out = this%asnowm (this%id_glb(:)) - this%asnowm = var_out - do nz = 1, nzone - do nv = 1, nveg - var_psn(:,nv,nz) = this%psnsunm(this%id_glb(:), nv,nz) - enddo - enddo - this%psnsunm= var_psn - - do nz = 1, nzone - do nv = 1, nveg - var_psn(:,nv,nz) = this%psnsham(this%id_glb(:), nv,nz) - enddo - enddo - this%psnsham = var_psn - - do nz = 1, nzone - var_out_zone(:,nz) = this%rzmm(this%id_glb(:), nz) - enddo - this%rzmm = var_out_zone + enddo + this%tg = tg_tmp + deallocate(tg_tmp) + + ! ndep(:) ! not done (parameter) + ! cli_t2m(:) ! not done (parameter) + ! BGALBVR(:) ! not done (parameter) + ! BGALBVF(:) ! not done (parameter) + ! BGALBNR(:) ! not done (parameter) + ! BGALBNF(:) ! not done (parameter) + ! + ! CNCOL(:,:) ! done in subroutine regrid_carbon() + ! CNPFT(:,:) ! done in subroutine regrid_carbon() + + do nz = 1, nzone + var_out_zone(:,nz) = this%tgwm(this%id_glb(:), nz) + enddo + this%tgwm = var_out_zone + + do nz = 1, nzone + var_out_zone(:,nz) = this%rzmm(this%id_glb(:), nz) + enddo + this%rzmm = var_out_zone + + var_out = this%bflowm (this%id_glb(:)); this%bflowm = var_out + var_out = this%totwatm(this%id_glb(:)); this%totwatm = var_out + var_out = this%tairm (this%id_glb(:)); this%tairm = var_out + var_out = this%tpm (this%id_glb(:)); this%tpm = var_out + var_out = this%cnsum (this%id_glb(:)); this%cnsum = var_out + + do nz = 1, nzone + do nv = 1, nveg + var_tmp3d(:,nv,nz) = this%psnsunm(this%id_glb(:), nv,nz) + enddo + enddo + this%psnsunm= var_tmp3d + + do nz = 1, nzone + do nv = 1, nveg + var_tmp3d(:,nv,nz) = this%psnsham(this%id_glb(:), nv,nz) + enddo + enddo + this%psnsham = var_tmp3d + + var_out = this%sndzm (this%id_glb(:)); this%sndzm = var_out + var_out = this%asnowm (this%id_glb(:)); this%asnowm = var_out + + if (this%isCLM40) then + + var_out = this%sfmcm (this%id_glb(:)); this%sfmcm = var_out + + elseif (this%isCLM51) then + + do nz = 1, nzone + var_out_zone(:,nz) = this%sfmm(this%id_glb(:), nz) + enddo + this%sfmm = var_out_zone + + ! ABM(:) ! not done (parameter) + ! PEATF(:) ! not done (parameter) + ! GDP(:) ! not done (parameter) + ! HDM(:) ! not done (parameter) + ! FIELDCAP(:) ! not done (parameter) + + var_out = this%rhm (this%id_glb(:)); this%rhm = var_out + var_out = this%windm (this%id_glb(:)); this%windm = var_out + var_out = this%rainfm (this%id_glb(:)); this%rainfm = var_out + var_out = this%snowfm (this%id_glb(:)); this%snowfm = var_out + var_out = this%runsrfm (this%id_glb(:)); this%runsrfm = var_out + var_out = this%ar1m (this%id_glb(:)); this%ar1m = var_out + + do nz = 1, nzone + do nv = 1, nveg + var_tmp3d(:,nv,nz) = this%lmrsunm(this%id_glb(:), nv,nz) + enddo + enddo + this%lmrsunm= var_tmp3d + + do nz = 1, nzone + do nv = 1, nveg + var_tmp3d(:,nv,nz) = this%lmrsham(this%id_glb(:), nv,nz) + enddo + enddo + this%lmrsham = var_tmp3d + + do nz = 1, nzone + do nv = 1, nveg + var_tmp3d(:,nv,nz) = this%laisunm(this%id_glb(:), nv,nz) + enddo + enddo + this%laisunm= var_tmp3d + + do nz = 1, nzone + do nv = 1, nveg + var_tmp3d(:,nv,nz) = this%laisham(this%id_glb(:), nv,nz) + enddo + enddo + this%laisham = var_tmp3d + + var_out = this%sndzm5d (this%id_glb(:)); this%sndzm5d = var_out ! rreichle, bug fix 4 Aug 2025: added for CNCLM51 + var_out = this%t2m10d (this%id_glb(:)); this%t2m10d = var_out + var_out = this%tg10d (this%id_glb(:)); this%tg10d = var_out ! rreichle, bug fix 4 Aug 2025: added for CNCLM51 + var_out = this%t2mmin5d(this%id_glb(:)); this%t2mmin5d = var_out ! rreichle, bug fix 4 Aug 2025: added for CNCLM51 + var_out = this%rh30d (this%id_glb(:)); this%rh30d = var_out ! rreichle, bug fix 4 Aug 2025: added for CNCLM51 + var_out = this%tprec10d(this%id_glb(:)); this%tprec10d = var_out + var_out = this%tprec60d(this%id_glb(:)); this%tprec60d = var_out + var_out = this%et365d (this%id_glb(:)); this%et365d = var_out ! rreichle, bug fix 4 Aug 2025: added for CNCLM51 + var_out = this%runsurf (this%id_glb(:)); this%runsurf = var_out ! rreichle, bug fix 4 Aug 2025: added for CNCLM51 + + + endif ! CNCLM40 or CNCLM51 + + i = 1 + do jj = 1,VAR_COL + do nz = 1,nzone + var_off_col(:,nz,jj) = this%cncol(:,i) ! note: will be inverted again in regrid_carbon() below + i = i + 1 + end do + end do + + i = 1 + do iv = 1,VAR_PFT + do nv = 1,nveg + do nz = 1,nzone + var_off_pft(:, nz,nv,iv) = this%cnpft(:,i) ! note: will be inverted again in regrid_carbon() below + i = i + 1 + end do + end do + end do - do nz = 1, nzone - var_out_zone(:,nz) = this%tgwm(this%id_glb(:), nz) - enddo - this%tgwm = var_out_zone + where(isnan(var_off_pft)) var_off_pft = 0. + where(var_off_pft /= var_off_pft) var_off_pft = 0. ! should do same as previous line, but keep for now just in case - if (this%isCLM40) then - var_out = this%sfmcm (this%id_glb(:)) - this%sfmcm = var_out - endif - if (this%isCLM45) then - var_out = this%ar1m (this%id_glb(:)) - this%ar1m = var_out - var_out = this%rainfm (this%id_glb(:)) - this%rainfm = var_out - var_out = this%rhm (this%id_glb(:)) - this%rhm = var_out - var_out = this%runsrfm (this%id_glb(:)) - this%runsrfm = var_out - var_out = this%snowfm (this%id_glb(:)) - this%snowfm = var_out - var_out = this%windm (this%id_glb(:)) - this%windm = var_out - var_out = this%tprec10d(this%id_glb(:)) - this%tprec10d= var_out - var_out = this%tprec60d(this%id_glb(:)) - this%tprec60d= var_out - var_out = this%t2m10d (this%id_glb(:)) - this%t2m10d = var_out - do nz = 1, nzone - var_out_zone(:,nz) = this%sfmm(this%id_glb(:), nz) - enddo - this%sfmm = var_out_zone - endif + print *, 'calculating regridded carbn' - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - var_off_col(:,nz,nv) = this%cncol(:,i) - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - var_off_pft(:, nz,nv,iv) = this%cnpft(:,i) - i = i + 1 - end do - end do - end do + if (this%isCLM40) then + allocate(iclass(1:npft_40)) + iclass = iclass_40 + elseif (this%isCLM51) then + allocate(iclass(1:npft_51)) + iclass = iclass_51 + end if - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. + call regrid_carbon (out_NTILES, in_ntiles,id_glb_cn, & + DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl, iclass) - print *, 'calculating regridded carbn' + deallocate (var_off_col,var_off_pft) - call regrid_carbon (out_NTILES, in_ntiles,id_glb_cn, & - DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) endif + call MPI_Barrier(MPI_COMM_WORLD, STATUS) _RETURN(_SUCCESS) contains - SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - - ! 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 - 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 (:,:,:,:) - integer :: N, STATUS, nv, nx, offl_cell, ityp_new, i, j, nz, iv - real :: fveg_new - character(256) :: Iam = "write_regridded_carbon" - - - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - 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) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - var_col_out = 0. - var_pft_out = NaN - - OUT_TILE : DO N = 1, NTILES - - ! if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - 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 (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) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - 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 - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - 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(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - 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.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars clm40 clm45 - ! ----------------- --------------------- - ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) - ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc - ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c - ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c - ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col - ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c - ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c - ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c - ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c - ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) - ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn - ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n - ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n - ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n - ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n - ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn - ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) - ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n - ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n - ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n - ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n - ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg - ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) - ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax - ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter - ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m - ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp - ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned - ! OLD ! 35 cps%altmax_lastyear - ! OLD ! 36 cps%altmax_indx - ! OLD ! 37 cps%fpg - ! OLD ! 38 cps%fpi_vr (:,1) - ! OLD ! 39 cps%altmax_lastyear_indx - - ! PFT vars CLM40 CLM45 - ! -------------- ----- - ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn - ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai - ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai - ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot - ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop - ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai - ! 75 pepv%plant_ndemand - ! OLD ! 75 pps%gddplant - ! OLD ! 76 pps%gddtsoi - ! OLD ! 77 pps%peaklai - ! OLD ! 78 pps%idop - ! OLD ! 79 pps%aleaf - ! OLD ! 80 pps%aleafi - ! OLD ! 81 pps%astem - ! OLD ! 82 pps%astemi - ! OLD ! 83 pps%htmx - ! OLD ! 84 pps%hdidx - ! OLD ! 85 pps%vf - ! OLD ! 86 pps%cumvd - ! OLD ! 87 pps%croplive - ! OLD ! 88 pps%cropplant - ! OLD ! 89 pps%harvdate - ! OLD ! 90 pps%gdd1020 - ! OLD ! 91 pps%gdd820 - ! OLD ! 92 pps%gdd020 - ! OLD ! 93 pps%gddmaturity - ! OLD ! 94 pps%huileaf - ! OLD ! 95 pps%huigrain - ! OLD ! 96 pcs%grainc - ! OLD ! 97 pcs%grainc_storage - ! OLD ! 98 pcs%grainc_xfer - ! OLD ! 99 pns%grainn - ! OLD !100 pns%grainn_storage - ! OLD !101 pns%grainn_xfer - ! OLD !102 pepv%fert_counter - ! OLD !103 pnf%fert - ! OLD !104 pepv%grain_flag - - end do OUT_TILE - - i = 1 - deallocate(this%cncol) - allocate(this%cncol(NTILES, nzone*VAR_COL)) - do nv = 1,VAR_COL - do nz = 1,nzone - this%cncol(:,i) = var_col_out(:, nz,nv) - !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do + + ! ------------------------------------------------------------------------------------------------- + + SUBROUTINE regrid_carbon (NTILES, in_ntiles, id_glb, & + DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl, iclass_in) + + ! regrid carbon variables: + ! - operates on "this": class(CatchmentCNRst), intent(inout) :: this + ! - otherwise only intent(in) arguments + ! - regrids the following fields: + ! - cnity + ! - fvg + ! - CNCOL + ! - CNPFT + + 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 - i = 1 - deallocate(this%cnpft) - allocate(this%cnpft(NTILES,VAR_PFT*nveg*nzone)) - if(this%isclm45) then - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - if(iv <= 74) then - 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) - else - if((iv == 78) .OR. (iv == 89)) then ! idop and harvdate - var_dum = 999 - this%cnpft(:,i) = var_dum - !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - else - var_dum = 0. - this%cnpft(:,i) = var_dum - !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - endif - endif - i = i + 1 - end do - end do - end do - else - 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 - endif + ! local variables + + 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 (:,:,:,:) + integer :: N, STATUS, nv, nx, offl_cell, ityp_new, i, j, nz, iv, jj + real :: fveg_new + character(256) :: Iam = "write_regridded_carbon" + + + allocate (CLMC_pf1(NTILES)) + allocate (CLMC_pf2(NTILES)) + allocate (CLMC_sf1(NTILES)) + allocate (CLMC_sf2(NTILES)) + allocate (CLMC_pt1(NTILES)) + allocate (CLMC_pt2(NTILES)) + allocate (CLMC_st1(NTILES)) + allocate (CLMC_st2(NTILES)) + allocate (VAR_DUM (NTILES)) + + if (this%isCLM40) 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(:,2) + CLMC_pf1 = this%fvg( :,1) + CLMC_sf1 = this%fvg( :,2) + + 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)) - deallocate (var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) + var_col_out = 0. + var_pft_out = NaN + + OUT_TILE : DO N = 1, NTILES + + ! if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) + + NVLOOP2 : do nv = 1, nveg + + if (this%isCLM40) 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 (fveg_new > fmin) then + + offl_cell = Id_glb(n,nv) + + if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then + 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_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) + endif + + ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst + ! ---------------------------------------------------------------------------------------- + + ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) + + var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) + var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? + + ! Check whether var_pft_out is realistic + do nz = 1, nzone + do j = 1, VAR_PFT + if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new + !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 + !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 + end do + end do + endif + + end do NVLOOP2 + + ! reset carbon if negative < 10g + ! ------------------------ + + NZLOOP : do nz = 1, nzone + + if(var_col_out (n, nz,14) < 10.) then + + var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) + var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) + var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) + var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) + var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) + var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) + var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) + var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) + var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c + var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) + var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) + var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) + var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) + var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) + var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) + var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) + var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) + var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) + var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) + var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) + var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) + var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) + + NVLOOP3 : do nv = 1,nveg + if (this%isCLM40) 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.) + var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) + var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) + var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) + + if(ityp_new <= 12) then ! tree or shrub deadstemc + var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) + else + var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) + endif + + var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) + var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) + var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) + var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) + var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) + var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) + var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) + + if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then + var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen + var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) + else + var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) + var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous + endif + + var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) + var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) + var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) + var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) + var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) + var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) + var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) + var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) + var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) + var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) + var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) + var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) + var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) + var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) + var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) + var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) + var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) + var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) + var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) + var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) + var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) + var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) + var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) + var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) + var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) + var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) + var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) + var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) + var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) + var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) + var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) + var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) + var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) + var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) + var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) + var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) + var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) + var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) + var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) + var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) + var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) + 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,75) = max(var_pft_out(n, nz,nv,75),0.) + 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 + end do NZLOOP ! end zone loop + + ! Update dayx variable var_pft_out (:,:,28) + + do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) + do nv = 1,nveg + do nz = 1,nzone + var_pft_out (n, nz,nv,j) = dayx(n) + end do + end do + end do + + ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) + + ! column vars clm40 ctsm51 + ! ----------------- --------------------- + ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 soilbiogeochem_carbonstate_inst%ctrunc_vr_col(n,1) + ! 2 clm3%g%l%c%ccs%cwdc ! 2 soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(n,1,4) ! cwdc + ! 3 clm3%g%l%c%ccs%litr1c ! 3 soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(n,1,1) ! litr1c + ! 4 clm3%g%l%c%ccs%litr2c ! 4 soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(n,1,2) ! litr2c + ! 5 clm3%g%l%c%ccs%litr3c ! 5 soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(n,1,3) ! litr3c + ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 bgc_vegetation_inst%cnveg_carbonstate_inst%totvegc_col(n) + ! 7 clm3%g%l%c%ccs%prod100c ! 7 bgc_vegetation_inst%c_products_inst%prod100_grc(nc)*CN_zone_weight(nz) + ! 8 clm3%g%l%c%ccs%prod10c ! 8 bgc_vegetation_inst%c_products_inst%prod100_grc(nc)*CN_zone_weight(nz) + ! 9 clm3%g%l%c%ccs%seedc ! 9 bgc_vegetation_inst%cnveg_carbonstate_inst%seedc_grc(nc)*CN_zone_weight(nz) + ! 10 clm3%g%l%c%ccs%soil1c ! 10 soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(n,1,5) ! soil1c + ! 11 clm3%g%l%c%ccs%soil2c ! 11 soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(n,1,6) ! soil2c + ! 12 clm3%g%l%c%ccs%soil3c ! 12 soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(n,1,7) ! soil3c + ! 13 clm3%g%l%c%ccs%soil4c ! 13 soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(n,1,8) ! soil4c + ! 14 clm3%g%l%c%ccs%totcolc ! 14 bgc_vegetation_inst%cnveg_carbonstate_inst%totc_col(n) + ! 15 clm3%g%l%c%ccs%totlitc ! 15 soilbiogeochem_carbonstate_inst%totlitc_col(n) + ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 soilbiogeochem_nitrogenstate_inst%ntrunc_vr_col(n,1) + ! 17 clm3%g%l%c%cns%cwdn ! 17 soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(n,1,4) ! cwdn + ! 18 clm3%g%l%c%cns%litr1n ! 18 soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(n,1,1) ! litr1n + ! 19 clm3%g%l%c%cns%litr2n ! 19 soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(n,1,2) ! litr2n + ! 20 clm3%g%l%c%cns%litr3n ! 20 soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(n,1,3) ! litr3n + ! 21 clm3%g%l%c%cns%prod100n ! 21 bgc_vegetation_inst%n_products_inst%prod100_grc(nc)*CN_zone_weight(nz) + ! 22 clm3%g%l%c%cns%prod10n ! 22 bgc_vegetation_inst%n_products_inst%prod100_grc(nc)*CN_zone_weight(nz) + ! 23 clm3%g%l%c%cns%seedn ! 23 bgc_vegetation_inst%cnveg_nitrogenstate_inst%seedn_grc(nc)*CN_zone_weight(nz) + ! 24 clm3%g%l%c%cns%sminn ! 24 soilbiogeochem_nitrogenstate_inst%sminn_vr_col(n,1) + ! 25 clm3%g%l%c%cns%soil1n ! 25 soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(n,1,5) ! soil1n + ! 26 clm3%g%l%c%cns%soil2n ! 26 soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(n,1,6) ! soil2n + ! 27 clm3%g%l%c%cns%soil3n ! 27 soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(n,1,7) ! soil3n + ! 28 clm3%g%l%c%cns%soil4n ! 28 soilbiogeochem_nitrogenstate_inst%decomp_npools_vr_col(n,1,8) ! soil4n + ! 29 clm3%g%l%c%cns%totcoln ! 29 bgc_vegetation_inst%cnveg_nitrogenstate_inst%totn_col(n) + ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 soilbiogeochem_state_inst%fpg_col(n) + ! 31 clm3%g%l%c%cps%annsum_counter ! 31 bgc_vegetation_inst%cnveg_state_inst%annsum_counter_col(n) + ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 bgc_vegetation_inst%cnveg_state_inst%annavg_t2m_col(n) + ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 bgc_vegetation_inst%cnveg_carbonflux_inst%annsum_npp_col(n) + ! 34 clm3%g%l%c%cps%farea_burned ! 34 bgc_vegetation_inst%cnveg_state_inst%farea_burned_col(n) + ! 35 clm3%g%l%c%cps%fire_prob ! 35 soilbiogeochem_state_inst%fpi_col(n) + ! 36 clm3%g%l%c%cps%fireseasonl ! 36 soilbiogeochem_nitrogenstate_inst%smin_no3_col(n) + ! 37 clm3%g%l%c%cps%fpg ! 37 soilbiogeochem_nitrogenstate_inst%smin_nh4_col(n) + ! 38 clm3%g%l%c%cps%fpi + ! 39 clm3%g%l%c%cps%me + ! 40 clm3%g%l%c%cps%mean_fire_prob + + ! PFT vars CLM40 CTSM5.1 + ! -------------- ----- + ! 1 clm3%g%l%c%p%pcs%cpool ! 1 bgc_vegetation_inst%cnveg_carbonstate_inst%cpool_patch + ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_patch + ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_storage_patch + ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 bgc_vegetation_inst%cnveg_carbonstate_inst%deadcrootc_xfer_patch + ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 bgc_vegetation_inst%cnveg_carbonstate_inst%deadstemc_patch + ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 bgc_vegetation_inst%cnveg_carbonstate_inst%deadstemc_storage_patch + ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 bgc_vegetation_inst%cnveg_carbonstate_inst%deadstemc_xfer_patch + ! 8 clm3%g%l%c%p%pcs%frootc ! 8 bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_patch + ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_storage_patch + ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 bgc_vegetation_inst%cnveg_carbonstate_inst%frootc_xfer_patch + ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 bgc_vegetation_inst%cnveg_carbonstate_inst%gresp_storage_patch + ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 bgc_vegetation_inst%cnveg_carbonstate_inst%gresp_xfer_patch + ! 13 clm3%g%l%c%p%pcs%leafc ! 13 bgc_vegetation_inst%cnveg_carbonstate_inst%leafc_patch + ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 bgc_vegetation_inst%cnveg_carbonstate_inst%leafc_storage_patch + ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 bgc_vegetation_inst%cnveg_carbonstate_inst%leafc_xfer_patch + ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_patch + ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_storage_patch + ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 bgc_vegetation_inst%cnveg_carbonstate_inst%livecrootc_xfer_patch + ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 bgc_vegetation_inst%cnveg_carbonstate_inst%livestemc_patch + ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 bgc_vegetation_inst%cnveg_carbonstate_inst%livestemc_storage_patch + ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 bgc_vegetation_inst%cnveg_carbonstate_inst%livestemc_xfer_patch + ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 bgc_vegetation_inst%cnveg_carbonstate_inst%ctrunc_patch + ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 bgc_vegetation_inst%cnveg_carbonstate_inst%xsmrpool_patch + ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 bgc_vegetation_inst%cnveg_state_inst%annavg_t2m_patch + ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 bgc_vegetation_inst%cnveg_state_inst%annmax_retransn_patch + ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 bgc_vegetation_inst%cnveg_carbonflux_inst%annsum_npp_patch + ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 bgc_vegetation_inst%cnveg_state_inst%annsum_potential_gpp_patch + ! 28 clm3%g%l%c%p%pepv%dayl ! 28 grc%dayl(nc) + ! 29 clm3%g%l%c%p%pepv%days_active ! 29 bgc_vegetation_inst%cnveg_state_inst%days_active_patch + ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 bgc_vegetation_inst%cnveg_state_inst%dormant_flag_patch + ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 bgc_vegetation_inst%cnveg_state_inst%offset_counter_patch + ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 bgc_vegetation_inst%cnveg_state_inst%offset_fdd_patch + ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 bgc_vegetation_inst%cnveg_state_inst%offset_flag_patch + ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 bgc_vegetation_inst%cnveg_state_inst%offset_swi_patch + ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 bgc_vegetation_inst%cnveg_state_inst%onset_counter_patch + ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 bgc_vegetation_inst%cnveg_state_inst%onset_fdd_patch + ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 bgc_vegetation_inst%cnveg_state_inst%onset_flag_patch + ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 bgc_vegetation_inst%cnveg_state_inst%onset_gdd_patch + ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 bgc_vegetation_inst%cnveg_state_inst%onset_gddflag_patch + ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 bgc_vegetation_inst%cnveg_state_inst%onset_swi_patch + ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 bgc_vegetation_inst%cnveg_carbonflux_inst%prev_frootc_to_litter_patch + ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 bgc_vegetation_inst%cnveg_carbonflux_inst%prev_leafc_to_litter_patch + ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 bgc_vegetation_inst%cnveg_state_inst%tempavg_t2m_patch + ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 bgc_vegetation_inst%cnveg_state_inst%tempmax_retransn_patch + ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 bgc_vegetation_inst%cnveg_carbonflux_inst%tempsum_npp_patch + ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 bgc_vegetation_inst%cnveg_state_inst%tempsum_potential_gpp_patch + ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 bgc_vegetation_inst%cnveg_carbonflux_inst%xsmrpool_recover_patch + ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadcrootn_patch + ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadcrootn_storage_patch + ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadcrootn_xfer_patch + ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadstemn_patch + ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadstemn_storage_patch + ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 bgc_vegetation_inst%cnveg_nitrogenstate_inst%deadstemn_xfer_patch + ! 54 clm3%g%l%c%p%pns%frootn ! 54 bgc_vegetation_inst%cnveg_nitrogenstate_inst%frootn_patch + ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 bgc_vegetation_inst%cnveg_nitrogenstate_inst%frootn_storage_patch + ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 bgc_vegetation_inst%cnveg_nitrogenstate_inst%frootn_xfer_patch + ! 57 clm3%g%l%c%p%pns%leafn ! 57 bgc_vegetation_inst%cnveg_nitrogenstate_inst%leafn_patch + ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 bgc_vegetation_inst%cnveg_nitrogenstate_inst%leafn_storage_patch + ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 bgc_vegetation_inst%cnveg_nitrogenstate_inst%leafn_xfer_patch + ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 bgc_vegetation_inst%cnveg_nitrogenstate_inst%livecrootn_patch + ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 bgc_vegetation_inst%cnveg_nitrogenstate_inst%livecrootn_storage_patch + ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 bgc_vegetation_inst%cnveg_nitrogenstate_inst%livecrootn_xfer_patch + ! 63 clm3%g%l%c%p%pns%livestemn ! 63 bgc_vegetation_inst%cnveg_nitrogenstate_inst%livestemn_patch + ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 bgc_vegetation_inst%cnveg_nitrogenstate_inst%livestemn_storage_patch + ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 bgc_vegetation_inst%cnveg_nitrogenstate_inst%livestemn_xfer_patch + ! 66 clm3%g%l%c%p%pns%npool ! 66 bgc_vegetation_inst%cnveg_nitrogenstate_inst%npool_patch + ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 bgc_vegetation_inst%cnveg_nitrogenstate_inst%ntrunc_patch + ! 68 clm3%g%l%c%p%pns%retransn ! 68 bgc_vegetation_inst%cnveg_nitrogenstate_inst%retransn_patch + ! 69 clm3%g%l%c%p%pps%elai ! 69 canopystate_inst%elai_patch + ! 70 clm3%g%l%c%p%pps%esai ! 70 canopystate_inst%esai_patch + ! 71 clm3%g%l%c%p%pps%hbot ! 71 canopystate_inst%hbot_patch + ! 72 clm3%g%l%c%p%pps%htop ! 72 canopystate_inst%htop_patch + ! 73 clm3%g%l%c%p%pps%tlai ! 73 canopystate_inst%tlai_patch + ! 74 clm3%g%l%c%p%pps%tsai ! 74 canopystate_inst%tsai_patch + ! 75 bgc_vegetation_inst%cnveg_nitrogenflux_inst%plant_ndemand_patch + ! 76 canopystate_inst%vegwp_patch(np,1) + ! 77 canopystate_inst%vegwp_patch(np,2) + ! 78 canopystate_inst%vegwp_patch(np,3) + ! 79 canopystate_inst%vegwp_patch(np,4) + ! 80 bgc_vegetation_inst%cnveg_carbonflux_inst%annsum_litfall_patch + ! 81 bgc_vegetation_inst%cnveg_carbonflux_inst%tempsum_litfall_patch + + end do OUT_TILE + + i = 1 + deallocate(this%cncol) + allocate(this%cncol(NTILES, nzone*VAR_COL)) + do jj = 1,VAR_COL + do nz = 1,nzone + this%cncol(:,i) = var_col_out(:, nz,jj) + !STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,jj)) ; VERIFY_(STATUS) + i = i + 1 + end do + end do + i = 1 + deallocate(this%cnpft) + allocate(this%cnpft(NTILES,VAR_PFT*nveg*nzone)) + + if(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 + 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 + endif + + deallocate (var_col_out,var_pft_out) + deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) + deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) + end subroutine regrid_carbon - - + end subroutine re_tile end module CatchmentCNRstMod + + +! ==================== EOF ======================================================================================================== 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 index 814ed551d..f0d688a66 100644 --- 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,27 @@ 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_40, & + nveg_51 => NUM_VEG_CN_51, & + npft_40 => NUM_PFT_CN_40, & + npft_51 => NUM_PFT_CN_51 + 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(npft_40) = (/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 +314,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), optional :: isCLM51 logical :: tile_found logical, allocatable, dimension (:) :: mask integer, allocatable, dimension (:) :: sub_tid @@ -314,6 +324,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_40)) + iclass = iclass_40 + nveg = nveg_40 + end if allocate (mask (1: NT_IN)) @@ -365,23 +385,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 +468,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_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 index e4ab880c8..ba475d02e 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 @@ -199,9 +199,9 @@ program mk_CatchCNRestarts use gFTL_StringVector use ieee_arithmetic, only: isnan => ieee_is_nan use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg => NUM_VEG_CN, & + use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg => NUM_VEG_CN_40, & VAR_COL => VAR_COL_40, VAR_PFT => VAR_PFT_40, & - npft => numpft_CN + npft => NUM_PFT_CN_40 implicit none include 'mpif.h'