diff --git a/.config_files.xml b/.config_files.xml index 22860601..14da9b0c 100644 --- a/.config_files.xml +++ b/.config_files.xml @@ -17,10 +17,13 @@ char unset - $SRCROOT - $CIMEROOT/src/components/data_comps/dlnd - $CIMEROOT/src/components/stub_comps/slnd - $CIMEROOT/src/components/xcpl_comps/xlnd + $SRCROOT + $SRCROOT/components/cpl7/components/data_comps_mct/dlnd + $SRCROOT/components/cdeps/dlnd + $SRCROOT/components/cpl7/components/stub_comps_mct/slnd + $SRCROOT/components/cpl7/components/xcpl_comps_mct/xlnd + $CIMEROOT/src/components/stub_comps_nuopc/slnd + $CIMEROOT/src/components/xcpl_comps_nuopc/xlnd case_comps env_case.xml diff --git a/.gitignore b/.gitignore index 85538e29..2af512c0 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,9 @@ manage_externals.log cime/ components/ +ccs_config/ +libraries/ +share/ # ignore svn directories **/.svn/** diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 4cc7399c..838f0c72 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -4,9 +4,9 @@ We recommend that you first open an issue (https://github.com/escomp/ctsm/issues discuss the changes or additions that you propose. You should also contact some of the responsible individuals for SLIM and run by the changes with them. -Erik Kluzek -- Software Engineering (erik@ucar.edu) -Marysa Legue -- Originator (marysa.lague@usask.ca) -Isla Simpson -- Principal Investigator (simpson@ucar.edu) +Erik Kluzek -- Software Engineering (erik@ucar.edu) +Marysa Lague -- Originator (marysa.lague@usask.ca) +Isla Simpson -- Principal Investigator (simpson@ucar.edu) Use the help from the wiki below to setup a fork and personal branch in GitHub to put your developments on and keep up to date with the master branch of SLIM. Once the changes are sufficiently advanced you @@ -14,7 +14,7 @@ can form a Pull Request on GitHub. Either from your fork on GitHub, or from the for SLIM (be sure to hit the "compare across forks" link at the top of the page when you first create the pull request). -https://github.com/ESCOMP/SLIM/pulls +https://github.com/ESCOMP/SimpleLand/pulls This allows you to show your proposed changes and start getting feedback on them (even if they aren't finished). This also allows your changes to be planned for and slated for a time to come into SLIM master. In most @@ -23,7 +23,7 @@ additional testing and bring the changes to SLIM master. #### SLIM Wiki: -https://github.com/ESCOMP/SLIM/wiki +https://github.com/ESCOMP/SimpleLand/wiki #### Code of Conduct: diff --git a/Externals.cfg b/Externals.cfg index 41589901..78dd1ff9 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -1,32 +1,89 @@ [slm] local_path = . protocol = externals_only -externals = Externals_SLIM.cfg required = True [cam] -tag = cam_cesm2_1_rel_53 +tag = cam6_3_071 protocol = git repo_url = https://github.com/ESCOMP/CAM local_path = components/cam externals = Externals_CAM.cfg required = True -[cice] -tag = cice5_cesm2_1_1_20190321 +[cice6] +tag = cesm_cice6_2_0_22 protocol = git -repo_url = https://github.com/ESCOMP/CESM_CICE5 +repo_url = https://github.com/ESCOMP/CESM_CICE local_path = components/cice +externals = Externals.cfg +required = True + +[cice5] +tag = cice5_20220204 +protocol = git +repo_url = https://github.com/ESCOMP/CESM_CICE5 +local_path = components/cice5 +required = True + +[ccs_config] +tag = ccs_config_cesm0.0.38 +protocol = git +repo_url = https://github.com/ESMCI/ccs_config_cesm.git +local_path = ccs_config +required = True + +[cdeps] +tag = cdeps0.12.65 +protocol = git +repo_url = https://github.com/ESCOMP/CDEPS +local_path = components/cdeps +externals = Externals_CDEPS.cfg +required = True + +[cmeps] +tag = cmeps0.13.71 +protocol = git +repo_url = https://github.com/ESCOMP/CMEPS +local_path = components/cmeps +required = True + +[cpl7] +tag = cpl7.0.14 +protocol = git +repo_url = https://github.com/ESCOMP/CESM_CPL7andDataComps +local_path = components/cpl7 +required = True + +[share] +tag = share1.0.13 +protocol = git +repo_url = https://github.com/ESCOMP/CESM_share +local_path = share +required = True + +[mct] +tag = MCT_2.11.0 +protocol = git +repo_url = https://github.com/MCSclimate/MCT +local_path = libraries/mct +required = True + +[parallelio] +tag = pio2_5_7 +protocol = git +repo_url = https://github.com/NCAR/ParallelIO +local_path = libraries/parallelio required = True [cime] local_path = cime protocol = git +#repo_url = https://github.com/ESMCI/cime repo_url = https://github.com/ekluzek/cime -hash = 25ba7866ec4835b148aac9f83242d0bc6257da5e -#branch = add_slim_comp +#tag = cime6.0.71 +hash = 9bbadb3b173c57f00ff8666790a474951e28391d required = True [externals_description] -schema_version = 1.0.0 - +schema_version = 1.0.01 diff --git a/Externals_SLIM.cfg b/Externals_SLIM.cfg deleted file mode 100644 index 31b2036d..00000000 --- a/Externals_SLIM.cfg +++ /dev/null @@ -1,3 +0,0 @@ -[externals_description] -schema_version = 1.0.0 - diff --git a/README b/README index ffaafcef..441333ec 100644 --- a/README +++ b/README @@ -3,15 +3,45 @@ Important files in main directories: ============================================================================================= Externals.cfg --------------- File for management of the main high level externals -Externals_SLIM.cfg ---------- File for management of the SLIM specific externals (if any) ============================================================================================= - QUICKSTART: using the CPL7 scripts: +Important main subdirectories +============================================================================================= + +src --------------- SLIM Source code. +tools ------------- SLIM Offline tools to prepare input datasets and process output. +cime_config ------- Configuration files of cime for compsets and SLIM settings +manage_externals -- Script to manage the external source directories +py_env_create ----- Script to setup the python environment for SLIM python tools using conda +python ------------ Some python modules +components -------- Other active sub-components needed for SLIM to run (CAM and CICE) +libraries --------- CESM libraries: MCT (Model Coupling Toolkit) and PIO +share ------------- CESM shared code + +cime/scripts --------------- cesm/cime driver scripts + +============================================================================================= + SLIM XML variables: +============================================================================================= + +SLIM_SCENARIO: Scenario to use, usually set by the compset +SLIM_START_TYPE: The start type to use, usually set by the RUN_TYPE + +============================================================================================= + SLIM important namelist items: +============================================================================================= + +mml_surdat -- Dataset of surface characteristics to use (usually set by the compset/grid) +finidat ----- Initial conditions to startup with +hist_nhtfrq - History file frequency of output + +============================================================================================= + QUICKSTART: using the CPL7 scripts: ============================================================================================= cd cime/scripts ./create_newcase # get help on how to run create_newcase - ./create_newcase --case testI --res f19_g17 --compset I2000SlimRsGs --mach cheyenne + ./create_newcase --case testI --res f19_f19_mg17 --compset I2000SlimRsGs # create new "I" case for cheyenne_intel at 1.9x2.5_gx1v7 res # "I2000SlimRsGs" case is SLIM active, datm8, and inactive ice/ocn/glc/rof cd testI diff --git a/README.md b/README.md index ce4662c6..b6b70e57 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,8 @@ Simple Land Model for CESM -For instructions on how to run SLIM on it's own or coupled to CESM on Cheyenne, see the Wiki. +For instructions on how to run SLIM on it's own or coupled to CESM on Cheyenne, see the Wiki, and the README file at the top of the +SLIM checkout. To cite, please use: diff --git a/README.rst b/README.rst index 1a3ae810..4ee39b82 100644 --- a/README.rst +++ b/README.rst @@ -1,3 +1,5 @@ ================ SimpleLandModel ================ + +SLIM the Simple Land Interface Model coupled to CESM2 diff --git a/README.testing b/README.testing index b4217de3..c328cf94 100644 --- a/README.testing +++ b/README.testing @@ -2,6 +2,8 @@ # # The test list "aux_slim" is run as a test suite with the "create_test" script under cime/scripts # as follows. +# NOTE: There are also tests for prealpha, prebeta for use with CESM testing +# And slim_sci to run a few standard tests for SLIM science # # Tests on cheyenne @@ -24,6 +26,4 @@ nohup ./create_test --compare --generate mac nohup ./create_test --compare --generate machine izumi -r cases \ --xml-category aux_slim --xml-machine izumi --xml-compiler gnu & nohup ./create_test --compare --generate machine izumi -r cases \ ---xml-category aux_slim --xml-machine izumi --xml-compiler pgi & -nohup ./create_test --compare --generate machine izumi -r cases \ --xml-category aux_slim --xml-machine izumi --xml-compiler intel & diff --git a/cime_config/buildlib b/cime_config/buildlib index d25deb98..547eece0 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -3,17 +3,18 @@ """ build slim ibrary """ -import sys, os, time, filecmp, shutil, imp +import sys, os, time, filecmp _CIMEROOT = os.environ.get("CIMEROOT") if _CIMEROOT is None: raise SystemExit("ERROR: must set CIMEROOT environment variable") -_LIBDIR = os.path.join(_CIMEROOT, "scripts", "Tools") +_LIBDIR = os.path.join(_CIMEROOT, "CIME", "Tools") sys.path.append(_LIBDIR) from standard_script_setup import * from CIME.buildlib import parse_input +from CIME.build import get_standard_makefile_args from CIME.case import Case from CIME.utils import run_cmd, expect @@ -21,59 +22,69 @@ logger = logging.getLogger(__name__) ############################################################################### def _main_func(): -############################################################################### + ############################################################################### caseroot, libroot, bldroot = parse_input(sys.argv) with Case(caseroot) as case: casetools = case.get_value("CASETOOLS") + makefile = os.path.join(casetools, "Makefile") lnd_root = case.get_value("COMP_ROOT_DIR_LND") gmake_j = case.get_value("GMAKE_J") gmake = case.get_value("GMAKE") - mach = case.get_value("MACH") + gmake_opts = get_standard_makefile_args(case) + driver = case.get_value("COMP_INTERFACE").lower() nthrds = case.get_value("LND_NTHRDS") - if ( nthrds > 1 ): - expect(False, "LND_NTHRDS must be 1 as threading isn't implemented (see issue #14)" ) + if nthrds > 1: + expect( + False, + "LND_NTHRDS must be 1 as threading isn't implemented (see issue #14)", + ) - #------------------------------------------------------- + # ------------------------------------------------------- # create Filepath file #------------------------------------------------------- + compname = case.get_value("COMP_LND") filepath_file = os.path.join(bldroot,"Filepath") if not os.path.isfile(filepath_file): caseroot = case.get_value("CASEROOT") - paths = [os.path.join(caseroot,"SourceMods","src.slim"), + expect( (compname == "slim"), "Unexpected COMP_LND name: %s" % (compname)) + paths = [os.path.join(caseroot,"SourceMods","src."+compname), + os.path.join(lnd_root,"src","cpl",driver), os.path.join(lnd_root,"src","main"), os.path.join(lnd_root,"src","init_interp"), os.path.join(lnd_root,"src","utils"), os.path.join(lnd_root,"src","cpl")] + # Paths needed to build the current system, but won't be long term - paths.append( os.path.join(lnd_root,"src","biogeophys") ) - paths.append( os.path.join(lnd_root,"src","biogeochem") ) - paths.append( os.path.join(lnd_root,"src","soilbiogeochem") ) + paths.append(os.path.join(lnd_root, "src", "biogeophys")) + paths.append(os.path.join(lnd_root, "src", "biogeochem")) + paths.append(os.path.join(lnd_root, "src", "soilbiogeochem")) with open(filepath_file, "w") as filepath: filepath.write("\n".join(paths)) filepath.write("\n") - - #------------------------------------------------------- + + # ------------------------------------------------------- # create the library in libroot - #------------------------------------------------------- + # ------------------------------------------------------- - complib = os.path.join(libroot,"liblnd.a") + complib = os.path.join(libroot, "liblnd.a") makefile = os.path.join(casetools, "Makefile") - macfile = os.path.join(caseroot, "Macros.%s" % mach) - cmd = "%s complib -j %d MODEL=slim COMPLIB=%s -f %s MACFILE=%s " \ - % (gmake, gmake_j, complib, makefile, macfile ) + cmd = "{} complib -j {} COMP_NAME={} COMPLIB={} -f {} {}" \ + .format(gmake, gmake_j, compname, complib, makefile, gmake_opts ) rc, out, err = run_cmd(cmd) - logger.info("%s: \n\n output:\n %s \n\n err:\n\n%s\n"%(cmd,out,err)) + logger.info("%s: \n\n output:\n %s \n\n err:\n\n%s\n" % (cmd, out, err)) expect(rc == 0, "Command %s failed with rc=%s" % (cmd, rc)) + ############################################################################### if __name__ == "__main__": + logger.warning( "WARNING: buildlib is being called as a program rather than a subroutine as " + + "it is expected to be in the CESM context" ) _main_func() - diff --git a/cime_config/buildnml b/cime_config/buildnml index a79cbcc3..e699e454 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -5,7 +5,9 @@ SLIM namelist creator executable """ import sys, os -_SLIM_PYTHON = os.path.normpath( os.path.join(os.path.dirname(os.path.abspath(__file__)), os.pardir, 'python') ) +_SLIM_PYTHON = os.path.normpath( + os.path.join(os.path.dirname(os.path.abspath(__file__)), os.pardir, "python") +) sys.path.insert(1, _SLIM_PYTHON) from slim import add_cime_to_path @@ -22,9 +24,12 @@ def _main_func(): caseroot = parse_input(sys.argv) level = logging.WARNING - setup_logging( level ) + setup_logging(level) with Case(caseroot) as case: - buildnml(case, caseroot, "slim") + compname = case.get_value("COMP_LND") + logger.warning( "WARNING: buildnml is being called as program rather than a subroutine " + + "as it is expected to be in the CESM context" ) + buildnml(case, caseroot, compname) if __name__ == "__main__": diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index b00fe93b..e90e3dcc 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -29,7 +29,7 @@ char global_uniform - global_uniform,realistic_from_1850,realistic_from_2000 + global_uniform,realistic_from_1850,realistic_from_2000,user_defined realistic_from_2000 realistic_from_1850 @@ -40,6 +40,10 @@ SLIM namelist use_case scenario. Determines the use-case scenario that will be used in the SLIM buildnml utility. This is normally set by the component set. + 'global_uniform' is for surface conditions are globally constant + 'realistic_from_1850' are surface conditions taken from a 1850 control simulation with CTSM + 'realistic_from_2000' are surface conditions taken from a 2000 control simulation with CTSM + 'user_defined' means the user will provide their own surface condition file (mml_surdat) diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index 83f26104..abc0f25c 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -13,9 +13,9 @@ TIME_ATM[%phys]_LND[%phys]_ICE[%phys]_OCN[%phys]_ROF[%phys]_GLC[%phys]_WAV[%phys][_BGC%phys] Where for the CAM specific compsets below the following is supported TIME = Time period (e.g. 2000, HIST, RCP8...) - ATM = [CAM40, CAM50, CAM55] + ATM = [CAM40, CAM50, CAM60] LND = [SLIM, SLND] - ICE = [CICE, DICE, SICE] + ICE = [CICE, CICE5, DICE, SICE] OCN = [DOCN, ,AQUAP, SOCN] ROF = [RTM, SROF] GLC = [SGLC] @@ -40,31 +40,46 @@ - E2000Cam6SlimRsGs + ELT2000ClimoTESTC6I5Slim + 2000_CAM60_SLIM_CICE5_DOCN%SOM_SROF_SGLC_SWAV + + + + ELT2000ClimoTESTC6I6Slim 2000_CAM60_SLIM_CICE_DOCN%SOM_SROF_SGLC_SWAV - + + + + ELT1850TESTC6I5Slim + 1850_CAM60_SLIM_CICE5_DOCN%SOM_SROF_SGLC_SWAV + - E1850Cam6SlimRsGs + ELT1850TESTC6I6Slim 1850_CAM60_SLIM_CICE_DOCN%SOM_SROF_SGLC_SWAV + - F2000Cam6SlimRsGs + FLT2000ClimoC6I5Slim + 2000_CAM60_SLIM_CICE5%PRES_DOCN%DOM_SROF_SGLC_SWAV + + + FLT2000ClimoC6I6Slim 2000_CAM60_SLIM_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - E2000Cam5SlimRsGs - 2000_CAM50_SLIM_CICE_DOCN%SOM_SROF_SGLC_SWAV + ELT2000ClimoTESTC5I5Slim + 2000_CAM50_SLIM_CICE5_DOCN%SOM_SROF_SGLC_SWAV - FHistCam5SlimRsGs - HIST_CAM50_SLIM_CICE_DOCN%SOM_SROF_SGLC_SWAV + FLTHISTC5I5Slim + HIST_CAM50_SLIM_CICE5%PRES_DOCN%DOM_SROF_SGLC_SWAV diff --git a/cime_config/config_pes.xml b/cime_config/config_pes.xml index ed50a0f7..9e6fa44b 100644 --- a/cime_config/config_pes.xml +++ b/cime_config/config_pes.xml @@ -5,36 +5,74 @@ - none + Default 4 nodes for any compset and machine - -4 - -4 - -4 - -4 - -4 - -4 - -4 - -4 + -4 + -4 + -4 + -4 + -4 + -4 + -4 + -4 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + + + + + + + + Single node for izumi for small PE layout + + -1 + -1 + -1 + -1 + -1 + -1 + -1 + -1 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 @@ -42,6 +80,7 @@ + Coupled to CAM for 2 degree on cheyenne -10 -10 @@ -78,7 +117,7 @@ - none + All compsets at 2 degree on any machine -4 -4 @@ -114,8 +153,8 @@ - - none + + 2 degree SLIM standalone "I compset" on cheyenne -1 -40 @@ -188,7 +227,8 @@ - + + 1 degree SLIM standalone "I compset" on cheyenne none -1 @@ -223,19 +263,19 @@ - + none - 5 - 5 - 5 - 5 - 5 - 5 - 5 - 5 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 1 @@ -260,58 +300,20 @@ - - - - none - - -4 - -4 - -4 - -4 - -4 - -4 - -4 - -4 - -4 - - - 1> - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - none + 10x15 degree single node for any machine and compset - -2 - -2 - -2 - -2 - -2 - -2 - -2 - -2 - -2 + -1 + -1 + -1 + -1 + -1 + -1 + -1 + -1 + -1 1> @@ -336,40 +338,40 @@ - - - - none + + + + 4x5 degree for cheyenne for I compsets - -1 - -1 - -1 - -1 - -1 - -1 - -1 - -1 - -1 + -1 + -4 + -4 + -4 + -4 + -4 + -4 + -4 + -4 1> - 1 - 1 - 1 - 1 - 1 - 1 - 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 diff --git a/cime_config/namelist_definition_slim.xml b/cime_config/namelist_definition_slim.xml index f18e4811..fc2b314d 100644 --- a/cime_config/namelist_definition_slim.xml +++ b/cime_config/namelist_definition_slim.xml @@ -17,10 +17,13 @@ slim_data_and_initial UNSET - $DIN_LOC_ROOT/lnd/slim/surdat/globalconst_alpha0.2_soilcv2e6_hc0.1_rs100.0_glc_hc0.01_f19_cdf5_20211105.nc - $DIN_LOC_ROOT/lnd/slim/surdat/slim_realistic_fromCLM5_alb1850_hc1850_rs1850_f19_20190110.nc - $DIN_LOC_ROOT/lnd/slim/surdat/slim2deg_fromCMIP6-AMIP-1deg_ensemble001-010_1991to2010clim_max-ctrl-bucket_rs150_c20210401.nc - $DIN_LOC_ROOT/lnd/slim/surdat/slim2deg_fromCMIP6-AMIP-1deg_ensemble001-010_1991to2010clim_max-ctrl-bucket_rs150_c20210401.nc + UNSET + $DIN_LOC_ROOT/lnd/slim/surdat/globalconst_alpha0.2_soilcv2e6_hc0.1_rs100.0_glc_hc0.01_f19_cdf5_20211105.nc + $DIN_LOC_ROOT/lnd/slim/surdat/slim_realistic_fromCLM5_alb1850_hc1850_rs1850_f19_20190110.nc + $DIN_LOC_ROOT/lnd/slim/surdat/slim2deg_fromCMIP6-AMIP-1deg_ensemble001-010_1991to2010clim_max-ctrl-bucket_rs150_c20210401.nc + $DIN_LOC_ROOT/lnd/slim/surdat/slim_realistic_f19_20190110_reverse_cutout_to_f09_c20230224.nc + $DIN_LOC_ROOT/lnd/slim/surdat/slim_realistic_f19_20190110_cutout_to_f45_c20230131.nc + $DIN_LOC_ROOT/lnd/slim/surdat/slim_realistic_f19_20190110_cutout_to_f10_c20230131.nc Surface dataset describing surface properties at each gridcell @@ -48,6 +51,7 @@ slim_data_and_initial + UNSET UNSET UNSET @@ -103,9 +107,9 @@ slim_performance slim_perf number of segments per clump for decomposition - 20 + 35 - 20 + 35 @@ -118,6 +122,9 @@ slim_physics slim_inparm Time step (seconds) + + UNSET + @@ -291,93 +298,22 @@ - + logical datasets finidat_consistency_checks - .true. - - .true. - - - If TRUE (which is the default), check consistency between pct_pft on the finidat file - and pct_pft read from the surface dataset. - - This requires that finidat be non-blank. - - This should probably be removed. - - - - - logical - datasets - clm_initinterp_inparm .false. - + .false. - - - If FALSE (which is the default): If an output type cannot be found in the input for initInterp, - code aborts - If TRUE: If an output type cannot be found in the input, fill with closest natural veg column - (using bare soil for patch-level variables) - - NOTE: Natural vegetation and crop landunits always behave as if this were true. e.g., if - we can't find a column with the same type as a given crop column in the output, then we - always fill with the closest natural veg patch / column, regardless of the value of this - flag. So interpolation from non-crop to crop cases can be done without setting this flag. - - This should probably be removed. - - - - - - - - char - datasets - abs - clm_inparm - - UNSET - $DIN_LOC_ROOT/lnd/clm2/surfdata_map/surfdata_1.9x2.5_16pfts_Irrig_CMIP6_simyr2000_c170824.nc - $DIN_LOC_ROOT/lnd/clm2/surfdata_map/surfdata_1.9x2.5_16pfts_Irrig_CMIP6_simyr1850_c170824.nc - $DIN_LOC_ROOT/lnd/clm2/surfdata_map/surfdata_0.9x1.25_16pfts_Irrig_CMIP6_simyr1850_c170824.nc - $DIN_LOC_ROOT/lnd/clm2/surfdata_map/surfdata_1.9x2.5_16pfts_Irrig_CMIP6_simyr2000_c170824.nc - $DIN_LOC_ROOT/lnd/clm2/surfdata_map/surfdata_0.9x1.25_16pfts_Irrig_CMIP6_simyr2000_c170824.nc - - - Surface dataset from CLM - - - - - char - datasets - abs - clm_inparm - - $DIN_LOC_ROOT/lnd/clm2/paramdata/clm_params.c170913.nc - + - PFT and parameter file - - + If TRUE, check consistency between year on the finidat file + and the current model year. This check is only done for a transient run. - - - logical - slim_physics - clm_inparm - - If Carbon/Nitrogen model should be used - Currently this is used in a couple places in SLIM, but should be removed. + This requires that finidat be non-blank. - diff --git a/cime_config/slim_cime_py/buildnml.py b/cime_config/slim_cime_py/buildnml.py index 242975b4..00654fed 100644 --- a/cime_config/slim_cime_py/buildnml.py +++ b/cime_config/slim_cime_py/buildnml.py @@ -332,6 +332,12 @@ def check_nml_data(nmlgen, case): mml_surdat = nmlgen.get_value("mml_surdat") if mml_surdat == "UNSET": + slim_scenario = case.get_value("SLIM_SCENARIO") + if slim_scenario == "user_defined": + raise SystemExit( + "When SLIM_SCENARIO is set to user_defined, you must provide the mml_surdat " + + "file by adding it to the user_nl_slim file to add it to the namelist" + ) raise SystemExit("mml_surdat file is NOT set and is required") # @@ -360,13 +366,6 @@ def check_nml_data(nmlgen, case): if finidat_dest is not None and not interp: raise SystemExit("finidat_interp_dest can NOT be set if use_init_interp is not on") - # ----------------------------------------------------------------------------------------- - # Requirements still in clm_inparm - # ----------------------------------------------------------------------------------------- - fsurdat = nmlgen.get_value("fsurdat") - if fsurdat == "UNSET": - raise SystemExit("fsurdat file is NOT set and is required") - # pylint: disable=too-many-arguments,too-many-locals,too-many-branches,too-many-statements # Turn off unused-argument for inst_string, since isn't in place right now @@ -388,6 +387,7 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path # ------------------------------------------------------ config = {} config["lnd_grid"] = case.get_value("LND_GRID") + config["compset"] = case.get_value("COMPSET") config["slim_scenario"] = case.get_value("SLIM_SCENARIO") config["slim_start_type"] = case.get_value("SLIM_START_TYPE") @@ -413,7 +413,6 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path # ---------------------------------------------------- logger.info("Write namelists") namelist_file = os.path.join(confdir, "lnd_in") - # Include clm_inparm until can be removed... nmlgen.write_output_file( namelist_file, data_list_path, @@ -423,8 +422,6 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path "slim_history", "slim_perf", "finidat_consistency_checks", - "clm_initinterp_inparm", - "clm_inparm", ], ) @@ -455,7 +452,7 @@ def buildnml(case, caseroot, compname): # Set confdir # ----------------------------------------------------- - confdir = os.path.join(caseroot, "Buildconf", "slimconf") + confdir = os.path.join(caseroot, "Buildconf", compname + "conf") if not os.path.isdir(confdir): os.makedirs(confdir) diff --git a/cime_config/testdefs/ExpectedTestFails.xml b/cime_config/testdefs/ExpectedTestFails.xml index 6673a0e1..a0dd1880 100644 --- a/cime_config/testdefs/ExpectedTestFails.xml +++ b/cime_config/testdefs/ExpectedTestFails.xml @@ -29,82 +29,64 @@ - - + + FAIL - marysa/SimpleLand#14 + ESCOMP/SimpleLand#85 - - + + FAIL - marysa/SimpleLand#14 + ESCOMP/SimpleLand#85 - - + + FAIL - marysa/SimpleLand#14 + ESCOMP/SimpleLand#85 - - + + FAIL - marysa/SimpleLand#14 + ESCOMP/SimpleLand#85 - - - FAIL - marysa/SimpleLand#14 - - - - - FAIL - marysa/SimpleLand#14 - - - - - FAIL - marysa/SimpleLand#14 - - - - + + FAIL - marysa/SimpleLand#14 + ESCOMP/SimpleLand#17 - - + + FAIL - marysa/SimpleLand#14 + ESCOMP/SimpleLand#17 - - + + FAIL - marysa/SimpleLand#14 + ESCOMP/SimpleLand#75 - - + + FAIL - marysa/SimpleLand#25? + ESCOMP/SimpleLand#79 - - + + FAIL - marysa/SimpleLand#17 + ESCOMP/SimpleLand#79 - - + + FAIL - marysa/SimpleLand#17 + ESCOMP/SimpleLand#79 diff --git a/cime_config/testdefs/testlist_slim.xml b/cime_config/testdefs/testlist_slim.xml index 0ea15815..10873d6a 100644 --- a/cime_config/testdefs/testlist_slim.xml +++ b/cime_config/testdefs/testlist_slim.xml @@ -6,26 +6,30 @@ - + + + + - + - + + - + @@ -34,7 +38,28 @@ - + + + + + + + + + + + + + + + + + + + + + + @@ -51,166 +76,205 @@ - - + + + + + + + + - - - - - - - - +--> + + - - - - + - - + + - + - - - + + - + - + - - + + + + + + + + + + + + - + + + + + + + + + + + + + - - - - + + - + + + + + + - - + + - + - + + + + - + - + - - + - + + - - + + - + + + + + + + + + + + + - + - + - + - + @@ -219,10 +283,13 @@ - + + + + @@ -231,7 +298,7 @@ - + @@ -241,7 +308,7 @@ - + diff --git a/cime_config/testdefs/testmods_dirs/clm/g16_SOM/shell_commands b/cime_config/testdefs/testmods_dirs/clm/g16_SOM/shell_commands deleted file mode 100755 index 28fa386d..00000000 --- a/cime_config/testdefs/testmods_dirs/clm/g16_SOM/shell_commands +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/bash -CIMEROOT=`./xmlquery --value -s CIMEROOT` -cp $CIMEROOT/../cime_config/testdefs/testmods_dirs/clm/g16_SOM/user_docn* . diff --git a/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensemble/user_nl_slim b/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensemble/user_nl_slim deleted file mode 100644 index 4801c113..00000000 --- a/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensemble/user_nl_slim +++ /dev/null @@ -1 +0,0 @@ -mml_surdat='$DIN_LOC_ROOT/lnd/slim/surdat/slim2deg_fromCMIP6-AMIP-1deg_ensemble001-010_1991to2010clim_max-ctrl-bucket_rs150_c20210401.nc' diff --git a/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensembleMonthly/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensembleMonthly/include_user_mods deleted file mode 100644 index 7aeecdf4..00000000 --- a/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensembleMonthly/include_user_mods +++ /dev/null @@ -1,2 +0,0 @@ -../Monthly -../2000_CMIP6_AMIP_1deg_ensemble diff --git a/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensemble_FHistMonthly/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensemble_FHistMonthly/include_user_mods deleted file mode 100644 index 4b850273..00000000 --- a/cime_config/testdefs/testmods_dirs/slim/2000_CMIP6_AMIP_1deg_ensemble_FHistMonthly/include_user_mods +++ /dev/null @@ -1,2 +0,0 @@ -../Monthly -../2000_CMIP6_AMIP_1deg_ensemble_FHist diff --git a/cime_config/testdefs/testmods_dirs/slim/Monthly/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/Monthly/include_user_mods new file mode 100644 index 00000000..fe0e18cf --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/slim/Monthly/include_user_mods @@ -0,0 +1 @@ +../default diff --git a/cime_config/testdefs/testmods_dirs/slim/Monthly/user_nl_clm b/cime_config/testdefs/testmods_dirs/slim/Monthly/user_nl_clm deleted file mode 100644 index 4eda119e..00000000 --- a/cime_config/testdefs/testmods_dirs/slim/Monthly/user_nl_clm +++ /dev/null @@ -1,4 +0,0 @@ - hist_nhtfrq = 0 - hist_mfilt = 1 - ! Don't restrict the list of fields - hist_empty_htapes = .false. diff --git a/cime_config/testdefs/testmods_dirs/slim/Monthly/user_nl_slim b/cime_config/testdefs/testmods_dirs/slim/Monthly/user_nl_slim new file mode 100644 index 00000000..11f012ed --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/slim/Monthly/user_nl_slim @@ -0,0 +1,2 @@ + hist_nhtfrq = 0 + hist_mfilt = 1 diff --git a/cime_config/testdefs/testmods_dirs/slim/default/user_nl_slim b/cime_config/testdefs/testmods_dirs/slim/default/user_nl_slim index 82ac77de..5e69970f 100644 --- a/cime_config/testdefs/testmods_dirs/slim/default/user_nl_slim +++ b/cime_config/testdefs/testmods_dirs/slim/default/user_nl_slim @@ -1,19 +1,3 @@ hist_ndens = 1 hist_nhtfrq =-24 hist_mfilt = 5 -! Empty the default history tapes and just output the MML fields - hist_empty_htapes = .true. - hist_fincl1 = 'MML_snowmaskdepth', 'MML_evap_rs', 'MML_bucket_cap', 'MML_soiltype', 'MML_roughness', 'MML_fsds', 'MML_fsdsnd', -'MML_fsdsni', - 'MML_fsdsvd', 'MML_fsdsvi', 'MML_lwdn', 'MML_zref', 'MML_tbot', 'MML_thref', 'MML_qbot', 'MML_uref', - 'MML_eref', 'MML_pbot', 'MML_psrf', 'MML_pco2', 'MML_rhomol', 'MML_rhoair', 'MML_cpair', 'MML_prec_liq', - 'MML_prec_frz', 'MML_ts', 'MML_qs', 'MML_qa', 'MML_swabs', 'MML_fsr', 'MML_fsrnd', 'MML_fsrni', - 'MML_fsrvd', 'MML_fsrvi', 'MML_snowmelt', 'MML_l2a_taux', 'MML_l2a_tauy', 'MML_lwup', 'MML_shflx', 'MML_lhflx', - 'MML_gsoi', 'MML_gsnow', 'MML_evap', 'MML_ustar', 'MML_tstar', 'MML_qstar', 'MML_tvstar', 'MML_obu', - 'MML_ram', 'MML_rah', 'MML_z0m', 'MML_z0h', 'MML_alb', 'MML_fsns', 'MML_flns', 'MML_maxice', - 'MML_soilz', 'MML_soil_t', 'MML_soil_liq', 'MML_soil_ice', 'MML_dz', 'MML_zh', 'MML_tk', 'MML_tkh', - 'MML_dtsoi', 'MML_cv', 'MML_water', 'MML_snow', 'MML_runoff', 'MML_l2a_tref2m', 'MML_l2a_qref2m', 'MML_l2a_uref10m', - 'MML_diag1_1d', 'MML_diag2_1d', 'MML_diag3_1d', 'MML_diag1_2d', 'MML_diag2_2d', 'MML_diag3_2d', 'MML_q_excess', -'MML_lh_excess', - 'MML_q_demand', 'MML_lh_demand', 'mml_err_h2o', 'mml_err_h2osno', 'mml_err_seb', 'mml_err_soi', 'mml_err_sol', 'WIND', - 'THBOT', 'RAIN', 'SNOW', 'RH' diff --git a/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850_g16_SOM_save_cplhist/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/g16_SOM_save_cplhist/include_user_mods similarity index 50% rename from cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850_g16_SOM_save_cplhist/include_user_mods rename to cime_config/testdefs/testmods_dirs/slim/g16_SOM_save_cplhist/include_user_mods index 4cec50ab..c15d76a8 100644 --- a/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850_g16_SOM_save_cplhist/include_user_mods +++ b/cime_config/testdefs/testmods_dirs/slim/g16_SOM_save_cplhist/include_user_mods @@ -1,3 +1,2 @@ -../realistic_fromCLM5_1850 ../g16_SOM ../save_cplhist diff --git a/cime_config/testdefs/testmods_dirs/slim/global_uniform/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/global_uniform/include_user_mods index d243c2a4..fe0e18cf 100644 --- a/cime_config/testdefs/testmods_dirs/slim/global_uniform/include_user_mods +++ b/cime_config/testdefs/testmods_dirs/slim/global_uniform/include_user_mods @@ -1,2 +1 @@ ../default -../../../../usermods_dirs/global_uniform diff --git a/cime_config/testdefs/testmods_dirs/slim/global_uniform/shell_commands b/cime_config/testdefs/testmods_dirs/slim/global_uniform/shell_commands new file mode 100755 index 00000000..9c10e11c --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/slim/global_uniform/shell_commands @@ -0,0 +1,2 @@ +#!/bin/bash +./xmlchange SLIM_SCENARIO="global_uniform" diff --git a/cime_config/testdefs/testmods_dirs/slim/realistic_2000/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/realistic_2000/include_user_mods new file mode 100644 index 00000000..fe0e18cf --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/slim/realistic_2000/include_user_mods @@ -0,0 +1 @@ +../default diff --git a/cime_config/testdefs/testmods_dirs/slim/realistic_2000/shell_commands b/cime_config/testdefs/testmods_dirs/slim/realistic_2000/shell_commands new file mode 100755 index 00000000..eea2a10d --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/slim/realistic_2000/shell_commands @@ -0,0 +1,2 @@ +#!/bin/bash +./xmlchange SLIM_SCENARIO="realistic_from_2000" diff --git a/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850/include_user_mods deleted file mode 100644 index ad975dc0..00000000 --- a/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850/include_user_mods +++ /dev/null @@ -1,2 +0,0 @@ -../default -../../../../usermods_dirs/realistic_fromCLM5_1850 diff --git a/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850Monthly/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850Monthly/include_user_mods deleted file mode 100644 index 19c81d9f..00000000 --- a/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850Monthly/include_user_mods +++ /dev/null @@ -1,2 +0,0 @@ -../Monthly -../realistic_fromCLM5_1850 diff --git a/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850_g16_SOM_save_cplhist/shell_commands b/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850_g16_SOM_save_cplhist/shell_commands deleted file mode 100755 index 626ff59f..00000000 --- a/cime_config/testdefs/testmods_dirs/slim/realistic_fromCLM5_1850_g16_SOM_save_cplhist/shell_commands +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/bash -./xmlchange CLM_CO2_TYPE="diagnostic" diff --git a/cime_config/testdefs/testmods_dirs/slim/save_cplhist/include_user_mods b/cime_config/testdefs/testmods_dirs/slim/save_cplhist/include_user_mods new file mode 100644 index 00000000..fe0e18cf --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/slim/save_cplhist/include_user_mods @@ -0,0 +1 @@ +../default diff --git a/cime_config/usermods_dirs/global_uniform/user_nl_slim b/cime_config/usermods_dirs/global_uniform/user_nl_slim deleted file mode 100644 index f84c9987..00000000 --- a/cime_config/usermods_dirs/global_uniform/user_nl_slim +++ /dev/null @@ -1 +0,0 @@ -mml_surdat = '$DIN_LOC_ROOT/lnd/slim/surdat/globalconst_alpha0.2_soilcv2e6_hc0.1_rs100.0_glc_hc0.01_f19_cdf5_20211105.nc' diff --git a/cime_config/usermods_dirs/realistic_fromCLM5_1850/user_nl_slim b/cime_config/usermods_dirs/realistic_fromCLM5_1850/user_nl_slim deleted file mode 100644 index f7953f1f..00000000 --- a/cime_config/usermods_dirs/realistic_fromCLM5_1850/user_nl_slim +++ /dev/null @@ -1 +0,0 @@ -mml_surdat = '$DIN_LOC_ROOT/lnd/slim/surdat/slim_realistic_fromCLM5_alb1850_hc1850_rs1850_f19_20190110.nc' diff --git a/cime_config/usermods_dirs/realistic_fromCLM5_2000/user_nl_slim b/cime_config/usermods_dirs/realistic_fromCLM5_2000/user_nl_slim deleted file mode 100644 index 171aa345..00000000 --- a/cime_config/usermods_dirs/realistic_fromCLM5_2000/user_nl_slim +++ /dev/null @@ -1 +0,0 @@ -mml_surdat = '$DIN_LOC_ROOT/lnd/slim/surdat/slim2deg_fromCMIP6-AMIP-1deg_ensemble001-010_1991to2010clim_max-ctrl-bucket_rs150_c20210401.nc' diff --git a/python/slim/config_utils.py b/python/slim/config_utils.py new file mode 100644 index 00000000..857fd746 --- /dev/null +++ b/python/slim/config_utils.py @@ -0,0 +1,162 @@ +""" +General-purpose utilities and functions for handling command-line +config files in slim python codes. +""" + +import logging +import configparser + +from slim.utils import abort + +logger = logging.getLogger(__name__) + +# This string is used in the out-of-the-box slim.cfg and modify.cfg files +# to denote a value that needs to be filled in +_CONFIG_PLACEHOLDER = "FILL_THIS_IN" +# This string is used in the out-of-the-box slim.cfg and modify.cfg files +# to denote a value that can be filled in, but doesn't absolutely need to be +_CONFIG_UNSET = "UNSET" + + +def lon_range_0_to_360(lon_in): + """ + Description + ----------- + Restrict longitude to 0 to 360 when given as -180 to 180. + """ + if -180 <= lon_in < 0: + lon_out = lon_in % 360 + logger.info( + "Resetting longitude from %s to %s to keep in the range " " 0 to 360", + str(lon_in), + str(lon_out), + ) + elif 0 <= lon_in <= 360 or lon_in is None: + lon_out = lon_in + else: + errmsg = "lon_in needs to be in the range 0 to 360" + abort(errmsg) + + return lon_out + + +def get_config_value( + config, + section, + item, + file_path, + allowed_values=None, + default=None, + is_list=False, + convert_to_type=None, + can_be_unset=False, +): + """Get a given item from a given section of the config object + Give a helpful error message if we can't find the given section or item + Note that the file_path argument is only used for the sake of the error message + If allowed_values is present, it should be a list of strings giving allowed values + The function _handle_config_value determines what to do if we read: + - a list or + - a str that needs to be converted to int / float / bool + - _CONFIG_UNSET: anything with the value "UNSET" will become "None" + """ + try: + val = config.get(section, item) + except configparser.NoSectionError: + abort("ERROR: Config file {} must contain section '{}'".format(file_path, section)) + except configparser.NoOptionError: + abort( + "ERROR: Config file {} must contain item '{}' in section '{}'".format( + file_path, item, section + ) + ) + + if val == _CONFIG_PLACEHOLDER: + abort("Error: {} needs to be specified in config file {}".format(item, file_path)) + + val = _handle_config_value( + var=val, + default=default, + item=item, + is_list=is_list, + convert_to_type=convert_to_type, + can_be_unset=can_be_unset, + allowed_values=allowed_values, + ) + return val + + +def _handle_config_value( + var, default, item, is_list, convert_to_type, can_be_unset, allowed_values +): + """ + Description + ----------- + Assign the default value or the user-specified one to var. + Convert from default type (str) to reqested type (int or float). + + If is_list is True, then default should be a list + """ + if var == _CONFIG_UNSET: + if can_be_unset: + return default # default may be None + abort("Must set a value for .cfg file variable: {}".format(item)) + + # convert string to list of strings; if there is just one element, + # we will get a list of size one, which we will convert back to a + # scalar later if needed + var = var.split() + + if convert_to_type is bool: + try: + var = [_convert_to_bool(v) for v in var] + except ValueError: + abort("Non-boolean value found for .cfg file variable: {}".format(item)) + elif convert_to_type is not None: + try: + var = [convert_to_type(v) for v in var] + except ValueError: + abort("Wrong type for .cfg file variable: {}".format(item)) + + if allowed_values is not None: + for val in var: + if val not in allowed_values: + print("val = ", val, " in var not in allowed_values") + errmsg = ( + "{} is not an allowed value for {} in .cfg file. " + "Check allowed_values".format(val, item) + ) + abort(errmsg) + + if not is_list: + if len(var) > 1: + abort("More than 1 element found for .cfg file variable: {}".format(item)) + var = var[0] + + return var + + +def _convert_to_bool(var): + """ + Function for converting different forms of + boolean strings to boolean value. + + Args: + var (str): String bool input + + Raises: + if the argument is not an acceptable boolean string + (such as yes or no ; true or false ; y or n ; t or f ; 0 or 1). + ValueError: The string should be one of the mentioned values. + + Returns: + var_out (bool): Boolean value corresponding to the input. + """ + if var.lower() in ("yes", "true", "t", "y", "1", "on"): + var_out = True + elif var.lower() in ("no", "false", "f", "n", "0", "off"): + var_out = False + else: + raise ValueError("Boolean value expected. [true or false] or [y or n]") + + return var_out diff --git a/python/slim/git_utils.py b/python/slim/git_utils.py new file mode 100644 index 00000000..c4c5cbe1 --- /dev/null +++ b/python/slim/git_utils.py @@ -0,0 +1,61 @@ +"""General-purpose git utility functions""" + +import logging +import subprocess + +from slim.path_utils import path_to_slim_root + +logger = logging.getLogger(__name__) + + +def get_slim_git_short_hash(): + """ + Returns Git short SHA for the SLIM repository. + + Args: + + Raises: + + Returns: + sha (str) : git short hash for slim repository + """ + sha = ( + subprocess.check_output(["git", "-C", path_to_slim_root(), "rev-parse", "--short", "HEAD"]) + .strip() + .decode() + ) + return sha + + +def get_slim_git_long_hash(): + """ + Returns Git long SHA for the SLIM repository. + + Args: + + Raises: + + Returns: + sha (str) : git long hash for slim repository + """ + sha = ( + subprocess.check_output(["git", "-C", path_to_slim_root(), "rev-parse", "HEAD"]) + .strip() + .decode() + ) + return sha + + +def get_slim_git_describe(): + """ + Function for giving the recent tag of the SLIM repository + + Args: + + Raises: + + Returns: + label (str) : ouput of running 'git describe' for the SLIM repository + """ + label = subprocess.check_output(["git", "-C", path_to_slim_root(), "describe"]).strip().decode() + return label diff --git a/python/slim/import_hook.py b/python/slim/import_hook.py index 955e6bae..4f1b9d36 100644 --- a/python/slim/import_hook.py +++ b/python/slim/import_hook.py @@ -3,5 +3,4 @@ import os _CIMEROOT = os.path.join(os.path.dirname(os.path.abspath(__file__)), "..", "..", "cime") -_LIB_DIR = os.path.join(_CIMEROOT, "scripts", "lib") -sys.path.append(_LIB_DIR) +sys.path.append(_CIMEROOT) diff --git a/python/slim/mksurdat/__init__.py b/python/slim/mksurdat/__init__.py new file mode 100644 index 00000000..e69de29b diff --git a/python/slim/mksurdat/mksurdat.ipynb b/python/slim/mksurdat/mksurdat.ipynb new file mode 100644 index 00000000..d774262c --- /dev/null +++ b/python/slim/mksurdat/mksurdat.ipynb @@ -0,0 +1,608 @@ +{ + "cells": [ + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "# Generate a SLIM surdat file from CTSM output\n", + "by S. Levis, \n", + "modified from pres_vs_hist_alb_LN_postAGU20190621_corrected_rs.ipynb by Marysa Lague" + ] + }, + { + "cell_type": "code", + "execution_count": 1, + "metadata": {}, + "outputs": [], + "source": [ + "import os\n", + "import sys\n", + "\n", + "import time as tm\n", + "from copy import copy \n", + "\n", + "import netCDF4 as nc\n", + "import xarray as xr\n", + "import numpy as np" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## USER MODIFY (first)" + ] + }, + { + "cell_type": "code", + "execution_count": 2, + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "12\n" + ] + } + ], + "source": [ + "# Name of simulation to provide data for the SLIM surdat file generated by this tool\n", + "# Simulation must be a bgc case, so as to include the history variable HTOP\n", + "casename = 'ihist_bgccrop' # USER MODIFY\n", + "\n", + "# This tool assumes that it will access files in the user's\n", + "# /glade/scratch//archive/ directories\n", + "# User may need to modify\n", + "username = os.environ.get('USER')\n", + "case_archive_dir = '/glade/scratch/' + username + '/archive/' + casename\n", + "ctsm_dir = case_archive_dir + '/lnd/hist/'\n", + "cpl_dir = case_archive_dir + '/cpl/hist/'\n", + "\n", + "# USER-GENERATED FILES\n", + "# 1) Currently required: CTSM\n", + "# nco-generated monthly means of ctsm history files\n", + "# assumed file name is .clm2.h0.nc\n", + "# Sample use of nco to concatenate 12 months of a single year:\n", + "# ncecat .clm2.h0.-* .clm2.h0.nc\n", + "# nco user's guide: https://nco.sourceforge.net/\n", + "ctsm_concatenated_file = ctsm_dir + casename + '.clm2.h0.nc' # USER may need to modify\n", + "\n", + "if os.path.exists(ctsm_concatenated_file):\n", + " ds = xr.open_dataset(ctsm_concatenated_file, decode_times=False)\n", + "else:\n", + " errmsg = \"ctsm_concatenated_file does not exist: \" + ctsm_concatenated_file\n", + " sys.exit(errmsg)\n", + "\n", + "ds['time'] = ds['record'] # ncecat (a few lines up) introduced the \"record\" dimension\n", + "lat_ctsm = ds.variables['lat'].values[:] # getting lat\n", + "lon_ctsm = ds.variables['lon'].values[:] # getting lon\n", + "landmask = ds.landmask.values[0,:,:] # getting landmask\n", + "dims = np.shape(landmask)\n", + "months_per_yr = len(ds['time'].values)\n", + "print(months_per_yr) # expect 12\n", + "\n", + "# 2) Optional: CPL\n", + "# nco-generated monthly means of coupler history files\n", + "# assumed file name is .cpl.h0.nc\n", + "# additional nco information a few lines up\n", + "# if dust_file does not exist, dust fluxes will be set to zero (later)\n", + "dust_file = cpl_dir + casename + '.cpl.h0.nc' # USER may need to modify" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## USER MODIFY (last)" + ] + }, + { + "cell_type": "code", + "execution_count": 3, + "metadata": {}, + "outputs": [], + "source": [ + "# Optional: ctsm fsurdat file from the simulation that produced the ctsm history a few lines up\n", + "surfdat_dir ='/glade/p/cesmdata/cseg/inputdata/lnd/clm2/surfdata_map/release-clm5.0.18/' # USER may need to modify\n", + "surfdat_file = surfdat_dir + 'surfdata_0.9x1.25_hist_78pfts_CMIP6_simyr2000_c190214.nc' # USER may wish to modify\n", + "\n", + "# If ctsm fsurdat file does not exist, glc_mask will equal zero everywhere\n", + "glc_mask = np.zeros(dims)\n", + "if os.path.exists(surfdat_file):\n", + " surfdat_ds = xr.open_dataset(surfdat_file)\n", + " # get glacier mask\n", + " glc_pct = (surfdat_ds.variables['PCT_GLACIER']).values[:]\n", + " # apply the glacier mask where glc_pct > 50% \n", + " glc_mask[glc_pct > 50] = 1\n", + "else:\n", + " surfdata_file = ''" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### add mask information to the dataset" + ] + }, + { + "cell_type": "code", + "execution_count": 4, + "metadata": {}, + "outputs": [], + "source": [ + "dirt_mask = np.where((landmask==1.) & (glc_mask==0.), 1.0, 0.0)\n", + "ds['glc_mask'] = xr.DataArray(dims=['lat','lon'], data=glc_mask)\n", + "ds['bareground_mask'] = xr.DataArray(dims=['lat','lon'], data=dirt_mask)" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### calculations of variables that will end up in the SLIM surdat file" + ] + }, + { + "cell_type": "code", + "execution_count": 5, + "metadata": {}, + "outputs": [], + "source": [ + "# ctsm history variables used in this script\n", + "# lndvars = ['FSR','FSDS','GSSHA','GSSUN','GSSHALN','GSSUNLN','TLAI','HTOP',\n", + "# 'LAISUN','LAISHA','SNOW_DEPTH',\n", + "# 'FSRND','FSRNI','FSRVD','FSRVI',\n", + "# 'FSDSND','FSDSNI','FSDSVD','FSDSVI' ]\n", + "\n", + "# Construct albedos from sw reflected / down:\n", + "#-------ALBEDO------#\n", + "nameswap = {}\n", + "nameswap['FSR'] = 'ALBEDO'\n", + "# albedo:\n", + "ds_temp = xr.merge([ds['FSR'], ds['FSDS']])\n", + "ds_temp['ALBEDO'] = ds_temp['FSR'] / ds_temp['FSDS']\n", + "ds_temp['ALBEDO'].attrs['units'] = 'unitless'\n", + "ds_temp['ALBEDO'].attrs['longname'] = 'multistream albedo'\n", + "ds['ALBEDO'] = ds_temp['ALBEDO']\n", + "\n", + "ds_temp = xr.merge([ds['FSRND'], ds['FSDSND']])\n", + "ds_temp['ALBEDO_ND'] = ds_temp['FSRND'] / ds_temp['FSDSND']\n", + "ds_temp['ALBEDO_ND'].attrs['units'] = 'unitless'\n", + "ds_temp['ALBEDO_ND'].attrs['longname'] = 'near-IR direct albedo'\n", + "ds['ALBEDO_ND'] = ds_temp['ALBEDO_ND']\n", + "\n", + "ds_temp = xr.merge([ds['FSRNI'], ds['FSDSNI']])\n", + "ds_temp['ALBEDO_NI'] = ds_temp['FSRNI'] / ds_temp['FSDSNI']\n", + "ds_temp['ALBEDO_NI'].attrs['units'] = 'unitless'\n", + "ds_temp['ALBEDO_NI'].attrs['longname'] = 'near-IR diffuse albedo'\n", + "ds['ALBEDO_NI'] = ds_temp['ALBEDO_NI']\n", + " \n", + "ds_temp = xr.merge([ds['FSRVD'], ds['FSDSVD']])\n", + "ds_temp['ALBEDO_VD'] = ds_temp['FSRVD'] / ds_temp['FSDSVD']\n", + "ds_temp['ALBEDO_VD'].attrs['units'] = 'unitless'\n", + "ds_temp['ALBEDO_VD'].attrs['longname'] = 'visible direct albedo'\n", + "ds['ALBEDO_VD'] = ds_temp['ALBEDO_VD']\n", + "\n", + "ds_temp = xr.merge([ds['FSRVI'], ds['FSDSVI']])\n", + "ds_temp['ALBEDO_VI'] = ds_temp['FSRVI'] / ds_temp['FSDSVI']\n", + "ds_temp['ALBEDO_VI'].attrs['units'] = 'unitless'\n", + "ds_temp['ALBEDO_VI'].attrs['longname'] = 'visible diffuse albedo'\n", + "ds['ALBEDO_VI'] = ds_temp['ALBEDO_VI']\n", + " \n", + "#-------EVAP RS------#\n", + "gs_to_rs = 42.3 * 10**6 # umol H20/m2/s to s/m\n", + "ds_temp = xr.merge([ds['GSSUNLN'], ds['GSSHALN'], ds['LAISUN'], ds['LAISHA']])\n", + "sunLN = ds['GSSUNLN'] * ds['LAISUN']\n", + "shaLN = ds['GSSHALN'] * ds['LAISHA']\n", + "ds_temp['evap_rs_LN'] = gs_to_rs / (sunLN + shaLN)\n", + "ds_temp['evap_rs_LN'].attrs['units'] = 's/m'\n", + "ds_temp['evap_rs_LN'].attrs['longname'] = 'evaporative resistance at local noon = (42.3 x 10^6)/(gssunln*laisun + gsshaln*laisha)'\n", + "ds['evap_rs_LN'] = ds_temp['evap_rs_LN']\n", + " \n", + "rs_LN_uncapped = gs_to_rs / (sunLN + shaLN)\n", + "rs_LN_capped = rs_LN_uncapped.copy()\n", + "rs_LN_capped.values = np.where(rs_LN_uncapped > 1000., 1000., rs_LN_uncapped)\n", + "ds_temp['evap_rs_LN_capped'] = rs_LN_capped\n", + "ds_temp['evap_rs_LN_capped'].attrs['units'] = 's/m'\n", + "ds_temp['evap_rs_LN_capped'].attrs['longname'] = 'evaporative resistance at local noon capped at 1000 s/m; else = (42.3 x 10^6)/(gssunln*laisun + gsshaln*laisha)'\n", + "ds['evap_rs_LN_capped'] = ds_temp['evap_rs_LN_capped']\n", + " \n", + "del ds_temp" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### Snow albedos proposed by Marysa L from calculation elsewhere" + ] + }, + { + "cell_type": "code", + "execution_count": 6, + "metadata": {}, + "outputs": [], + "source": [ + "s_alb = {}\n", + "s_alb['vd'] = 0.97333038\n", + "s_alb['vi'] = 0.965662\n", + "s_alb['nd'] = 0.66046935\n", + "s_alb['ni'] = 0.7067166" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## JJA snowmask" + ] + }, + { + "cell_type": "code", + "execution_count": 7, + "metadata": {}, + "outputs": [], + "source": [ + "snow_thresh = 0.01 # m\n", + "snow = ds['SNOW_DEPTH'][6:9,:,:] # JJA\n", + "jja_snowfree = np.where(snow > snow_thresh , np.nan , 1.0).mean(axis=0)" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## albedo values" + ] + }, + { + "cell_type": "code", + "execution_count": 8, + "metadata": {}, + "outputs": [], + "source": [ + "alb = {}\n", + "\n", + "alb['vd'] = ds['ALBEDO_VD']\n", + "alb['vi'] = ds['ALBEDO_VI']\n", + "alb['nd'] = ds['ALBEDO_ND']\n", + "alb['ni'] = ds['ALBEDO_NI']\n", + "\n", + "# make a new albedo field using values anywhere there wasn't snow\n", + "nc_alb = {}\n", + "nc_alb['ground'] = {}\n", + "nc_alb['snow'] = {}\n", + "\n", + "# do this in np arrays, not datasets\n", + "alb_ocn = 0.1 # set ocean points to this generic value\n", + "for a in alb.keys():\n", + " nc_alb['ground'][a] = np.where(jja_snowfree==1., alb[a], alb[a])\n", + " \n", + " # put snow albedos where glacier mask is true\n", + " nc_alb['ground'][a] = np.where(glc_mask==1., s_alb[a], nc_alb['ground'][a])\n", + " \n", + " # get rid of nans on ocean points\n", + " nc_alb['ground'][a] = np.where(np.isnan(nc_alb['ground'][a]), alb_ocn, nc_alb['ground'][a]).mean(axis=0)\n", + " \n", + " # snow albedo just a single block of color:\n", + " nc_alb['snow'][a] = np.ones(np.shape(landmask)) * s_alb[a]\n", + " nc_alb['snow'][a] = np.where(np.isnan(nc_alb['snow'][a]), alb_ocn, nc_alb['snow'][a])" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## rs values:" + ] + }, + { + "cell_type": "code", + "execution_count": 9, + "metadata": {}, + "outputs": [], + "source": [ + "nc_rs = {}\n", + "nc_rs = ds['evap_rs_LN_capped']\n", + "\n", + "# eliminate nans: set to 1000\n", + "rs_where_nan = 1000\n", + "nc_rs = np.where(np.isnan(nc_rs), rs_where_nan, nc_rs)" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## hc values:" + ] + }, + { + "cell_type": "code", + "execution_count": 10, + "metadata": {}, + "outputs": [], + "source": [ + "nc_hc = {}\n", + "nc_hc = ds['HTOP']\n", + "\n", + "# eliminate nans: set to 0.01 (very smooth). \n", + "hmin=0.01\n", + "nc_hc = np.where(np.isnan(nc_hc), hmin, nc_hc)\n", + "\n", + "# eliminate zeros: messes up the turbulence calculation. Make those smooth, too.\n", + "nc_hc = np.where(nc_hc < hmin, hmin, nc_hc)\n", + "\n", + "# set glacier \"height\" to 0.01\n", + "glc_hc = 0.01 # From BATS: glacier roughness 0.01 - constant\n", + "nc_hc = np.where(glc_mask==1., glc_hc, nc_hc)" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### Other required values" + ] + }, + { + "cell_type": "code", + "execution_count": 11, + "metadata": {}, + "outputs": [], + "source": [ + "if os.path.exists(dust_file):\n", + " dust_ds = xr.open_dataset(dust_file)\n", + " dust1 = (dust_ds.variables['l2xavg_Fall_flxdst1']).values\n", + " dust2 = (dust_ds.variables['l2xavg_Fall_flxdst2']).values\n", + " dust3 = (dust_ds.variables['l2xavg_Fall_flxdst3']).values\n", + " dust4 = (dust_ds.variables['l2xavg_Fall_flxdst4']).values\n", + " # clobber nans\n", + " dust1 = np.where(np.isnan(dust1), 0.0, dust1)\n", + " dust2 = np.where(np.isnan(dust2), 0.0, dust2)\n", + " dust3 = np.where(np.isnan(dust3), 0.0, dust3)\n", + " dust4 = np.where(np.isnan(dust4), 0.0, dust4)\n", + "else:\n", + " dust1 = 0\n", + " dust2 = 0\n", + " dust3 = 0\n", + " dust4 = 0\n", + " dust_file = ''" + ] + }, + { + "cell_type": "code", + "execution_count": 12, + "metadata": {}, + "outputs": [], + "source": [ + "soil_cv_str = '2e6'\n", + "soil_cv_val = 2.0e6 # [J/m3/K]\n", + "soil_tk_val = 1.5 # [W/m/K]\n", + "glc_cv = 1.9e6 # [J/m3/K]\n", + "glc_tk = 2.4 # [W/m/K]\n", + "snow_mask_depth = 50.0 # [kg/m2]\n", + "bucket_capacity = 200.0 # [kg/m2]\n", + "\n", + "# dummy array of ones to extend a lat x lon array into time: mon x lat x lon\n", + "stretch = np.ones([months_per_yr, dims[0], dims[1]])" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "### set up a dictionary called nc_data that stores all the variables to be output" + ] + }, + { + "cell_type": "code", + "execution_count": 13, + "metadata": {}, + "outputs": [], + "source": [ + "nc_data = {} # empty dictionary\n", + "\n", + "# glacier mask:\n", + "nc_data['glc_mask'] = np.copy(glc_mask[:] * stretch)\n", + "\n", + "# Albedos as alb_[g-ground/s-snow][v-visible/n-nir][d-direct/f-diffuse]\n", + "nc_data['alb_gvd'] = nc_alb['ground']['vd'] * stretch\n", + "nc_data['alb_svd'] = nc_alb['snow']['vd'] * stretch\n", + "nc_data['alb_gnd'] = nc_alb['ground']['nd'] * stretch\n", + "nc_data['alb_snd'] = nc_alb['snow']['nd'] * stretch\n", + "nc_data['alb_gvf'] = nc_alb['ground']['vi'] * stretch\n", + "nc_data['alb_svf'] = nc_alb['snow']['vi'] * stretch\n", + "nc_data['alb_gnf'] = nc_alb['ground']['ni'] * stretch\n", + "nc_data['alb_snf'] = nc_alb['snow']['ni'] * stretch\n", + "\n", + "# Bucket capacity in [kg/m2] (or equivalently [mm])\n", + "nc_data['bucketdepth'] = np.copy(bucket_capacity * stretch)\n", + "\n", + "# snow masking \"depth\" in water mass equivalent ([kg/m2] or [mm])\n", + "nc_data['snowmask'] = np.copy(snow_mask_depth * stretch)\n", + "\n", + "# Emissivity (1 = perfect blackbody, not physically realistic)\n", + "nc_data['emissivity'] = np.copy(1.0 * stretch)\n", + "\n", + "# Roughness as \"vegetation height\" [m] (which is then scaled down in the model \n", + "# as .1*veg height for actual roughness used)\n", + "nc_data['roughness'] = nc_hc.mean(axis=0) * stretch\n", + "\n", + "# evaporative resistance [s/m] as a sort of \"bulk stomatal resistance\" - actual\n", + "# resistance is calculated as a combination of this and how full the bucket is\n", + "# Initial pass, set all roughness to 100 (this is our \"base\" for glaciers also)\n", + "nc_data['evap_res'] = nc_rs.mean(axis=0) * stretch\n", + "\n", + "# Dust fluxes (from clm4.5 coupled run). There are 4 different dust bins, each\n", + "# is given its own field here, to avoid problems I ran into trying to read\n", + "# netcdf fields with depth dimensions in the actual model code\n", + "nc_data['l2xavg_Fall_flxdst1'] = np.copy(dust1 * stretch)\n", + "nc_data['l2xavg_Fall_flxdst2'] = np.copy(dust2 * stretch)\n", + "nc_data['l2xavg_Fall_flxdst3'] = np.copy(dust3 * stretch)\n", + "nc_data['l2xavg_Fall_flxdst4'] = np.copy(dust4 * stretch)\n", + "\n", + "# Soil Type (not used, set to 0)\n", + "nc_data['soil_type'] = np.copy(0.0 * stretch)\n", + "\n", + "# Thermal Properties\n", + "# soil heat capacity cv [J/m3/K] (uniform across column using this definition)\n", + "# ranges: 1.5e6 for gravel to 3 for clay/silt; 4.2 for water (if we go very saturated, but the dirt'll still be in there...)\n", + "nc_data['soil_cv_1d'] = np.copy(soil_cv_val * stretch)\n", + "\n", + "# soil thermal conductivity tk [W/m/K] (uniform across column using this definition)\n", + "nc_data['soil_tk_1d'] = np.copy(soil_tk_val * stretch)\n", + "\n", + "# ice (glacier) heat capacity cv [J/m3/K] (uniform across column using this definition)\n", + "# cv water = 4.188e6 , cv ice = 1.9415e+06 \n", + "# near -20 C\n", + "nc_data['glc_cv_1d'] = np.copy(glc_cv * stretch)\n", + "\n", + "# ice (glacier) thermal conductivity tk [W/m/K] (uniform across column using this definition)\n", + "# near -20 C\n", + "nc_data['glc_tk_1d'] = np.copy(glc_tk * stretch)" + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "## Put all the vars into an xarray dataset" + ] + }, + { + "cell_type": "code", + "execution_count": 14, + "metadata": {}, + "outputs": [], + "source": [ + "# Define a time vector for months 1-12\n", + "time_vect = range(months_per_yr + 1)[1:months_per_yr + 1]\n", + "\n", + "# Prepare dataset to be written out to file\n", + "ds_slim = {}\n", + "ds_slim = xr.Dataset({'glc_mask': (['time','lsmlat','lsmlon'], nc_data['glc_mask']),\n", + " 'alb_gvd': (['time','lsmlat','lsmlon'], nc_data['alb_gvd']),\n", + " 'alb_svd': (['time','lsmlat','lsmlon'], nc_data['alb_svd']),\n", + " 'alb_gnd': (['time','lsmlat','lsmlon'], nc_data['alb_gnd']),\n", + " 'alb_snd': (['time','lsmlat','lsmlon'], nc_data['alb_snd']),\n", + " 'alb_gvf': (['time','lsmlat','lsmlon'], nc_data['alb_gvf']),\n", + " 'alb_svf': (['time','lsmlat','lsmlon'], nc_data['alb_svf']),\n", + " 'alb_gnf': (['time','lsmlat','lsmlon'], nc_data['alb_gnf']),\n", + " 'alb_snf': (['time','lsmlat','lsmlon'], nc_data['alb_snf']),\n", + " 'bucketdepth': (['time','lsmlat','lsmlon'], nc_data['bucketdepth']),\n", + " 'emissivity': (['time','lsmlat','lsmlon'], nc_data['emissivity']),\n", + " 'snowmask': (['time','lsmlat','lsmlon'], nc_data['snowmask']), \n", + " 'roughness': (['time','lsmlat','lsmlon'], nc_data['roughness']),\n", + " 'evap_res': (['time','lsmlat','lsmlon'], nc_data['evap_res']),\n", + " 'l2xavg_Fall_flxdst1': (['time','lsmlat','lsmlon'], nc_data['l2xavg_Fall_flxdst1']),\n", + " 'l2xavg_Fall_flxdst2': (['time','lsmlat','lsmlon'], nc_data['l2xavg_Fall_flxdst2']),\n", + " 'l2xavg_Fall_flxdst3': (['time','lsmlat','lsmlon'], nc_data['l2xavg_Fall_flxdst3']),\n", + " 'l2xavg_Fall_flxdst4': (['time','lsmlat','lsmlon'], nc_data['l2xavg_Fall_flxdst4']),\n", + " 'soil_type': (['time','lsmlat','lsmlon'], nc_data['soil_type']),\n", + " 'soil_tk_1d': (['time','lsmlat','lsmlon'], nc_data['soil_tk_1d']),\n", + " 'soil_cv_1d': (['time','lsmlat','lsmlon'], nc_data['soil_cv_1d']),\n", + " 'glc_tk_1d': (['time','lsmlat','lsmlon'], nc_data['glc_tk_1d']),\n", + " 'glc_cv_1d': (['time','lsmlat','lsmlon'], nc_data['glc_cv_1d'])},\n", + " coords = {'lsmlon': (['lsmlon'], lon_ctsm),\n", + " 'lsmlat': (['lsmlat'], lat_ctsm), \n", + " 'time': (['time'], time_vect)},\n", + " attrs = {'Author': username,\n", + " 'Date_created': tm.strftime(\"%Y-%m-%d %H:%M:%S\") + ' ' + tm.tzname[0] + ' ' + tm.tzname[1],\n", + " 'Resolution': 'see surfdat_file listed below',\n", + " 'Description': 'SLIM surdat file',\n", + " 'ccesm_source_run': casename,\n", + " 'ctsm_file': ctsm_concatenated_file,\n", + " 'dust_file': dust_file,\n", + " 'surfdat_file_for_glc_mask': surfdat_file,\n", + " }\n", + " )\n", + "\n", + "# Define each variable's [units, _FillValue, long_name, valid_range]\n", + "# and map onto the dataset\n", + "# Guidance: \n", + "# https://cfconventions.org/Data/cf-conventions/cf-conventions-1.10/cf-conventions.html#attribute-appendix\n", + "attr_map = {'glc_mask': ['unitless', 1e36, 'Glacier/ice sheet mask', [0, 1]], \n", + " 'alb_gvd': ['unitless', 1e36, 'Visible direct albedo for bare ground', []], \n", + " 'alb_svd': ['unitless', 1e36, 'Visible direct albedo for deep snow', []],\n", + " 'alb_gnd': ['unitless', 1e36, 'NIR direct albedo for bare ground', []], \n", + " 'alb_snd': ['unitless', 1e36, 'NIR direct albedo for deep snow', []], \n", + " 'alb_gvf': ['unitless', 1e36, 'Visible diffuse albedo for bare ground', []],\n", + " 'alb_svf': ['unitless', 1e36, 'Visible diffuse albedo for deep snow', []], \n", + " 'alb_gnf': ['unitless', 1e36, 'NIR diffuse albedo for bare ground', []], \n", + " 'alb_snf': ['unitless', 1e36, 'NIR diffuse albedo for deep snow', []],\n", + " 'bucketdepth': ['kg/m2', 1e36, 'Bucket capacity', []], \n", + " 'emissivity': ['unitless', 1e36, 'Surface emissivity for longwave radiation', []], \n", + " 'snowmask': ['kg/m2', 1e36, 'Snow-masking depth', []],\n", + " 'roughness': ['m', 1e36, 'Vegetation height', []], \n", + " 'evap_res': ['s/m', 1e36, 'Evaporative resistance', []],\n", + " 'l2xavg_Fall_flxdst1': ['unknown', 1e36, 'Dust flux', []], \n", + " 'l2xavg_Fall_flxdst2': ['unknown', 1e36, 'Dust flux', []], \n", + " 'l2xavg_Fall_flxdst3': ['unknown', 1e36, 'Dust flux', []], \n", + " 'l2xavg_Fall_flxdst4': ['unknown', 1e36, 'Dust flux', []], \n", + " 'soil_type': ['unitless', 1e36, 'Soil type (unused)', [0]], \n", + " 'soil_tk_1d': ['W/m/K', 1e36, 'Soil thermal conductivity', []], \n", + " 'soil_cv_1d': ['J/m3/K', 1e36, 'Soil heat capacity', []], \n", + " 'glc_tk_1d': ['W/m/K', 1e36, 'Ice thermal conductivity', []], \n", + " 'glc_cv_1d': ['J/m3/K', 1e36, 'Ice heat capacity', []], \n", + " 'lsmlat': ['degrees north', False, 'Coordinate latitude', []],\n", + " 'lsmlon': ['degrees east', False, 'Coordinate longitude', []], \n", + " 'time': ['month', False, '', []]}\n", + "\n", + "for var, val in attr_map.items():\n", + " ds_slim[var].attrs['Units'] = val[0]\n", + " ds_slim[var].attrs['_FillValue'] = val[1]\n", + " ds_slim[var].attrs['long_name'] = val[2]\n", + " ds_slim[var].attrs['valid_range'] = val[3]" + ] + }, + { + "cell_type": "markdown", + "metadata": { + "tags": [] + }, + "source": [ + "## Write out the new dataset" + ] + }, + { + "cell_type": "code", + "execution_count": 15, + "metadata": {}, + "outputs": [], + "source": [ + "ds_slim.to_netcdf(path = 'surdat_' + tm.strftime(\"%Y%m%d\") + '.nc', format = 'NETCDF3_64BIT')" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "metadata": {}, + "outputs": [], + "source": [] + } + ], + "metadata": { + "kernelspec": { + "display_name": "Python [conda env:ctsm_pylib]", + "language": "python", + "name": "conda-env-ctsm_pylib-py" + }, + "language_info": { + "codemirror_mode": { + "name": "ipython", + "version": 3 + }, + "file_extension": ".py", + "mimetype": "text/x-python", + "name": "python", + "nbconvert_exporter": "python", + "pygments_lexer": "ipython3", + "version": "3.7.9" + } + }, + "nbformat": 4, + "nbformat_minor": 4 +} diff --git a/python/slim/modify_input_files/__init__.py b/python/slim/modify_input_files/__init__.py new file mode 100644 index 00000000..e69de29b diff --git a/python/slim/modify_input_files/modify_surdat.py b/python/slim/modify_input_files/modify_surdat.py new file mode 100644 index 00000000..97be7f31 --- /dev/null +++ b/python/slim/modify_input_files/modify_surdat.py @@ -0,0 +1,192 @@ +""" +Run this code by using the following wrapper script: +/tools/modify_input_files/surdat_modifier + +The wrapper script includes a full description and instructions. +""" + +import os +import logging +from configparser import ConfigParser + +from math import isclose +import numpy as np +import xarray as xr + +from slim.utils import abort +from slim.path_utils import path_to_slim_root +from slim.config_utils import lon_range_0_to_360, get_config_value + +logger = logging.getLogger(__name__) + + +class ModifySurdat: + """ + Description + ----------- + """ + + def __init__( + self, my_data, lon_1, lon_2, lat_1, lat_2, landmask_file, lat_dimname, lon_dimname + ): + + self.file = my_data + + self.rectangle = self._get_rectangle( + lon_1=lon_1, + lon_2=lon_2, + lat_1=lat_1, + lat_2=lat_2, + longxy=self.file.lsmlon, + latixy=self.file.lsmlat, + ) + + if landmask_file is not None: + # overwrite self.not_rectangle with data from + # user-specified .nc file in the .cfg file + landmask_ds = xr.open_dataset(landmask_file) + self.rectangle = landmask_ds.mod_lnd_props.data + # CF convention has dimension and coordinate variable names the same + if lat_dimname is None: # set to default + lat_dimname = "lsmlat" + if lon_dimname is None: # set to default + lon_dimname = "lsmlon" + lsmlat = landmask_ds.dims[lat_dimname] + lsmlon = landmask_ds.dims[lon_dimname] + + for row in range(lsmlat): # rows from landmask file + for col in range(lsmlon): # cols from landmask file + errmsg = ( + "landmask_ds.mod_lnd_props not 0 or 1 at " + + f"row, col, value = {row} {col} {self.rectangle[row, col]}" + ) + assert isclose(self.rectangle[row, col], 0, abs_tol=1e-9) or isclose( + self.rectangle[row, col], 1, abs_tol=1e-9 + ), errmsg + + self.not_rectangle = np.logical_not(self.rectangle) + self.months = int(max(self.file.time)) # number of months (typically 12) + + @classmethod + def init_from_file( + cls, surdat_in, lon_1, lon_2, lat_1, lat_2, landmask_file, lat_dimname, lon_dimname + ): + """Initialize a ModifySurdat object from file surdat_in""" + logger.info("Opening surdat_in file to be modified: %s", surdat_in) + my_file = xr.open_dataset(surdat_in) + return cls(my_file, lon_1, lon_2, lat_1, lat_2, landmask_file, lat_dimname, lon_dimname) + + @staticmethod + def _get_rectangle(lon_1, lon_2, lat_1, lat_2, longxy, latixy): + """ + Description + ----------- + """ + + # ensure that lon ranges 0-360 in case user entered -180 to 180 + lon_1 = lon_range_0_to_360(lon_1) + lon_2 = lon_range_0_to_360(lon_2) + + # determine the rectangle(s) + # TODO This is not really "nearest" for the edges but isel didn't work + rectangle_1 = longxy >= lon_1 + rectangle_2 = longxy <= lon_2 + eps = np.finfo(np.float32).eps # to avoid roundoff issue + rectangle_3 = latixy >= (lat_1 - eps) + rectangle_4 = latixy <= (lat_2 + eps) + + if lon_1 <= lon_2: + # rectangles overlap + union_1 = np.logical_and(rectangle_1, rectangle_2) + else: + # rectangles don't overlap: stradling the 0-degree meridian + union_1 = np.logical_or(rectangle_1, rectangle_2) + + if lat_1 < -90 or lat_1 > 90 or lat_2 < -90 or lat_2 > 90: + errmsg = "lat_1 and lat_2 need to be in the range -90 to 90" + abort(errmsg) + elif lat_1 <= lat_2: + # rectangles overlap + union_2 = np.logical_and(rectangle_3, rectangle_4) + else: + # rectangles don't overlap: one in the north, one in the south + union_2 = np.logical_or(rectangle_3, rectangle_4) + + # union rectangles overlap + rectangle = np.logical_and(union_1, union_2) + + return rectangle + + def set_monthly_values(self, var, val): + """ + Description + ----------- + If user has specified monthly values, use them. Else do nothing. + """ + if len(val) != self.months: + errmsg = ( + "Error: Variable should have exactly " + + str(self.months) + + " entries in the configure file: " + + var + ) + abort(errmsg) + for mon in self.file.time - 1: # loop over the months + # set 3D variable + self.setvar_lev1(var, val[int(mon)], lev1_dim=int(mon)) + + def setvar_lev1(self, var, val, lev1_dim): + """ + Sets 3d variable var to value val in user-defined rectangle, + defined as "other" in the function + + HINT for working with 2d or 4d variables instead: + See ctsm subdirectory /python/ctsm/modify_input_files, + file modify_fsurdat.py for templates of the corresponding functions + """ + self.file[var][lev1_dim, ...] = self.file[var][lev1_dim, ...].where( + self.not_rectangle, other=val + ) + + def set_defaults(self, vars_3d, allowed): + """ + Description + ----------- + Set default surdat values in a rectangle defined by lon/lat limits + """ + + # Overwrite in rectangle(s) + # ------------------------ + # If defaults, then user makes changes to variables as follows. + # Values in the user-defined rectangle are replaced. + # Values outside the rectangle are preserved. + # ------------------------ + + # Default values of 3d variables. For guidance in selecting values, see + # /glade/p/cesmdata/cseg/inputdata/lnd/slim/surdat/ + # globalconst_alpha0.2_soilcv2e6_hc0.1_rs100.0_glc_hc0.01_f19_cdf5_20211105.nc + # read the .cfg (config) file containing the defaults + config = ConfigParser() + cfg_path = os.path.join( + path_to_slim_root(), "tools/modify_input_files/modify_surdat_defaults.cfg" + ) + config.read(cfg_path) + section = config.sections()[0] # name of the first section + + # initialize entry + entry = [None, None, None, None, None, None, None, None, None, None, None, None] * len( + vars_3d + ) + for var, val in vars_3d.items(): + # obtain default values from the configure file + entry[val[1]] = get_config_value( + config=config, + section=section, + item=var, + file_path=cfg_path, + allowed_values=allowed, + is_list=True, + convert_to_type=val[0], + can_be_unset=True, + ) + self.set_monthly_values(var=var, val=entry[val[1]]) diff --git a/python/slim/modify_input_files/surdat_modifier.py b/python/slim/modify_input_files/surdat_modifier.py new file mode 100644 index 00000000..e94dd7d1 --- /dev/null +++ b/python/slim/modify_input_files/surdat_modifier.py @@ -0,0 +1,197 @@ +""" +Run this code by using the following wrapper script: +tools/modify_input_files/surdat_modifier + +The wrapper script includes a full description and instructions. +""" + +import os +import logging +import argparse +from configparser import ConfigParser + +from slim.utils import abort, write_output +from slim.config_utils import get_config_value +from slim.slim_logging import ( + setup_logging_pre_config, + add_logging_args, + process_logging_args, +) +from slim.modify_input_files.modify_surdat import ModifySurdat + +logger = logging.getLogger(__name__) + + +def main(): + """ + Description + ----------- + Calls function that modifies a surdat file (surface dataset) + """ + + # set up logging allowing user control + setup_logging_pre_config() + + # read the command line argument to obtain the path to the .cfg file + parser = argparse.ArgumentParser() + parser.add_argument("cfg_path", help="/path/name.cfg of input file, eg ./modify.cfg") + add_logging_args(parser) + args = parser.parse_args() + process_logging_args(args) + surdat_modifier(args.cfg_path) + + +def surdat_modifier(cfg_path): + """Implementation of surdat_modifier command""" + # read the .cfg (config) file + config = ConfigParser() + config.read(cfg_path) + section = config.sections()[0] # name of the first section + + # required: user must set these in the .cfg file + surdat_in = get_config_value( + config=config, section=section, item="surdat_in", file_path=cfg_path + ) + surdat_out = get_config_value( + config=config, section=section, item="surdat_out", file_path=cfg_path + ) + + # required but fallback values available for variables omitted + # entirely from the .cfg file + defaults = get_config_value( + config=config, + section=section, + item="defaults", + file_path=cfg_path, + convert_to_type=bool, + ) + lnd_lat_1 = get_config_value( + config=config, + section=section, + item="lnd_lat_1", + file_path=cfg_path, + convert_to_type=float, + ) + lnd_lat_2 = get_config_value( + config=config, + section=section, + item="lnd_lat_2", + file_path=cfg_path, + convert_to_type=float, + ) + lnd_lon_1 = get_config_value( + config=config, + section=section, + item="lnd_lon_1", + file_path=cfg_path, + convert_to_type=float, + ) + lnd_lon_2 = get_config_value( + config=config, + section=section, + item="lnd_lon_2", + file_path=cfg_path, + convert_to_type=float, + ) + + landmask_file = get_config_value( + config=config, + section=section, + item="landmask_file", + file_path=cfg_path, + can_be_unset=True, + ) + + lat_dimname = get_config_value( + config=config, section=section, item="lat_dimname", file_path=cfg_path, can_be_unset=True + ) + lon_dimname = get_config_value( + config=config, section=section, item="lon_dimname", file_path=cfg_path, can_be_unset=True + ) + + # Create ModifySurdat object + modify_surdat = ModifySurdat.init_from_file( + surdat_in, + lnd_lon_1, + lnd_lon_2, + lnd_lat_1, + lnd_lat_2, + landmask_file, + lat_dimname, + lon_dimname, + ) + + # If output file exists, abort before starting work + if os.path.exists(surdat_out): + errmsg = "Output file already exists: " + surdat_out + abort(errmsg) + + # dictionary of entries to loop over + # "variable name": [type, index] + # dimensions are time,lsmlat,lsmlon + vars_3d = { + "glc_mask": [int, 0], + "alb_gvd": [float, 1], + "alb_svd": [float, 2], + "alb_gnd": [float, 3], + "alb_snd": [float, 4], + "alb_gvf": [float, 5], + "alb_svf": [float, 6], + "alb_gnf": [float, 7], + "alb_snf": [float, 8], + "bucketdepth": [float, 9], + "emissivity": [float, 10], + "snowmask": [float, 11], + "roughness": [float, 12], + "evap_res": [float, 13], + "soil_type": [int, 14], + "soil_tk_1d": [float, 15], + "soil_cv_1d": [float, 16], + "glc_tk_1d": [float, 17], + "glc_cv_1d": [float, 18], + } + # initialize entry + entry = [None, None, None, None, None, None, None, None, None, None, None, None] * len(vars_3d) + # not required: user may set these in the .cfg file + for var, val in vars_3d.items(): + # obtain allowed from surdat_in variable's metadata + allowed = modify_surdat.file[var].attrs["valid_range"] + if not allowed.any(): # which means that allowed is "empty" + allowed = None + # obtain user-defined values from the configure file + entry[val[1]] = get_config_value( + config=config, + section=section, + item=var, + file_path=cfg_path, + allowed_values=allowed, + is_list=True, + convert_to_type=val[0], + can_be_unset=True, + ) + + # ------------------------------ + # modify surface data properties + # ------------------------------ + + # Set surdat variables in a rectangle that could be global (default). + # Note that the land/ocean mask gets specified in the domain file for + # MCT or the ocean mesh files for NUOPC. Here the user may specify + # surdat variables inside a box but cannot change which points will + # run as land and which as ocean. + if defaults: + modify_surdat.set_defaults(vars_3d, allowed) # set 3D variables + logger.info("defaults complete") + + # User-selected values will overwrite either + # - set_default's values if defaults = True or + # - the input surdat's values if defaults = False + + for var, val in vars_3d.items(): + if entry[val[1]] is not None: + modify_surdat.set_monthly_values(var=var, val=entry[val[1]]) + + # ---------------------------------------------- + # Output the now modified SLIM surface data file + # ---------------------------------------------- + write_output(modify_surdat.file, surdat_in, surdat_out, "surdat") diff --git a/python/slim/path_utils.py b/python/slim/path_utils.py index 724be4f4..289a3ff5 100644 --- a/python/slim/path_utils.py +++ b/python/slim/path_utils.py @@ -96,9 +96,8 @@ def add_cime_lib_to_path(standalone_only=False): path_to_cime """ cime_path = path_to_cime(standalone_only=standalone_only) - cime_lib_path = os.path.join(cime_path, "scripts", "lib") - prepend_to_python_path(cime_lib_path) - cime_lib_path = os.path.join(cime_path, "scripts", "Tools") + prepend_to_python_path(cime_path) + cime_lib_path = os.path.join(cime_path, "CIME", "Tools") prepend_to_python_path(cime_lib_path) return cime_path diff --git a/python/slim/test/test_sys_buildnml.py b/python/slim/test/test_sys_buildnml.py index 8d69e162..d0dd04d3 100755 --- a/python/slim/test/test_sys_buildnml.py +++ b/python/slim/test/test_sys_buildnml.py @@ -12,13 +12,13 @@ from pathlib import Path -from CIME.BuildTools.configure import FakeCase -from CIME.utils import expect - # pylint: disable=wrong-import-order,unused-import from slim import add_slim_cime_py_to_path from slim import unit_testing +from CIME.BuildTools.configure import configure, FakeCase +from CIME.utils import expect + from slim_cime_py.buildnml import buildnml logger = logging.getLogger(__name__) @@ -32,12 +32,13 @@ def getVariableFromNML(nmlfile, variable): """Get a variable from the namelist file""" with open(nmlfile, "r") as nfile: for line in nfile: - if variable in line: + match = re.search(r"\s*" + variable + r"\s*=", line) + if match is not None: print("lnd_in:" + line) - match = re.search('= ["]*([ a-zA-Z0-9._//-]+)["]*', line) + match = re.search(r'= ["]*([ a-zA-Z0-9._//-]+)["]*', line) if match is not None: return match.group(1) - match = re.search("= [']*([ a-zA-Z0-9._//-]+)[']*", line) + match = re.search(r"= [']*([ a-zA-Z0-9._//-]+)[']*", line) if match is not None: return match.group(1) return None @@ -70,8 +71,9 @@ def setUp(self): os.path.dirname(os.path.abspath(__file__)), os.pardir, os.pardir, os.pardir ) ) - self.case = FakeCase(compiler=None, mpilib=None, debug=None) + self.case = FakeCase(compiler=None, comp_interface="nuopc", mpilib=None, debug=None) self.case.set_value("CASEROOT", self._testdir) + self.case.set_value("COMPSET", "2000_DATM%GSWP3v1_SLIM_SICE_SOCN_SROF_SGLC_SWAV") self.case.set_value("RUN_TYPE", "any") self.case.set_value("RUN_STARTDATE", "2000-01-01") self.case.set_value("RUN_REFCASE", "case.std") @@ -255,7 +257,7 @@ def test_start_types(self): "Input data list file should exist after running buildnml", ) value = getVariableFromNML("lnd_in", "finidat") - self.assertEqual(value, finidat, msg="finidat not set as expected") + self.assertEqual(value, finidat, msg="finidat not set as expected: type=" + stype) stype = "required" finidat = "TESTFINIDATFILENAME.nc" Path(finidat).touch() diff --git a/python/slim/test/test_sys_surdat_modifier.py b/python/slim/test/test_sys_surdat_modifier.py new file mode 100755 index 00000000..4842e52b --- /dev/null +++ b/python/slim/test/test_sys_surdat_modifier.py @@ -0,0 +1,291 @@ +#!/usr/bin/env python3 + +"""System tests for surdat_modifier + +""" + +import os +import re + +import unittest +import tempfile +import shutil + +import numpy as np +import xarray as xr + +from slim.path_utils import path_to_slim_root +from slim.config_utils import lon_range_0_to_360 +from slim.utils import write_output +from slim import unit_testing +from slim.modify_input_files.surdat_modifier import surdat_modifier + +# Allow test names that pylint doesn't like; otherwise hard to make them +# readable +# pylint: disable=invalid-name + + +class TestSysSurdatModifier(unittest.TestCase): + """System tests for surdat_modifier""" + + def setUp(self): + """ + Obtain path to the existing modify_surdat_template.cfg file + Make /_tempdir for use by these tests + Obtain path and names for the files being created in /_tempdir: + - modify_surdat.cfg + - surdat_out.nc + - surdat_in.nc + Generate dummy surdat_in file and save + Come up with modifications to be introduced to surdat_in + """ + self._cfg_template_path = os.path.join( + path_to_slim_root(), "tools/modify_input_files/modify_surdat_template.cfg" + ) + self._tempdir = tempfile.mkdtemp() + self._cfg_file_path = os.path.join(self._tempdir, "modify_surdat.cfg") + self._surdat_out = os.path.join(self._tempdir, "surdat_out.nc") + self._surdat_in = os.path.join(self._tempdir, "surdat_in.nc") + months = 12 + + # ----------------------------------------------------------- + # create dummy SLIM surdat file + # ----------------------------------------------------------- + # get lon/lat that would normally come from a surdat file + # self._get_longxy_latixy will convert -180 to 180 to 0-360 longitudes + # get cols, rows also + self._lon_range = [2, 10] # expected in ascending order: [min, max] + self._lat_range = [3, 12] # expected in ascending order: [min, max] + longxy, latixy, cols, rows = self._get_longxy_latixy( + _min_lon=min(self._lon_range), + _max_lon=max(self._lon_range), + _min_lat=min(self._lat_range), + _max_lat=max(self._lat_range), + ) + lon_1d = longxy[0, :] + lat_1d = latixy[:, 0] + # create xarray dataset containing lev1 variables; + # the surdat_modify tool reads variables like this from a surdat file + var_1d = np.arange(cols) + ones_3d = np.ones((months, rows, cols)) + var_lev1 = var_1d * ones_3d + self._surdat_in_data = xr.Dataset( + data_vars=dict( + time=(["time"], np.arange(months) + 1), + lsmlon=(["lsmlon"], lon_1d), + lsmlat=(["lsmlat"], lat_1d), + glc_mask=(["time", "lsmlat", "lsmlon"], var_lev1), + alb_gvd=(["time", "lsmlat", "lsmlon"], var_lev1), + alb_svd=(["time", "lsmlat", "lsmlon"], var_lev1), + alb_gnd=(["time", "lsmlat", "lsmlon"], var_lev1), + alb_snd=(["time", "lsmlat", "lsmlon"], var_lev1), + alb_gvf=(["time", "lsmlat", "lsmlon"], var_lev1), + alb_svf=(["time", "lsmlat", "lsmlon"], var_lev1), + alb_gnf=(["time", "lsmlat", "lsmlon"], var_lev1), + alb_snf=(["time", "lsmlat", "lsmlon"], var_lev1), + bucketdepth=(["time", "lsmlat", "lsmlon"], var_lev1), + emissivity=(["time", "lsmlat", "lsmlon"], var_lev1), + snowmask=(["time", "lsmlat", "lsmlon"], var_lev1), + roughness=(["time", "lsmlat", "lsmlon"], var_lev1), + evap_res=(["time", "lsmlat", "lsmlon"], var_lev1), + l2xavg_Fall_flxdst1=(["time", "lsmlat", "lsmlon"], var_lev1), + l2xavg_Fall_flxdst2=(["time", "lsmlat", "lsmlon"], var_lev1), + l2xavg_Fall_flxdst3=(["time", "lsmlat", "lsmlon"], var_lev1), + l2xavg_Fall_flxdst4=(["time", "lsmlat", "lsmlon"], var_lev1), + soil_type=(["time", "lsmlat", "lsmlon"], var_lev1), + soil_tk_1d=(["time", "lsmlat", "lsmlon"], var_lev1), + soil_cv_1d=(["time", "lsmlat", "lsmlon"], var_lev1), + glc_tk_1d=(["time", "lsmlat", "lsmlon"], var_lev1), + glc_cv_1d=(["time", "lsmlat", "lsmlon"], var_lev1), + ) + ) + # Add attributes to all the variables + attr_map = { + "glc_mask": ["unitless", 1e36, "Glacier/ice sheet mask", [0, 1]], + "alb_gvd": ["unitless", 1e36, "Visible direct albedo for bare ground", []], + "alb_svd": ["unitless", 1e36, "Visible direct albedo for deep snow", []], + "alb_gnd": ["unitless", 1e36, "NIR direct albedo for bare ground", []], + "alb_snd": ["unitless", 1e36, "NIR direct albedo for deep snow", []], + "alb_gvf": ["unitless", 1e36, "Visible diffuse albedo for bare ground", []], + "alb_svf": ["unitless", 1e36, "Visible diffuse albedo for deep snow", []], + "alb_gnf": ["unitless", 1e36, "NIR diffuse albedo for bare ground", []], + "alb_snf": ["unitless", 1e36, "NIR diffuse albedo for deep snow", []], + "bucketdepth": ["kg/m2", 1e36, "Bucket capacity", []], + "emissivity": ["unitless", 1e36, "Surface emissivity for longwave radiation", []], + "snowmask": ["kg/m2", 1e36, "Snow-masking depth", []], + "roughness": ["m", 1e36, "Vegetation height", []], + "evap_res": ["s/m", 1e36, "Evaporative resistance", []], + "l2xavg_Fall_flxdst1": ["unknown", 1e36, "Dust flux", []], + "l2xavg_Fall_flxdst2": ["unknown", 1e36, "Dust flux", []], + "l2xavg_Fall_flxdst3": ["unknown", 1e36, "Dust flux", []], + "l2xavg_Fall_flxdst4": ["unknown", 1e36, "Dust flux", []], + "soil_type": ["unitless", 1e36, "Soil type (unused)", [0]], + "soil_tk_1d": ["W/m/K", 1e36, "Soil thermal conductivity", []], + "soil_cv_1d": ["J/m3/K", 1e36, "Soil heat capacity", []], + "glc_tk_1d": ["W/m/K", 1e36, "Ice thermal conductivity", []], + "glc_cv_1d": ["J/m3/K", 1e36, "Ice heat capacity", []], + "lsmlat": ["degrees north", False, "Coordinate latitude", []], + "lsmlon": ["degrees east", False, "Coordinate longitude", []], + "time": ["month", False, "", []], + } + for var, val in attr_map.items(): + self._surdat_in_data[var].attrs["Units"] = val[0] + self._surdat_in_data[var].attrs["_FillValue"] = val[1] + self._surdat_in_data[var].attrs["long_name"] = val[2] + self._surdat_in_data[var].attrs["valid_range"] = val[3] + + # save in tempdir; _in and _out files are the same file in this case + write_output(self._surdat_in_data, self._surdat_in, self._surdat_in, "surdat") + # come up with modifications to be introduced to surdat_in + self._modified_1 = ones_3d.astype(int) + self._modified_2 = 0 * self._modified_1 + self._modified_3 = 0.5 * self._modified_1 + self._modified_4 = 195 * self._modified_1 + + def tearDown(self): + """ + Remove temporary directory + """ + shutil.rmtree(self._tempdir, ignore_errors=True) + + def test_minimalInfo(self): + """ + This test specifies a minimal amount of information + Create .cfg file, run the tool, compare surdat_in to surdat_out + """ + + self._create_config_file_minimal() + + # run the surdat_modifier tool + surdat_modifier(self._cfg_file_path) + # the critical piece of this test is that the above command + # doesn't generate errors; however, we also do some assertions below + + surdat_out_data = xr.open_dataset(self._surdat_out) + # assert that surdat_out equals surdat_in + self.assertTrue(surdat_out_data.equals(self._surdat_in_data)) + + def test_allInfo(self): + """ + This version specifies all possible information + Create .cfg file, run the tool, compare surdat_in to surdat_out + Here also compare surdat_out to surdat_out_baseline + """ + + self._create_config_file_complete() + + # run the surdat_modifier tool + surdat_modifier(self._cfg_file_path) + # the critical piece of this test is that the above command + # doesn't generate errors; however, we also do some assertions below + + # compare surdat_out to surdat_in + surdat_out_data = xr.open_dataset(self._surdat_out) + # assert that surdat_out does not equal surdat_in + self.assertFalse(surdat_out_data.equals(self._surdat_in_data)) + + # ----------------------------------------------------------- + # compare surdat_out to surdat_out_baseline + # ----------------------------------------------------------- + # generate surdat_out_baseline by merging surdat_in into the + # modified dataset and compare to surdat_out + modified_1_through_4 = xr.Dataset( + data_vars=dict( + glc_mask=(["time", "lsmlat", "lsmlon"], self._modified_1), + alb_gvd=(["time", "lsmlat", "lsmlon"], self._modified_2), + alb_svd=(["time", "lsmlat", "lsmlon"], self._modified_3), + bucketdepth=(["time", "lsmlat", "lsmlon"], self._modified_4), + ) + ) + surdat_out_base_data = modified_1_through_4.merge(self._surdat_in_data, compat="override") + + # assert that surdat_out equals surdat_out_baseline + self.assertTrue(surdat_out_data.equals(surdat_out_base_data)) + + def _create_config_file_minimal(self): + """ + Open the new and the template .cfg files + Loop line by line through the template .cfg file + When string matches, replace that line's content + """ + with open(self._cfg_file_path, "w", encoding="utf-8") as cfg_out: + with open(self._cfg_template_path, "r", encoding="utf-8") as cfg_in: + for line in cfg_in: + if re.match(r" *surdat_in *=", line): + line = f"surdat_in = {self._surdat_in}" + elif re.match(r" *surdat_out *=", line): + line = f"surdat_out = {self._surdat_out}" + cfg_out.write(line) + + def _create_config_file_complete(self): + """ + Open the new and the template .cfg files + Loop line by line through the template .cfg file + When string matches, replace that line's content + """ + with open(self._cfg_file_path, "w", encoding="utf-8") as cfg_out: + with open(self._cfg_template_path, "r", encoding="utf-8") as cfg_in: + for line in cfg_in: + if re.match(r" *surdat_in *=", line): + line = f"surdat_in = {self._surdat_in}" + elif re.match(r" *surdat_out *=", line): + line = f"surdat_out = {self._surdat_out}" + elif re.match(r" *defaults *=", line): + line = "defaults = False" + elif re.match(r" *lnd_lat_1 *=", line): + line = "lnd_lat_1 = " + str(min(self._lat_range)) + "\n" + elif re.match(r" *lnd_lat_2 *=", line): + line = "lnd_lat_2 = " + str(max(self._lat_range)) + "\n" + elif re.match(r" *lnd_lon_1 *=", line): + line = "lnd_lon_1 = " + str(min(self._lon_range)) + "\n" + elif re.match(r" *lnd_lon_2 *=", line): + line = "lnd_lon_2 = " + str(max(self._lon_range)) + "\n" + elif re.match(r" *glc_mask *=", line): + # in .cfg file user enters list of monthly (i.e. 12) + # values without punctuation (e.g. brackets or commas) + line = "glc_mask = " + str(self._modified_1[:, 0, 0])[1:-1] + "\n" + elif re.match(r" *alb_gvd *=", line): + # in .cfg file user enters list of monthly (i.e. 12) + # values without punctuation (e.g. brackets or commas) + line = "alb_gvd = " + str(self._modified_2[:, 0, 0])[1:-1] + "\n" + elif re.match(r" *alb_svd *=", line): + # in .cfg file user enters list of monthly (i.e. 12) + # values without punctuation (e.g. brackets or commas) + line = "alb_svd = " + str(self._modified_3[:, 0, 0])[1:-1] + "\n" + elif re.match(r" *bucketdepth *=", line): + # in .cfg file user enters list of monthly (i.e. 12) + # values without punctuation (e.g. brackets or commas) + line = "bucketdepth = " + str(self._modified_4[:, 0, 0])[1:-1] + "\n" + cfg_out.write(line) + + def _get_longxy_latixy(self, _min_lon, _max_lon, _min_lat, _max_lat): + """ + Return longxy, latixy, cols, rows + Function copied from test_unit_modify_surdat.py + TODO Move to a separate file of test utilities? + """ + cols = _max_lon - _min_lon + 1 + rows = _max_lat - _min_lat + 1 + + long = np.arange(_min_lon, _max_lon + 1) + long = [lon_range_0_to_360(longitude) for longitude in long] + longxy = long * np.ones((rows, cols)) + compare = np.repeat([long], rows, axis=0) # alternative way to form + # assert this to confirm intuitive understanding of these matrices + np.testing.assert_array_equal(longxy, compare) + + lati = np.arange(_min_lat, _max_lat + 1) + self.assertEqual(min(lati), _min_lat) + self.assertEqual(max(lati), _max_lat) + latixy_transp = lati * np.ones((cols, rows)) + compare = np.repeat([lati], cols, axis=0) # alternative way to form + # assert this to confirm intuitive understanding of these matrices + np.testing.assert_array_equal(latixy_transp, compare) + latixy = np.transpose(latixy_transp) + + return longxy, latixy, cols, rows + + +if __name__ == "__main__": + unit_testing.setup_for_tests() + unittest.main() diff --git a/python/slim/test/test_unit_buildnml.py b/python/slim/test/test_unit_buildnml.py index fd013733..d60931e0 100755 --- a/python/slim/test/test_unit_buildnml.py +++ b/python/slim/test/test_unit_buildnml.py @@ -57,7 +57,7 @@ def setUp(self): setup_logging(logging.DEBUG) os.chdir(self._testdir) - self.case = FakeCase(compiler=None, mpilib=None, debug=None) + self.case = FakeCase(compiler=None, comp_interface="nuopc", mpilib=None, debug=None) self.case.set_value("RUNDIR", self._testdir) self.case.set_value("RUN_TYPE", "startup") self.case.set_value("RUN_STARTDATE", "2000-01-01") @@ -288,6 +288,15 @@ def test_check_init_data(self): ): check_nml_initial_conditions(self.nmlgen, self.case) + def test_check_set_user_defined(self): + """Test the check nml initial data subroutine for user_defined""" + self.case.set_value("SLIM_SCENARIO", "user_defined") + self.InitNML() + with self.assertRaisesRegex( + SystemExit, "When SLIM_SCENARIO is set to user_defined, you must provide the mml_surdat" + ): + check_nml_data(self.nmlgen, self.case) + def test_check_use_init_interp(self): """Test the check nml initial data subroutine for use_init_interp options""" self.case.set_value("SLIM_START_TYPE", "startup") diff --git a/python/slim/test/test_unit_modify_surdat.py b/python/slim/test/test_unit_modify_surdat.py new file mode 100755 index 00000000..76654054 --- /dev/null +++ b/python/slim/test/test_unit_modify_surdat.py @@ -0,0 +1,371 @@ +#!/usr/bin/env python3 + +""" +Unit tests for _get_rectangle +""" + +import unittest + +import numpy as np +import xarray as xr + +from slim import unit_testing +from slim.config_utils import lon_range_0_to_360 +from slim.modify_input_files.modify_surdat import ModifySurdat + +# Allow test names that pylint doesn't like; otherwise hard to make them +# readable +# pylint: disable=invalid-name + +# pylint: disable=protected-access + + +class TestModifySurdat(unittest.TestCase): + """Tests the setvar_lev functions and the _get_rectangle function""" + + def test_setvarLev1(self): + """ + Tests that setvar_lev1 updates values of + variables within a rectangle defined by user-specified + lon_1, lon_2, lat_1, lat_2 + """ + # get longxy, latixy that would normally come from a surdat file + # self._get_longxy_latixy will convert -180 to 180 to 0-360 longitudes + # get cols, rows also + min_lon = 2 # expects min_lon < max_lon + min_lat = 3 # expects min_lat < max_lat + longxy, latixy, cols, rows = self._get_longxy_latixy( + _min_lon=min_lon, _max_lon=10, _min_lat=min_lat, _max_lat=12 + ) + + # get not_rectangle from user-defined lon_1, lon_2, lat_1, lat_2 + lon_1 = 3 + lon_2 = 5 # lon_1 < lon_2 + lat_1 = 5 + lat_2 = 7 # lat_1 < lat_2 + + # create xarray dataset containing lev1 variables; + # the surdat_modify tool reads variables like this from surdat file + var_1d = np.arange(cols) + var_lev1 = var_1d * np.ones((cols, rows, cols)) + my_data = xr.Dataset( + data_vars=dict( + time=(["z"], np.arange(12)), # __init__ expects time + lsmlon=(["x", "y"], longxy), + lsmlat=(["x", "y"], latixy), # __init__ expects lsmlon, lsmlat + var_lev1=(["w", "x", "y"], var_lev1), + ) + ) + + # create ModifySurdat object + modify_surdat = ModifySurdat( + my_data=my_data, + lon_1=lon_1, + lon_2=lon_2, + lat_1=lat_1, + lat_2=lat_2, + landmask_file=None, + lat_dimname=None, + lon_dimname=None, + ) + + # initialize and then modify the comparison matrices + comp_lev1 = modify_surdat.file.var_lev1 + val_for_rectangle = 1.5 + comp_lev1[ + ..., + lat_1 - min_lat : lat_2 - min_lat + 1, + lon_1 - min_lon : lon_2 - min_lon + 1, + ] = val_for_rectangle + + # test setvar + modify_surdat.setvar_lev1("var_lev1", val_for_rectangle, cols - 1) + np.testing.assert_array_equal(modify_surdat.file.var_lev1, comp_lev1) + + def test_getNotRectangle_lon1leLon2Lat1leLat2(self): + """ + Tests that not_rectangle is True and False in the grid cells expected + according to the user-specified lon_1, lon_2, lat_1, lat_2 + When lon_1 <= lon_2 and lat_1 <= lat_2, expect not_rectangle to be + False in a rectangle bounded by these lon/lat values + Work with integer lon/lat values to keep the testing simple + """ + # get longxy, latixy that would normally come from a surdat file + # self._get_longxy_latixy will convert -180 to 180 to 0-360 longitudes + # get cols, rows also + min_lon = 2 # expects min_lon < max_lon + min_lat = 3 # expects min_lat < max_lat + longxy, latixy, cols, rows = self._get_longxy_latixy( + _min_lon=min_lon, _max_lon=7, _min_lat=min_lat, _max_lat=8 + ) + + # get not_rectangle from user-defined lon_1, lon_2, lat_1, lat_2 + lon_1 = 3 + lon_2 = 5 # lon_1 < lon_2 + lat_1 = 6 + lat_2 = 8 # lat_1 < lat_2 + rectangle = ModifySurdat._get_rectangle( + lon_1=lon_1, + lon_2=lon_2, + lat_1=lat_1, + lat_2=lat_2, + longxy=longxy, + latixy=latixy, + ) + not_rectangle = np.logical_not(rectangle) + compare = np.ones((rows, cols)) + # assert this to confirm intuitive understanding of these matrices + self.assertEqual(np.size(not_rectangle), np.size(compare)) + + # Hardwire where I expect not_rectangle to be False (0) + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple + compare[lat_1 - min_lat : lat_2 - min_lat + 1, lon_1 - min_lon : lon_2 - min_lon + 1] = 0 + np.testing.assert_array_equal(not_rectangle, compare) + + def test_getNotRectangle_lon1leLon2Lat1gtLat2(self): + """ + Tests that not_rectangle is True and False in the grid cells expected + according to the user-specified lon_1, lon_2, lat_1, lat_2 + When lon_1 <= lon_2 and lat_1 > lat_2, expect not_rectangle to be + False in two rectangles bounded by these lon/lat values, one to the + north of lat_1 and one to the south of lat_2 + Work with integer lon/lat values to keep the testing simple + """ + # get longxy, latixy that would normally come from an surdat file + # self._get_longxy_latixy will convert -180 to 180 to 0-360 longitudes + # get cols, rows also + min_lon = -3 # expects min_lon < max_lon + min_lat = -2 # expects min_lat < max_lat + longxy, latixy, cols, rows = self._get_longxy_latixy( + _min_lon=min_lon, _max_lon=6, _min_lat=min_lat, _max_lat=5 + ) + + # get not_rectangle from user-defined lon_1, lon_2, lat_1, lat_2 + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple (see usage below) + lon_1 = 0 + lon_2 = 4 # lon_1 < lon_2 + lat_1 = 4 + lat_2 = 0 # lat_1 > lat_2 + rectangle = ModifySurdat._get_rectangle( + lon_1=lon_1, + lon_2=lon_2, + lat_1=lat_1, + lat_2=lat_2, + longxy=longxy, + latixy=latixy, + ) + not_rectangle = np.logical_not(rectangle) + compare = np.ones((rows, cols)) + # assert this to confirm intuitive understanding of these matrices + self.assertEqual(np.size(not_rectangle), np.size(compare)) + + # Hardwire where I expect not_rectangle to be False (0) + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple + compare[: lat_2 - min_lat + 1, lon_1 - min_lon : lon_2 - min_lon + 1] = 0 + compare[lat_1 - min_lat :, lon_1 - min_lon : lon_2 - min_lon + 1] = 0 + np.testing.assert_array_equal(not_rectangle, compare) + + def test_getNotRectangle_lon1gtLon2Lat1leLat2(self): + """ + Tests that not_rectangle is True and False in the grid cells expected + according to the user-specified lon_1, lon_2, lat_1, lat_2 + When lon_1 > lon_2 and lat_1 <= lat_2, expect not_rectangle to be + False in two rectangles bounded by these lon/lat values, one to the + east of lat_1 and one to the west of lat_2 + Work with integer lon/lat values to keep the testing simple + """ + # get longxy, latixy that would normally come from an surdat file + # self._get_longxy_latixy will convert -180 to 180 to 0-360 longitudes + # get cols, rows also + min_lon = 1 # expects min_lon < max_lon + min_lat = 1 # expects min_lat < max_lat + longxy, latixy, cols, rows = self._get_longxy_latixy( + _min_lon=min_lon, _max_lon=359, _min_lat=min_lat, _max_lat=90 + ) + + # get not_rectangle from user-defined lon_1, lon_2, lat_1, lat_2 + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple (see usage below) + lon_1 = 4 + lon_2 = 2 # lon_1 > lon_2 + lat_1 = 2 + lat_2 = 3 # lat_1 < lat_2 + rectangle = ModifySurdat._get_rectangle( + lon_1=lon_1, + lon_2=lon_2, + lat_1=lat_1, + lat_2=lat_2, + longxy=longxy, + latixy=latixy, + ) + not_rectangle = np.logical_not(rectangle) + compare = np.ones((rows, cols)) + # assert this to confirm intuitive understanding of these matrices + self.assertEqual(np.size(not_rectangle), np.size(compare)) + + # Hardwire where I expect not_rectangle to be False (0) + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple + compare[lat_1 - min_lat : lat_2 - min_lat + 1, : lon_2 - min_lon + 1] = 0 + compare[lat_1 - min_lat : lat_2 - min_lat + 1, lon_1 - min_lon :] = 0 + np.testing.assert_array_equal(not_rectangle, compare) + + def test_getNotRectangle_lon1gtLon2Lat1gtLat2(self): + """ + Tests that not_rectangle is True and False in the grid cells expected + according to the user-specified lon_1, lon_2, lat_1, lat_2 + When lon_1 > lon_2 and lat_1 > lat_2, expect not_rectangle to be + False in four rectangles bounded by these lon/lat values, in the + top left, top right, bottom left, and bottom right of the domain + Work with integer lon/lat values to keep the testing simple + """ + # get longxy, latixy that would normally come from an surdat file + # self._get_longxy_latixy will convert -180 to 180 to 0-360 longitudes + # get cols, rows also + min_lon = -8 # expects min_lon < max_lon + min_lat = -9 # expects min_lat < max_lat + longxy, latixy, cols, rows = self._get_longxy_latixy( + _min_lon=min_lon, _max_lon=5, _min_lat=min_lat, _max_lat=6 + ) + + # get not_rectangle from user-defined lon_1, lon_2, lat_1, lat_2 + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple (see usage below) + lon_1 = -1 + lon_2 = -6 # lon_1 > lon_2 + lat_1 = 0 + lat_2 = -3 # lat_1 > lat_2 + rectangle = ModifySurdat._get_rectangle( + lon_1=lon_1, + lon_2=lon_2, + lat_1=lat_1, + lat_2=lat_2, + longxy=longxy, + latixy=latixy, + ) + not_rectangle = np.logical_not(rectangle) + compare = np.ones((rows, cols)) + # assert this to confirm intuitive understanding of these matrices + self.assertEqual(np.size(not_rectangle), np.size(compare)) + + # Hardwire where I expect not_rectangle to be False (0) + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple + compare[: lat_2 - min_lat + 1, : lon_2 - min_lon + 1] = 0 + compare[: lat_2 - min_lat + 1, lon_1 - min_lon :] = 0 + compare[lat_1 - min_lat :, : lon_2 - min_lon + 1] = 0 + compare[lat_1 - min_lat :, lon_1 - min_lon :] = 0 + np.testing.assert_array_equal(not_rectangle, compare) + + def test_getNotRectangle_lonsStraddle0deg(self): + """ + Tests that not_rectangle is True and False in the grid cells expected + according to the user-specified lon_1, lon_2, lat_1, lat_2 + When lon_1 > lon_2 and lat_1 > lat_2, expect not_rectangle to be + False in four rectangles bounded by these lon/lat values, in the + top left, top right, bottom left, and bottom right of the domain + Work with integer lon/lat values to keep the testing simple + """ + # get longxy, latixy that would normally come from an surdat file + # self._get_longxy_latixy will convert -180 to 180 to 0-360 longitudes + # get cols, rows also + min_lon = 0 # expects min_lon < max_lon + min_lat = -5 # expects min_lat < max_lat + longxy, latixy, cols, rows = self._get_longxy_latixy( + _min_lon=min_lon, _max_lon=359, _min_lat=min_lat, _max_lat=5 + ) + + # get not_rectangle from user-defined lon_1, lon_2, lat_1, lat_2 + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple (see usage below) + lon_1 = 355 + lon_2 = 5 # lon_1 > lon_2 + lat_1 = -4 + lat_2 = -6 # lat_1 > lat_2 + rectangle = ModifySurdat._get_rectangle( + lon_1=lon_1, + lon_2=lon_2, + lat_1=lat_1, + lat_2=lat_2, + longxy=longxy, + latixy=latixy, + ) + not_rectangle = np.logical_not(rectangle) + compare = np.ones((rows, cols)) + # assert this to confirm intuitive understanding of these matrices + self.assertEqual(np.size(not_rectangle), np.size(compare)) + + # Hardwire where I expect not_rectangle to be False (0) + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple + compare[: lat_2 - min_lat + 1, : lon_2 - min_lon + 1] = 0 + compare[: lat_2 - min_lat + 1, lon_1 - min_lon :] = 0 + compare[lat_1 - min_lat :, : lon_2 - min_lon + 1] = 0 + compare[lat_1 - min_lat :, lon_1 - min_lon :] = 0 + np.testing.assert_array_equal(not_rectangle, compare) + + def test_getNotRectangle_latsOutOfBounds(self): + """ + Tests that out-of-bound latitude values abort with message + Out-of-bound longitudes already tested in test_unit_utils.py + """ + # get longxy, latixy that would normally come from an surdat file + # self._get_longxy_latixy will convert -180 to 180 to 0-360 longitudes + # get cols, rows also + min_lon = 0 # expects min_lon < max_lon + min_lat = -5 # expects min_lat < max_lat + longxy, latixy, _, _ = self._get_longxy_latixy( + _min_lon=min_lon, _max_lon=359, _min_lat=min_lat, _max_lat=5 + ) + + # get not_rectangle from user-defined lon_1, lon_2, lat_1, lat_2 + # I have chosen the lon/lat ranges to match their corresponding index + # values to keep this simple (see usage below) + lon_1 = 355 + lon_2 = 5 + lat_1 = -91 + lat_2 = 91 + with self.assertRaisesRegex( + SystemExit, "lat_1 and lat_2 need to be in the range -90 to 90" + ): + _ = ModifySurdat._get_rectangle( + lon_1=lon_1, + lon_2=lon_2, + lat_1=lat_1, + lat_2=lat_2, + longxy=longxy, + latixy=latixy, + ) + + def _get_longxy_latixy(self, _min_lon, _max_lon, _min_lat, _max_lat): + """ + Return longxy, latixy, cols, rows + """ + cols = _max_lon - _min_lon + 1 + rows = _max_lat - _min_lat + 1 + + long = np.arange(_min_lon, _max_lon + 1) + long = [lon_range_0_to_360(longitude) for longitude in long] + longxy = long * np.ones((rows, cols)) + compare = np.repeat([long], rows, axis=0) # alternative way to form + # assert this to confirm intuitive understanding of these matrices + np.testing.assert_array_equal(longxy, compare) + + lati = np.arange(_min_lat, _max_lat + 1) + self.assertEqual(min(lati), _min_lat) + self.assertEqual(max(lati), _max_lat) + latixy_transp = lati * np.ones((cols, rows)) + compare = np.repeat([lati], cols, axis=0) # alternative way to form + # assert this to confirm intuitive understanding of these matrices + np.testing.assert_array_equal(latixy_transp, compare) + latixy = np.transpose(latixy_transp) + + return longxy, latixy, cols, rows + + +if __name__ == "__main__": + unit_testing.setup_for_tests() + unittest.main() diff --git a/python/slim/utils.py b/python/slim/utils.py index 964d2d6c..44fc4664 100644 --- a/python/slim/utils.py +++ b/python/slim/utils.py @@ -1,9 +1,15 @@ """General-purpose utility functions""" import logging +import os import sys import pdb +from datetime import date +from getpass import getuser + +from slim.git_utils import get_slim_git_short_hash + logger = logging.getLogger(__name__) @@ -16,3 +22,86 @@ def abort(errmsg): pdb.set_trace() sys.exit("ERROR: {}".format(errmsg)) + + +def update_metadata(file, title, summary, contact, data_script, description): + """ + Description + ----------- + Update netcdf file's metadata + Arguments + --------- + title: No more than short one-sentence explanation. + summary: No more than two-sentence explanation. + contact: E.g. CAM bulletin board at https://bb.cgd.ucar.edu + data_script: Script or instructions used to generate the dataset. + description: Anything else that's relevant. Capturing the command-line + would be good (sys.argv) here or in data_script. + """ + + # update attributes + today = date.today() + today_string = today.strftime("%Y-%m-%d") + + # This is the required metadata for inputdata files + file.attrs["title"] = title + file.attrs["summary"] = summary + file.attrs["creator"] = getuser() + file.attrs["contact"] = contact + file.attrs["creation_date"] = today_string + file.attrs["data_script"] = data_script + file.attrs["description"] = description + + # delete unrelated attributes if they exist + del_attrs = [ + "source_code", + "SVN_url", + "hostname", + "history", + "History_Log", + "Logname", + "Host", + "Version", + "Compiler_Optimized", + ] + attr_list = file.attrs + + for attr in del_attrs: + if attr in attr_list: + del file.attrs[attr] + + +def write_output(file, file_in, file_out, file_type): + """ + Description + ----------- + Write output file + Arguments + --------- + file_in: + (str) User-defined entry of input file + file_out: + (str) User-defined entry of output file + file_type: + (str) examples: mesh, surdat + """ + + # update attributes + title = "Modified " + file_type + " file" + summary = "Modified " + file_type + " file" + contact = "N/A" + data_script = os.path.abspath(__file__) + " -- " + get_slim_git_short_hash() + description = "Modified this file: " + file_in + update_metadata( + file, + title=title, + summary=summary, + contact=contact, + data_script=data_script, + description=description, + ) + + # mode 'w' overwrites file if it exists + file.to_netcdf(path=file_out, mode="w", format="NETCDF3_64BIT") + logger.info("Successfully created: %s", file_out) + file.close() diff --git a/src/biogeochem/CNBalanceCheckMod.F90 b/src/biogeochem/CNBalanceCheckMod.F90 deleted file mode 100644 index f2811d29..00000000 --- a/src/biogeochem/CNBalanceCheckMod.F90 +++ /dev/null @@ -1,358 +0,0 @@ -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 - 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 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) carbon mass, beginning of time step - real(r8), pointer :: endcb_col(:) ! (gC/m2) carbon mass, end of time step - real(r8), pointer :: begnb_col(:) ! (gN/m2) nitrogen mass, beginning of time step - real(r8), pointer :: endnb_col(:) ! (gN/m2) nitrogen mass, end of time step - contains - procedure , public :: Init - procedure , public :: BeginCNBalance - 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) - class(cn_balance_type) :: this - type(bounds_type) , intent(in) :: bounds - - call this%InitAllocate(bounds) - end subroutine Init - - !----------------------------------------------------------------------- - subroutine InitAllocate(this, bounds) - class(cn_balance_type) :: this - type(bounds_type) , intent(in) :: bounds - - integer :: begc, endc - - 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 BeginCNBalance(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 the CN state summaries have been computed 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) carbon mass, beginning of time step - col_begnb => this%begnb_col , & ! Output: [real(r8) (:)] (gN/m2) 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 BeginCNBalance - - !----------------------------------------------------------------------- - subroutine CBalanceCheck(this, bounds, num_soilc, filter_soilc, & - soilbiogeochem_carbonflux_inst, cnveg_carbonflux_inst, cnveg_carbonstate_inst) - ! - ! !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 - ! - ! !LOCAL VARIABLES: - integer :: c,err_index ! indices - integer :: fc ! lake filter indices - logical :: err_found ! error flag - real(r8) :: dt ! radiation time step (seconds) - real(r8) :: col_cinputs - real(r8) :: col_coutputs - real(r8) :: col_errcb(bounds%begc:bounds%endc) - !----------------------------------------------------------------------- - - associate( & - 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 - - 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 = real( get_step_size(), r8 ) - - 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) - - ! 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)) > 1e-7_r8) then - err_found = .true. - err_index = c - end if - if (abs(col_errcb(c)) > 1e-8_r8) then - write(iulog,*) 'cbalance warning',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,*)'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 - - end associate - - end subroutine CBalanceCheck - - !----------------------------------------------------------------------- - subroutine NBalanceCheck(this, bounds, num_soilc, filter_soilc, & - soilbiogeochem_nitrogenflux_inst, cnveg_nitrogenflux_inst, cnveg_nitrogenstate_inst) - ! - ! !DESCRIPTION: - ! Perform nitrogen mass conservation check - ! - ! !USES: - use clm_varctl, only : use_crop - ! - ! !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 - ! - ! !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) - real(r8):: col_ninputs(bounds%begc:bounds%endc) - real(r8):: col_noutputs(bounds%begc:bounds%endc) - real(r8):: col_errnb(bounds%begc:bounds%endc) - !----------------------------------------------------------------------- - - associate( & - col_begnb => this%begnb_col , & ! Input: [real(r8) (:) ] (gN/m2) nitrogen mass, beginning of time step - col_endnb => this%endnb_col , & ! Output: [real(r8) (:) ] (gN/m2) 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 = real( get_step_size(), 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 - - ! 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) - - ! calculate the total column-level nitrogen balance error for this time step - col_errnb(c) = (col_ninputs(c) - col_noutputs(c))*dt - & - (col_endnb(c) - col_begnb(c)) - - if (abs(col_errnb(c)) > 1e-3_r8) then - err_found = .true. - err_index = c - end if - - if (abs(col_errnb(c)) > 1e-7_r8) then - write(iulog,*) 'nbalance warning',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 - - end associate - - end subroutine NBalanceCheck - -end module CNBalanceCheckMod diff --git a/src/biogeochem/CNDVType.F90 b/src/biogeochem/CNDVType.F90 deleted file mode 100644 index daacd845..00000000 --- a/src/biogeochem/CNDVType.F90 +++ /dev/null @@ -1,519 +0,0 @@ -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 : numpft - use pftconMod , only : allom1s, allom2s, allom1, allom2, allom3, reinickerp - use pftconMod , only : ntree, 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:numpft)) - allocate(dgv_ecophyscon%tcmin (0:numpft)) - allocate(dgv_ecophyscon%tcmax (0:numpft)) - allocate(dgv_ecophyscon%gddmin (0:numpft)) - allocate(dgv_ecophyscon%twmax (0:numpft)) - allocate(dgv_ecophyscon%reinickerp (0:numpft)) - allocate(dgv_ecophyscon%allom1 (0:numpft)) - allocate(dgv_ecophyscon%allom2 (0:numpft)) - allocate(dgv_ecophyscon%allom3 (0:numpft)) - - do m = 0,numpft - 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 (m > ntree .and. m <= nbrdlf_dcd_brl_shrub ) 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, default='inactive') - - 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((ubound(t_a10_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(t_ref2m_patch) == (/endp/)), errMsg(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/src/biogeochem/CNDriverMod.F90 b/src/biogeochem/CNDriverMod.F90 deleted file mode 100644 index ea3abb5c..00000000 --- a/src/biogeochem/CNDriverMod.F90 +++ /dev/null @@ -1,37 +0,0 @@ -module CNDriverMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Ecosystem dynamics: phenology, vegetation - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use decompMod , only : bounds_type - use perf_mod , only : t_startf, t_stopf - ! - ! !PUBLIC TYPES: - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: CNDriverInit ! Ecosystem dynamics: initialization - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine CNDriverInit(bounds, NLFilename) - ! - ! !DESCRIPTION: - ! Initialzation of the CN Ecosystem dynamics. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - character(len=*) , intent(in) :: NLFilename ! Namelist filename - !----------------------------------------------------------------------- - - end subroutine CNDriverInit - -end module CNDriverMod diff --git a/src/biogeochem/CNGapMortalityMod.F90 b/src/biogeochem/CNGapMortalityMod.F90 deleted file mode 100644 index a2f8c4fd..00000000 --- a/src/biogeochem/CNGapMortalityMod.F90 +++ /dev/null @@ -1,493 +0,0 @@ -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 - use CNVegCarbonFluxType , only : cnveg_carbonflux_type - use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type - use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type - use CanopyStateType , only : canopystate_type - use ColumnType , only : col - use PatchType , only : patch - ! - 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, & - 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 - 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 - 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 - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(leaf_prof_patch) == (/bounds%endp,nlevdecomp_full/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(froot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(croot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(stem_prof_patch) == (/bounds%endp,nlevdecomp_full/)), errMsg(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 - ) - - ! 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 - 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 - if (spinup_state == 2 .and. .not. use_cndv) then !accelerate mortality of dead woody pools - cnveg_carbonflux_inst%m_deadstemc_to_litter_patch(p) = cnveg_carbonstate_inst%deadstemc_patch(p) * m * 10._r8 - cnveg_carbonflux_inst%m_deadcrootc_to_litter_patch(p) = cnveg_carbonstate_inst%deadcrootc_patch(p) * m * 10._r8 - else - cnveg_carbonflux_inst%m_deadstemc_to_litter_patch(p) = cnveg_carbonstate_inst%deadstemc_patch(p) * m - cnveg_carbonflux_inst%m_deadcrootc_to_litter_patch(p) = cnveg_carbonstate_inst%deadcrootc_patch(p) * m - end if - - ! storage pools - 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 - - !------------------------------------------------------ - ! patch-level gap mortality nitrogen fluxes - !------------------------------------------------------ - - ! displayed pools - 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 - - if (spinup_state == 2 .and. .not. use_cndv) then !accelerate mortality of dead woody pools - cnveg_nitrogenflux_inst%m_deadstemn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadstemn_patch(p) * m * 10._r8 - cnveg_nitrogenflux_inst%m_deadcrootn_to_litter_patch(p) = cnveg_nitrogenstate_inst%deadcrootn_patch(p) * m * 10._r8 - else - 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 - end if - - if (ivt(p) < npcropmin) then - cnveg_nitrogenflux_inst%m_retransn_to_litter_patch(p) = cnveg_nitrogenstate_inst%retransn_patch(p) * m - end if - - ! 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 - - ! 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 : maxpatch_pft, 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((ubound(leaf_prof_patch) == (/bounds%endp,nlevdecomp_full/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(froot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(croot_prof_patch) == (/bounds%endp,nlevdecomp_full/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(stem_prof_patch) == (/bounds%endp,nlevdecomp_full/)), errMsg(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,maxpatch_pft - 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/src/biogeochem/CNMRespMod.F90 b/src/biogeochem/CNMRespMod.F90 deleted file mode 100644 index 74ff1a9d..00000000 --- a/src/biogeochem/CNMRespMod.F90 +++ /dev/null @@ -1,237 +0,0 @@ -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 :: 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 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/src/biogeochem/CNNDynamicsMod.F90 b/src/biogeochem/CNNDynamicsMod.F90 deleted file mode 100644 index 0d367efe..00000000 --- a/src/biogeochem/CNNDynamicsMod.F90 +++ /dev/null @@ -1,375 +0,0 @@ -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 WaterStateType , only : waterstate_type - use WaterFluxType , only : waterflux_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 :: 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 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, & - waterflux_inst, soilbiogeochem_nitrogenflux_inst) - - - use clm_time_manager , only : get_days_per_year, get_step_size - 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(waterflux_type) , intent(inout) :: waterflux_inst - ! - ! !LOCAL VARIABLES: - integer :: c,fc !indices - real(r8) :: dayspyr !days per year - real(r8) :: secs_per_year !seconds per year - - associate( & - AnnET => waterflux_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, get_step_size - 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, & - waterstate_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(waterstate_type) , intent(in) :: waterstate_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 => waterstate_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/src/biogeochem/CNPhenologyMod.F90 b/src/biogeochem/CNPhenologyMod.F90 deleted file mode 100644 index b54cff51..00000000 --- a/src/biogeochem/CNPhenologyMod.F90 +++ /dev/null @@ -1,247 +0,0 @@ -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 : numpft, nlevdecomp_full - use clm_varctl , only : iulog, use_cndv - 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 WaterstateType , only : waterstate_type - use ColumnType , only : col - use GridcellType , only : grc - use PatchType , only : patch - use atm2lndType , only : atm2lnd_type - use atm2lndType , only : atm2lnd_type - ! - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: readParams ! Read parameters - public :: CNPhenologyInit ! Initialization - ! - ! !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) - 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) - - ! 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 - - real(r8), private :: initial_seed_at_planting = 3._r8 ! Initial seed at planting - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine readParams ( ncid ) - ! - ! !DESCRIPTION: - ! - ! !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 = 'CNPhenolParamsType' - 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='crit_dayl' - 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%crit_dayl=tempr - - 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 - - tString='fstor2tran' - 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%fstor2tran=tempr - - tString='crit_onset_fdd' - 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%crit_onset_fdd=tempr - - tString='crit_onset_swi' - 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%crit_onset_swi=tempr - - tString='soilpsi_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%soilpsi_on=tempr - - tString='crit_offset_fdd' - 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%crit_offset_fdd=tempr - - tString='crit_offset_swi' - 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%crit_offset_swi=tempr - - tString='soilpsi_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%soilpsi_off=tempr - - tString='lwtop_ann' - 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%lwtop=tempr - - end subroutine readParams - - !----------------------------------------------------------------------- - 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 - 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 = real( get_step_size(), r8 ) - 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 - - ! ----------------------------------------- - ! 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 - -end module CNPhenologyMod diff --git a/src/biogeochem/CNPrecisionControlMod.F90 b/src/biogeochem/CNPrecisionControlMod.F90 deleted file mode 100644 index 8c5660d1..00000000 --- a/src/biogeochem/CNPrecisionControlMod.F90 +++ /dev/null @@ -1,498 +0,0 @@ -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:: 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 = -6.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 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 clm_varpar , 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 - 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 - 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__, & - c13=c13cs%leafc_patch, c14=c14cs%leafc_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, & - c13=c13cs%leafc_storage_patch, c14=c14cs%leafc_storage_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, & - c13=c13cs%leafc_xfer_patch, c14=c14cs%leafc_xfer_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, & - c13=c13cs%frootc_patch, c14=c14cs%frootc_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:), allowneg=.true. ) - 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__, c13=c13cs%frootc_storage_patch, c14=c14cs%frootc_storage_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, & - c13=c13cs%frootc_xfer_patch, c14=c14cs%frootc_xfer_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - 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__, & - c13=c13cs%grainc_patch, c14=c14cs%grainc_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:), croponly=.true. ) - - ! 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__, c13=c13cs%grainc_storage_patch, c14=c14cs%grainc_storage_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:), croponly=.true. ) - - ! 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__, & - c13=c13cs%grainc_xfer_patch, c14=c14cs%grainc_xfer_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:), croponly=.true. ) - - ! 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__, & - c13=c13cs%cropseedc_deficit_patch, c14=c14cs%cropseedc_deficit_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:), allowneg=.true., croponly=.true. ) - - 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__, & - c13=c13cs%livestemc_patch, c14=c14cs%livestemc_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, c13=c13cs%livestemc_storage_patch, c14=c14cs%livestemc_storage_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, c13=c13cs%livestemc_xfer_patch, c14=c14cs%livestemc_xfer_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, & - c13=c13cs%deadstemc_patch, c14=c14cs%deadstemc_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - ! 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__, c13=c13cs%deadstemc_storage_patch, c14=c14cs%deadstemc_storage_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, c13=c13cs%deadstemc_xfer_patch, c14=c14cs%deadstemc_xfer_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, & - c13=c13cs%livecrootc_patch, c14=c14cs%livecrootc_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, c13=c13cs%livecrootc_storage_patch, c14=c14cs%livecrootc_storage_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, c13=c13cs%livecrootc_xfer_patch, c14=c14cs%livecrootc_xfer_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, & - c13=c13cs%deadcrootc_patch, c14=c14cs%deadcrootc_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, c13=c13cs%deadcrootc_storage_patch, c14=c14cs%deadcrootc_storage_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! 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__, c13=c13cs%deadcrootc_xfer_patch, c14=c14cs%deadcrootc_xfer_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! gresp_storage (C only) - call TruncateCStates( bounds, filter_soilp, num_soilp, cs%gresp_storage_patch(bounds%begp:bounds%endp), & - pc(bounds%begp:), __LINE__, & - c13=c13cs%gresp_storage_patch, c14=c14cs%gresp_storage_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! gresp_xfer(c only) - call TruncateCStates( bounds, filter_soilp, num_soilp, cs%gresp_xfer_patch(bounds%begp:bounds%endp), & - pc(bounds%begp:), __LINE__, & - c13=c13cs%gresp_xfer_patch, c14=c14cs%gresp_xfer_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - ! cpool (C only) - call TruncateCStates( bounds, filter_soilp, num_soilp, cs%cpool_patch(bounds%begp:bounds%endp), & - pc(bounds%begp:), __LINE__, & - c13=c13cs%cpool_patch, c14=c14cs%cpool_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:) ) - - 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__, & - c13=c13cs%xsmrpool_patch, c14=c14cs%xsmrpool_patch, & - pc13=pc13(bounds%begp:), pc14=pc14(bounds%begp:), allowneg=.true., croponly=.true. ) - - 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) - - end do - - end associate - - end subroutine CNPrecisionControl - - subroutine TruncateCandNStates( bounds, filter_soilp, num_soilp, carbon_patch, nitrogen_patch, pc, pn, lineno, c13, c14, & - pc13, pc14, 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_nguardrail - 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 - real(r8), intent(inout), optional, pointer :: c13(:) - real(r8), intent(inout), optional, pointer :: c14(:) - real(r8), intent(inout), optional :: pc13(bounds%begp:) - real(r8), intent(inout), optional :: pc14(bounds%begp:) - logical , intent(in) , optional :: croponly - logical , intent(in) , optional :: allowneg - - logical :: lcroponly, lallowneg - integer :: fp, p - - SHR_ASSERT_ALL((ubound(carbon_patch) == (/bounds%endp/)), 'ubnd(carb)'//errMsg(sourcefile, lineno)) - SHR_ASSERT_ALL((ubound(nitrogen_patch) == (/bounds%endp/)), 'ubnd(nitro)'//errMsg(sourcefile, lineno)) - SHR_ASSERT_ALL((ubound(pc) == (/bounds%endp/)), 'ubnd(pc)'//errMsg(sourcefile, lineno)) - SHR_ASSERT_ALL((ubound(pn) == (/bounds%endp/)), 'ubnd(pn)'//errMsg(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 - 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 ( abs(carbon_patch(p)) < ccrit .or. (use_nguardrail .and. abs(nitrogen_patch(p)) < ncrit) ) then - 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 do - end subroutine TruncateCandNStates - - subroutine TruncateCStates( bounds, filter_soilp, num_soilp, carbon_patch, pc, lineno, c13, c14, pc13, pc14, 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 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 - real(r8) , intent(inout), optional, pointer :: c13(:) - real(r8) , intent(inout), optional, pointer :: c14(:) - real(r8) , intent(inout), optional :: pc13(bounds%begp:) - real(r8) , intent(inout), optional :: pc14(bounds%begp:) - logical , intent(in) , optional :: croponly - logical , intent(in) , optional :: allowneg - - logical :: lcroponly, lallowneg - integer :: fp, p - - SHR_ASSERT_ALL((ubound(carbon_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(pc) == (/bounds%endp/)), errMsg(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 - 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 - 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((ubound(nitrogen_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(pn) == (/bounds%endp/)), errMsg(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 - -end module CNPrecisionControlMod diff --git a/src/biogeochem/CNProductsMod.F90 b/src/biogeochem/CNProductsMod.F90 deleted file mode 100644 index d71d7b15..00000000 --- a/src/biogeochem/CNProductsMod.F90 +++ /dev/null @@ -1,741 +0,0 @@ -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 - 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 - - ! ------------------------------------------------------------------------ - ! Private instance variables - ! ------------------------------------------------------------------------ - - class(species_base_type), allocatable :: species ! C, N, C13, C14, etc. - - ! States - real(r8), pointer :: cropprod1_grc(:) ! (g[C or N]/m2) grain product pool, 1-year lifespan - 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 - real(r8), pointer :: tot_woodprod_grc(:) ! (g[C or N]/m2) total wood product pool - - ! 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 grain 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=*), parameter :: subname = 'InitHistory' - !----------------------------------------------------------------------- - - begg = bounds%begg - endg = bounds%endg - - 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 grain product ' // this%species%get_species(), & - ptr_gcell = this%cropprod1_grc, default='inactive') - - 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='inactive') - - 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='inactive') - - 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='inactive') - - 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 grain product pool', & - ptr_gcell = this%cropprod1_loss_grc, default='inactive') - - 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='inactive') - - 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 - - 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((ubound(dwt_wood_product_gain_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(wood_harvest_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(dwt_crop_product_gain_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(grain_to_cropprod_patch) == (/bounds%endp/)), errMsg(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 = real( get_step_size(), r8 ) - - ! update product state variables - do g = bounds%begg, bounds%endg - - ! fluxes into wood & grain 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 & grain 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 & grain 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/src/biogeochem/CNSharedParamsMod.F90 b/src/biogeochem/CNSharedParamsMod.F90 deleted file mode 100644 index 6d373000..00000000 --- a/src/biogeochem/CNSharedParamsMod.F90 +++ /dev/null @@ -1,191 +0,0 @@ -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 :: anoxia_wtsat = .false. - 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 - write(iulog,*) 'Could not find ' // namelist_group // ' namelist' - 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/src/biogeochem/CNSpeciesMod.F90 b/src/biogeochem/CNSpeciesMod.F90 deleted file mode 100644 index fc89f3ac..00000000 --- a/src/biogeochem/CNSpeciesMod.F90 +++ /dev/null @@ -1,68 +0,0 @@ -module CNSpeciesMod - - !----------------------------------------------------------------------- - ! Module holding information about different species available in the CN code (C, C13, - ! C14, N). - ! - ! - ! NOTE(wjs, 2016-06-05) Eventually I could imagine having a cn_species base class, with - ! derived classes for each species type - so a cn_species_c class, a cn_species_c13 - ! class, a cn_species_c14 class and a cn_species_n class. These would contain methods - ! to handle calculations specific to each species type. For example, there could be a - ! carbon_multiplier method that returns the species-specific multiplier that you would - ! apply to a variable in units of gC/m2 to give you g[this species]/m2 (this would - ! depend on pft type). - ! - ! Basically, anywhere where there is code that has a conditional based on the constants - ! defined here, we could replace that with polymorphism using a cn_species class. - ! - ! Eventually I think it would make sense to make this contain an instance of - ! species_base_type (i.e., the class used to determine history & restart field names), - ! with forwarding methods. So then (e.g.) a cn_products_type object would just contain a - ! cn_species object (which in turn would contain a species_metadata [or whatever we call - ! it] object). - - implicit none - private - - integer, parameter, public :: CN_SPECIES_C12 = 1 - integer, parameter, public :: CN_SPECIES_C13 = 2 - integer, parameter, public :: CN_SPECIES_C14 = 3 - integer, parameter, public :: CN_SPECIES_N = 4 - - public :: species_from_string ! convert a string representation to one of the constants defined here - -contains - - !----------------------------------------------------------------------- - function species_from_string(species_string) result(species) - ! - ! !DESCRIPTION: - ! Convert a string representation to one of the constants defined here - ! - ! !USES: - ! - ! !ARGUMENTS: - integer :: species ! function result - character(len=*), intent(in) :: species_string ! string representation of species (should be lowercase) - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'species_from_string' - !----------------------------------------------------------------------- - - select case (species_string) - case ('c12') - species = CN_SPECIES_C12 - case ('c13') - species = CN_SPECIES_C13 - case ('c14') - species = CN_SPECIES_C14 - case ('n') - species = CN_SPECIES_N - end select - - end function species_from_string - - -end module CNSpeciesMod diff --git a/src/biogeochem/CNVegCarbonFluxType.F90 b/src/biogeochem/CNVegCarbonFluxType.F90 deleted file mode 100644 index 3fa76b3a..00000000 --- a/src/biogeochem/CNVegCarbonFluxType.F90 +++ /dev/null @@ -1,3891 +0,0 @@ -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 - use clm_varpar , only : nlevdecomp_full, nlevgrnd, nlevdecomp - use clm_varcon , only : spval, dzsoi_decomp - use clm_varctl , only : use_cndv, use_nitrif_denitrif, use_crop - 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 abortutils , only : endrun - ! - ! !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 :: 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 :: 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_col (:) ! (gC/m2/s) conversion slash flux due to landcover change - 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) - - contains - - procedure , public :: Init - 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 - - end type cnveg_carbonflux_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, bounds, carbon_type) - - class(cnveg_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, carbon_type) - call this%InitHistory ( bounds, carbon_type ) - call this%InitCold (bounds ) - - end subroutine Init - - !------------------------------------------------------------------------ - 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 - 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 (:) = nan - 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%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 (:) = nan - 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_col (begc:endc)) ; this%dwt_slash_cflux_col (:) =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 (:) = nan - 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 - - ! 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 - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - ! 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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_col(begc:endc) = spval - call hist_addfld1d (fname='DWT_SLASH_CFLUX', units='gC/m^2/s', & - avgflag='A', long_name='slash C flux to litter and CWD due to land use', & - ptr_col=this%dwt_slash_cflux_col, 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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_col(begc:endc) = spval - call hist_addfld1d (fname='C13_DWT_SLASH_CFLUX', units='gC/m^2/s', & - avgflag='A', long_name='C13 slash C flux to litter and CWD due to land use', & - ptr_col=this%dwt_slash_cflux_col, 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') - - 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_col(begc:endc) = spval - call hist_addfld1d (fname='C14_DWT_SLASH_CFLUX', units='gC/m^2/s', & - avgflag='A', long_name='C14 slash C flux to litter and CWD due to land use', & - ptr_col=this%dwt_slash_cflux_col, 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') - - 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 - - if (lun%ifspecial(l)) then - this%availc_patch(p) = spval - 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 - end if - if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then - this%availc_patch(p) = 0._r8 - 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 - this%dwt_slash_cflux_col(c) = 0._r8 - 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 (& - 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 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) - 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' - !----------------------------------------------------------------------- - - end subroutine RestartAllIsotopes - - !----------------------------------------------------------------------- - subroutine SetValues ( this, & - 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 - 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 - end do - - 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%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 - this%fire_closs_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 - - end do - - end subroutine SetValues - -end module CNVegCarbonFluxType - - diff --git a/src/biogeochem/CNVegCarbonStateType.F90 b/src/biogeochem/CNVegCarbonStateType.F90 deleted file mode 100644 index a9402f8f..00000000 --- a/src/biogeochem/CNVegCarbonStateType.F90 +++ /dev/null @@ -1,2346 +0,0 @@ -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 - use clm_varcon , only : spval, c3_r2, c4_r2, c14ratio - use clm_varctl , only : iulog, use_cndv, use_crop - 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 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 - - ! 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 - - contains - - procedure , public :: Init - procedure , public :: SetValues - procedure , public :: Restart - - 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 - - ! !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, & - 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 - 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) - - 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 - write(iulog,*) "Could NOT find "//nmlname//"namelist" - 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 - 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 - 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 - 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 - 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 - 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 - 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%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 - allocate(this%woodc_patch (begp:endp)) ; this%woodc_patch (:) = nan - - 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 - - end subroutine InitAllocate - - !------------------------------------------------------------------------ - subroutine InitHistory(this, bounds, carbon_type) - ! - ! !DESCRIPTION: - ! add history fields for all CN variables, always set as default='inactive' - ! - ! !USES: - 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, default='inactive') - 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, 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, default='inactive') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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') - - 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') - - 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') - - 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') - - 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') - - 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') - - 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, default='inactive') - - 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, default='inactive') - - 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') - 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') - - 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') - - 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') - - 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') - - 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') - - 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') - - 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, default='inactive') - - 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, default='inactive') - - 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') - 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, default='inactive': - use landunit_varcon , only : istsoil, istcrop - use clm_time_manager , only : is_restart, get_nstep - use clm_varctl, only : MM_Nuptake_opt - ! - ! !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 - 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 - 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 - 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 - 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 - end if - end if - this%leafc_xfer_patch(p) = 0._r8 - 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 - end if - this%frootc_xfer_patch(p) = 0._r8 - - this%livestemc_patch(p) = 0._r8 - this%livestemc_storage_patch(p) = 0._r8 - this%livestemc_xfer_patch(p) = 0._r8 - - if (pftcon%woody(patch%itype(p)) == 1._r8) then - this%deadstemc_patch(p) = 0.1_r8 * ratio - else - this%deadstemc_patch(p) = 0._r8 - end if - this%deadstemc_storage_patch(p) = 0._r8 - this%deadstemc_xfer_patch(p) = 0._r8 - - this%livecrootc_patch(p) = 0._r8 - this%livecrootc_storage_patch(p) = 0._r8 - this%livecrootc_xfer_patch(p) = 0._r8 - - this%deadcrootc_patch(p) = 0._r8 - this%deadcrootc_storage_patch(p) = 0._r8 - this%deadcrootc_xfer_patch(p) = 0._r8 - - 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 - - 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 - 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 - end do - - if ( .not. is_restart() .and. get_nstep() == 1 ) then - - do p = bounds%begp,bounds%endp - if (pftcon%c3psn(patch%itype(p)) == 1._r8) then - this%grainc_patch(p) = c12_cnveg_carbonstate_inst%grainc_patch(p) * c3_r2 - this%grainc_storage_patch(p) = c12_cnveg_carbonstate_inst%grainc_storage_patch(p) * c3_r2 - this%grainc_xfer_patch(p) = c12_cnveg_carbonstate_inst%grainc_xfer_patch(p) * c3_r2 - this%dispvegc_patch(p) = c12_cnveg_carbonstate_inst%dispvegc_patch(p) * c3_r2 - this%storvegc_patch(p) = c12_cnveg_carbonstate_inst%storvegc_patch(p) * c3_r2 - this%totvegc_patch(p) = c12_cnveg_carbonstate_inst%totvegc_patch(p) * c3_r2 - this%totc_patch(p) = c12_cnveg_carbonstate_inst%totc_patch(p) * c3_r2 - this%woodc_patch(p) = c12_cnveg_carbonstate_inst%woodc_patch(p) * c3_r2 - else - this%grainc_patch(p) = c12_cnveg_carbonstate_inst%grainc_patch(p) * c4_r2 - this%grainc_storage_patch(p) = c12_cnveg_carbonstate_inst%grainc_storage_patch(p) * c4_r2 - this%grainc_xfer_patch(p) = c12_cnveg_carbonstate_inst%grainc_xfer_patch(p) * c4_r2 - this%dispvegc_patch(p) = c12_cnveg_carbonstate_inst%dispvegc_patch(p) * c4_r2 - this%storvegc_patch(p) = c12_cnveg_carbonstate_inst%storvegc_patch(p) * c4_r2 - this%totvegc_patch(p) = c12_cnveg_carbonstate_inst%totvegc_patch(p) * c4_r2 - this%totc_patch(p) = c12_cnveg_carbonstate_inst%totc_patch(p) * c4_r2 - this%woodc_patch(p) = c12_cnveg_carbonstate_inst%woodc_patch(p) * c4_r2 - end if - end do - end if - - ! 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) - ! - ! !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 clm_time_manager , only : get_nstep, is_restart, get_nstep - 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 - ! - ! !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 - - !------------------------------------------------------------------------ - - 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) - - 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) - - 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) - - 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) - - 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) - - 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) - - 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) - - 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 10 for exit spinup' - do i = bounds%begp,bounds%endp - this%deadstemc_patch(i) = this%deadstemc_patch(i) * 10._r8 - this%deadcrootc_patch(i) = this%deadcrootc_patch(i) * 10._r8 - 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 10 for enter spinup ' - do i = bounds%begp,bounds%endp - this%deadstemc_patch(i) = this%deadstemc_patch(i) / 10._r8 - this%deadcrootc_patch(i) = this%deadcrootc_patch(i) / 10._r8 - 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 (indicated by totvegc = 0) 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. 0.0_r8) then - !----------------------------------------------- - ! initialize patch-level carbon state variables - !----------------------------------------------- - - this%leafcmax_patch(i) = 0._r8 - - l = patch%landunit(i) - if (lun%itype(l) == istsoil )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 - 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 - 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 - end if - end if - this%leafc_xfer_patch(i) = 0._r8 - 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 - 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 (pftcon%woody(patch%itype(i)) == 1._r8) then - this%deadstemc_patch(i) = 0.1_r8 * ratio - else - this%deadstemc_patch(i) = 0._r8 - end if - this%deadstemc_storage_patch(i) = 0._r8 - this%deadstemc_xfer_patch(i) = 0._r8 - - 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 - - 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 - this%cropseedc_deficit_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 ( .not. is_restart() .and. get_nstep() == 1 ) then - - do p = bounds%begp,bounds%endp - if (this%leafc_patch(p) .lt. 0.01_r8) then - if (pftcon%c3psn(patch%itype(p)) == 1._r8) then - this%grainc_patch(p) = c12_cnveg_carbonstate_inst%grainc_patch(p) * c3_r2 - this%grainc_storage_patch(p) = c12_cnveg_carbonstate_inst%grainc_storage_patch(p) * c3_r2 - this%grainc_xfer_patch(p) = c12_cnveg_carbonstate_inst%grainc_xfer_patch(p) * c3_r2 - this%dispvegc_patch(p) = c12_cnveg_carbonstate_inst%dispvegc_patch(p) * c3_r2 - this%storvegc_patch(p) = c12_cnveg_carbonstate_inst%storvegc_patch(p) * c3_r2 - this%totvegc_patch(p) = c12_cnveg_carbonstate_inst%totvegc_patch(p) * c3_r2 - this%totc_patch(p) = c12_cnveg_carbonstate_inst%totc_patch(p) * c3_r2 - this%woodc_patch(p) = c12_cnveg_carbonstate_inst%woodc_patch(p) * c3_r2 - else - this%grainc_patch(p) = c12_cnveg_carbonstate_inst%grainc_patch(p) * c4_r2 - this%grainc_storage_patch(p) = c12_cnveg_carbonstate_inst%grainc_storage_patch(p) * c4_r2 - this%grainc_xfer_patch(p) = c12_cnveg_carbonstate_inst%grainc_xfer_patch(p) * c4_r2 - this%dispvegc_patch(p) = c12_cnveg_carbonstate_inst%dispvegc_patch(p) * c4_r2 - this%storvegc_patch(p) = c12_cnveg_carbonstate_inst%storvegc_patch(p) * c4_r2 - this%totvegc_patch(p) = c12_cnveg_carbonstate_inst%totvegc_patch(p) * c4_r2 - this%totc_patch(p) = c12_cnveg_carbonstate_inst%totc_patch(p) * c4_r2 - this%woodc_patch(p) = c12_cnveg_carbonstate_inst%woodc_patch(p) * c4_r2 - end if - end if - end do - end if - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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='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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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='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 - - 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 - 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 - this%cropseedc_deficit_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 - -end module CNVegCarbonStateType diff --git a/src/biogeochem/CNVegComputeSeedMod.F90 b/src/biogeochem/CNVegComputeSeedMod.F90 deleted file mode 100644 index 01cf471e..00000000 --- a/src/biogeochem/CNVegComputeSeedMod.F90 +++ /dev/null @@ -1,259 +0,0 @@ -module CNVegComputeSeedMod - - !----------------------------------------------------------------------- - ! Module to compute seed amounts for new patch areas - ! - ! !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 pftconMod , only : pftcon, noveg - use clm_varcon , only : c3_r2, c4_r2, c14ratio - use clm_varctl , only : iulog - use PatchType , only : patch - use abortutils , only : endrun - use CNSpeciesMod , only : CN_SPECIES_C12, CN_SPECIES_C13, CN_SPECIES_C14, CN_SPECIES_N - ! - ! !PUBLIC ROUTINES: - implicit none - private - - public :: ComputeSeedAmounts - - ! !PRIVATE ROUTINES: - - private :: SpeciesTypeMultiplier - private :: LeafProportions ! compute leaf proportions (leaf, storage and xfer) - - ! !PRIVATE DATA: - - integer, parameter :: COMPONENT_LEAF = 1 - integer, parameter :: COMPONENT_DEADWOOD = 2 - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - !----------------------------------------------------------------------- - subroutine ComputeSeedAmounts(bounds, & - num_soilp_with_inactive, filter_soilp_with_inactive, & - species, & - leafc_seed, deadstemc_seed, & - leaf_patch, leaf_storage_patch, leaf_xfer_patch, & - compute_here_patch, ignore_current_state_patch, & - seed_leaf_patch, seed_leaf_storage_patch, seed_leaf_xfer_patch, & - seed_deadstem_patch) - ! - ! !DESCRIPTION: - ! Compute seed amounts for patches that increase in area, for various variables, for - ! the given species (c12, c13, c14 or n). - ! - ! The output variables are only set for patches inside the filter, where - ! compute_here_patch is true; for other patches, they remain at their original values. - ! - ! Note that, regardless of the species, leafc_seed and deadstemc_seed are specified - ! in terms of gC/m2; these amounts are converted to the amount of the given species - ! here. - ! - ! !USES: - ! - ! !ARGUMENTS: - 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 - integer , intent(in) :: species ! which C/N species we're operating on; should be one of the values in CNSpeciesMod - 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(in) :: leaf_patch( bounds%begp: ) ! current leaf C or N content (g/m2) - real(r8) , intent(in) :: leaf_storage_patch( bounds%begp: ) ! current leaf C or N storage content (g/m2) - real(r8) , intent(in) :: leaf_xfer_patch( bounds%begp: ) ! current leaf C or N xfer content (g/m2) - - ! whether to compute outputs for each patch - logical, intent(in) :: compute_here_patch( bounds%begp: ) - - ! If ignore_current_state is true, then use default leaf proportions rather than - ! proportions based on current state. - logical, intent(in) :: ignore_current_state_patch( bounds%begp: ) - - real(r8), intent(inout) :: seed_leaf_patch( bounds%begp: ) ! seed amount for leaf itself for this species (g/m2) - real(r8), intent(inout) :: seed_leaf_storage_patch( bounds%begp: ) ! seed amount for leaf storage for this species (g/m2) - real(r8), intent(inout) :: seed_leaf_xfer_patch( bounds%begp: ) ! seed amount for leaf xfer for this species (g/m2) - real(r8), intent(inout) :: seed_deadstem_patch( bounds%begp: ) ! seed amount for deadstem for this species (g/m2) - ! - ! !LOCAL VARIABLES: - integer :: fp, p - integer :: begp, endp - real(r8) :: my_leaf_seed - real(r8) :: my_deadstem_seed - integer :: pft_type - real(r8) :: pleaf - real(r8) :: pstor - real(r8) :: pxfer - - character(len=*), parameter :: subname = 'ComputeSeedAmounts' - !----------------------------------------------------------------------- - - begp = bounds%begp - endp = bounds%endp - - SHR_ASSERT_ALL((ubound(leaf_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(leaf_storage_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(leaf_xfer_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(compute_here_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(ignore_current_state_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(seed_leaf_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(seed_leaf_storage_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(seed_leaf_xfer_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(seed_deadstem_patch) == (/endp/)), errMsg(sourcefile, __LINE__)) - - - do fp = 1, num_soilp_with_inactive - p = filter_soilp_with_inactive(fp) - - if (compute_here_patch(p)) then - - my_leaf_seed = 0._r8 - my_deadstem_seed = 0._r8 - - pft_type = patch%itype(p) - - call LeafProportions( & - ignore_current_state = ignore_current_state_patch(p), & - pft_type = pft_type, & - leaf = leaf_patch(p), & - leaf_storage = leaf_storage_patch(p), & - leaf_xfer = leaf_xfer_patch(p), & - pleaf = pleaf, & - pstorage = pstor, & - pxfer = pxfer) - - if (pft_type /= noveg) then - my_leaf_seed = leafc_seed * & - SpeciesTypeMultiplier(species, pft_type, COMPONENT_LEAF) - if (pftcon%woody(pft_type) == 1._r8) then - my_deadstem_seed = deadstemc_seed * & - SpeciesTypeMultiplier(species, pft_type, COMPONENT_DEADWOOD) - end if - end if - - seed_leaf_patch(p) = my_leaf_seed * pleaf - seed_leaf_storage_patch(p) = my_leaf_seed * pstor - seed_leaf_xfer_patch(p) = my_leaf_seed * pxfer - seed_deadstem_patch(p) = my_deadstem_seed - end if - - end do - - end subroutine ComputeSeedAmounts - - - !----------------------------------------------------------------------- - function SpeciesTypeMultiplier(species, pft_type, component) result(multiplier) - ! - ! !DESCRIPTION: - ! Returns a multiplier based on the species type. This multiplier is - ! meant to be applied to some state variable expressed in terms of g C, translating - ! this value into an appropriate value for c13, c14 or n. - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8) :: multiplier ! function result - integer, intent(in) :: species ! which C/N species we're operating on; should be one of the values in CNSpeciesMod - integer, intent(in) :: pft_type - integer, intent(in) :: component ! which plant component; should be one of the COMPONENT_* parameters defined in this module - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'SpeciesTypeMultiplier' - !----------------------------------------------------------------------- - - select case (species) - case (CN_SPECIES_C12) - multiplier = 1._r8 - - case (CN_SPECIES_C13) - if (pftcon%c3psn(pft_type) == 1._r8) then - multiplier = c3_r2 - else - multiplier = c4_r2 - end if - - case (CN_SPECIES_C14) - ! 14c state is initialized assuming initial "modern" 14C of 1.e-12 - multiplier = c14ratio - - case (CN_SPECIES_N) - select case (component) - case (COMPONENT_LEAF) - multiplier = 1._r8 / pftcon%leafcn(pft_type) - case (COMPONENT_DEADWOOD) - multiplier = 1._r8 / pftcon%deadwdcn(pft_type) - case default - write(iulog,*) subname//' ERROR: unknown component: ', component - call endrun(subname//': unknown component') - end select - - case default - write(iulog,*) subname//' ERROR: unknown species: ', species - call endrun(subname//': unknown species') - end select - - end function SpeciesTypeMultiplier - - - !----------------------------------------------------------------------- - subroutine LeafProportions(ignore_current_state, & - pft_type, & - leaf, leaf_storage, leaf_xfer, & - pleaf, pstorage, pxfer) - ! - ! !DESCRIPTION: - ! Compute leaf proportions (leaf, storage and xfer) - ! - ! If ignore_current_state is true, then use default proportions rather than - ! proportions based on current state. (Also use default proportions if total leaf mass - ! is 0 for this patch.) - ! - ! !USES: - ! - ! !ARGUMENTS: - logical, intent(in) :: ignore_current_state ! see comment above - integer , intent(in) :: pft_type - real(r8), intent(in) :: leaf ! g/m2 leaf C or N - real(r8), intent(in) :: leaf_storage ! g/m2 leaf C or N storage - real(r8), intent(in) :: leaf_xfer ! g/m2 leaf C or N transfer - - real(r8), intent(out) :: pleaf ! proportion in leaf itself - real(r8), intent(out) :: pstorage ! proportion in leaf storage - real(r8), intent(out) :: pxfer ! proportion in leaf xfer - ! - ! !LOCAL VARIABLES: - real(r8) :: tot_leaf - - character(len=*), parameter :: subname = 'LeafProportions' - !----------------------------------------------------------------------- - - tot_leaf = leaf + leaf_storage + leaf_xfer - pleaf = 0._r8 - pstorage = 0._r8 - pxfer = 0._r8 - - if (tot_leaf == 0._r8 .or. ignore_current_state) then - if (pftcon%evergreen(pft_type) == 1._r8) then - pleaf = 1._r8 - else - pstorage = 1._r8 - end if - else - pleaf = leaf/tot_leaf - pstorage = leaf_storage/tot_leaf - pxfer = leaf_xfer/tot_leaf - end if - - end subroutine LeafProportions - -end module CNVegComputeSeedMod diff --git a/src/biogeochem/CNVegNitrogenFluxType.F90 b/src/biogeochem/CNVegNitrogenFluxType.F90 deleted file mode 100644 index 65727f5c..00000000 --- a/src/biogeochem/CNVegNitrogenFluxType.F90 +++ /dev/null @@ -1,1737 +0,0 @@ -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 - use clm_varcon , only : spval, ispval, dzsoi_decomp - use clm_varctl , only : use_nitrif_denitrif, use_vertsoilc, use_crop - 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 - ! - ! !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 :: 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) - - contains - - procedure , public :: Init - procedure , public :: Restart - procedure , public :: SetValues - procedure , private :: InitAllocate - 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) - call this%InitHistory (bounds) - call this%InitCold (bounds) - - end subroutine Init - - !------------------------------------------------------------------------ - 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%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 - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - end if - - if (use_crop) 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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_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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, 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(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 - if (lun%ifspecial(l)) then - this%plant_ndemand_patch(p) = spval - this%avail_retransn_patch(p) = spval - this%plant_nalloc_patch(p) = spval - this%Npassive_patch(p) = spval - this%Nactive_patch(p) = spval - this%Nnonmyc_patch(p) = spval - this%Nam_patch(p) = spval - this%Necm_patch(p) = spval - if (use_nitrif_denitrif) then - this%Nactive_no3_patch(p) = spval - this%Nactive_nh4_patch(p) = spval - this%Nnonmyc_no3_patch(p) = spval - this%Nnonmyc_nh4_patch(p) = spval - this%Nam_no3_patch(p) = spval - this%Nam_nh4_patch(p) = spval - this%Necm_no3_patch(p) = spval - this%Necm_nh4_patch(p) = spval - end if - this%Nfix_patch(p) = spval - this%Nretrans_patch(p) = spval - this%Nretrans_org_patch(p) = spval - this%Nretrans_season_patch(p) = spval - this%Nretrans_stress_patch(p) = spval - this%Nuptake_patch(p) = spval - this%sminn_to_plant_fun_patch(p) = spval - this%cost_nfix_patch = spval - this%cost_nactive_patch = spval - this%cost_nretrans_patch = spval - this%nuptake_npp_fraction_patch = spval - - do j = 1, nlevdecomp - this%sminn_to_plant_fun_vr_patch(p,j) = spval - this%sminn_to_plant_fun_no3_vr_patch(p,j) = spval - this%sminn_to_plant_fun_nh4_vr_patch(p,j) = spval - end do - end if - end if - 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 ) - ! - ! !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) - - call restartvar(ncid=ncid, flag=flag, varname='plant_nalloc', xtype=ncd_double, & - dim1name='pft', & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%plant_nalloc_patch) - - if ( use_fun ) then - 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 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 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 restartvar(ncid=ncid, flag=flag, varname='Necm', xtype=ncd_double, & - dim1name='pft', & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%Necm_patch) - - 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 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 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 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 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 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 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 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) - 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 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 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 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 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 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 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 restartvar(ncid=ncid, flag=flag, varname='sminn_to_plant_fun', xtype=ncd_double, & - dim1name='pft', & - long_name='Total soil N uptake of FUN', units='gN/m2/s', & - interpinic_flag='interp', readvar=readvar, data=this%sminn_to_plant_fun_patch) - end if - - end subroutine Restart - - !----------------------------------------------------------------------- - subroutine SetValues ( this, & - 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 - 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%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 - - 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 - -end module CNVegNitrogenFluxType - diff --git a/src/biogeochem/CNVegNitrogenStateType.F90 b/src/biogeochem/CNVegNitrogenStateType.F90 deleted file mode 100644 index 5910caad..00000000 --- a/src/biogeochem/CNVegNitrogenStateType.F90 +++ /dev/null @@ -1,911 +0,0 @@ -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 shr_log_mod , only : errMsg => shr_log_errMsg - 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 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 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 :: 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 :: 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 :: 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 :: 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 - - ! 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 - - contains - - procedure , public :: Init - procedure , public :: Restart - procedure , public :: SetValues - 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 - 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 - 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 - 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 - 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 - - 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, default='inactive') - 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, default='inactive') - - 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_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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - !------------------------------- - ! 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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((ubound(leafc_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(leafc_storage_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(frootc_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(frootc_storage_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(deadstemc_patch) == (/bounds%endp/)), errMsg(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 (MM_Nuptake_opt .eqv. .true.) then - this%frootn_patch(p) = 0._r8 - this%frootn_storage_patch(p) = 0._r8 - 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 (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)) - end if - end if - - this%leafn_xfer_patch(p) = 0._r8 - - 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 - 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 - 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 - - ! 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)) - else - this%deadstemn_patch(p) = 0._r8 - end if - - this%deadstemn_storage_patch(p) = 0._r8 - this%deadstemn_xfer_patch(p) = 0._r8 - 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 - 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 - 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 - 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 ) - ! - ! !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 - ! - ! !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) - - 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) - - 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) - - 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) - - 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 10 for exit spinup ' - do i = bounds%begp,bounds%endp - this%deadstemn_patch(i) = this%deadstemn_patch(i) * 10._r8 - this%deadcrootn_patch(i) = this%deadcrootn_patch(i) * 10._r8 - 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 10 for enter spinup ' - do i = bounds%begp,bounds%endp - this%deadstemn_patch(i) = this%deadstemn_patch(i) / 10._r8 - this%deadcrootn_patch(i) = this%deadcrootn_patch(i) / 10._r8 - 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 (MM_Nuptake_opt .eqv. .true.) then - this%frootn_patch(p) = 0._r8 - this%frootn_storage_patch(p) = 0._r8 - 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 (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)) - end if - end if - - this%leafn_xfer_patch(p) = 0._r8 - - 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 - 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 - 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 - - ! 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)) - else - this%deadstemn_patch(p) = 0._r8 - end if - - this%deadstemn_storage_patch(p) = 0._r8 - this%deadstemn_xfer_patch(p) = 0._r8 - 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 - 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 - 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 - -end module CNVegNitrogenStateType diff --git a/src/biogeochem/CNVegStateType.F90 b/src/biogeochem/CNVegStateType.F90 deleted file mode 100644 index 1d78017a..00000000 --- a/src/biogeochem/CNVegStateType.F90 +++ /dev/null @@ -1,905 +0,0 @@ -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 - ! - ! !PUBLIC TYPES: - implicit none - private - ! - ! !PUBLIC TYPES: - type, public :: cnveg_state_type - - integer , pointer :: burndate_patch (:) ! patch crop burn date - 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 - - 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, default='inactive') - - 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, default='inactive') - - this%farea_burned_col(begc:endc) = spval - call hist_addfld1d (fname='FAREA_BURNED', units='proportion/sec', & - avgflag='A', long_name='timestep fractional area burned', & - ptr_col=this%farea_burned_col, default='inactive') - - this%baf_crop_col(begc:endc) = spval - call hist_addfld1d (fname='BAF_CROP', units='proportion/sec', & - avgflag='A', long_name='fractional area burned for crop', & - ptr_col=this%baf_crop_col, default='inactive') - - this%baf_peatf_col(begc:endc) = spval - call hist_addfld1d (fname='BAF_PEATF', units='proportion/sec', & - avgflag='A', long_name='fractional area burned in peatland', & - ptr_col=this%baf_peatf_col, default='inactive') - - 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 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/src/biogeochem/CNVegStructUpdateMod.F90 b/src/biogeochem/CNVegStructUpdateMod.F90 deleted file mode 100644 index 27b677b0..00000000 --- a/src/biogeochem/CNVegStructUpdateMod.F90 +++ /dev/null @@ -1,307 +0,0 @@ -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 WaterStateType , only : waterstate_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 - use CanopyStateType , only : canopystate_type - use PatchType , only : patch - ! - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: CNVegStructUpdate - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine CNVegStructUpdate(num_soilp, filter_soilp, & - waterstate_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 : pftcon - use clm_varctl , only : spinup_state - use clm_time_manager , only : get_rad_step_size - ! - ! !ARGUMENTS: - integer , intent(in) :: num_soilp ! number of column soil points in patch filter - integer , intent(in) :: filter_soilp(:) ! patch filter for soil points - type(waterstate_type) , intent(in) :: waterstate_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) :: 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 ! PATCH 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) - !----------------------------------------------------------------------- - ! 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: - - 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) - - snow_depth => waterstate_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 - - 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 - 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 ) - - ! constant allometric parameters - taper = 200._r8 - stocking = 1000._r8 - - ! convert from stems/ha -> stems/m^2 - stocking = stocking / 10000._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) - - 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 (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))**(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 - if (spinup_state == 2) then - htop(p) = ((3._r8 * deadstemc(p) * 10._r8 * taper * taper)/ & - (SHR_CONST_PI * stocking * dwood(ivt(p))))**(1._r8/3._r8) - else - htop(p) = ((3._r8 * deadstemc(p) * taper * taper)/ & - (SHR_CONST_PI * stocking * dwood(ivt(p))))**(1._r8/3._r8) - end if - - 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) 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) 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 associate - - end subroutine CNVegStructUpdate - -end module CNVegStructUpdateMod diff --git a/src/biogeochem/CNVegetationFacade.F90 b/src/biogeochem/CNVegetationFacade.F90 deleted file mode 100644 index 6bb79f96..00000000 --- a/src/biogeochem/CNVegetationFacade.F90 +++ /dev/null @@ -1,422 +0,0 @@ -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 abortutils , only : endrun - use spmdMod , only : masterproc - 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 CNProductsMod , only : cn_products_type - use SpeciesIsotopeType , only : species_isotope_type - use SpeciesNonIsotopeType , only : species_non_isotope_type - use CNDriverMod , only : CNDriverInit - ! - 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 - - ! Control variables - logical, private :: reseed_dead_plants ! Flag to indicate if should reseed dead plants when starting up the model - - ! 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 :: Restart - - procedure, public :: Init2 ! Do initialization in initialize phase, after subgrid weights are determined - procedure, public :: WriteHistory ! Do any history writes that are specific to veg dynamics - - 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 - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - !----------------------------------------------------------------------- - subroutine Init(this, bounds, NLFilename) - ! - ! !DESCRIPTION: - ! Initialize a CNVeg object. - ! - ! Should be called regardless of whether use_cn is true - ! - ! !USES: - use clm_varcon , only : c13ratio, c14ratio - ! - ! !ARGUMENTS: - class(cn_vegetation_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - character(len=*) , intent(in) :: NLFilename ! namelist filename - ! - ! !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) - - 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) - call this%cnveg_carbonflux_inst%Init(bounds, carbon_type='c12') - 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')) - call this%n_products_inst%Init(bounds, species_non_isotope_type('N')) - - call this%cn_balance_inst%Init(bounds) - - end if - - 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 - namelist /cn_general/ reseed_dead_plants - - reseed_dead_plants = this%reseed_dead_plants - - 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 - write(iulog,*) "Could NOT find "//nmlname//"namelist" - end if - call relavu( unitn ) - end if - - call shr_mpi_bcast (reseed_dead_plants , mpicom) - - this%reseed_dead_plants = reseed_dead_plants - - 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' - !----------------------------------------------------------------------- - - 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' - !----------------------------------------------------------------------- - - end subroutine InitAccVars - - !----------------------------------------------------------------------- - 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 - ! - ! !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 - - 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 ) - 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 - call this%cnveg_carbonflux_inst%restart(bounds, ncid, flag=flag, carbon_type='c12') - - 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) - 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) - call this%n_products_inst%restart(bounds, ncid, 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 ) - - end subroutine Init2 - - - !----------------------------------------------------------------------- - 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' - !----------------------------------------------------------------------- - - end subroutine WriteHistory - - !----------------------------------------------------------------------- - 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/src/biogeochem/CropType.F90 b/src/biogeochem/CropType.F90 deleted file mode 100644 index 1b28927b..00000000 --- a/src/biogeochem/CropType.F90 +++ /dev/null @@ -1,644 +0,0 @@ -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 - ! 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 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='inactive') - - 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((ubound(t_ref2m_patch) == (/endp/)) , errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(t_soisno_col) == (/endc,nlevgrnd/)) , errMsg(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.,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/src/biogeochem/DUSTMod.F90 b/src/biogeochem/DUSTMod.F90 deleted file mode 100644 index 6a906e41..00000000 --- a/src/biogeochem/DUSTMod.F90 +++ /dev/null @@ -1,925 +0,0 @@ -module DUSTMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Routines in this module calculate Dust mobilization and dry deposition for dust. - ! Simulates dust mobilization due to wind from the surface into the - ! lowest atmospheric layer. On output flx_mss_vrt_dst(ndst) is the surface dust - ! emission (kg/m**2/s) [ + = to atm]. - ! Calculates the turbulent component of dust dry deposition, (the turbulent deposition - ! velocity through the lowest atmospheric layer). CAM will calculate the settling - ! velocity through the whole atmospheric column. The two calculations will determine - ! the dust dry deposition flux to the surface. - ! - ! !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 clm_varpar , only : dst_src_nbr, ndst, sz_nbr - use clm_varcon , only : grav, spval - use landunit_varcon , only : istcrop, istsoil - use clm_varctl , only : iulog - use abortutils , only : endrun - use subgridAveMod , only : p2l_1d - use decompMod , only : bounds_type - use atm2lndType , only : atm2lnd_type - use SoilStateType , only : soilstate_type - use CanopyStateType , only : canopystate_type - use WaterstateType , only : waterstate_type - use FrictionVelocityMod , only : frictionvel_type - use LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch - ! - ! !PUBLIC TYPES - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - ! - public DustEmission ! Dust mobilization - public DustDryDep ! Turbulent dry deposition for dust - ! - ! !PUBLIC DATA: - ! - real(r8) , allocatable :: ovr_src_snk_mss(:,:) - real(r8) , allocatable :: dmt_vwr(:) ![m] Mass-weighted mean diameter resolved - real(r8) , allocatable :: stk_crc(:) ![frc] Correction to Stokes settling velocity - real(r8) tmp1 !Factor in saltation computation (named as in Charlie's code) - real(r8) dns_aer ![kg m-3] Aerosol density - ! - ! !PUBLIC DATA TYPES: - ! - type, public :: dust_type - - real(r8), pointer, PUBLIC :: flx_mss_vrt_dst_patch (:,:) ! surface dust emission (kg/m**2/s) [ + = to atm] (ndst) - real(r8), pointer, private :: flx_mss_vrt_dst_tot_patch (:) ! total dust flux into atmosphere - real(r8), pointer, private :: vlc_trb_patch (:,:) ! turbulent deposition velocity (m/s) (ndst) - real(r8), pointer, private :: vlc_trb_1_patch (:) ! turbulent deposition velocity 1(m/s) - real(r8), pointer, private :: vlc_trb_2_patch (:) ! turbulent deposition velocity 2(m/s) - real(r8), pointer, private :: vlc_trb_3_patch (:) ! turbulent deposition velocity 3(m/s) - real(r8), pointer, private :: vlc_trb_4_patch (:) ! turbulent deposition velocity 4(m/s) - real(r8), pointer, private :: mbl_bsn_fct_col (:) ! basin factor - - contains - - procedure , public :: Init - procedure , private :: InitAllocate - procedure , private :: InitHistory - procedure , private :: InitCold - procedure , private :: InitDustVars ! Initialize variables used in subroutine Dust - - end type dust_type - !------------------------------------------------------------------------ - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, bounds) - - class(dust_type) :: this - type(bounds_type), intent(in) :: bounds - - call this%InitAllocate (bounds) - call this%InitHistory (bounds) - call this%InitCold (bounds) - call this%InitDustVars (bounds) - - end subroutine Init - - !------------------------------------------------------------------------ - subroutine InitAllocate(this, bounds) - ! - ! !ARGUMENTS: - class (dust_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%flx_mss_vrt_dst_patch (begp:endp,1:ndst)) ; this%flx_mss_vrt_dst_patch (:,:) = nan - allocate(this%flx_mss_vrt_dst_tot_patch (begp:endp)) ; this%flx_mss_vrt_dst_tot_patch (:) = nan - allocate(this%vlc_trb_patch (begp:endp,1:ndst)) ; this%vlc_trb_patch (:,:) = nan - allocate(this%vlc_trb_1_patch (begp:endp)) ; this%vlc_trb_1_patch (:) = nan - allocate(this%vlc_trb_2_patch (begp:endp)) ; this%vlc_trb_2_patch (:) = nan - allocate(this%vlc_trb_3_patch (begp:endp)) ; this%vlc_trb_3_patch (:) = nan - allocate(this%vlc_trb_4_patch (begp:endp)) ; this%vlc_trb_4_patch (:) = nan - allocate(this%mbl_bsn_fct_col (begc:endc)) ; this%mbl_bsn_fct_col (:) = nan - - end subroutine InitAllocate - - !------------------------------------------------------------------------ - subroutine InitHistory(this, bounds) - ! - ! !USES: - use histFileMod, only : hist_addfld1d - ! - ! - ! !ARGUMENTS: - class (dust_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begp,endp - !------------------------------------------------------------------------ - - begp = bounds%begp; endp = bounds%endp - - this%flx_mss_vrt_dst_tot_patch(begp:endp) = spval - call hist_addfld1d (fname='DSTFLXT', units='kg/m2/s', & - avgflag='A', long_name='total surface dust emission', & - ptr_patch=this%flx_mss_vrt_dst_tot_patch, set_lake=0._r8, set_urb=0._r8, default='inactive') - - this%vlc_trb_1_patch(begp:endp) = spval - call hist_addfld1d (fname='DPVLTRB1', units='m/s', & - avgflag='A', long_name='turbulent deposition velocity 1', & - ptr_patch=this%vlc_trb_1_patch, default='inactive') - - this%vlc_trb_2_patch(begp:endp) = spval - call hist_addfld1d (fname='DPVLTRB2', units='m/s', & - avgflag='A', long_name='turbulent deposition velocity 2', & - ptr_patch=this%vlc_trb_2_patch, default='inactive') - - this%vlc_trb_3_patch(begp:endp) = spval - call hist_addfld1d (fname='DPVLTRB3', units='m/s', & - avgflag='A', long_name='turbulent deposition velocity 3', & - ptr_patch=this%vlc_trb_3_patch, default='inactive') - - this%vlc_trb_4_patch(begp:endp) = spval - call hist_addfld1d (fname='DPVLTRB4', units='m/s', & - avgflag='A', long_name='turbulent deposition velocity 4', & - ptr_patch=this%vlc_trb_4_patch, default='inactive') - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine InitCold(this, bounds) - ! - ! !ARGUMENTS: - class (dust_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: c,l - !----------------------------------------------------------------------- - - ! Set basin factor to 1 for now - - do c = bounds%begc, bounds%endc - l = col%landunit(c) - - if (.not.lun%lakpoi(l)) then - this%mbl_bsn_fct_col(c) = 1.0_r8 - end if - end do - - end subroutine InitCold - - !------------------------------------------------------------------------ - subroutine DustEmission (bounds, & - num_nolakep, filter_nolakep, & - atm2lnd_inst, soilstate_inst, canopystate_inst, waterstate_inst, & - frictionvel_inst, dust_inst) - ! - ! !DESCRIPTION: - ! Dust mobilization. This code simulates dust mobilization due to wind - ! from the surface into the lowest atmospheric layer - ! On output flx_mss_vrt_dst(ndst) is the surface dust emission - ! (kg/m**2/s) [ + = to atm] - ! Source: C. Zender's dust model - ! - ! !USES - use shr_const_mod, only : SHR_CONST_RHOFW - use subgridaveMod, only : p2g - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_nolakep ! number of column non-lake points in patch filter - integer , intent(in) :: filter_nolakep(num_nolakep) ! patch filter for non-lake points - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(soilstate_type) , intent(in) :: soilstate_inst - type(canopystate_type) , intent(in) :: canopystate_inst - type(waterstate_type) , intent(in) :: waterstate_inst - type(frictionvel_type) , intent(in) :: frictionvel_inst - type(dust_type) , intent(inout) :: dust_inst - - ! - ! !LOCAL VARIABLES - integer :: fp,p,c,l,g,m,n ! indices - real(r8) :: liqfrac ! fraction of total water that is liquid - real(r8) :: wnd_frc_rat ! [frc] Wind friction threshold over wind friction - real(r8) :: wnd_frc_slt_dlt ! [m s-1] Friction velocity increase from saltatn - real(r8) :: wnd_rfr_dlt ! [m s-1] Reference windspeed excess over threshld - real(r8) :: dst_slt_flx_rat_ttl - real(r8) :: flx_mss_hrz_slt_ttl - real(r8) :: flx_mss_vrt_dst_ttl(bounds%begp:bounds%endp) - real(r8) :: frc_thr_wet_fct - real(r8) :: frc_thr_rgh_fct - real(r8) :: wnd_frc_thr_slt - real(r8) :: wnd_rfr_thr_slt - real(r8) :: wnd_frc_slt - real(r8) :: lnd_frc_mbl(bounds%begp:bounds%endp) - real(r8) :: bd - real(r8) :: gwc_sfc - real(r8) :: ttlai(bounds%begp:bounds%endp) - real(r8) :: tlai_lu(bounds%begl:bounds%endl) - real(r8) :: sumwt(bounds%begl:bounds%endl) ! sum of weights - logical :: found ! temporary for error check - integer :: index - ! - ! constants - ! - real(r8), parameter :: cst_slt = 2.61_r8 ! [frc] Saltation constant - real(r8), parameter :: flx_mss_fdg_fct = 5.0e-4_r8 ! [frc] Empir. mass flx tuning eflx_lh_vegt - real(r8), parameter :: vai_mbl_thr = 0.3_r8 ! [m2 m-2] VAI threshold quenching dust mobilization - !------------------------------------------------------------------------ - - associate( & - forc_rho => atm2lnd_inst%forc_rho_downscaled_col , & ! Input: [real(r8) (:) ] downscaled density (kg/m**3) - - gwc_thr => soilstate_inst%gwc_thr_col , & ! Input: [real(r8) (:) ] threshold gravimetric soil moisture based on clay content - mss_frc_cly_vld => soilstate_inst%mss_frc_cly_vld_col , & ! Input: [real(r8) (:) ] [frc] Mass fraction clay limited to 0.20 - watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] saturated volumetric soil water - - 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 - - frac_sno => waterstate_inst%frac_sno_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) - h2osoi_vol => waterstate_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) - h2osoi_liq => waterstate_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid soil water (kg/m2) - h2osoi_ice => waterstate_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:) ] frozen soil water (kg/m2) - - fv => frictionvel_inst%fv_patch , & ! Input: [real(r8) (:) ] friction velocity (m/s) (for dust model) - u10 => frictionvel_inst%u10_patch , & ! Input: [real(r8) (:) ] 10-m wind (m/s) (created for dust model) - - mbl_bsn_fct => dust_inst%mbl_bsn_fct_col , & ! Input: [real(r8) (:) ] basin factor - flx_mss_vrt_dst => dust_inst%flx_mss_vrt_dst_patch , & ! Output: [real(r8) (:,:) ] surface dust emission (kg/m**2/s) - flx_mss_vrt_dst_tot => dust_inst%flx_mss_vrt_dst_tot_patch & ! Output: [real(r8) (:) ] total dust flux back to atmosphere (pft) - ) - - ttlai(bounds%begp : bounds%endp) = 0._r8 - ! make lai average at landunit level - do fp = 1,num_nolakep - p = filter_nolakep(fp) - ttlai(p) = tlai(p)+tsai(p) - enddo - - tlai_lu(bounds%begl : bounds%endl) = spval - sumwt(bounds%begl : bounds%endl) = 0._r8 - do p = bounds%begp,bounds%endp - if (ttlai(p) /= spval .and. patch%active(p) .and. patch%wtlunit(p) /= 0._r8) then - c = patch%column(p) - l = patch%landunit(p) - if (sumwt(l) == 0._r8) tlai_lu(l) = 0._r8 - tlai_lu(l) = tlai_lu(l) + ttlai(p) * patch%wtlunit(p) - sumwt(l) = sumwt(l) + patch%wtlunit(p) - 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 - exit - else if (sumwt(l) /= 0._r8) then - tlai_lu(l) = tlai_lu(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(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Loop through patches - - ! initialize variables which get passed to the atmosphere - flx_mss_vrt_dst(bounds%begp:bounds%endp,:)=0._r8 - - do fp = 1,num_nolakep - p = filter_nolakep(fp) - c = patch%column(p) - l = patch%landunit(p) - - ! the following code from subr. lnd_frc_mbl_get was adapted for lsm use - ! purpose: return fraction of each gridcell suitable for dust mobilization - - ! the "bare ground" fraction of the current sub-gridscale cell decreases - ! linearly from 1 to 0 as VAI(=tlai+tsai) increases from 0 to vai_mbl_thr - ! if ice sheet, wetland, or lake, no dust allowed - - if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then - if (tlai_lu(l) < vai_mbl_thr) then - lnd_frc_mbl(p) = 1.0_r8 - (tlai_lu(l))/vai_mbl_thr - else - lnd_frc_mbl(p) = 0.0_r8 - endif - lnd_frc_mbl(p) = lnd_frc_mbl(p) * (1.0_r8 - frac_sno(c)) - else - lnd_frc_mbl(p) = 0.0_r8 - end if - end do - - do fp = 1,num_nolakep - p = filter_nolakep(fp) - if (lnd_frc_mbl(p)>1.0_r8 .or. lnd_frc_mbl(p)<0.0_r8) then - write(iulog,*)'Error dstmbl: pft= ',p,' lnd_frc_mbl(p)= ',lnd_frc_mbl(p) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do - - ! reset history output variables before next if-statement to avoid output = inf - - do fp = 1,num_nolakep - p = filter_nolakep(fp) - flx_mss_vrt_dst_tot(p) = 0.0_r8 - end do - do n = 1, ndst - do fp = 1,num_nolakep - p = filter_nolakep(fp) - flx_mss_vrt_dst(p,n) = 0.0_r8 - end do - end do - - do fp = 1,num_nolakep - p = filter_nolakep(fp) - c = patch%column(p) - l = patch%landunit(p) - g = patch%gridcell(p) - - ! only perform the following calculations if lnd_frc_mbl is non-zero - - if (lnd_frc_mbl(p) > 0.0_r8) then - - ! the following comes from subr. frc_thr_rgh_fct_get - ! purpose: compute factor by which surface roughness increases threshold - ! friction velocity (currently a constant) - - frc_thr_rgh_fct = 1.0_r8 - - ! the following comes from subr. frc_thr_wet_fct_get - ! purpose: compute factor by which soil moisture increases threshold friction velocity - ! adjust threshold velocity for inhibition by moisture - ! modified 4/5/2002 (slevis) to use gravimetric instead of volumetric - ! water content - - bd = (1._r8-watsat(c,1))*2.7e3_r8 ![kg m-3] Bulk density of dry surface soil - gwc_sfc = h2osoi_vol(c,1)*SHR_CONST_RHOFW/bd ![kg kg-1] Gravimetric H2O cont - if (gwc_sfc > gwc_thr(c)) then - frc_thr_wet_fct = sqrt(1.0_r8 + 1.21_r8 * (100.0_r8*(gwc_sfc - gwc_thr(c)))**0.68_r8) - else - frc_thr_wet_fct = 1.0_r8 - end if - - ! slevis: adding liqfrac here, because related to effects from soil water - - liqfrac = max( 0.0_r8, min( 1.0_r8, h2osoi_liq(c,1) / (h2osoi_ice(c,1)+h2osoi_liq(c,1)+1.0e-6_r8) ) ) - - ! the following lines come from subr. dst_mbl - ! purpose: adjust threshold friction velocity to acct for moisture and - ! roughness. The ratio tmp1 / sqrt(forc_rho) comes from - ! subr. wnd_frc_thr_slt_get which computes dry threshold - ! friction velocity for saltation - - wnd_frc_thr_slt = tmp1 / sqrt(forc_rho(c)) * frc_thr_wet_fct * frc_thr_rgh_fct - - ! reset these variables which will be updated in the following if-block - - wnd_frc_slt = fv(p) - flx_mss_hrz_slt_ttl = 0.0_r8 - flx_mss_vrt_dst_ttl(p) = 0.0_r8 - - ! the following line comes from subr. dst_mbl - ! purpose: threshold saltation wind speed - - wnd_rfr_thr_slt = u10(p) * wnd_frc_thr_slt / fv(p) - - ! the following if-block comes from subr. wnd_frc_slt_get - ! purpose: compute the saltating friction velocity - ! theory: saltation roughens the boundary layer, AKA "Owen's effect" - - if (u10(p) >= wnd_rfr_thr_slt) then - wnd_rfr_dlt = u10(p) - wnd_rfr_thr_slt - wnd_frc_slt_dlt = 0.003_r8 * wnd_rfr_dlt * wnd_rfr_dlt - wnd_frc_slt = fv(p) + wnd_frc_slt_dlt - end if - - ! the following comes from subr. flx_mss_hrz_slt_ttl_Whi79_get - ! purpose: compute vertically integrated streamwise mass flux of particles - - if (wnd_frc_slt > wnd_frc_thr_slt) then - wnd_frc_rat = wnd_frc_thr_slt / wnd_frc_slt - flx_mss_hrz_slt_ttl = cst_slt * forc_rho(c) * (wnd_frc_slt**3.0_r8) * & - (1.0_r8 - wnd_frc_rat) * (1.0_r8 + wnd_frc_rat) * (1.0_r8 + wnd_frc_rat) / grav - - ! the following loop originates from subr. dst_mbl - ! purpose: apply land sfc and veg limitations and global tuning factor - ! slevis: multiply flx_mss_hrz_slt_ttl by liqfrac to incude the effect - ! of frozen soil - - flx_mss_hrz_slt_ttl = flx_mss_hrz_slt_ttl * lnd_frc_mbl(p) * mbl_bsn_fct(c) * & - flx_mss_fdg_fct * liqfrac - end if - - ! the following comes from subr. flx_mss_vrt_dst_ttl_MaB95_get - ! purpose: diagnose total vertical mass flux of dust from vertically - ! integrated streamwise mass flux - - dst_slt_flx_rat_ttl = 100.0_r8 * exp( log(10.0_r8) * (13.4_r8 * mss_frc_cly_vld(c) - 6.0_r8) ) - flx_mss_vrt_dst_ttl(p) = flx_mss_hrz_slt_ttl * dst_slt_flx_rat_ttl - - end if ! lnd_frc_mbl > 0.0 - - end do - - ! the following comes from subr. flx_mss_vrt_dst_prt in C. Zender's code - ! purpose: partition total vertical mass flux of dust into transport bins - - do n = 1, ndst - do m = 1, dst_src_nbr - do fp = 1,num_nolakep - p = filter_nolakep(fp) - if (lnd_frc_mbl(p) > 0.0_r8) then - flx_mss_vrt_dst(p,n) = flx_mss_vrt_dst(p,n) + ovr_src_snk_mss(m,n) * flx_mss_vrt_dst_ttl(p) - end if - end do - end do - end do - - do n = 1, ndst - do fp = 1,num_nolakep - p = filter_nolakep(fp) - if (lnd_frc_mbl(p) > 0.0_r8) then - flx_mss_vrt_dst_tot(p) = flx_mss_vrt_dst_tot(p) + flx_mss_vrt_dst(p,n) - end if - end do - end do - - end associate - - end subroutine DustEmission - - !------------------------------------------------------------------------ - subroutine DustDryDep (bounds, & - atm2lnd_inst, frictionvel_inst, dust_inst) - ! - ! !DESCRIPTION: - ! - ! Determine Turbulent dry deposition for dust. Calculate the turbulent - ! component of dust dry deposition, (the turbulent deposition velocity - ! through the lowest atmospheric layer. CAM will calculate the settling - ! velocity through the whole atmospheric column. The two calculations - ! will determine the dust dry deposition flux to the surface. - ! Note: Same process should occur over oceans. For the coupled CESM, - ! we may find it more efficient to let CAM calculate the turbulent dep - ! velocity over all surfaces. This would require passing the - ! aerodynamic resistance, ram(1), and the friction velocity, fv, from - ! the land to the atmosphere component. In that case, dustini need not - ! calculate particle diamter (dmt_vwr) and particle density (dns_aer). - ! Source: C. Zender's dry deposition code - ! - ! !USES - use shr_const_mod, only : SHR_CONST_PI, SHR_CONST_RDAIR, SHR_CONST_BOLTZ - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(frictionvel_type) , intent(in) :: frictionvel_inst - type(dust_type) , intent(inout) :: dust_inst - ! - ! !LOCAL VARIABLES - integer :: p,c,g,m,n ! indices - real(r8) :: vsc_dyn_atm(bounds%begp:bounds%endp) ! [kg m-1 s-1] Dynamic viscosity of air - real(r8) :: vsc_knm_atm(bounds%begp:bounds%endp) ! [m2 s-1] Kinematic viscosity of atmosphere - real(r8) :: shm_nbr_xpn ! [frc] Sfc-dep exponent for aerosol-diffusion dependence on Schmidt number - real(r8) :: shm_nbr ! [frc] Schmidt number - real(r8) :: stk_nbr ! [frc] Stokes number - real(r8) :: mfp_atm ! [m] Mean free path of air - real(r8) :: dff_aer ! [m2 s-1] Brownian diffusivity of particle - real(r8) :: rss_trb ! [s m-1] Resistance to turbulent deposition - real(r8) :: slp_crc(bounds%begp:bounds%endp,ndst) ! [frc] Slip correction factor - real(r8) :: vlc_grv(bounds%begp:bounds%endp,ndst) ! [m s-1] Settling velocity - real(r8) :: rss_lmn(bounds%begp:bounds%endp,ndst) ! [s m-1] Quasi-laminar layer resistance - real(r8) :: tmp ! temporary - real(r8), parameter::shm_nbr_xpn_lnd=-2._r8/3._r8 ![frc] shm_nbr_xpn over land - !------------------------------------------------------------------------ - - associate( & - forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atm pressure (Pa) - forc_rho => atm2lnd_inst%forc_rho_downscaled_col , & ! Input: [real(r8) (:) ] atm density (kg/m**3) - forc_t => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:) ] atm temperature (K) - - ram1 => frictionvel_inst%ram1_patch , & ! Input: [real(r8) (:) ] aerodynamical resistance (s/m) - fv => frictionvel_inst%fv_patch , & ! Input: [real(r8) (:) ] friction velocity (m/s) - - vlc_trb => dust_inst%vlc_trb_patch , & ! Output: [real(r8) (:,:) ] Turbulent deposn velocity (m/s) - vlc_trb_1 => dust_inst%vlc_trb_1_patch , & ! Output: [real(r8) (:) ] Turbulent deposition velocity 1 - vlc_trb_2 => dust_inst%vlc_trb_2_patch , & ! Output: [real(r8) (:) ] Turbulent deposition velocity 2 - vlc_trb_3 => dust_inst%vlc_trb_3_patch , & ! Output: [real(r8) (:) ] Turbulent deposition velocity 3 - vlc_trb_4 => dust_inst%vlc_trb_4_patch & ! Output: [real(r8) (:) ] Turbulent deposition velocity 4 - ) - - do p = bounds%begp,bounds%endp - if (patch%active(p)) then - g = patch%gridcell(p) - c = patch%column(p) - - ! from subroutine dst_dps_dry (consider adding sanity checks from line 212) - ! when code asks to use midlayer density, pressure, temperature, - ! I use the data coming in from the atmosphere, ie forc_t, forc_pbot, forc_rho - - ! Quasi-laminar layer resistance: call rss_lmn_get - ! Size-independent thermokinetic properties - - vsc_dyn_atm(p) = 1.72e-5_r8 * ((forc_t(c)/273.0_r8)**1.5_r8) * 393.0_r8 / & - (forc_t(c)+120.0_r8) ![kg m-1 s-1] RoY94 p. 102 - mfp_atm = 2.0_r8 * vsc_dyn_atm(p) / & ![m] SeP97 p. 455 - (forc_pbot(c)*sqrt(8.0_r8/(SHR_CONST_PI*SHR_CONST_RDAIR*forc_t(c)))) - vsc_knm_atm(p) = vsc_dyn_atm(p) / forc_rho(c) ![m2 s-1] Kinematic viscosity of air - - do m = 1, ndst - slp_crc(p,m) = 1.0_r8 + 2.0_r8 * mfp_atm * & - (1.257_r8+0.4_r8*exp(-1.1_r8*dmt_vwr(m)/(2.0_r8*mfp_atm))) / & - dmt_vwr(m) ![frc] Slip correction factor SeP97 p. 464 - vlc_grv(p,m) = (1.0_r8/18.0_r8) * dmt_vwr(m) * dmt_vwr(m) * dns_aer * & - grav * slp_crc(p,m) / vsc_dyn_atm(p) ![m s-1] Stokes' settling velocity SeP97 p. 466 - vlc_grv(p,m) = vlc_grv(p,m) * stk_crc(m) ![m s-1] Correction to Stokes settling velocity - end do - end if - end do - - do m = 1, ndst - do p = bounds%begp,bounds%endp - if (patch%active(p)) then - g = patch%gridcell(p) - c = patch%column(p) - - stk_nbr = vlc_grv(p,m) * fv(p) * fv(p) / (grav * vsc_knm_atm(p)) ![frc] SeP97 p.965 - dff_aer = SHR_CONST_BOLTZ * forc_t(c) * slp_crc(p,m) / & ![m2 s-1] - (3.0_r8*SHR_CONST_PI * vsc_dyn_atm(p) * dmt_vwr(m)) !SeP97 p.474 - shm_nbr = vsc_knm_atm(p) / dff_aer ![frc] SeP97 p.972 - shm_nbr_xpn = shm_nbr_xpn_lnd ![frc] - - ! fxm: Turning this on dramatically reduces - ! deposition velocity in low wind regimes - ! Schmidt number exponent is -2/3 over solid surfaces and - ! -1/2 over liquid surfaces SlS80 p. 1014 - ! if (oro(i)==0.0) shm_nbr_xpn=shm_nbr_xpn_ocn else shm_nbr_xpn=shm_nbr_xpn_lnd - ! [frc] Surface-dependent exponent for aerosol-diffusion dependence on Schmidt # - - tmp = shm_nbr**shm_nbr_xpn + 10.0_r8**(-3.0_r8/stk_nbr) - rss_lmn(p,m) = 1.0_r8 / (tmp * fv(p)) ![s m-1] SeP97 p.972,965 - end if - end do - end do - - ! Lowest layer: Turbulent deposition (CAM will calc. gravitational dep) - - do m = 1, ndst - do p = bounds%begp,bounds%endp - if (patch%active(p)) then - rss_trb = ram1(p) + rss_lmn(p,m) + ram1(p) * rss_lmn(p,m) * vlc_grv(p,m) ![s m-1] - vlc_trb(p,m) = 1.0_r8 / rss_trb ![m s-1] - end if - end do - end do - - do p = bounds%begp,bounds%endp - if (patch%active(p)) then - vlc_trb_1(p) = vlc_trb(p,1) - vlc_trb_2(p) = vlc_trb(p,2) - vlc_trb_3(p) = vlc_trb(p,3) - vlc_trb_4(p) = vlc_trb(p,4) - end if - end do - - end associate - - end subroutine DustDryDep - - !------------------------------------------------------------------------ - subroutine InitDustVars(this, bounds) - ! - ! !DESCRIPTION: - ! - ! Compute source efficiency factor from topography - ! Initialize other variables used in subroutine Dust: - ! ovr_src_snk_mss(m,n) and tmp1. - ! Define particle diameter and density needed by atm model - ! as well as by dry dep model - ! Source: Paul Ginoux (for source efficiency factor) - ! Modifications by C. Zender and later by S. Levis - ! Rest of subroutine from C. Zender's dust model - ! - ! !USES - use shr_const_mod , only: SHR_CONST_PI, SHR_CONST_RDAIR - use shr_spfn_mod , only: erf => shr_spfn_erf - use decompMod , only : get_proc_bounds - ! - ! !ARGUMENTS: - class(dust_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES - integer :: fc,c,l,m,n ! indices - real(r8) :: ovr_src_snk_frc - real(r8) :: sqrt2lngsdi ! [frc] Factor in erf argument - real(r8) :: lndmaxjovrdmdni ! [frc] Factor in erf argument - real(r8) :: lndminjovrdmdni ! [frc] Factor in erf argument - real(r8) :: ryn_nbr_frc_thr_prx_opt ! [frc] Threshold friction Reynolds number approximation for optimal size - real(r8) :: ryn_nbr_frc_thr_opt_fnc ! [frc] Threshold friction Reynolds factor for saltation calculation - real(r8) :: icf_fct ! Interpartical cohesive forces factor for saltation calc - real(r8) :: dns_fct ! Density ratio factor for saltation calculation - real(r8) :: dmt_min(ndst) ! [m] Size grid minimum - real(r8) :: dmt_max(ndst) ! [m] Size grid maximum - real(r8) :: dmt_ctr(ndst) ! [m] Diameter at bin center - real(r8) :: dmt_dlt(ndst) ! [m] Width of size bin - real(r8) :: slp_crc(ndst) ! [frc] Slip correction factor - real(r8) :: vlm_rsl(ndst) ! [m3 m-3] Volume concentration resolved - real(r8) :: vlc_stk(ndst) ! [m s-1] Stokes settling velocity - real(r8) :: vlc_grv(ndst) ! [m s-1] Settling velocity - real(r8) :: ryn_nbr_grv(ndst) ! [frc] Reynolds number at terminal velocity - real(r8) :: cff_drg_grv(ndst) ! [frc] Drag coefficient at terminal velocity - real(r8) :: tmp ! temporary - real(r8) :: ln_gsd ! [frc] ln(gsd) - real(r8) :: gsd_anl ! [frc] Geometric standard deviation - real(r8) :: dmt_vma ! [m] Mass median diameter analytic She84 p.75 Tabl.1 - real(r8) :: dmt_nma ! [m] Number median particle diameter - real(r8) :: lgn_dst ! Lognormal distribution at sz_ctr - real(r8) :: eps_max ! [frc] Relative accuracy for convergence - real(r8) :: eps_crr ! [frc] Current relative accuracy - real(r8) :: itr_idx ! [idx] Counting index - real(r8) :: dns_mdp ! [kg m-3] Midlayer density - real(r8) :: mfp_atm ! [m] Mean free path of air - real(r8) :: vsc_dyn_atm ! [kg m-1 s-1] Dynamic viscosity of air - real(r8) :: vsc_knm_atm ! [kg m-1 s-1] Kinematic viscosity of air - real(r8) :: vlc_grv_old ! [m s-1] Previous gravitational settling velocity - real(r8) :: series_ratio ! Factor for logarithmic grid - real(r8) :: lngsdsqrttwopi_rcp ! Factor in lognormal distribution - real(r8) :: sz_min(sz_nbr) ! [m] Size Bin minima - real(r8) :: sz_max(sz_nbr) ! [m] Size Bin maxima - real(r8) :: sz_ctr(sz_nbr) ! [m] Size Bin centers - real(r8) :: sz_dlt(sz_nbr) ! [m] Size Bin widths - - ! constants - real(r8), allocatable :: dmt_vma_src(:) ! [m] Mass median diameter BSM96 p. 73 Table 2 - real(r8), allocatable :: gsd_anl_src(:) ! [frc] Geometric std deviation BSM96 p. 73 Table 2 - real(r8), allocatable :: mss_frc_src(:) ! [frc] Mass fraction BSM96 p. 73 Table 2 - - real(r8) :: dmt_grd(5) = & ! [m] Particle diameter grid - (/ 0.1e-6_r8, 1.0e-6_r8, 2.5e-6_r8, 5.0e-6_r8, 10.0e-6_r8 /) - real(r8), parameter :: dmt_slt_opt = 75.0e-6_r8 ! [m] Optim diam for saltation - real(r8), parameter :: dns_slt = 2650.0_r8 ! [kg m-3] Density of optimal saltation particles - !------------------------------------------------------------------------ - - associate(& - mbl_bsn_fct => this%mbl_bsn_fct_col & ! Output: [real(r8) (:)] basin factor - ) - - ! allocate module variable - allocate (ovr_src_snk_mss(dst_src_nbr,ndst)) - allocate (dmt_vwr(ndst)) - allocate (stk_crc(ndst)) - - ! allocate local variable - allocate (dmt_vma_src(dst_src_nbr)) - allocate (gsd_anl_src(dst_src_nbr)) - allocate (mss_frc_src(dst_src_nbr)) - - dmt_vma_src(:) = (/ 0.832e-6_r8 , 4.82e-6_r8 , 19.38e-6_r8 /) - gsd_anl_src(:) = (/ 2.10_r8 , 1.90_r8 , 1.60_r8 /) - mss_frc_src(:) = (/ 0.036_r8 , 0.957_r8 , 0.007_r8 /) - - ! the following comes from (1) szdstlgn.F subroutine ovr_src_snk_frc_get - ! and (2) dstszdst.F subroutine dst_szdst_ini - ! purpose(1): given one set (the "source") of lognormal distributions, - ! and one set of bin boundaries (the "sink"), compute and return - ! the overlap factors between the source and sink distributions - ! purpose(2): set important statistics of size distributions - - do m = 1, dst_src_nbr - sqrt2lngsdi = sqrt(2.0_r8) * log(gsd_anl_src(m)) - do n = 1, ndst - lndmaxjovrdmdni = log(dmt_grd(n+1)/dmt_vma_src(m)) - lndminjovrdmdni = log(dmt_grd(n )/dmt_vma_src(m)) - ovr_src_snk_frc = 0.5_r8 * (erf(lndmaxjovrdmdni/sqrt2lngsdi) - & - erf(lndminjovrdmdni/sqrt2lngsdi)) - ovr_src_snk_mss(m,n) = ovr_src_snk_frc * mss_frc_src(m) - end do - end do - - ! The following code from subroutine wnd_frc_thr_slt_get was placed - ! here because tmp1 needs to be defined just once - - ryn_nbr_frc_thr_prx_opt = 0.38_r8 + 1331.0_r8 * (100.0_r8*dmt_slt_opt)**1.56_r8 - - if (ryn_nbr_frc_thr_prx_opt < 0.03_r8) then - write(iulog,*) 'dstmbl: ryn_nbr_frc_thr_prx_opt < 0.03' - call endrun(msg=errMsg(sourcefile, __LINE__)) - else if (ryn_nbr_frc_thr_prx_opt < 10.0_r8) then - ryn_nbr_frc_thr_opt_fnc = -1.0_r8 + 1.928_r8 * (ryn_nbr_frc_thr_prx_opt**0.0922_r8) - ryn_nbr_frc_thr_opt_fnc = 0.1291_r8 * 0.1291_r8 / ryn_nbr_frc_thr_opt_fnc - else - ryn_nbr_frc_thr_opt_fnc = 1.0_r8 - 0.0858_r8 * exp(-0.0617_r8*(ryn_nbr_frc_thr_prx_opt-10.0_r8)) - ryn_nbr_frc_thr_opt_fnc = 0.120_r8 * 0.120_r8 * ryn_nbr_frc_thr_opt_fnc * ryn_nbr_frc_thr_opt_fnc - end if - - icf_fct = 1.0_r8 + 6.0e-07_r8 / (dns_slt * grav * (dmt_slt_opt**2.5_r8)) - dns_fct = dns_slt * grav * dmt_slt_opt - tmp1 = sqrt(icf_fct * dns_fct * ryn_nbr_frc_thr_opt_fnc) - - ! Introducing particle diameter. Needed by atm model and by dry dep model. - ! Taken from Charlie Zender's subroutines dst_psd_ini, dst_sz_rsl, - ! grd_mk (dstpsd.F90) and subroutine lgn_evl (psdlgn.F90) - - ! Charlie allows logarithmic or linear option for size distribution - ! however, he hardwires the distribution to logarithmic in his code - ! therefore, I take his logarithmic code only - ! furthermore, if dst_nbr == 4, he overrides the automatic grid calculation - ! he currently works with dst_nbr = 4, so I only take the relevant code - ! if ndst ever becomes different from 4, must add call grd_mk (dstpsd.F90) - ! as done in subroutine dst_psd_ini - ! note that here ndst = dst_nbr - - ! Override automatic grid with preset grid if available - - if (ndst == 4) then - do n = 1, ndst - dmt_min(n) = dmt_grd(n) ![m] Max diameter in bin - dmt_max(n) = dmt_grd(n+1) ![m] Min diameter in bin - dmt_ctr(n) = 0.5_r8 * (dmt_min(n)+dmt_max(n)) ![m] Diameter at bin ctr - dmt_dlt(n) = dmt_max(n)-dmt_min(n) ![m] Width of size bin - end do - else - write(iulog,*) 'Dustini error: ndst must equal to 4 with current code' - call endrun(msg=errMsg(sourcefile, __LINE__)) - !see more comments above end if ndst == 4 - end if - - ! Bin physical properties - - gsd_anl = 2.0_r8 ! [frc] Geometric std dev PaG77 p. 2080 Table1 - ln_gsd = log(gsd_anl) - dns_aer = 2.5e+3_r8 ! [kg m-3] Aerosol density - - ! Set a fundamental statistic for each bin - - dmt_vma = 3.5000e-6_r8 ! [m] Mass median diameter analytic She84 p.75 Table1 - - ! Compute analytic size statistics - ! Convert mass median diameter to number median diameter (call vma2nma) - - dmt_nma = dmt_vma * exp(-3.0_r8*ln_gsd*ln_gsd) ! [m] - - ! Compute resolved size statistics for each size distribution - ! In C. Zender's code call dst_sz_rsl - - do n = 1, ndst - - series_ratio = (dmt_max(n)/dmt_min(n))**(1.0_r8/sz_nbr) - sz_min(1) = dmt_min(n) - do m = 2, sz_nbr ! Loop starts at 2 - sz_min(m) = sz_min(m-1) * series_ratio - end do - - ! Derived grid values - do m = 1, sz_nbr-1 ! Loop ends at sz_nbr-1 - sz_max(m) = sz_min(m+1) ! [m] - end do - sz_max(sz_nbr) = dmt_max(n) ! [m] - - ! Final derived grid values - do m = 1, sz_nbr - sz_ctr(m) = 0.5_r8 * (sz_min(m)+sz_max(m)) - sz_dlt(m) = sz_max(m)-sz_min(m) - end do - - lngsdsqrttwopi_rcp = 1.0_r8 / (ln_gsd*sqrt(2.0_r8*SHR_CONST_PI)) - dmt_vwr(n) = 0.0_r8 ! [m] Mass wgted diameter resolved - vlm_rsl(n) = 0.0_r8 ! [m3 m-3] Volume concentration resolved - - do m = 1, sz_nbr - - ! Evaluate lognormal distribution for these sizes (call lgn_evl) - tmp = log(sz_ctr(m)/dmt_nma) / ln_gsd - lgn_dst = lngsdsqrttwopi_rcp * exp(-0.5_r8*tmp*tmp) / sz_ctr(m) - - ! Integrate moments of size distribution - dmt_vwr(n) = dmt_vwr(n) + sz_ctr(m) * & - SHR_CONST_PI / 6.0_r8 * (sz_ctr(m)**3.0_r8) * & ![m3] Volume - lgn_dst * sz_dlt(m) ![# m-3] Number concentrn - vlm_rsl(n) = vlm_rsl(n) + & - SHR_CONST_PI / 6.0_r8 * (sz_ctr(m)**3.0_r8) * & ![m3] Volume - lgn_dst * sz_dlt(m) ![# m-3] Number concentrn - - end do - - dmt_vwr(n) = dmt_vwr(n) / vlm_rsl(n) ![m] Mass weighted diameter resolved - - end do - - ! calculate correction to Stokes' settling velocity (subroutine stk_crc_get) - - eps_max = 1.0e-4_r8 - dns_mdp = 100000._r8 / (295.0_r8*SHR_CONST_RDAIR) ![kg m-3] const prs_mdp & tpt_vrt - - ! Size-independent thermokinetic properties - - vsc_dyn_atm = 1.72e-5_r8 * ((295.0_r8/273.0_r8)**1.5_r8) * 393.0_r8 / & - (295.0_r8+120.0_r8) ![kg m-1 s-1] RoY94 p.102 tpt_mdp=295.0 - mfp_atm = 2.0_r8 * vsc_dyn_atm / & !SeP97 p. 455 constant prs_mdp, tpt_mdp - (100000._r8*sqrt(8.0_r8/(SHR_CONST_PI*SHR_CONST_RDAIR*295.0_r8))) - vsc_knm_atm = vsc_dyn_atm / dns_mdp ![m2 s-1] Kinematic viscosity of air - - do m = 1, ndst - slp_crc(m) = 1.0_r8 + 2.0_r8 * mfp_atm * & - (1.257_r8+0.4_r8*exp(-1.1_r8*dmt_vwr(m)/(2.0_r8*mfp_atm))) / & - dmt_vwr(m) ! [frc] Slip correction factor SeP97 p.464 - vlc_stk(m) = (1.0_r8/18.0_r8) * dmt_vwr(m) * dmt_vwr(m) * dns_aer * & - grav * slp_crc(m) / vsc_dyn_atm ! [m s-1] SeP97 p.466 - end do - - ! For Reynolds number flows Re < 0.1 Stokes' velocity is valid for - ! vlc_grv SeP97 p. 466 (8.42). For larger Re, inertial effects become - ! important and empirical drag coefficients must be employed - ! Implicit equation for Re, Cd, and Vt is SeP97 p. 467 (8.44) - ! Using Stokes' velocity rather than iterative solution with empirical - ! drag coefficient causes 60% errors for D = 200 um SeP97 p. 468 - - ! Iterative solution for drag coefficient, Reynolds number, and terminal veloc - do m = 1, ndst - - ! Initialize accuracy and counter - eps_crr = eps_max + 1.0_r8 ![frc] Current relative accuracy - itr_idx = 0 ![idx] Counting index - - ! Initial guess for vlc_grv is exact for Re < 0.1 - vlc_grv(m) = vlc_stk(m) ![m s-1] - - do while(eps_crr > eps_max) - - ! Save terminal velocity for convergence test - vlc_grv_old = vlc_grv(m) ![m s-1] - ryn_nbr_grv(m) = vlc_grv(m) * dmt_vwr(m) / vsc_knm_atm !SeP97 p.460 - - ! Update drag coefficient based on new Reynolds number - if (ryn_nbr_grv(m) < 0.1_r8) then - cff_drg_grv(m) = 24.0_r8 / ryn_nbr_grv(m) !Stokes' law Sep97 p.463 (8.32) - else if (ryn_nbr_grv(m) < 2.0_r8) then - cff_drg_grv(m) = (24.0_r8/ryn_nbr_grv(m)) * & - (1.0_r8 + 3.0_r8*ryn_nbr_grv(m)/16.0_r8 + & - 9.0_r8*ryn_nbr_grv(m)*ryn_nbr_grv(m)* & - log(2.0_r8*ryn_nbr_grv(m))/160.0_r8) !Sep97 p.463 (8.32) - else if (ryn_nbr_grv(m) < 500.0_r8) then - cff_drg_grv(m) = (24.0_r8/ryn_nbr_grv(m)) * & - (1.0_r8 + 0.15_r8*ryn_nbr_grv(m)**0.687_r8) !Sep97 p.463 (8.32) - else if (ryn_nbr_grv(m) < 2.0e5_r8) then - cff_drg_grv(m) = 0.44_r8 !Sep97 p.463 (8.32) - else - write(iulog,'(a,es9.2)') "ryn_nbr_grv(m) = ",ryn_nbr_grv(m) - write(iulog,*)'Dustini error: Reynolds number too large in stk_crc_get()' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Update terminal velocity based on new Reynolds number and drag coeff - ! [m s-1] Terminal veloc SeP97 p.467 (8.44) - - vlc_grv(m) = sqrt(4.0_r8 * grav * dmt_vwr(m) * slp_crc(m) * dns_aer / & - (3.0_r8*cff_drg_grv(m)*dns_mdp)) - eps_crr = abs((vlc_grv(m)-vlc_grv_old)/vlc_grv(m)) !Relative convergence - if (itr_idx == 12) then - ! Numerical pingpong may occur when Re = 0.1, 2.0, or 500.0 - ! due to discontinuities in derivative of drag coefficient - vlc_grv(m) = 0.5_r8 * (vlc_grv(m)+vlc_grv_old) ! [m s-1] - end if - if (itr_idx > 20) then - write(iulog,*) 'Dustini error: Terminal velocity not converging ',& - ' in stk_crc_get(), breaking loop...' - goto 100 !to next iteration - end if - itr_idx = itr_idx + 1 - - end do !end while - -100 continue !Label to jump to when iteration does not converge - end do !end loop over size - - ! Compute factors to convert Stokes' settling velocities to - ! actual settling velocities - - do m = 1, ndst - stk_crc(m) = vlc_grv(m) / vlc_stk(m) - end do - - end associate - - end subroutine InitDustVars - -end module DUSTMod diff --git a/src/biogeochem/DryDepVelocity.F90 b/src/biogeochem/DryDepVelocity.F90 deleted file mode 100644 index 603e9d24..00000000 --- a/src/biogeochem/DryDepVelocity.F90 +++ /dev/null @@ -1,678 +0,0 @@ -Module DryDepVelocity - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Deposition velocity (m/s) - ! - ! Method: - ! This code simulates dry deposition velocities using the Wesely scheme. - ! Details of this method can be found in: - ! - ! M.L Wesely. Parameterization of surface resistances to gaseous dry deposition - ! in regional-scale numericl models. 1989. Atmospheric Environment vol.23 No.6 - ! pp. 1293-1304. - ! - ! In Wesely (1998) "the magnitude of the dry deposition velocity can be found - ! as: - ! - ! |vd|=(ra+rb+rc)^-1 - ! - ! where ra is the aerodynamic resistance (common to all gases) between a - ! specific height and the surface, rb is the quasilaminar sublayer resistance - ! (whose only dependence on the porperties of the gas of interest is its - ! molecular diffusivity in air), and rc is the bulk surface resistance". - ! - ! In this subroutine both ra and rb are calculated elsewhere in CLM. - ! - ! In Wesely (1989) rc is estimated for five seasonal categories and 11 landuse - ! types. For each season and landuse type, Wesely compiled data into a - ! look-up-table for several parameters used to calculate rc. In this subroutine - ! the same values are used as found in wesely's look-up-tables, the only - ! difference is that this subroutine uses a CLM generated LAI to select values - ! from the look-up-table instead of seasonality. Inaddition, Wesely(1989) - ! land use types are "mapped" into CLM patch types. - ! - ! Subroutine written to operate at the patch level. - ! - ! Output: - ! - ! vd(n_species) !Dry deposition velocity [m s-1] for each molecule or species - ! - ! Author: Beth Holland and James Sulzman - ! - ! Modified: Francis Vitt -- 30 Mar 2007 - ! Modified: Maria Val Martin -- 15 Jan 2014 - ! Corrected major bugs in the leaf and stomatal resitances. The code is now - ! coupled to LAI and Rs uses the Ball-Berry Scheme. Also, corrected minor - ! bugs in rlu and rcl calculations. Added - ! no vegetation removal for CO. See README for details and - ! Val Martin et al., 2014 GRL for major corrections - ! Modified: Louisa Emmons -- 30 November 2017 - ! Corrected the equation calculating stomatal resistance from rssun and rssha, - ! and removed factor that scaled Rs to match observations - ! - !----------------------------------------------------------------------- - - use shr_log_mod , only : errMsg => shr_log_errMsg - use shr_kind_mod , only : r8 => shr_kind_r8 - use abortutils , only : endrun - use clm_time_manager , only : get_nstep, get_curr_date, get_curr_time - use spmdMod , only : masterproc - use seq_drydep_mod , only : n_drydep, drydep_list - use seq_drydep_mod , only : drydep_method, DD_XLND - use seq_drydep_mod , only : index_o3=>o3_ndx, index_o3a=>o3a_ndx, index_so2=>so2_ndx, index_h2=>h2_ndx - use seq_drydep_mod , only : index_co=>co_ndx, index_ch4=>ch4_ndx, index_pan=>pan_ndx - use seq_drydep_mod , only : index_xpan=>xpan_ndx - use decompMod , only : bounds_type - use clm_varcon , only : namep - use atm2lndType , only : atm2lnd_type - use CanopyStateType , only : canopystate_type - use FrictionVelocityMod , only : frictionvel_type - use PhotosynthesisMod , only : photosyns_type - use WaterstateType , only : waterstate_type - use GridcellType , only : grc - use LandunitType , only : lun - use PatchType , only : patch - ! - implicit none - private - ! - public :: depvel_compute - ! - type, public :: drydepvel_type - - real(r8), pointer, public :: velocity_patch (:,:) ! Dry Deposition Velocity - real(r8), pointer, private :: rs_drydep_patch (:) ! Stomatal resistance associated with dry deposition velocity for Ozone - - contains - - procedure , public :: Init - procedure , private :: InitAllocate - procedure , private :: InitHistory - - end type drydepvel_type - !----------------------------------------------------------------------- - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -CONTAINS - - !------------------------------------------------------------------------ - subroutine Init(this, bounds) - - class(drydepvel_type) :: this - type(bounds_type), intent(in) :: bounds - - call this%InitAllocate(bounds) - call this%InitHistory(bounds) - - end subroutine Init - - !------------------------------------------------------------------------ - subroutine InitAllocate(this, bounds) - ! - ! !USES: - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use seq_drydep_mod , only : n_drydep, drydep_method, DD_XLND - ! - ! !ARGUMENTS: - class(drydepvel_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begp, endp - !------------------------------------------------------------------------ - - begp = bounds%begp; endp= bounds%endp - - ! Dry Deposition Velocity - if ( n_drydep > 0 .and. drydep_method == DD_XLND )then - allocate(this%velocity_patch(begp:endp, n_drydep)); this%velocity_patch(:,:) = nan - allocate(this%rs_drydep_patch(begp:endp)) ; this%rs_drydep_patch(:) = nan - end if - - end subroutine InitAllocate - - !----------------------------------------------------------------------- - subroutine InitHistory(this, bounds) - ! - ! !DESCRIPTION: - ! Initialize history output fields for dry deposition diagnositics - ! - ! !USES - use clm_varcon , only : spval - use histFileMod , only : hist_addfld1d - use seq_drydep_mod , only : mapping - ! - ! !ARGUMENTS: - class(drydepvel_type) :: this - type(bounds_type), intent(in) :: bounds - real(r8), pointer :: ptr_1d(:) ! pointer to 1d patch array - ! - ! !LOCAL VARIABLES - integer :: ispec - integer :: begp, endp - !--------------------------------------------------------------------- - - begp = bounds%begp; endp = bounds%endp - - if ( n_drydep == 0 .or. drydep_method /= DD_XLND ) return - - do ispec=1,n_drydep - if(mapping(ispec) <= 0) cycle - - this%velocity_patch(begp:endp,ispec)= spval - ptr_1d => this%velocity_patch(begp:endp,ispec) - call hist_addfld1d ( fname='DRYDEPV_'//trim(drydep_list(ispec)), units='cm/sec', & - avgflag='A', long_name='Dry Deposition Velocity', & - ptr_patch=ptr_1d, default='inactive' ) - end do - - this%rs_drydep_patch(begp:endp)= spval - call hist_addfld1d ( fname='RS_DRYDEP_O3', units='s/m', & - avgflag='A', long_name='Stomatal Resistance Associated with Ozone Dry Deposition Velocity', & - ptr_patch=this%rs_drydep_patch, default='inactive' ) - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine depvel_compute( bounds, & - atm2lnd_inst, canopystate_inst, waterstate_inst, frictionvel_inst, & - photosyns_inst, drydepvel_inst) - ! - ! !DESCRIPTION: - ! computes the dry deposition velocity of tracers - ! - ! !USES: - use shr_const_mod , only : tmelt => shr_const_tkfrz - use seq_drydep_mod , only : seq_drydep_setHCoeff, mapping, drat, foxd - use seq_drydep_mod , only : rcls, h2_a, h2_b, h2_c, ri, rac, rclo, rlu, rgss, rgso - use landunit_varcon, only : istsoil, istice_mec, istdlak, istwet - use clm_varctl , only : iulog - use pftconMod , only : noveg, ndllf_evr_tmp_tree, ndllf_evr_brl_tree - use pftconMod , only : ndllf_dcd_brl_tree, nbrdlf_evr_trp_tree - use pftconMod , only : nbrdlf_evr_tmp_tree, nbrdlf_dcd_trp_tree - use pftconMod , only : nbrdlf_dcd_tmp_tree, nbrdlf_dcd_brl_tree - use pftconMod , only : nbrdlf_evr_shrub, nbrdlf_dcd_tmp_shrub - use pftconMod , only : nbrdlf_dcd_brl_shrub,nc3_arctic_grass - use pftconMod , only : nc3_nonarctic_grass, nc4_grass, nc3crop - use pftconMod , only : nc3irrig, npcropmin, npcropmax - use clm_varcon , only : spval - - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(canopystate_type) , intent(in) :: canopystate_inst - type(waterstate_type) , intent(in) :: waterstate_inst - type(frictionvel_type) , intent(in) :: frictionvel_inst - type(photosyns_type) , intent(in) :: photosyns_inst - type(drydepvel_type) , intent(inout) :: drydepvel_inst - ! - ! !LOCAL VARIABLES: - integer :: c - real(r8) :: soilw, var_soilw, fact_h2, dv_soil_h2 - integer :: pi,g, l - integer :: ispec - integer :: length - integer :: wesveg !wesely vegegation index - integer :: clmveg !clm veg index from ivegtype - integer :: i - integer :: index_season !seasonal index based on LAI. This indexs wesely data tables - integer :: nstep !current step - integer :: indexp - - real(r8) :: pg ! surface pressure - real(r8) :: tc ! temperature in celsius - real(r8) :: es ! saturation vapor pressur - real(r8) :: ws ! saturation mixing ratio - real(r8) :: rmx ! resistance by vegetation - real(r8) :: qs ! saturation specific humidity - real(r8) :: dewm ! multiplier for rs when dew occurs - real(r8) :: crs ! multiplier to calculate crs - real(r8) :: rdc ! part of lower canopy resistance - real(r8) :: rain ! rain fall - real(r8) :: spec_hum ! specific humidity - real(r8) :: solar_flux ! solar radiation(direct beam) W/m2 - real(r8) :: lat ! latitude in degrees - real(r8) :: lon ! longitude in degrees - real(r8) :: sfc_temp ! surface temp - real(r8) :: minlai ! minimum of monthly lai - real(r8) :: maxlai ! maximum of monthly lai - real(r8) :: rds ! resistance for aerosols - - !mvm 11/30/2013 - real(r8) :: rlu_lai ! constant to calculate rlu over bulk canopy - - logical :: has_dew - logical :: has_rain - real(r8), parameter :: rain_threshold = 1.e-7_r8 ! of the order of 1cm/day expressed in m/s - - ! local arrays: dependent on species only - real(r8), dimension(n_drydep) :: rsmx !vegetative resistance (plant mesophyll) - real(r8), dimension(n_drydep) :: rclx !lower canopy resistance - real(r8), dimension(n_drydep) :: rlux !vegetative resistance (upper canopy) - real(r8), dimension(n_drydep) :: rgsx !gournd resistance - real(r8), dimension(n_drydep) :: heff - real(r8) :: rs ! stomatal resistance associated with dry deposition velocity (s/m) - real(r8) :: rc !combined surface resistance - real(r8) :: cts !correction to flu rcl and rgs for frost - real(r8) :: rlux_o3 !to calculate O3 leaf resistance in dew/rain conditions - - ! constants - real(r8), parameter :: slope = 0._r8 ! Used to calculate rdc in (lower canopy resistance) - integer, parameter :: wveg_unset = -1 ! Unset Wesley vegetation type - character(len=32), parameter :: subname = "depvel_compute" - - ! jfl : mods for PAN - real(r8) :: dv_pan - real(r8) :: c0_pan(11) = (/ 0.000_r8, 0.006_r8, 0.002_r8, 0.009_r8, 0.015_r8, & - 0.006_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.002_r8, 0.002_r8 /) - real(r8) :: k_pan (11) = (/ 0.000_r8, 0.010_r8, 0.005_r8, 0.004_r8, 0.003_r8, & - 0.005_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.075_r8, 0.002_r8 /) - !----------------------------------------------------------------------- - - if ( n_drydep == 0 .or. drydep_method /= DD_XLND ) return - - associate( & - forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (visible only) - forc_solad => atm2lnd_inst%forc_solad_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (visible only) - forc_t => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:) ] downscaled atmospheric temperature (Kelvin) - forc_q => atm2lnd_inst%forc_q_downscaled_col , & ! Input: [real(r8) (:) ] downscaled atmospheric specific humidity (kg/kg) - forc_psrf => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] downscaled surface pressure (Pa) - forc_rain => atm2lnd_inst%forc_rain_downscaled_col , & ! Input: [real(r8) (:) ] downscaled rain rate [mm/s] - - h2osoi_vol => waterstate_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) - snow_depth => waterstate_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) - - ram1 => frictionvel_inst%ram1_patch , & ! Input: [real(r8) (:) ] aerodynamical resistance - rb1 => frictionvel_inst%rb1_patch , & ! Input: [real(r8) (:) ] leaf boundary layer resistance [s/m] - vds => frictionvel_inst%vds_patch , & ! Input: [real(r8) (:) ] aerodynamical resistance - - rssun => photosyns_inst%rssun_patch , & ! Input: [real(r8) (:) ] stomatal resistance - rssha => photosyns_inst%rssha_patch , & ! Input: [real(r8) (:) ] shaded stomatal resistance (s/m) - - fsun => canopystate_inst%fsun_patch , & ! Input: [real(r8) (:) ] sunlit fraction of canopy - elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow - mlaidiff => canopystate_inst%mlaidiff_patch , & ! Input: [real(r8) (:) ] difference in lai between month one and month two - annlai => canopystate_inst%annlai_patch , & ! Input: [real(r8) (:,:) ] 12 months of monthly lai from input data set - - velocity => drydepvel_inst%velocity_patch , & ! Output: [real(r8) (:,:) ] cm/sec - rs_drydep => drydepvel_inst%rs_drydep_patch & ! Output: [real(r8) (:) ] stomatal resistance associated with Ozone dry deposition velocity (s/m) - ) - - !_________________________________________________________________ - ! Begin loop through patches - - pft_loop: do pi = bounds%begp,bounds%endp - l = patch%landunit(pi) - - active: if (patch%active(pi)) then - - c = patch%column(pi) - g = patch%gridcell(pi) - pg = forc_psrf(c) - spec_hum = forc_q(c) - rain = forc_rain(c) - sfc_temp = forc_t(c) - solar_flux = forc_solad(g,1) - lat = grc%latdeg(g) - lon = grc%londeg(g) - clmveg = patch%itype(pi) - soilw = h2osoi_vol(c,1) - - !map CLM veg type into Wesely veg type - wesveg = wveg_unset - if (clmveg == noveg ) wesveg = 8 - if (clmveg == ndllf_evr_tmp_tree ) wesveg = 5 - if (clmveg == ndllf_evr_brl_tree ) wesveg = 5 - if (clmveg == ndllf_dcd_brl_tree ) wesveg = 5 - if (clmveg == nbrdlf_evr_trp_tree ) wesveg = 4 - if (clmveg == nbrdlf_evr_tmp_tree ) wesveg = 4 - if (clmveg == nbrdlf_dcd_trp_tree ) wesveg = 4 - if (clmveg == nbrdlf_dcd_tmp_tree ) wesveg = 4 - if (clmveg == nbrdlf_dcd_brl_tree ) wesveg = 4 - if (clmveg == nbrdlf_evr_shrub ) wesveg = 11 - if (clmveg == nbrdlf_dcd_tmp_shrub ) wesveg = 11 - if (clmveg == nbrdlf_dcd_brl_shrub ) wesveg = 11 - if (clmveg == nc3_arctic_grass ) wesveg = 3 - if (clmveg == nc3_nonarctic_grass ) wesveg = 3 - if (clmveg == nc4_grass ) wesveg = 3 - if (clmveg == nc3crop ) wesveg = 2 - if (clmveg == nc3irrig ) wesveg = 2 - if (clmveg >= npcropmin .and. clmveg <= npcropmax ) wesveg = 2 - if (wesveg == wveg_unset )then - write(iulog,*) 'clmveg = ', clmveg, 'lun%itype = ', lun%itype(l) - call endrun(decomp_index=pi, clmlevel=namep, & - msg='ERROR: Not able to determine Wesley vegetation type'//& - errMsg(sourcefile, __LINE__)) - end if - - ! create seasonality index used to index wesely data tables from LAI, Bascially - !if elai is between max lai from input data and half that max the index_season=1 - - - !mail1j and mlai2j are the two monthly lai values pulled from a CLM input data set - !/fs/cgd/csm/inputdata/lnd/clm2/rawdata/mksrf_lai.nc. lai for dates in the middle - !of the month are interpolated using using these values and stored in the variable - !elai (done elsewhere). If the difference between mlai1j and mlai2j is greater - !than zero it is assumed to be fall and less than zero it is assumed to be spring. - - !wesely seasonal "index_season" - ! 1 - midsummer with lush vegetation - ! 2 - Autumn with unharvested cropland - ! 3 - Late autumn after frost, no snow - ! 4 - Winter, snow on ground and subfreezing - ! 5 - Transitional spring with partially green short annuals - - - !mlaidiff=jan-feb - minlai=minval(annlai(:,pi)) - maxlai=maxval(annlai(:,pi)) - - index_season = -1 - - if ( lun%itype(l) /= istsoil )then - if ( lun%itype(l) == istice_mec ) then - wesveg = 8 - index_season = 4 - elseif ( lun%itype(l) == istdlak ) then - wesveg = 7 - index_season = 4 - elseif ( lun%itype(l) == istwet ) then - wesveg = 9 - index_season = 2 - elseif ( lun%urbpoi(l) ) then - wesveg = 1 - index_season = 2 - end if - else if ( snow_depth(c) > 0 ) then - index_season = 4 - else if(elai(pi) > 0.5_r8*maxlai) then - index_season = 1 - endif - - if (index_season<0) then - if (elai(pi) < (minlai+0.05*(maxlai-minlai))) then - index_season = 3 - endif - endif - - if (index_season<0) then - if (mlaidiff(pi) > 0.0_r8) then - index_season = 2 - elseif (mlaidiff(pi) < 0.0_r8) then - index_season = 5 - elseif (mlaidiff(pi).eq.0.0_r8) then - index_season = 3 - endif - endif - - if (index_season<0) then - call endrun('ERROR: not able to determine season'//errmsg(sourcefile, __LINE__)) - endif - - ! saturation specific humidity - ! - es = 611_r8*exp(5414.77_r8*((1._r8/tmelt)-(1._r8/sfc_temp))) - ws = .622_r8*es/(pg-es) - qs = ws/(1._r8+ws) - - has_dew = .false. - if( qs <= spec_hum ) then - has_dew = .true. - end if - if( sfc_temp < tmelt ) then - has_dew = .false. - end if - - has_rain = rain > rain_threshold - - if ( has_dew .or. has_rain ) then - dewm = 3._r8 - else - dewm = 1._r8 - end if - - !Define tc - tc = sfc_temp - tmelt - - ! - ! rdc (lower canopy res) - ! - rdc=100._r8*(1._r8+1000._r8/(solar_flux+10._r8))/(1._r8+1000._r8*slope) - - ! surface resistance : depends on both land type and species - ! land types are computed seperately, then resistance is computed as average of values - ! following wesely rc=(1/(rs+rm) + 1/rlu +1/(rdc+rcl) + 1/(rac+rgs))**-1 - - !******************************************************* - call seq_drydep_setHCoeff( sfc_temp, heff(:n_drydep) ) - !********************************************************* - - species_loop1: do ispec=1, n_drydep - if(mapping(ispec) <= 0) cycle - - if(ispec.eq.index_o3.or.ispec.eq.index_o3a.or.ispec.eq.index_so2) then - rmx=0._r8 - else - rmx=1._r8/((heff(ispec)/3000._r8)+(100._r8*foxd(ispec))) - endif - - ! correction for frost - cts = 1000._r8*exp( -tc - 4._r8 ) - - !ground resistance - rgsx(ispec) = 1._r8/((heff(ispec)/(1.e5_r8*(rgss(index_season,wesveg)+cts))) + & - (foxd(ispec)/(rgso(index_season,wesveg)+cts))) - - !------------------------------------------------------------------------------------- - ! special case for H2 and CO;; CH4 is set ot a fraction of dv(H2) - !------------------------------------------------------------------------------------- - if( ispec == index_h2 .or. ispec == index_co .or. ispec == index_ch4 ) then - - if( ispec == index_co ) then - fact_h2 = 1.0_r8 - elseif ( ispec == index_h2 ) then - fact_h2 = 0.5_r8 - elseif ( ispec == index_ch4 ) then - fact_h2 = 50.0_r8 - end if - - !------------------------------------------------------------------------------------- - ! no deposition on snow, ice, desert, and water - !------------------------------------------------------------------------------------- - if( wesveg == 1 .or. wesveg == 7 .or. wesveg == 8 .or. index_season == 4 ) then - rgsx(ispec) = spval - else - var_soilw = max( .1_r8,min( soilw,.3_r8 ) ) - if( wesveg == 3 ) then - var_soilw = log( var_soilw ) - end if - dv_soil_h2 = h2_c(wesveg) + var_soilw*(h2_b(wesveg) + var_soilw*h2_a(wesveg)) - if( dv_soil_h2 > 0._r8 ) then - rgsx(ispec) = fact_h2/(dv_soil_h2*1.e-4_r8) - end if - end if - end if - - !------------------------------------------------------------------------------------- - ! no deposition on water or no vegetation or snow (elai<=0) - !------------------------------------------------------------------------------------- - - no_dep: if( wesveg == 7 .or. elai(pi).le.0_r8 ) then !mvm 11/26/2013 - rclx(ispec) = spval - rsmx(ispec) = spval - rlux(ispec) = spval - rs = spval - else - - !Stomatal resistance - - ! fvitt -- at midnight rssun and/or rssha can be zero in some places which sets rs to zero - ! --- this fix prevents divide by zero error (when rsmx is zero) - if (rssun(pi)>0._r8 .and. rssun(pi)<1.e30 .and. rssha(pi)>0._r8 .and. rssha(pi)<1.e30 ) then - !LKE: corrected rs to add rssun and rssha in parallel (11/30/2017) - rs=1._r8/(fsun(pi)*elai(pi)/rssun(pi) + (1.-fsun(pi))*elai(pi)/rssha(pi)) - else - rs=spval - endif - - rsmx(ispec) = rs*drat(ispec)+rmx - - ! Leaf resistance - !MVM: adjusted rlu by LAI to get leaf resistance over bulk canopy (gao and wesely, 1995) - rlu_lai=cts+rlu(index_season,wesveg)/elai(pi) - rlux(ispec) = rlu_lai/(1.e-5_r8*heff(ispec)+foxd(ispec)) - - !Lower canopy resistance - rclx(ispec) = 1._r8/((heff(ispec)/(1.e5_r8*(rcls(index_season,wesveg)+cts))) + & - (foxd(ispec)/(rclo(index_season,wesveg)+cts))) - - !----------------------------------- - !mvm 11/30/2013: special case for CO - !Dry deposition of CO and hydrocarbons is negligibly - !small in vegetation [Mueller and Brasseur, 1995]. - !------------------------------------ - if( ispec == index_co ) then - rclx(ispec) = spval - rsmx(ispec) = spval - rlux(ispec) = spval - endif - - !-------------------------------------------- - ! jfl : special case for PAN - !-------------------------------------------- - if( ispec == index_pan ) then - dv_pan = c0_pan(wesveg) * (1._r8 - exp(-k_pan(wesveg)*(rs*drat(ispec))*1.e-2_r8 )) - - if( dv_pan > 0._r8 .and. index_season /= 4 ) then - rsmx(ispec) = ( 1._r8/dv_pan ) - end if - end if - - endif no_dep - if ( ispec == index_o3 )then - rs_drydep(pi) = rs - end if - - end do species_loop1 - - - !---------------------------------------------- - !Adjustment for dew and rain in leaf resitances - !--------------------------------------------- - ! no effect over water - no_water: if( wesveg.ne.7 ) then - !MVM: effect only on vegetated areas (elai> 0) - with_LAI: if (elai(pi).gt.0._r8) then - - ! - ! no effect if sfc_temp < O C - ! - non_freezing: if(sfc_temp.gt.tmelt) then - if( has_dew ) then - rlu_lai=cts+rlu(index_season,wesveg)/elai(pi) - rlux_o3 = 1._r8/((1._r8/3000._r8)+(1._r8/(3._r8*rlu_lai))) - - if (index_o3 > 0) then - rlux(index_o3) = rlux_o3 - endif - if (index_o3a > 0) then - rlux(index_o3a) = rlux_o3 - endif - endif - - if(has_rain) then - rlu_lai=cts+rlu(index_season,wesveg)/elai(pi) - rlux_o3 = 1._r8/((1._r8/1000._r8)+(1._r8/(3._r8*rlu_lai))) - - if (index_o3 > 0) then - rlux(index_o3) = rlux_o3 - endif - if (index_o3a > 0) then - rlux(index_o3a) = rlux_o3 - endif - endif - - species_loop2: do ispec=1,n_drydep - if(mapping(ispec).le.0) cycle - if(ispec.ne.index_o3.and.ispec.ne.index_o3a.and.ispec.ne.index_so2) then - - if( has_dew .or. has_rain) then - rlu_lai=cts+rlu(index_season,wesveg)/elai(pi) - rlux(ispec)=1._r8/((1._r8/(3._r8*rlu_lai))+ & - (1.e-7_r8*heff(ispec))+(foxd(ispec)/rlux_o3)) - endif - - elseif(ispec.eq.index_so2) then - - if( has_dew ) then - rlux(ispec) = 100._r8 - endif - - if(has_rain) then - rlu_lai=cts+rlu(index_season,wesveg)/elai(pi) - rlux(ispec) = 1._r8/((1._r8/5000._r8)+(1._r8/(3._r8*rlu_lai))) - endif - - if( has_dew .or. has_rain ) then - !MVM:rlux=50 for SO2 in dew or rain only for *urban land* type surfaces. - if (wesveg.eq.1) then - rlux(ispec)=50._r8 - endif - endif - end if - !mvm 11/30/2013: special case for CO - if( ispec.eq.index_co ) then - rlux(ispec) = spval - endif - end do species_loop2 - endif non_freezing - endif with_LAI - endif no_water - - ! resistance for aerosols - rds = 1._r8/vds(pi) - - species_loop3: do ispec=1,n_drydep - if(mapping(ispec) <= 0) cycle - - ! - ! compute rc - ! - rc = 1._r8/((1._r8/rsmx(ispec))+(1._r8/rlux(ispec)) + & - (1._r8/(rdc+rclx(ispec)))+(1._r8/(rac(index_season,wesveg)+rgsx(ispec)))) - rc = max( 10._r8, rc) - ! - ! assume no surface resistance for SO2 over water - ! - if ( drydep_list(ispec) == 'SO2' .and. wesveg == 7 ) then - rc = 0._r8 - end if - - select case( drydep_list(ispec) ) - case ( 'SO4' ) - velocity(pi,ispec) = (1._r8/(ram1(pi)+rds))*100._r8 - case ( 'NH4','NH4NO3','XNH4NO3' ) - velocity(pi,ispec) = (1._r8/(ram1(pi)+0.5_r8*rds))*100._r8 - case ( 'Pb' ) - velocity(pi,ispec) = 0.2_r8 - case ( 'CB1', 'CB2', 'OC1', 'OC2', 'SOAM', 'SOAI', 'SOAT', 'SOAB', 'SOAX' ) - velocity(pi,ispec) = 0.10_r8 - case ( 'SO2' ) - velocity(pi,ispec) = (1._r8/(ram1(pi)+rb1(pi)+rc))*200._r8 - case default - velocity(pi,ispec) = (1._r8/(ram1(pi)+rb1(pi)+rc))*100._r8 - end select - end do species_loop3 - endif active - end do pft_loop - - end associate - - end subroutine depvel_compute - -end module DryDepVelocity diff --git a/src/biogeochem/SatellitePhenologyMod.F90 b/src/biogeochem/SatellitePhenologyMod.F90 deleted file mode 100644 index 6bb6e5f4..00000000 --- a/src/biogeochem/SatellitePhenologyMod.F90 +++ /dev/null @@ -1,684 +0,0 @@ -module SatellitePhenologyMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! CLM Satelitte Phenology model (SP) ecosystem dynamics (phenology, vegetation). - ! Allow some subroutines to be used by the CLM Carbon Nitrogen model (CLMCN) - ! so that DryDeposition code can get estimates of LAI differences between months. - ! - ! !USES: - use shr_strdata_mod , only : shr_strdata_type, shr_strdata_create - use shr_strdata_mod , only : shr_strdata_print, shr_strdata_advance - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_kind_mod , only : CL => shr_kind_CL - use shr_log_mod , only : errMsg => shr_log_errMsg - use decompMod , only : bounds_type - use abortutils , only : endrun - use clm_varctl , only : scmlat,scmlon,single_column - use clm_varctl , only : iulog, use_lai_streams - use clm_varcon , only : grlnd - use controlMod , only : NLFilename - use decompMod , only : gsmap_lnd_gdc2glo - use domainMod , only : ldomain - use fileutils , only : getavu, relavu - use PatchType , only : patch - use CanopyStateType , only : canopystate_type - use WaterstateType , only : waterstate_type - use perf_mod , only : t_startf, t_stopf - use spmdMod , only : masterproc - use spmdMod , only : mpicom, comp_id - use mct_mod - use ncdio_pio - ! - ! !PUBLIC TYPES: - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: SatellitePhenology ! CLMSP Ecosystem dynamics: phenology, vegetation - public :: SatellitePhenologyInit ! Dynamically allocate memory - public :: interpMonthlyVeg ! interpolate monthly vegetation data - public :: readAnnualVegetation ! Read in annual vegetation (needed for Dry-deposition) - ! - ! !PRIVATE MEMBER FUNCTIONS: - private :: readMonthlyVegetation ! read monthly vegetation data for two months - private :: lai_init ! position datasets for LAI - private :: lai_interp ! interpolates between two years of LAI data - - ! !PRIVATE MEMBER DATA: - type(shr_strdata_type) :: sdat_lai ! LAI input data stream - ! - ! !PRIVATE TYPES: - integer , private :: InterpMonths1 ! saved month index - real(r8), private :: timwt(2) ! time weights for month 1 and month 2 - real(r8), private, allocatable :: mlai2t(:,:) ! lai for interpolation (2 months) - real(r8), private, allocatable :: msai2t(:,:) ! sai for interpolation (2 months) - real(r8), private, allocatable :: mhvt2t(:,:) ! top vegetation height for interpolation (2 months) - real(r8), private, allocatable :: mhvb2t(:,:) ! bottom vegetation height for interpolation(2 months) - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - ! - ! lai_init - ! - !----------------------------------------------------------------------- - subroutine lai_init(bounds) - ! - ! Initialize data stream information for LAI. - ! - ! - ! !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 - use shr_stream_mod , only : shr_stream_file_null - use shr_string_mod , only : shr_string_listCreateField - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - ! - ! !LOCAL VARIABLES: - integer :: i ! index - integer :: stream_year_first_lai ! first year in Lai stream to use - integer :: stream_year_last_lai ! last year in Lai stream to use - integer :: model_year_align_lai ! align stream_year_first_lai 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_lai ! lai stream filename to read - character(len=CL) :: lai_mapalgo = 'bilinear' ! Mapping alogrithm - - character(*), parameter :: subName = "('laidyn_init')" - character(*), parameter :: F00 = "('(laidyn_init) ',4a)" - character(*), parameter :: laiString = "LAI" ! base string for field string - integer , parameter :: numLaiFields = 16 ! number of fields to build field string - character(SHR_KIND_CXX) :: fldList ! field string - !----------------------------------------------------------------------- - ! - ! deal with namelist variables here in init - ! - namelist /lai_streams/ & - stream_year_first_lai, & - stream_year_last_lai, & - model_year_align_lai, & - lai_mapalgo, & - stream_fldFileName_lai - - ! Default values for namelist - stream_year_first_lai = 1 ! first year in stream to use - stream_year_last_lai = 1 ! last year in stream to use - model_year_align_lai = 1 ! align stream_year_first_lai with this model year - stream_fldFileName_lai = shr_stream_file_null - - ! Read lai_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, 'lai_streams', status=nml_error) - if (nml_error == 0) then - read(nu_nml, nml=lai_streams,iostat=nml_error) - if (nml_error /= 0) then - call endrun(subname // ':: ERROR reading lai_streams namelist') - end if - else - write(iulog,*) "Could NOT find lai_streams namelist" - end if - close(nu_nml) - call relavu( nu_nml ) - endif - - call shr_mpi_bcast(stream_year_first_lai, mpicom) - call shr_mpi_bcast(stream_year_last_lai, mpicom) - call shr_mpi_bcast(model_year_align_lai, mpicom) - call shr_mpi_bcast(stream_fldFileName_lai, mpicom) - - if (masterproc) then - - write(iulog,*) ' ' - write(iulog,*) 'lai_stream settings:' - write(iulog,*) ' stream_year_first_lai = ',stream_year_first_lai - write(iulog,*) ' stream_year_last_lai = ',stream_year_last_lai - write(iulog,*) ' model_year_align_lai = ',model_year_align_lai - write(iulog,*) ' stream_fldFileName_lai = ',trim(stream_fldFileName_lai) - - endif - - call clm_domain_mct (bounds, dom_clm) - - ! - ! create the field list for these lai fields...use in shr_strdata_create - ! - fldList = shr_string_listCreateField( numLaiFields, laiString ) - - call shr_strdata_create(sdat_lai,name="laidyn", & - 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_lai, & - yearLast=stream_year_last_lai, & - yearAlign=model_year_align_lai, & - offset=0, & - domFilePath='', & - domFileName=trim(stream_fldFileName_lai), & - domTvarName='time', & - domXvarName='lon' , & - domYvarName='lat' , & - domAreaName='area', & - domMaskName='mask', & - filePath='', & - filename=(/stream_fldFileName_lai/), & - fldListFile=fldList, & - fldListModel=fldList, & - fillalgo='none', & - mapalgo=lai_mapalgo, & - calendar=get_calendar(), & - taxmode='cycle' ) - - if (masterproc) then - call shr_strdata_print(sdat_lai,'LAI data') - endif - - end subroutine lai_init - - !----------------------------------------------------------------------- - ! - ! lai_interp - ! - !----------------------------------------------------------------------- - subroutine lai_interp(bounds, canopystate_inst) - ! - ! Interpolate data stream information for Lai. - ! - ! !USES: - use clm_time_manager, only : get_curr_date - use pftconMod , only : noveg - ! - ! !ARGUMENTS: - implicit none - type(bounds_type) , intent(in) :: bounds - type(canopystate_type) , intent(inout) :: canopystate_inst - ! - ! !LOCAL VARIABLES: - integer :: ivt, p, g, ip, ig, gpft - 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) - character(len=CL) :: stream_var_name - !----------------------------------------------------------------------- - - call get_curr_date(year, mon, day, sec) - mcdate = year*10000 + mon*100 + day - - call shr_strdata_advance(sdat_lai, mcdate, sec, mpicom, 'laidyn') - - do p = bounds%begp, bounds%endp - ivt = patch%itype(p) - if (ivt /= noveg) then ! vegetated pft - write(stream_var_name,"(i6)") ivt - stream_var_name = 'LAI_'//trim(adjustl(stream_var_name)) - ip = mct_aVect_indexRA(sdat_lai%avs(1),trim(stream_var_name)) - endif - gpft = patch%gridcell(p) - - ! - ! Determine vector index corresponding to gpft - ! - ig = 0 - do g = bounds%begg,bounds%endg - ig = ig+1 - if (g == gpft) exit - end do - - ! - ! Set lai for each gridcell/patch combination - ! - if (ivt /= noveg) then ! vegetated pft - canopystate_inst%tlai_patch(p) = sdat_lai%avs(1)%rAttr(ip,ig) - else ! non-vegetated pft - canopystate_inst%tlai_patch(p) = 0._r8 - endif - end do - - end subroutine lai_interp - - !----------------------------------------------------------------------- - subroutine SatellitePhenologyInit (bounds) - ! - ! !DESCRIPTION: - ! Dynamically allocate memory and set to signaling NaN. - ! - ! !USES: - use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: ier ! error code - !----------------------------------------------------------------------- - - InterpMonths1 = -999 ! saved month index - - ier = 0 - if(.not.allocated(mlai2t)) then - allocate (mlai2t(bounds%begp:bounds%endp,2), & - msai2t(bounds%begp:bounds%endp,2), & - mhvt2t(bounds%begp:bounds%endp,2), & - mhvb2t(bounds%begp:bounds%endp,2), stat=ier) - end if - if (ier /= 0) then - write(iulog,*) 'EcosystemDynini allocation error' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - mlai2t(bounds%begp : bounds%endp, :) = nan - msai2t(bounds%begp : bounds%endp, :) = nan - mhvt2t(bounds%begp : bounds%endp, :) = nan - mhvb2t(bounds%begp : bounds%endp, :) = nan - - if (use_lai_streams) then - call lai_init(bounds) - endif - - end subroutine SatellitePhenologyInit - - !----------------------------------------------------------------------- - subroutine SatellitePhenology(bounds, num_nolakep, filter_nolakep, & - waterstate_inst, canopystate_inst) - ! - ! !DESCRIPTION: - ! Ecosystem dynamics: phenology, vegetation - ! Calculates leaf areas (tlai, elai), stem areas (tsai, esai) and height (htop). - ! - ! !USES: - use pftconMod, only : noveg, nbrdlf_dcd_brl_shrub - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_nolakep ! number of column non-lake points in patch filter - integer , intent(in) :: filter_nolakep(bounds%endp-bounds%begp+1) ! patch filter for non-lake points - type(waterstate_type) , intent(in) :: waterstate_inst - type(canopystate_type) , intent(inout) :: canopystate_inst - ! - ! !LOCAL VARIABLES: - integer :: fp,p,c ! indices - real(r8) :: ol ! thickness of canopy layer covered by snow (m) - real(r8) :: fb ! fraction of canopy layer covered by snow - !----------------------------------------------------------------------- - - associate( & - frac_sno => waterstate_inst%frac_sno_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) - snow_depth => waterstate_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) - 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 - 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) - frac_veg_nosno_alb => canopystate_inst%frac_veg_nosno_alb_patch & ! Output: [integer (:) ] fraction of vegetation not covered by snow (0 OR 1) [-] - ) - - if (use_lai_streams) then - call lai_interp(bounds, canopystate_inst) - endif - - do fp = 1, num_nolakep - p = filter_nolakep(fp) - c = patch%column(p) - - ! need to update elai and esai only every albedo time step so do not - ! have any inconsistency in lai and sai between SurfaceAlbedo calls (i.e., - ! if albedos are not done every time step). - ! leaf phenology - ! Set leaf and stem areas based on day of year - ! Interpolate leaf area index, stem area index, and vegetation heights - ! between two monthly - ! The weights below (timwt(1) and timwt(2)) were obtained by a call to - ! routine InterpMonthlyVeg in subroutine NCARlsm. - ! Field Monthly Values - ! ------------------------- - ! leaf area index LAI <- mlai1 and mlai2 - ! leaf area index SAI <- msai1 and msai2 - ! top height HTOP <- mhvt1 and mhvt2 - ! bottom height HBOT <- mhvb1 and mhvb2 - - if (.not. use_lai_streams) then - tlai(p) = timwt(1)*mlai2t(p,1) + timwt(2)*mlai2t(p,2) - endif - - tsai(p) = timwt(1)*msai2t(p,1) + timwt(2)*msai2t(p,2) - htop(p) = timwt(1)*mhvt2t(p,1) + timwt(2)*mhvt2t(p,2) - hbot(p) = timwt(1)*mhvb2t(p,1) + timwt(2)*mhvb2t(p,2) - - ! adjust lai and sai for burying by snow. if exposed lai and sai - ! are less than 0.05, set equal to zero to prevent numerical - ! problems associated with very small lai and sai. - - ! snow burial fraction for short vegetation (e.g. grasses) as in - ! Wang and Zeng, 2007. - - if (patch%itype(p) > noveg .and. patch%itype(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 - - ! area weight by snow covered fraction - - elai(p) = max(tlai(p)*(1.0_r8 - frac_sno(c)) + tlai(p)*fb*frac_sno(c), 0.0_r8) - esai(p) = max(tsai(p)*(1.0_r8 - frac_sno(c)) + tsai(p)*fb*frac_sno(c), 0.0_r8) - if (elai(p) < 0.05_r8) elai(p) = 0._r8 - if (esai(p) < 0.05_r8) esai(p) = 0._r8 - - ! Fraction of vegetation free of snow - - if ((elai(p) + esai(p)) >= 0.05_r8) then - frac_veg_nosno_alb(p) = 1 - else - frac_veg_nosno_alb(p) = 0 - end if - - end do ! end of patch loop - - end associate - - end subroutine SatellitePhenology - - !----------------------------------------------------------------------- - subroutine interpMonthlyVeg (bounds, canopystate_inst) - ! - ! !DESCRIPTION: - ! Determine if 2 new months of data are to be read. - ! - ! !USES: - use clm_varctl , only : fsurdat - use clm_time_manager, only : get_curr_date, get_step_size, get_nstep - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - type(canopystate_type), intent(inout) :: canopystate_inst - ! - ! !LOCAL VARIABLES: - integer :: kyr ! year (0, ...) for nstep+1 - integer :: kmo ! month (1, ..., 12) - integer :: kda ! day of month (1, ..., 31) - integer :: ksec ! seconds into current date for nstep+1 - real(r8):: dtime ! land model time step (sec) - real(r8):: t ! a fraction: kda/ndaypm - integer :: it(2) ! month 1 and month 2 (step 1) - integer :: months(2) ! months to be interpolated (1 to 12) - integer, dimension(12) :: ndaypm= & - (/31,28,31,30,31,30,31,31,30,31,30,31/) !days per month - !----------------------------------------------------------------------- - - dtime = get_step_size() - - call get_curr_date(kyr, kmo, kda, ksec, offset=int(dtime)) - - t = (kda-0.5_r8) / ndaypm(kmo) - it(1) = t + 0.5_r8 - it(2) = it(1) + 1 - months(1) = kmo + it(1) - 1 - months(2) = kmo + it(2) - 1 - if (months(1) < 1) months(1) = 12 - if (months(2) > 12) months(2) = 1 - timwt(1) = (it(1)+0.5_r8) - t - timwt(2) = 1._r8-timwt(1) - - if (InterpMonths1 /= months(1)) then - if (masterproc) then - write(iulog,*) 'Attempting to read monthly vegetation data .....' - write(iulog,*) 'nstep = ',get_nstep(),' month = ',kmo,' day = ',kda - end if - call t_startf('readMonthlyVeg') - call readMonthlyVegetation (bounds, fsurdat, months, canopystate_inst) - InterpMonths1 = months(1) - call t_stopf('readMonthlyVeg') - end if - - end subroutine interpMonthlyVeg - - !----------------------------------------------------------------------- - subroutine readAnnualVegetation (bounds, canopystate_inst) - ! - ! !DESCRIPTION: - ! read 12 months of veg data for dry deposition - ! - ! !USES: - use clm_varpar , only : numpft - use pftconMod , only : noveg - use domainMod , only : ldomain - use fileutils , only : getfil - use clm_varctl , only : fsurdat - use shr_scam_mod, only : shr_scam_getCloseLatLon - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - type(canopystate_type), intent(inout) :: canopystate_inst - ! - ! !LOCAL VARIABLES: - type(file_desc_t) :: ncid ! netcdf id - real(r8), pointer :: annlai(:,:) ! 12 months of monthly lai from input data set - real(r8), pointer :: mlai(:,:) ! lai read from input files - real(r8):: closelat,closelon ! single column vars - integer :: ier ! error code - integer :: g,k,l,m,n,p ! indices - integer :: ni,nj,ns ! indices - integer :: dimid,varid ! input netCDF id's - integer :: ntim ! number of input data time samples - integer :: nlon_i ! number of input data longitudes - integer :: nlat_i ! number of input data latitudes - integer :: npft_i ! number of input data patch types - integer :: closelatidx,closelonidx ! single column vars - logical :: isgrid2d ! true => file is 2d - character(len=256) :: locfn ! local file name - character(len=32) :: subname = 'readAnnualVegetation' - !----------------------------------------------------------------------- - - annlai => canopystate_inst%annlai_patch - - ! Determine necessary indices - - allocate(mlai(bounds%begg:bounds%endg,0:numpft), stat=ier) - if (ier /= 0) then - write(iulog,*)subname, 'allocation error ' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if (masterproc) then - write (iulog,*) 'Attempting to read annual vegetation data .....' - end if - - call getfil(fsurdat, locfn, 0) - call ncd_pio_openfile (ncid, trim(locfn), 0) - call ncd_inqfdims (ncid, isgrid2d, ni, nj, ns) - - if (ldomain%ns /= ns .or. ldomain%ni /= ni .or. ldomain%nj /= nj) then - write(iulog,*)trim(subname), 'ldomain and input file do not match dims ' - write(iulog,*)trim(subname), 'ldomain%ni,ni,= ',ldomain%ni,ni - write(iulog,*)trim(subname), 'ldomain%nj,nj,= ',ldomain%nj,nj - write(iulog,*)trim(subname), 'ldomain%ns,ns,= ',ldomain%ns,ns - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - call check_dim(ncid, 'lsmpft', numpft+1) - - if (single_column) then - call shr_scam_getCloseLatLon(locfn, scmlat, scmlon, & - closelat, closelon, closelatidx, closelonidx) - endif - - do k=1,12 !! loop over months and read vegetated data - - call ncd_io(ncid=ncid, varname='MONTHLY_LAI', flag='read', data=mlai, & - dim1name=grlnd, nt=k) - - !! only vegetated patches have nonzero values - !! Assign lai/sai/hgtt/hgtb to the top [maxpatch_pft] patches - !! as determined in subroutine surfrd - - do p = bounds%begp,bounds%endp - g =patch%gridcell(p) - if (patch%itype(p) /= noveg) then !! vegetated pft - do l = 0, numpft - if (l == patch%itype(p)) then - annlai(k,p) = mlai(g,l) - end if - end do - else !! non-vegetated pft - annlai(k,p) = 0._r8 - end if - end do ! end of loop over patches - - enddo ! months loop - - call ncd_pio_closefile(ncid) - - deallocate(mlai) - - endsubroutine readAnnualVegetation - - !----------------------------------------------------------------------- - subroutine readMonthlyVegetation (bounds, & - fveg, months, canopystate_inst) - ! - ! !DESCRIPTION: - ! Read monthly vegetation data for two consec. months. - ! - ! !USES: - use clm_varpar , only : numpft - use pftconMod , only : noveg - use fileutils , only : getfil - use spmdMod , only : masterproc, mpicom, MPI_REAL8, MPI_INTEGER - use shr_scam_mod , only : shr_scam_getCloseLatLon - use clm_time_manager , only : get_nstep - use netcdf - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - character(len=*) , intent(in) :: fveg ! file with monthly vegetation data - integer , intent(in) :: months(2) ! months to be interpolated (1 to 12) - type(canopystate_type), intent(inout) :: canopystate_inst - ! - ! !LOCAL VARIABLES: - character(len=256) :: locfn ! local file name - type(file_desc_t) :: ncid ! netcdf id - integer :: g,n,k,l,m,p,ni,nj,ns ! indices - integer :: dimid,varid ! input netCDF id's - integer :: ntim ! number of input data time samples - integer :: nlon_i ! number of input data longitudes - integer :: nlat_i ! number of input data latitudes - integer :: npft_i ! number of input data patch types - integer :: ier ! error code - integer :: closelatidx,closelonidx - real(r8):: closelat,closelon - logical :: readvar - real(r8), pointer :: mlai(:,:) ! lai read from input files - real(r8), pointer :: msai(:,:) ! sai read from input files - real(r8), pointer :: mhgtt(:,:) ! top vegetation height - real(r8), pointer :: mhgtb(:,:) ! bottom vegetation height - character(len=32) :: subname = 'readMonthlyVegetation' - !----------------------------------------------------------------------- - - ! Determine necessary indices - - allocate(& - mlai(bounds%begg:bounds%endg,0:numpft), & - msai(bounds%begg:bounds%endg,0:numpft), & - mhgtt(bounds%begg:bounds%endg,0:numpft), & - mhgtb(bounds%begg:bounds%endg,0:numpft), & - stat=ier) - if (ier /= 0) then - write(iulog,*)subname, 'allocation big error ' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! ---------------------------------------------------------------------- - ! Open monthly vegetation file - ! Read data and convert from gridcell to patch data - ! ---------------------------------------------------------------------- - - call getfil(fveg, locfn, 0) - call ncd_pio_openfile (ncid, trim(locfn), 0) - - if (single_column) then - call shr_scam_getCloseLatLon (ncid, scmlat, scmlon, closelat, closelon,& - closelatidx, closelonidx) - endif - - do k=1,2 !loop over months and read vegetated data - - call ncd_io(ncid=ncid, varname='MONTHLY_LAI', flag='read', data=mlai, dim1name=grlnd, & - nt=months(k), readvar=readvar) - if (.not. readvar) call endrun(msg=' ERROR: MONTHLY_LAI NOT on fveg file'//errMsg(sourcefile, __LINE__)) - - call ncd_io(ncid=ncid, varname='MONTHLY_SAI', flag='read', data=msai, dim1name=grlnd, & - nt=months(k), readvar=readvar) - if (.not. readvar) call endrun(msg=' ERROR: MONTHLY_SAI NOT on fveg file'//errMsg(sourcefile, __LINE__)) - - call ncd_io(ncid=ncid, varname='MONTHLY_HEIGHT_TOP', flag='read', data=mhgtt, dim1name=grlnd, & - nt=months(k), readvar=readvar) - if (.not. readvar) call endrun(msg=' ERROR: MONTHLY_HEIGHT_TOP NOT on fveg file'//errMsg(sourcefile, __LINE__)) - - call ncd_io(ncid=ncid, varname='MONTHLY_HEIGHT_BOT', flag='read', data=mhgtb, dim1name=grlnd, & - nt=months(k), readvar=readvar) - if (.not. readvar) call endrun(msg=' ERROR: MONTHLY_HEIGHT_TOP NOT on fveg file'//errMsg(sourcefile, __LINE__)) - - ! Only vegetated patches have nonzero values - ! Assign lai/sai/hgtt/hgtb to the top [maxpatch_pft] patches - ! as determined in subroutine surfrd - - do p = bounds%begp,bounds%endp - g =patch%gridcell(p) - if (patch%itype(p) /= noveg) then ! vegetated pft - do l = 0, numpft - if (l == patch%itype(p)) then - mlai2t(p,k) = mlai(g,l) - msai2t(p,k) = msai(g,l) - mhvt2t(p,k) = mhgtt(g,l) - mhvb2t(p,k) = mhgtb(g,l) - end if - end do - else ! non-vegetated pft - mlai2t(p,k) = 0._r8 - msai2t(p,k) = 0._r8 - mhvt2t(p,k) = 0._r8 - mhvb2t(p,k) = 0._r8 - end if - end do ! end of loop over patches - - end do ! end of loop over months - - call ncd_pio_closefile(ncid) - - if (masterproc) then - k = 2 - write(iulog,*) 'Successfully read monthly vegetation data for' - write(iulog,*) 'month ', months(k) - write(iulog,*) - end if - - deallocate(mlai, msai, mhgtt, mhgtb) - - do p = bounds%begp,bounds%endp - canopystate_inst%mlaidiff_patch(p) = mlai2t(p,1)-mlai2t(p,2) - enddo - - end subroutine readMonthlyVegetation - -end module SatellitePhenologyMod diff --git a/src/biogeochem/SpeciesBaseType.F90 b/src/biogeochem/SpeciesBaseType.F90 deleted file mode 100644 index 239ca91f..00000000 --- a/src/biogeochem/SpeciesBaseType.F90 +++ /dev/null @@ -1,67 +0,0 @@ -module SpeciesBaseType - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Defines a base class for working with chemical species, such as building history and - ! restart field names. - ! - ! !USES: - ! - implicit none - private - - ! !PUBLIC TYPES: - - type, abstract, public :: species_base_type - contains - ! Get a history field name for this species - procedure(hist_fname_interface), public, deferred :: hist_fname - - ! Get a restart field name for this species - procedure(rest_fname_interface), public, deferred :: rest_fname - - ! Get the full species name - procedure(get_species_interface), public, deferred :: get_species - end type species_base_type - - abstract interface - pure function hist_fname_interface(this, basename, suffix) result(fname) - ! Get a history field name for this species - ! - ! basename gives the base name of the history field - ! - ! suffix, if provided, gives a suffix that appears after all species information - ! in the field name - import :: species_base_type - - character(len=:) , allocatable :: fname ! function result - class(species_base_type) , intent(in) :: this - character(len=*) , intent(in) :: basename - character(len=*) , optional, intent(in) :: suffix - end function hist_fname_interface - - function rest_fname_interface(this, basename, suffix) result(fname) - ! Get a restart field name for this species - ! - ! basename gives the base name of the restart field - ! - ! suffix, if provided, gives a suffix that appears after all species information - ! in the field name - import :: species_base_type - - character(len=:) , allocatable :: fname ! function result - class(species_base_type) , intent(in) :: this - character(len=*) , intent(in) :: basename - character(len=*) , optional, intent(in) :: suffix - end function rest_fname_interface - - pure function get_species_interface(this) result(species_name) - ! Get the full species name - import :: species_base_type - - character(len=:), allocatable :: species_name - class(species_base_type) , intent(in) :: this - end function get_species_interface - end interface - -end module SpeciesBaseType diff --git a/src/biogeochem/SpeciesIsotopeType.F90 b/src/biogeochem/SpeciesIsotopeType.F90 deleted file mode 100644 index b5fb7498..00000000 --- a/src/biogeochem/SpeciesIsotopeType.F90 +++ /dev/null @@ -1,136 +0,0 @@ -module SpeciesIsotopeType - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Defines a class for working with chemical species, such as building history and - ! restart field names. - ! - ! This version is used for isotopic species - ! - ! !USES: - ! - use SpeciesBaseType, only : species_base_type - use abortutils, only : endrun - use shr_log_mod, only : errMsg => shr_log_errMsg - use clm_varctl, only : iulog - - implicit none - save - private - - ! COMPILER_BUG(wjs, 2016-03-16, pgi 15.10) Ideally, we would use allocatable characters - ! for species_name and isotope_name. However, this causes problems for pgi: it seems - ! that these allocatable characters randomly get changed. So, for now, using - ! fixed-length character variables. (It's possible that this was programmer error on my - ! part, although using allocatable character variables worked with other compilers.) - ! - ! If species_name and isotope_name were changed back to allocatable-length characters, - ! then we could remove the error checking in the constructor as well as various 'trim' - ! statements scattered throughout the code (because this%species_name and - ! this%isotope_name would already be trimmed). - integer, parameter :: species_name_maxlen = 8 - integer, parameter :: isotope_name_maxlen = 8 - - type, extends(species_base_type), public :: species_isotope_type - private - character(len=species_name_maxlen) :: species_name ! does not contain the isotope number - character(len=isotope_name_maxlen) :: isotope_name ! e.g., just the 13 for C13 - contains - procedure, public :: hist_fname - procedure, public :: rest_fname - procedure, public :: get_species - end type species_isotope_type - - interface species_isotope_type - module procedure constructor - end interface species_isotope_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - function constructor(species_name, isotope_name) result(this) - ! Create a species_isotope_type object - - type(species_isotope_type) :: this ! function result - character(len=*), intent(in) :: species_name ! e.g., 'C' or 'N' - without the isotope number - character(len=*), intent(in) :: isotope_name ! e.g., '13' for C13 - !----------------------------------------------------------------------- - - if (len_trim(species_name) > species_name_maxlen) then - write(iulog,*) 'species_isotope_type constructor: species_name too long' - write(iulog,*) trim(species_name) // ' exceeds max length: ', species_name_maxlen - call endrun(msg='species_isotope_type constructor: species_name too long: '// & - errMsg(sourcefile, __LINE__)) - end if - if (len_trim(isotope_name) > isotope_name_maxlen) then - write(iulog,*) 'species_isotope_type constructor: isotope_name too long' - write(iulog,*) trim(isotope_name) // ' exceeds max length: ', isotope_name_maxlen - call endrun(msg='species_isotope_type constructor: isotope_name too long: '// & - errMsg(sourcefile, __LINE__)) - end if - - this%species_name = trim(species_name) - this%isotope_name = trim(isotope_name) - end function constructor - - pure function hist_fname(this, basename, suffix) result(fname) - ! Get a history field name for this species - ! - ! basename gives the base name of the history field - ! - ! suffix, if provided, gives a suffix that appears after all species information - ! in the field name - - character(len=:), allocatable :: fname ! function result - class(species_isotope_type) , intent(in) :: this - character(len=*), intent(in) :: basename - character(len=*), optional, intent(in) :: suffix - !----------------------------------------------------------------------- - - fname = trim(this%species_name) // trim(this%isotope_name) // '_' // & - trim(basename) // trim(this%species_name) - if (present(suffix)) then - fname = trim(fname) // trim(suffix) - end if - - end function hist_fname - - function rest_fname(this, basename, suffix) result(fname) - ! Get a restart field name for this species - ! - ! basename gives the base name of the restart field - ! - ! suffix, if provided, gives a suffix that appears after all species information in - ! the field name - use shr_string_mod, only : shr_string_toLower - - character(len=:), allocatable :: fname ! function result - class(species_isotope_type) , intent(in) :: this - character(len=*), intent(in) :: basename - character(len=*), optional, intent(in) :: suffix - - character(len=:), allocatable :: species_name_lcase - !----------------------------------------------------------------------- - - species_name_lcase = shr_string_toLower(trim(this%species_name)) - fname = trim(basename) // species_name_lcase // '_' // trim(this%isotope_name) - if (present(suffix)) then - fname = trim(fname) // trim(suffix) - end if - - end function rest_fname - - pure function get_species(this) result(species_name) - ! Get the full species name (e.g., 'C13') - - character(len=:), allocatable :: species_name - class(species_isotope_type) , intent(in) :: this - !----------------------------------------------------------------------- - - species_name = trim(this%species_name) // trim(this%isotope_name) - - end function get_species - -end module SpeciesIsotopeType diff --git a/src/biogeochem/SpeciesNonIsotopeType.F90 b/src/biogeochem/SpeciesNonIsotopeType.F90 deleted file mode 100644 index 0daf6b3f..00000000 --- a/src/biogeochem/SpeciesNonIsotopeType.F90 +++ /dev/null @@ -1,125 +0,0 @@ -module SpeciesNonIsotopeType - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Defines a class for working with chemical species, such as building history and - ! restart field names. - ! - ! This version is used for non-isotopic species - ! - ! !USES: - ! - use SpeciesBaseType, only : species_base_type - use abortutils, only : endrun - use shr_log_mod, only : errMsg => shr_log_errMsg - use clm_varctl, only : iulog - - implicit none - save - private - - ! COMPILER_BUG(wjs, 2016-03-16, pgi 15.10) Ideally, we would use an allocatable - ! character variable for species_name. However, this causes problems for pgi: it seems - ! that this allocatable character variable randomly gets changed. So, for now, using a - ! fixed-length character variable. (It's possible that this was programmer error on my - ! part, although using allocatable character variables worked with other compilers.) - ! - ! If species_name was changed back to an allocatable-length character variable, then we - ! could remove the error checking in the constructor as well as various 'trim' - ! statements scattered throughout the code (because this%species_name would already be - ! trimmed). - integer, parameter :: species_name_maxlen = 8 - - type, extends(species_base_type), public :: species_non_isotope_type - private - character(len=species_name_maxlen) :: species_name - contains - procedure, public :: hist_fname - procedure, public :: rest_fname - procedure, public :: get_species - end type species_non_isotope_type - - interface species_non_isotope_type - module procedure constructor - end interface species_non_isotope_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - function constructor(species_name) result(this) - ! Create a species_non_isotope_type object - - type(species_non_isotope_type) :: this ! function result - character(len=*), intent(in) :: species_name ! e.g., 'C' or 'N' - !----------------------------------------------------------------------- - - if (len_trim(species_name) > species_name_maxlen) then - write(iulog,*) 'species_isotope_type constructor: species_name too long' - write(iulog,*) trim(species_name) // ' exceeds max length: ', species_name_maxlen - call endrun(msg='species_isotope_type constructor: species_name too long: '// & - errMsg(sourcefile, __LINE__)) - end if - - this%species_name = trim(species_name) - end function constructor - - pure function hist_fname(this, basename, suffix) result(fname) - ! Get a history field name for this species - ! - ! basename gives the base name of the history field - ! - ! suffix, if provided, gives a suffix that appears after all species information - ! in the field name - - character(len=:), allocatable :: fname ! function result - class(species_non_isotope_type) , intent(in) :: this - character(len=*), intent(in) :: basename - character(len=*), optional, intent(in) :: suffix - !----------------------------------------------------------------------- - - fname = trim(basename) // trim(this%species_name) - if (present(suffix)) then - fname = trim(fname) // trim(suffix) - end if - - end function hist_fname - - function rest_fname(this, basename, suffix) result(fname) - ! Get a restart field name for this species - ! - ! basename gives the base name of the restart field - ! - ! suffix, if provided, gives a suffix that appears after all species information in - ! the field name - use shr_string_mod, only : shr_string_toLower - - character(len=:), allocatable :: fname ! function result - class(species_non_isotope_type) , intent(in) :: this - character(len=*), intent(in) :: basename - character(len=*), optional, intent(in) :: suffix - - character(len=:), allocatable :: species_name_lcase - !----------------------------------------------------------------------- - - species_name_lcase = shr_string_toLower(trim(this%species_name)) - fname = trim(basename) // trim(species_name_lcase) - if (present(suffix)) then - fname = trim(fname) // trim(suffix) - end if - - end function rest_fname - - pure function get_species(this) result(species_name) - ! Get the full species name - - character(len=:), allocatable :: species_name - class(species_non_isotope_type) , intent(in) :: this - !----------------------------------------------------------------------- - - species_name = trim(this%species_name) - - end function get_species - -end module SpeciesNonIsotopeType diff --git a/src/biogeochem/VOCEmissionMod.F90 b/src/biogeochem/VOCEmissionMod.F90 deleted file mode 100644 index 1c9a0e58..00000000 --- a/src/biogeochem/VOCEmissionMod.F90 +++ /dev/null @@ -1,26 +0,0 @@ -module VOCEmissionMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Volatile organic compound emission - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - ! - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - ! - ! !PUBLIC TYPES: - type, public :: vocemis_type - end type vocemis_type - ! - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------ - -end module VOCEmissionMod - - diff --git a/src/biogeochem/ch4Mod.F90 b/src/biogeochem/ch4Mod.F90 deleted file mode 100644 index 81978bf6..00000000 --- a/src/biogeochem/ch4Mod.F90 +++ /dev/null @@ -1,123 +0,0 @@ -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 abortutils , only : endrun - ! - 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 - - 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_bef_col (:) ! col 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 :: zwt0_col (:) ! col coefficient for determining finundated (m) - real(r8), pointer, private :: f0_col (:) ! col maximum inundated fraction for a gridcell (for methane code) - real(r8), pointer, private :: p3_col (:) ! col coefficient for determining finundated (m) - 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_col (:) ! col 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] - - end type ch4_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------ - -end module ch4Mod - diff --git a/src/biogeophys/ActiveLayerMod.F90 b/src/biogeophys/ActiveLayerMod.F90 deleted file mode 100644 index a1b87182..00000000 --- a/src/biogeophys/ActiveLayerMod.F90 +++ /dev/null @@ -1,155 +0,0 @@ -module ActiveLayerMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Module holding routines for calculation of active layer dynamics - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_const_mod , only : SHR_CONST_TKFRZ - use clm_varctl , only : iulog - use TemperatureType , only : temperature_type - use CanopyStateType , only : canopystate_type - use GridcellType , only : grc - use ColumnType , only : col - ! - implicit none - save - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public:: alt_calc - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine alt_calc(num_soilc, filter_soilc, & - temperature_inst, canopystate_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: - 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 - type(canopystate_type) , intent(inout) :: canopystate_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 => canopystate_inst%alt_col , & ! Output: [real(r8) (:) ] current depth of thaw - altmax => canopystate_inst%altmax_col , & ! Output: [real(r8) (:) ] maximum annual depth of thaw - altmax_lastyear => canopystate_inst%altmax_lastyear_col , & ! Output: [real(r8) (:) ] prior year maximum annual depth of thaw - alt_indx => canopystate_inst%alt_indx_col , & ! Output: [integer (:) ] current depth of thaw - altmax_indx => canopystate_inst%altmax_indx_col , & ! Output: [integer (:) ] maximum annual depth of thaw - altmax_lastyear_indx => canopystate_inst%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/src/biogeophys/AerosolMod.F90 b/src/biogeophys/AerosolMod.F90 deleted file mode 100644 index 06111cd1..00000000 --- a/src/biogeophys/AerosolMod.F90 +++ /dev/null @@ -1,29 +0,0 @@ -module AerosolMod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - 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 - ! - ! !PUBLIC TYPES: - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - ! - ! !PUBLIC DATA MEMBERS: - real(r8), public, parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also cold "fresh snow" value) [microns] - real(r8), public :: fresh_snw_rds_max = 204.526_r8 ! maximum warm fresh snow effective radius [microns] - ! - type, public :: aerosol_type - - end type aerosol_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -end module AerosolMod diff --git a/src/biogeophys/BandDiagonalMod.F90 b/src/biogeophys/BandDiagonalMod.F90 deleted file mode 100644 index 5065ea59..00000000 --- a/src/biogeophys/BandDiagonalMod.F90 +++ /dev/null @@ -1,224 +0,0 @@ -module BandDiagonalMod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Band Diagonal matrix solution - ! - ! !USES: - use shr_log_mod , only : errMsg => shr_log_errMsg - use decompMod , only : bounds_type - use abortutils , only : endrun - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog - ! - ! !PUBLIC TYPES: - implicit none - save - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: BandDiagonal - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine BandDiagonal(bounds, lbj, ubj, jtop, jbot, numf, filter, nband, b, r, u) - ! - ! !DESCRIPTION: - ! Tridiagonal matrix solution - ! - ! !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) :: jbot( bounds%begc: ) ! bottom level for each column [col] - integer , intent(in) :: numf ! filter dimension - integer , intent(in) :: nband ! band width - integer , intent(in) :: filter(:) ! filter - real(r8), intent(in) :: b( bounds%begc: , 1: , lbj: ) ! compact band matrix [col, nband, j] - real(r8), intent(in) :: r( bounds%begc: , lbj: ) ! "r" rhs of linear system [col, j] - real(r8), intent(inout) :: u( bounds%begc: , lbj: ) ! solution [col, j] - ! - ! ! LOCAL VARIABLES: - integer :: j,ci,fc,info,m,n !indices - integer :: kl,ku !number of sub/super diagonals - integer, allocatable :: ipiv(:) !temporary - real(r8),allocatable :: ab(:,:),temp(:,:) !compact storage array - real(r8),allocatable :: result(:) - - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - SHR_ASSERT_ALL((ubound(jtop) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(jbot) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(b) == (/bounds%endc, nband, ubj/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(r) == (/bounds%endc, ubj/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(u) == (/bounds%endc, ubj/)), errMsg(sourcefile, __LINE__)) - - -!!$ SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -!!$* -!!$* -- LAPACK driver routine (version 3.1) -- -!!$* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -!!$* November 2006 -!!$* -!!$* .. Scalar Arguments .. -!!$ INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -!!$* .. -!!$* .. Array Arguments .. -!!$ INTEGER IPIV( * ) -!!$ REAL AB( LDAB, * ), B( LDB, * ) -!!$* .. -!!$* -!!$* Purpose -!!$* ======= -!!$* -!!$* SGBSV computes the solution to a real system of linear equations -!!$* A * X = B, where A is a band matrix of order N with KL subdiagonals -!!$* and KU superdiagonals, and X and B are N-by-NRHS matrices. -!!$* -!!$* The LU decomposition with partial pivoting and row interchanges is -!!$* used to factor A as A = L * U, where L is a product of permutation -!!$* and unit lower triangular matrices with KL subdiagonals, and U is -!!$* upper triangular with KL+KU superdiagonals. The factored form of A -!!$* is then used to solve the system of equations A * X = B. -!!$* -!!$* Arguments -!!$* ========= -!!$* -!!$* N (input) INTEGER -!!$* The number of linear equations, i.e., the order of the -!!$* matrix A. N >= 0. -!!$* -!!$* KL (input) INTEGER -!!$* The number of subdiagonals within the band of A. KL >= 0. -!!$* -!!$* KU (input) INTEGER -!!$* The number of superdiagonals within the band of A. KU >= 0. -!!$* -!!$* NRHS (input) INTEGER -!!$* The number of right hand sides, i.e., the number of columns -!!$* of the matrix B. NRHS >= 0. -!!$* -!!$* AB (input/output) REAL array, dimension (LDAB,N) -!!$* On entry, the matrix A in band storage, in rows KL+1 to -!!$* 2*KL+KU+1; rows 1 to KL of the array need not be set. -!!$* The j-th column of A is stored in the j-th column of the -!!$* array AB as follows: -!!$* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) -!!$* On exit, details of the factorization: U is stored as an -!!$* upper triangular band matrix with KL+KU superdiagonals in -!!$* rows 1 to KL+KU+1, and the multipliers used during the -!!$* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -!!$* See below for further details. -!!$* -!!$* LDAB (input) INTEGER -!!$* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -!!$* -!!$* IPIV (output) INTEGER array, dimension (N) -!!$* The pivot indices that define the permutation matrix P; -!!$* row i of the matrix was interchanged with row IPIV(i). -!!$* -!!$* B (input/output) REAL array, dimension (LDB,NRHS) -!!$* On entry, the N-by-NRHS right hand side matrix B. -!!$* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -!!$* -!!$* LDB (input) INTEGER -!!$* The leading dimension of the array B. LDB >= max(1,N). -!!$* -!!$* INFO (output) INTEGER -!!$* = 0: successful exit -!!$* < 0: if INFO = -i, the i-th argument had an illegal value -!!$* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -!!$* has been completed, but the factor U is exactly -!!$* singular, and the solution has not been computed. -!!$* -!!$* Further Details -!!$* =============== -!!$* -!!$* The band storage scheme is illustrated by the following example, when -!!$* M = N = 6, KL = 2, KU = 1: -!!$* -!!$* On entry: On exit: -!!$* -!!$* * * * + + + * * * u14 u25 u36 -!!$* * * + + + + * * u13 u24 u35 u46 -!!$* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -!!$* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -!!$* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -!!$* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -!!$* -!!$* Array elements marked * are not used by the routine; elements marked -!!$* + need not be set on entry, but are required by the routine to store -!!$* elements of U because of fill-in resulting from the row interchanges. - - -!Set up input matrix AB -!An m-by-n band matrix with kl subdiagonals and ku superdiagonals -!may be stored compactly in a two-dimensional array with -!kl+ku+1 rows and n columns -!AB(KL+KU+1+i-j,j) = A(i,j) - - do fc = 1,numf - ci = filter(fc) - - kl=(nband-1)/2 - ku=kl -! m is the number of rows required for storage space by dgbsv - m=2*kl+ku+1 -! n is the number of levels (snow/soil) -!scs: replace ubj with jbot - n=jbot(ci)-jtop(ci)+1 - - allocate(ab(m,n)) - ab=0.0 - - ab(kl+ku-1,3:n)=b(ci,1,jtop(ci):jbot(ci)-2) ! 2nd superdiagonal - ab(kl+ku+0,2:n)=b(ci,2,jtop(ci):jbot(ci)-1) ! 1st superdiagonal - ab(kl+ku+1,1:n)=b(ci,3,jtop(ci):jbot(ci)) ! diagonal - ab(kl+ku+2,1:n-1)=b(ci,4,jtop(ci)+1:jbot(ci)) ! 1st subdiagonal - ab(kl+ku+3,1:n-2)=b(ci,5,jtop(ci)+2:jbot(ci)) ! 2nd subdiagonal - - allocate(temp(m,n)) - temp=ab - - allocate(ipiv(n)) - allocate(result(n)) - -! on input result is rhs, on output result is solution vector - result(:)=r(ci,jtop(ci):jbot(ci)) - -! DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) - call dgbsv( n, kl, ku, 1, ab, m, ipiv, result, n, info ) - u(ci,jtop(ci):jbot(ci))=result(:) - - if(info /= 0) then - write(iulog,*)'index: ', ci - write(iulog,*)'n,kl,ku,m ',n,kl,ku,m - write(iulog,*)'dgbsv info: ',ci,info - - write(iulog,*) '' - write(iulog,*) 'ab matrix' - do j=1,n - ! write(iulog,'(i2,7f18.7)') j,temp(:,j) - write(iulog,'(i2,5f18.7)') j,temp(3:7,j) - enddo - write(iulog,*) '' - call endrun( 'BandDiagonal ERROR: dgbsv returned error code' ) - endif - deallocate(temp) - - deallocate(ab) - deallocate(ipiv) - deallocate(result) - end do - - end subroutine BandDiagonal - -end module BandDiagonalMod diff --git a/src/biogeophys/CanopyStateType.F90 b/src/biogeophys/CanopyStateType.F90 deleted file mode 100644 index e1e600bf..00000000 --- a/src/biogeophys/CanopyStateType.F90 +++ /dev/null @@ -1,640 +0,0 @@ -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 ColumnType , only : col - 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 :: htop_patch (:) ! patch canopy top (m) - real(r8) , pointer :: hbot_patch (:) ! patch canopy bottom (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 :: alt_col (:) ! col current depth of thaw - integer , pointer :: alt_indx_col (:) ! col current depth of thaw - real(r8) , pointer :: altmax_col (:) ! col maximum annual depth of thaw - real(r8) , pointer :: altmax_lastyear_col (:) ! col prior year maximum annual depth of thaw - integer , pointer :: altmax_indx_col (:) ! col maximum annual depth of thaw - integer , pointer :: altmax_lastyear_indx_col (:) ! col prior year maximum annual depth of thaw - - real(r8) , pointer :: dewmx_patch (:) ! patch maximum allowed dew [mm] - 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) :: 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%htop_patch (begp:endp)) ; this%htop_patch (:) = nan - allocate(this%hbot_patch (begp:endp)) ; this%hbot_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%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) - - allocate(this%dewmx_patch (begp:endp)) ; this%dewmx_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 - - 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, default='inactive') - - 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, default='inactive') - - this%tlai_patch(begp:endp) = spval - call hist_addfld1d (fname='TLAI', units='none', & - avgflag='A', long_name='total projected leaf area index', & - ptr_patch=this%tlai_patch, default='inactive') - - this%tsai_patch(begp:endp) = spval - call hist_addfld1d (fname='TSAI', units='none', & - avgflag='A', long_name='total projected stem area index', & - ptr_patch=this%tsai_patch, default='inactive') - - this%laisun_patch(begp:endp) = spval - call hist_addfld1d (fname='LAISUN', units='none', & - avgflag='A', long_name='sunlit projected leaf area index', & - ptr_patch=this%laisun_patch, set_urb=0._r8, default='inactive') - - this%laisha_patch(begp:endp) = spval - call hist_addfld1d (fname='LAISHA', units='none', & - avgflag='A', long_name='shaded projected leaf area index', & - ptr_patch=this%laisha_patch, set_urb=0._r8, 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%dewmx_patch(begp:endp) = spval - call hist_addfld1d (fname='DEWMX', units='mm', & - avgflag='A', long_name='Maximum allowed dew', & - ptr_patch=this%dewmx_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, default='inactive') - - 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 - - if (use_cn) then - 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='inactive') - - 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='inactive') - - 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 if - - ! Allow active layer fields to be optionally output even if not running CN - - if (.not. use_cn) then - 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='inactive') - - 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='inactive') - - 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 if - - - - ! 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, default='inactive') - 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, default='inactive') - 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 - write(iulog,*) "Could not find clm_canopy_inparm namelist" - 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%frac_veg_nosno_patch(p) = 0._r8 - 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%htop_patch(p) = 0._r8 - this%hbot_patch(p) = 0._r8 - this%dewmx_patch(p) = 0.1_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 - - 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 spmdMod , only : masterproc - use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_double, ncd_int, ncd_inqvdlen - 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='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_cn .or. use_fates) then - 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 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) - - end if - - end subroutine Restart - -end module CanopyStateType diff --git a/src/biogeophys/EnergyFluxType.F90 b/src/biogeophys/EnergyFluxType.F90 deleted file mode 100644 index 83b5281e..00000000 --- a/src/biogeophys/EnergyFluxType.F90 +++ /dev/null @@ -1,1022 +0,0 @@ -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 decompMod , only : bounds_type - use LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch - ! - implicit none - save - private - ! - type, public :: energyflux_type - - ! Fluxes - 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 :: btran2_patch (:) ! patch root zone soil wetness factor (0 to 1) - 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] - - ! 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 ! 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((ubound(t_grnd_col) == (/bounds%endc/)), errMsg(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_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_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%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%btran2_patch (begp:endp)) ; this%btran2_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 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, default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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, default='inactive') - - 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', default='inactive') - ! 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, default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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, default='inactive') - - 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', default='inactive') - - 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, default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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 - - if (use_cn) then - 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') - end if - - 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, default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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', default='inactive') - 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', default='inactive') - - 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', default='inactive') - - 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', default='inactive') - 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, default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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, default='inactive') - ! 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, default='inactive') - - 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, set_lake=spval, set_urb=spval, default='inactive') - 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, set_lake=spval, set_urb=spval, default='inactive') - - 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, set_lake=spval, set_urb=spval, default='inactive') - - 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, 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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((ubound(t_grnd_col) == (/bounds%endc/)), errMsg(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='btran2', xtype=ncd_double, & - dim1name='pft', & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%btran2_patch) - - 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 restartvar(ncid=ncid, flag=flag, varname='eflx_grnd_lake', xtype=ncd_double, & - dim1name='pft', & - long_name='net heat flux into lake/snow surface, excluding light transmission', units='W/m^2', & - interpinic_flag='interp', readvar=readvar, data=this%eflx_grnd_lake_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 [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 - 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() - - 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/src/biogeophys/FrictionVelocityMod.F90 b/src/biogeophys/FrictionVelocityMod.F90 deleted file mode 100644 index 46ce6087..00000000 --- a/src/biogeophys/FrictionVelocityMod.F90 +++ /dev/null @@ -1,772 +0,0 @@ -module FrictionVelocityMod - -#include "shr_assert.h" - - !------------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Calculation of the friction velocity, relation for potential - ! temperature and humidity profiles of surface boundary layer. - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - 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 - ! - ! !PUBLIC TYPES: - implicit none - save - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: FrictionVelocity ! Calculate friction velocity - public :: MoninObukIni ! Initialization of the Monin-Obukhov length - ! - ! !PRIVATE MEMBER FUNCTIONS: - private :: StabilityFunc1 ! Stability function for rib < 0. - private :: StabilityFunc2 ! Stability function for rib < 0. - - type, public :: frictionvel_type - - ! 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 :: z0m_patch (:) ! patch momentum roughness length (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] - - contains - - ! Public procedures - procedure, public :: Init - procedure, public :: Restart - - ! Private procedures - procedure, private :: InitAllocate - procedure, private :: InitHistory - procedure, private :: InitCold - - end type frictionvel_type - - type, public :: frictionvel_parms_type - real(r8) :: zetamaxstable ! Max value zeta ("height" used in Monin-Obukhov theory) can go to under stable conditions - end type frictionvel_parms_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------------ - - type(frictionvel_parms_type), public, protected :: frictionvel_parms_inst - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, bounds) - - class(frictionvel_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 - ! - ! !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%z0m_patch (begp:endp)) ; this%z0m_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 - - 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, default='inactive') - - 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, default='inactive') - - 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 - - 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%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') - 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 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 FrictionVelocity(lbn, ubn, fn, filtern, & - displa, z0m, z0h, z0q, & - obu, iter, ur, um, ustar, & - temp1, temp2, temp12m, temp22m, fm, frictionvel_inst, 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: - 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] - type(frictionvel_type) , intent(inout) :: frictionvel_inst - 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((ubound(displa) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(z0m) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(z0h) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(z0q) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(obu) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(ur) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(um) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(ustar) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(temp1) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(temp12m) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(temp2) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(temp22m) == (/ubn/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(fm) == (/ubn/)), errMsg(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 => frictionvel_inst%forc_hgt_u_patch , & ! Input: [real(r8) (:) ] observational height of wind at pft level [m] - forc_hgt_t_patch => frictionvel_inst%forc_hgt_t_patch , & ! Input: [real(r8) (:) ] observational height of temperature at pft level [m] - forc_hgt_q_patch => frictionvel_inst%forc_hgt_q_patch , & ! Input: [real(r8) (:) ] observational height of specific humidity at pft level [m] - vds => frictionvel_inst%vds_patch , & ! Output: [real(r8) (:) ] dry deposition velocity term (m/s) (for SO4 NH4NO3) - u10 => frictionvel_inst%u10_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) (for dust model) - u10_clm => frictionvel_inst%u10_clm_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) - va => frictionvel_inst%va_patch , & ! Output: [real(r8) (:) ] atmospheric wind speed plus convective velocity (m/s) - fv => frictionvel_inst%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))& - - StabilityFunc1(-zetam) & - + StabilityFunc1(z0m(n)/obu(n)) & - + 1.14_r8*((-zeta(n))**0.333_r8-(zetam)**0.333_r8)) - else if (zeta(n) < 0._r8) then - ustar(n) = vkc*um(n)/(log(zldis(n)/z0m(n))& - - StabilityFunc1(zeta(n))& - + StabilityFunc1(z0m(n)/obu(n))) - else if (zeta(n) <= 1._r8) then - ustar(n) = vkc*um(n)/(log(zldis(n)/z0m(n)) + 5._r8*zeta(n) -5._r8*z0m(n)/obu(n)) - else - ustar(n) = vkc*um(n)/(log(obu(n)/z0m(n))+5._r8-5._r8*z0m(n)/obu(n) & - +(5._r8*log(zeta(n))+zeta(n)-1._r8)) - end if - - if (zeta(n) < 0._r8) then - vds_tmp = 2.e-3_r8*ustar(n) * ( 1._r8 + (300._r8/(-obu(n)))**0.666_r8) - else - vds_tmp = 2.e-3_r8*ustar(n) - endif - - if (present(landunit_index)) then - do pp = pfti(n),pftf(n) - vds(pp) = vds_tmp - end do - else - vds(n) = vds_tmp - end if - - ! 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))) & - - StabilityFunc1(-zetam) & - + 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))) & - - StabilityFunc1(zeta(n)) & - + 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))) & - - StabilityFunc1(-zetam) & - + 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))) & - - StabilityFunc1(zeta(n)) & - + 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))& - - StabilityFunc2(-zetat) & - + StabilityFunc2(z0h(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) - else if (zeta(n) < 0._r8) then - temp1(n) = vkc/(log(zldis(n)/z0h(n)) & - - StabilityFunc2(zeta(n)) & - + StabilityFunc2(z0h(n)/obu(n))) - else if (zeta(n) <= 1._r8) then - temp1(n) = vkc/(log(zldis(n)/z0h(n)) + 5._r8*zeta(n) - 5._r8*z0h(n)/obu(n)) - else - temp1(n) = vkc/(log(obu(n)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(n) & - + (5._r8*log(zeta(n))+zeta(n)-1._r8)) - end if - - ! Humidity profile - - if (present(landunit_index)) then - if (forc_hgt_q_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)) & - - StabilityFunc2(-zetat) & - + StabilityFunc2(z0q(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) - else if (zeta(n) < 0._r8) then - temp2(n) = vkc/(log(zldis(n)/z0q(n)) & - - StabilityFunc2(zeta(n)) & - + StabilityFunc2(z0q(n)/obu(n))) - else if (zeta(n) <= 1._r8) then - temp2(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n)) - else - temp2(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & - + (5._r8*log(zeta(n))+zeta(n)-1._r8)) - end if - end if - else - if (forc_hgt_q_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)) & - - StabilityFunc2(-zetat) & - + StabilityFunc2(z0q(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) - else if (zeta(n) < 0._r8) then - temp2(n) = vkc/(log(zldis(n)/z0q(n)) & - - StabilityFunc2(zeta(n)) & - + StabilityFunc2(z0q(n)/obu(n))) - else if (zeta(n) <= 1._r8) then - temp2(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n)) - else - temp2(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & - + (5._r8*log(zeta(n))+zeta(n)-1._r8)) - end if - endif - endif - - ! Temperature profile applied at 2-m - - zldis(n) = 2.0_r8 + z0h(n) - zeta(n) = zldis(n)/obu(n) - if (zeta(n) < -zetat) then - temp12m(n) = vkc/(log(-zetat*obu(n)/z0h(n))& - - StabilityFunc2(-zetat) & - + StabilityFunc2(z0h(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) - else if (zeta(n) < 0._r8) then - temp12m(n) = vkc/(log(zldis(n)/z0h(n)) & - - StabilityFunc2(zeta(n)) & - + StabilityFunc2(z0h(n)/obu(n))) - else if (zeta(n) <= 1._r8) then - temp12m(n) = vkc/(log(zldis(n)/z0h(n)) + 5._r8*zeta(n) - 5._r8*z0h(n)/obu(n)) - else - temp12m(n) = vkc/(log(obu(n)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(n) & - + (5._r8*log(zeta(n))+zeta(n)-1._r8)) - end if - - ! Humidity profile applied at 2-m - - if (z0q(n) == z0h(n)) then - temp22m(n) = temp12m(n) - else - zldis(n) = 2.0_r8 + z0q(n) - zeta(n) = zldis(n)/obu(n) - if (zeta(n) < -zetat) then - temp22m(n) = vkc/(log(-zetat*obu(n)/z0q(n)) - & - StabilityFunc2(-zetat) + StabilityFunc2(z0q(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8))) - else if (zeta(n) < 0._r8) then - temp22m(n) = vkc/(log(zldis(n)/z0q(n)) - & - StabilityFunc2(zeta(n))+StabilityFunc2(z0q(n)/obu(n))) - else if (zeta(n) <= 1._r8) then - temp22m(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n)) - else - temp22m(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & - + (5._r8*log(zeta(n))+zeta(n)-1._r8)) - end if - end if - - ! 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. - ! - ! !USES: - use shr_const_mod, only: SHR_CONST_PI - ! - ! !ARGUMENTS: - implicit none - 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. - ! - ! !USES: - use shr_const_mod, only: SHR_CONST_PI - ! - ! !ARGUMENTS: - implicit none - 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 (ur, thv, dthv, zldis, z0m, um, obu) - ! - ! !DESCRIPTION: - ! Initialization of the Monin-Obukhov length. - ! The scheme is based on the work of Zeng et al. (1998): - ! Intercomparison of bulk aerodynamic algorithms for the computation - ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, - ! Vol. 11, 2628-2644. - ! - ! !USES: - use clm_varcon, only : grav - ! - ! !ARGUMENTS: - implicit none - real(r8), intent(in) :: ur ! wind speed at reference height [m/s] - real(r8), intent(in) :: thv ! virtual potential temperature (kelvin) - real(r8), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface - real(r8), intent(in) :: zldis ! reference height "minus" zero displacement heght [m] - real(r8), intent(in) :: z0m ! roughness length, momentum [m] - real(r8), intent(out) :: um ! wind speed including the stability effect [m/s] - real(r8), intent(out) :: obu ! monin-obukhov length (m) - ! - ! !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(frictionvel_parms_inst%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/src/biogeophys/GlacierSurfaceMassBalanceMod.F90 b/src/biogeophys/GlacierSurfaceMassBalanceMod.F90 deleted file mode 100644 index adaa6cee..00000000 --- a/src/biogeophys/GlacierSurfaceMassBalanceMod.F90 +++ /dev/null @@ -1,452 +0,0 @@ -module GlacierSurfaceMassBalanceMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Computes fluxes that are specific to glaciers - ! - ! !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_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use decompMod , only : bounds_type - use clm_varcon , only : spval, secspday - use clm_varpar , only : nlevgrnd - use clm_varctl , only : glc_snow_persistence_max_days - use clm_time_manager, only : get_step_size - use landunit_varcon, only : istice_mec - use ColumnType , only : col - use LandunitType , only : lun - use glc2lndMod , only : glc2lnd_type - use WaterstateType , only : waterstate_type - use WaterfluxType , only : waterflux_type - - ! !PUBLIC TYPES: - implicit none - private - save - - type, public :: glacier_smb_type - private - - ! ------------------------------------------------------------------------ - ! Public data - ! ------------------------------------------------------------------------ - - real(r8), pointer, public :: 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, public :: 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 - - ! ------------------------------------------------------------------------ - ! Private data - ! ------------------------------------------------------------------------ - - 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 - - contains - - ! ------------------------------------------------------------------------ - ! Public routines - ! ------------------------------------------------------------------------ - - procedure, public :: Init - - ! The science routines need to be separated into a few pieces so they can be - ! sequenced properly based on what variables they depend on, and what they affect - procedure, public :: HandleIceMelt ! compute ice melt in glacier columns, and convert liquid back to ice - procedure, public :: ComputeSurfaceMassBalance ! compute fluxes other than ice melt - procedure, public :: AdjustRunoffTerms ! adjust liquid and ice runoff fluxes due to glacier fluxes - - ! ------------------------------------------------------------------------ - ! Private routines - ! ------------------------------------------------------------------------ - - procedure, private :: InitAllocate - procedure, private :: InitHistory - procedure, private :: InitCold - - end type glacier_smb_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - ! ======================================================================== - ! Infrastructure routines - ! ======================================================================== - - !----------------------------------------------------------------------- - subroutine Init(this, bounds) - class(glacier_smb_type), intent(inout) :: 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) - class(glacier_smb_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - - integer :: begc, endc - !----------------------------------------------------------------------- - - begc = bounds%begc; endc = bounds%endc - - allocate(this%qflx_glcice_col (begc:endc)) ; this%qflx_glcice_col (:) = nan - allocate(this%qflx_glcice_dyn_water_flux_col(begc:endc)) ; this%qflx_glcice_dyn_water_flux_col (:) = nan - allocate(this%qflx_glcice_frz_col (begc:endc)) ; this%qflx_glcice_frz_col (:) = nan - allocate(this%qflx_glcice_melt_col (begc:endc)) ; this%qflx_glcice_melt_col (:) = nan - end subroutine InitAllocate - - !----------------------------------------------------------------------- - subroutine InitHistory(this, bounds) - ! - ! !USES: - use histFileMod , only : hist_addfld1d - ! - ! !ARGUMENTS: - class(glacier_smb_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begc, endc - !----------------------------------------------------------------------- - - begc = bounds%begc; endc = bounds%endc - - this%qflx_glcice_col(begc:endc) = spval - call hist_addfld1d (fname='QICE', units='mm/s', & - avgflag='A', long_name='ice growth/melt', & - ptr_col=this%qflx_glcice_col, l2g_scale_type='ice', default='inactive') - - this%qflx_glcice_frz_col(begc:endc) = spval - call hist_addfld1d (fname='QICE_FRZ', units='mm/s', & - avgflag='A', long_name='ice growth', & - ptr_col=this%qflx_glcice_frz_col, l2g_scale_type='ice', default='inactive') - - this%qflx_glcice_melt_col(begc:endc) = spval - call hist_addfld1d (fname='QICE_MELT', units='mm/s', & - avgflag='A', long_name='ice melt', & - ptr_col=this%qflx_glcice_melt_col, l2g_scale_type='ice', default='inactive') - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine InitCold(this, bounds) - class(glacier_smb_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - - integer :: c - !----------------------------------------------------------------------- - - ! 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 fluxes intentionally remain unset (spval) outside the do_smb filter, so that - ! they are flagged as missing value outside that filter. - do c = bounds%begc, bounds%endc - this%qflx_glcice_dyn_water_flux_col(c) = 0._r8 - end do - - end subroutine InitCold - - ! ======================================================================== - ! Science routines - ! ======================================================================== - - !----------------------------------------------------------------------- - subroutine HandleIceMelt(this, bounds, num_do_smb_c, filter_do_smb_c, & - waterstate_inst) - ! - ! !DESCRIPTION: - ! Compute ice melt in glacier columns, and convert liquid back to ice - ! - ! Ideally this should be called immediately after ice is melted, so that liquid is - ! converted back to ice as soon as possible. - ! - ! NOTE(wjs, 2016-06-29) Currently this is separated from the main ComputeSurfaceMassBalance - ! routine so that it can be called from the same place in the driver loop where it was - ! done before the introduction of GlacierSurfaceMassBalanceMod. This was needed to maintain - ! identical answers, due to the adjustment of h2osoi_ice and h2osoi_liq in this - ! routine. In principle we should be able to do these adjustments of h2osoi_ice and - ! h2osoi_liq later in the driver loop: this would just mean that some intervening - ! science code is operating on the temporarily-thawed state, before the water runs off - ! and is replaced by ice from below. The main reason to make this change would be to - ! simplify the driver logic, consolidating calls to this module. On the other hand, - ! having a period when there is liquid water at the top of the glacier column could - ! defeat some of the purpose of converting it immediately back to ice (i.e., so that - ! the surface fluxes are always generated based on an ice-covered surface) - so it - ! may be best to keep this separate. - ! - ! !ARGUMENTS: - class(glacier_smb_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - integer, intent(in) :: num_do_smb_c ! number of column points in filter_do_smb_c - integer, intent(in) :: filter_do_smb_c(:) ! column filter for points where SMB is calculated - type(waterstate_type), intent(inout) :: waterstate_inst - ! - ! !LOCAL VARIABLES: - integer :: j - integer :: fc, c, l - real(r8) :: dtime ! land model time step (sec) - - character(len=*), parameter :: subname = 'HandleIceMelt' - !----------------------------------------------------------------------- - - associate( & - qflx_glcice_melt => this%qflx_glcice_melt_col , & ! Output: [real(r8) (:) ] ice melt (positive definite) (mm H2O/s) - h2osoi_liq => waterstate_inst%h2osoi_liq_col , & ! Output: [real(r8) (:,:) ] liquid water (kg/m2) - h2osoi_ice => waterstate_inst%h2osoi_ice_col & ! Output: [real(r8) (:,:) ] ice lens (kg/m2) - ) - - dtime = get_step_size() - - do fc = 1, num_do_smb_c - c = filter_do_smb_c(fc) - qflx_glcice_melt(c) = 0._r8 - end do - - ! Note that, because the following code only operates over the do_smb filter, that - ! means that the conversion of water back to ice only happens for glacier columns - ! where we're computing SMB. - - do j = 1, nlevgrnd - do fc = 1, num_do_smb_c - c = filter_do_smb_c(fc) - l = col%landunit(c) - - if (lun%itype(l) == istice_mec) then - if (h2osoi_liq(c,j) > 0._r8) then ! ice layer with meltwater - qflx_glcice_melt(c) = qflx_glcice_melt(c) + h2osoi_liq(c,j)/dtime - - ! convert layer back to pure ice by "borrowing" ice from below the column - h2osoi_ice(c,j) = h2osoi_ice(c,j) + h2osoi_liq(c,j) - h2osoi_liq(c,j) = 0._r8 - end if ! liquid water is present - end if ! istice_mec - end do - end do - - end associate - - end subroutine HandleIceMelt - - !----------------------------------------------------------------------- - subroutine ComputeSurfaceMassBalance(this, bounds, num_allc, filter_allc, & - num_do_smb_c, filter_do_smb_c, glc2lnd_inst, waterstate_inst, waterflux_inst) - ! - ! !DESCRIPTION: - ! Compute glacier fluxes other than ice melt. - ! - ! This sets the public fields qflx_glcice_col and qflx_glcice_dyn_water_flux_col to - ! their final values. - ! - ! Should be called after HandleIceMelt, and after waterflux_inst%qflx_snwcp_ice_col is - ! computed - ! - ! !ARGUMENTS: - class(glacier_smb_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 - integer, intent(in) :: num_do_smb_c ! number of column points in filter_do_smb_c - integer, intent(in) :: filter_do_smb_c(:) ! column filter for points where SMB is calculated - type(glc2lnd_type), intent(in) :: glc2lnd_inst - type(waterstate_type), intent(in) :: waterstate_inst - type(waterflux_type), intent(in) :: waterflux_inst - ! - ! !LOCAL VARIABLES: - integer :: fc, c, l, g - - character(len=*), parameter :: subname = 'ComputeSurfaceMassBalance' - !----------------------------------------------------------------------- - - associate( & - qflx_glcice => this%qflx_glcice_col , & ! Output: [real(r8) (:)] net flux of new glacial ice (growth - melt) (mm H2O/s) - qflx_glcice_frz => this%qflx_glcice_frz_col , & ! Output: [real(r8) (:)] ice growth (positive definite) (mm H2O/s) - qflx_glcice_dyn_water_flux => this%qflx_glcice_dyn_water_flux_col , & ! Output: [real(r8) (:)] water flux needed for balance check due to glc_dyn_runoff_routing (mm H2O/s) (positive means addition of water to the system) - qflx_glcice_melt => this%qflx_glcice_melt_col , & ! Input: [real(r8) (:)] ice melt (positive definite) (mm H2O/s) - glc_dyn_runoff_routing => glc2lnd_inst%glc_dyn_runoff_routing_grc , & ! Input: [real(r8) (:)] whether we're doing runoff routing appropriate for having a dynamic icesheet - snow_persistence => waterstate_inst%snow_persistence_col , & ! Input: [real(r8) (:)] counter for length of time snow-covered - qflx_snwcp_ice => waterflux_inst%qflx_snwcp_ice_col & ! Input: [real(r8) (:)] excess solid h2o due to snow capping (outgoing) (mm H2O /s) [+] - ) - - ! NOTE(wjs, 2016-06-29) The following initialization is done in case the columns - ! included / excluded in the do_smb_c filter can change mid-run (besides just being - ! active vs. inactive): If an active column was inside this filter in the previous - ! timestep, but is no longer inside this filter in this timestep, we want this flux to - ! be 0 (rather than remaining at its previous value). (Currently, the set of active - ! columns included in the do_smb filter cannot change mid-run, but the logic is - ! complex enough that I don't want to assume that that will always remain true.) This - ! initialization also handles the case where glc_dyn_runoff_routing may change - ! mid-run, so that a point previously inside that mask no longer is. - do fc = 1, num_allc - c = filter_allc(fc) - qflx_glcice_dyn_water_flux(c) = 0._r8 - end do - - - ! Calculate positive surface mass balance to ice sheets, both from already-glaciated - ! landunits and from non-glaciated landunits (glacial inception) - do fc = 1, num_do_smb_c - c = filter_do_smb_c(fc) - l = col%landunit(c) - g = col%gridcell(c) - ! In the following, we convert glc_snow_persistence_max_days to r8 to avoid overflow - if ( (snow_persistence(c) >= (real(glc_snow_persistence_max_days, r8) * secspday)) & - .or. lun%itype(l) == istice_mec) then - qflx_glcice_frz(c) = qflx_snwcp_ice(c) - else - qflx_glcice_frz(c) = 0._r8 - end if - - qflx_glcice(c) = qflx_glcice_frz(c) - qflx_glcice_melt(c) - - ! For glc_dyn_runoff_routing > 0:: - ! (1) All or part of the excess snow (from snow capping) has been incorporated in - ! qflx_glcice_frz. This flux must be included here to complete the water - ! balance, because it is a sink of water as far as CLM is concerned (this water - ! will now be owned by CISM). - ! (2) Meltwater from ice (qflx_glcice_melt) is allowed to run off and is included - ! in qflx_qrgwl, but the water content of the ice column has not changed - ! because an equivalent ice mass has been "borrowed" from the base of the - ! column. So this borrowing is a source of water as far as CLM is concerned. - ! - ! For glc_dyn_runoff_routing = 0: Point (2) is the same as for the - ! glc_dyn_runoff_routing > 0 case: there is a source of water equal to - ! qflx_glcice_melt. However, in this case, the sink of water is also equal to - ! qflx_glcice_melt: We have simply replaced some liquid water with an equal amount - ! of solid ice. Another way to think about this is: - ! (1) qflx_ice_runoff_snwcp is reduced by an amount equal to qflx_glcice_melt (done - ! elsewhere in this module). The amount of snow removal is therefore given by - ! (qflx_ice_runoff_snwcp + qflx_glcice_melt), meaning that there is an - ! additional sink of water equal to qflx_glcice_melt. - ! (2) Meltwater from ice (qflx_glcice_melt) is allowed to run off and is included - ! in qflx_qrgwl, but the water content of the ice column has not changed - ! because an equivalent ice mass has been "borrowed" from the base of the - ! column. So this borrowing is a source of water as far as CLM is concerned. - ! These two corrections cancel out, so nothing is done here. - qflx_glcice_dyn_water_flux(c) = glc_dyn_runoff_routing(g) * (qflx_glcice_melt(c) - qflx_glcice_frz(c)) - end do - - end associate - - end subroutine ComputeSurfaceMassBalance - - !----------------------------------------------------------------------- - subroutine AdjustRunoffTerms(this, bounds, num_do_smb_c, filter_do_smb_c, & - glc2lnd_inst, qflx_qrgwl, qflx_ice_runoff_snwcp) - ! - ! !DESCRIPTION: - ! Adjust liquid and ice runoff fluxes due to glacier fluxes - ! - ! Should be called after ComputeSurfaceMassBalance, and after qflx_qrgwl and - ! qflx_ice_runoff_snwcp have been given their initial values - ! - ! !USES: - ! - ! !ARGUMENTS: - class(glacier_smb_type), intent(in) :: this - type(bounds_type), intent(in) :: bounds - integer, intent(in) :: num_do_smb_c ! number of column points in filter_do_smb_c - integer, intent(in) :: filter_do_smb_c(:) ! column filter for points where SMB is calculated - type(glc2lnd_type), intent(in) :: glc2lnd_inst - real(r8), intent(inout) :: qflx_qrgwl( bounds%begc: ) ! col qflx_surf at glaciers, wetlands, lakes - real(r8), intent(inout) :: qflx_ice_runoff_snwcp( bounds%begc: ) ! col solid runoff from snow capping (mm H2O /s) - ! - ! !LOCAL VARIABLES: - integer :: fc, c, g - - character(len=*), parameter :: subname = 'AdjustRunoffTerms' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(qflx_qrgwl) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(qflx_ice_runoff_snwcp) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - associate( & - qflx_glcice_frz => this%qflx_glcice_frz_col , & ! Input: [real(r8) (:)] ice growth (positive definite) (mm H2O/s) - qflx_glcice_melt => this%qflx_glcice_melt_col , & ! Input: [real(r8) (:)] ice melt (positive definite) (mm H2O/s) - glc_dyn_runoff_routing => glc2lnd_inst%glc_dyn_runoff_routing_grc & ! Input: [real(r8) (:)] gridcell fraction coupled to dynamic ice sheet - ) - - ! Note that, because the following code only operates over the do_smb filter, that - ! means that the adjustments here are only applied for glacier columns where we're - ! computing SMB. This is consistent with the use of the do_smb filter in - ! HandleIceMelt. - - do fc = 1, num_do_smb_c - c = filter_do_smb_c(fc) - g = col%gridcell(c) - - ! Melt is only generated for glacier columns. But it doesn't hurt to do this for - ! all columns in the do_smb filter: this melt term will be 0 for other columns. - ! Note: Ice melt is added to the runoff whether or not the column is coupled - ! to a dynamic glacier model. - - qflx_qrgwl(c) = qflx_qrgwl(c) + qflx_glcice_melt(c) - - ! For the part of the column that is coupled to a dynamic glacier model, - ! the glacier model handles the fate of capped snow, so we do not want it sent to runoff. - qflx_ice_runoff_snwcp(c) = qflx_ice_runoff_snwcp(c) - glc_dyn_runoff_routing(g)*qflx_glcice_frz(c) - - ! In places where we are not coupled to a dynamic glacier model, CLM sends all of - ! the snow capping to the ocean as an ice runoff term. (This is essentially a crude - ! parameterization of calving, assuming steady state - i.e., all ice gain is - ! balanced by an ice loss.) But each unit of melt that happens is an indication - ! that 1 unit of the ice shouldn't have made it to the ocean - but instead melted - ! before it got there. So we need to correct for that by removing 1 unit of ice - ! runoff for each unit of melt. Note that, for a given point in space & time, this - ! can result in negative ice runoff. However, we expect that, in a temporally and - ! spatially-integrated sense (if we're near equilibrium), this will just serve to - ! decrease the too-high positive ice runoff. - ! - ! Another way to think about this is: ice melt removes mass; the snow capping flux - ! also removes mass. If both the accumulation and melt remove mass, there is a - ! double-counting. So we need to correct that by: for each unit of ice melt - ! (resulting in 1 unit of liquid runoff), remove 1 unit of ice runoff. (This is not - ! an issue for parts of the column coupled to the dynamic glacier model, because - ! then the snow capping mass is retained in the LND-GLC coupled system.) - ! - ! The alternative of simply not adding ice melt to the runoff stream where - ! glc_dyn_runoff_routing = 0 conserves mass, but fails to conserve energy, for a - ! similar reason: Ice melt in CLM removes energy; also, the ocean's melting of the - ! snow capping flux removes energy. If both the accumulation and melting remove - ! energy, there is a double-counting. - ! - ! Yet another way to think about this is: When ice melted, we let the liquid run - ! off, and replaced it with new ice from below. But that new ice needed to come - ! from somewhere to keep the system in water balance. We "request" the new ice from - ! the ocean by generating a negataive ice runoff equivalent to the amount we have - ! melted (i.e., equivalent to the amount of new ice that we created from below). - - ! As above: Melt is only generated for glacier columns. But it doesn't hurt to do - ! this for all columns in the do_smb filter: this melt term will be 0 for other - ! columns. - - qflx_ice_runoff_snwcp(c) = qflx_ice_runoff_snwcp(c) - (1.0_r8 - glc_dyn_runoff_routing(g)) * qflx_glcice_melt(c) - - ! Recall that glc_dyn_runoff_routing = min(lfrac, Sg_icemask_coupled_fluxes_l) / lfrac. - ! - ! Consider a cell with lfrac = 0.8 and Sg_icemask_coupled_fluxes_l = 0.4. (For - ! instance, the cell might have half its land coverage in Greenland and the other - ! half in Ellemere.) Given qflx_ice_runoff_snwcp(c) = 1 m/yr, half the flux (0.5 - ! m/yr) will be sent to the runoff model, where it will be multiplied by lfrac to - ! give a net flux of 0.4 m/yr times the cell area. - ! - ! The full SMB of 1 m/yr will be sent to the coupler's prep_glc_mod, but it will be - ! weighted by 0.4 when integrating over the whole ice sheet. So a net flux of 0.4 - ! m/yr will also be applied to the ice sheet model. The total flux of 0.8 m/yr, - ! split evenly between runoff and ice sheet, is what we want. - - end do - - end associate - - end subroutine AdjustRunoffTerms - -end module GlacierSurfaceMassBalanceMod diff --git a/src/biogeophys/LakeCon.F90 b/src/biogeophys/LakeCon.F90 deleted file mode 100644 index a42a3d01..00000000 --- a/src/biogeophys/LakeCon.F90 +++ /dev/null @@ -1,178 +0,0 @@ -module LakeCon - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Module containing constants and parameters for the Lake code - ! (CLM4-LISSS, documented in Subin et al. 2011, JAMES) - ! Also contains time constant variables for Lake code - ! Created by Zack Subin, 2011 - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use decompMod , only : bounds_type - use clm_varctl , only : iulog - use spmdMod , only : masterproc - ! - ! !PUBLIC TYPES: - implicit none - save - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: LakeConInit - !----------------------------------------------------------------------- - - !------------------------------------------------------------------ - ! Lake Model non-tuneable constants - !------------------------------------------------------------------ - - ! temperature of maximum water density (K) - ! This is from Hostetler and Bartlein (1990); more updated sources suggest 277.13 K. - real(r8), parameter :: tdmax = 277._r8 - - !------------------------------------------------------------------ - ! Lake Model tuneable constants - !------------------------------------------------------------------ - - ! lake emissivity. This is used for both frozen and unfrozen lakes. - ! This is pulled in from CLM4 and the reference is unclear. - real(r8), parameter :: emg_lake = 0.97_r8 - - ! The fraction of the visible (e.g. vis not nir from atm) sunlight - ! absorbed in ~1 m of water (the surface layer za_lake). - ! This is roughly the fraction over 700 nm but may depend on the details - ! of atmospheric radiative transfer. As long as NIR = 700 nm and up, this can be zero. - real(r8) :: betavis = 0.0_r8 - - ! Momentum Roughness length over frozen lakes without snow (m) - ! Typical value found in the literature, and consistent with Mironov expressions. - ! See e.g. Morris EM 1989, Andreas EL 1987, Guest & Davidson 1991 (as cited in Vavrus 1996) - real(r8), parameter :: z0frzlake = 0.001_r8 - - ! Base of surface light absorption layer for lakes (m) - real(r8), parameter :: za_lake = 0.6_r8 - - ! For calculating prognostic roughness length - real(r8), parameter :: cur0 = 0.01_r8 ! min. Charnock parameter - real(r8), parameter :: cus = 0.1_r8 ! empirical constant for roughness under smooth flow - real(r8), parameter :: curm = 0.1_r8 ! maximum Charnock parameter - - ! The following will be set in initLake based on namelists. !TODO - fix this commend - real(r8) :: fcrit ! critical dimensionless fetch for Charnock parameter. - real(r8) :: minz0lake ! (m) Minimum allowed roughness length for unfrozen lakes. - - ! For calculating enhanced diffusivity - real(r8), parameter :: n2min = 7.5e-5_r8 ! (s^-2) (yields diffusivity about 6 times km) ! Fang & Stefan 1996 - - ! Note, this will be adjusted in initLake if the timestep is not 1800 s. - ! Lake top numerics can oscillate with 0.01m top layer and 1800 s timestep. - ! The problem is that the surface flux is fixed during the calculation of the top - ! layer temperature in the diffusion and not corrected for the tendency of the top layer. - ! This thickness will be added to all minimum and maximum snow layer thicknesses compared to that used over non-lakes. - ! Analysis of the CFL condition suggests that the minimum snow layer thickness for 1800 s needs - ! to be at least ~1.2 cm for the bulk snow values of conductivity and heat capacity - ! and as much as 2.3 cm for pure ice. - ! Alternatively, a check could be done in LakeTemperature in case - ! t_grnd(c) - t_soisno(c,snl(c)+1) changed sign after the Crank-Nicholson step. - ! Such an approach, while perhaps allowing additional snow layer resolution, has not been tested. - ! The approach used over non-lakes is to have a first-order surface flux correction. - ! We choose not to do that here because t_grnd can vary independently of the top model - ! layer temperature, while it is fixed to the top layer temperature if tbot > tfrz and - ! the lake is frozen, or if there is an unstable density gradient in the top unfrozen lake layer. - real(r8) :: lsadz = 0.03_r8 ! m - - !! The following will be set in initLake based on namelists. - real(r8) :: pudz ! (m) Optional minimum total ice thickness required to allow lake puddling. - ! Currently used for sensitivity tests only. - real(r8) :: depthcrit ! (m) Depth beneath which to increase mixing. See discussion in Subin et al. 2011 - real(r8) :: mixfact ! Mixing increase factor. - - !!!!!!!!!!! - ! Namelists (some of these have not been extensively tested and are hardwired to default values currently). - !!!!!!!!!!! - - ! used in LakeFluxes - ! true => use old fcrit & minz0 as per Subin et al 2011 form - ! See initLakeMod for details. Difference is very small for - ! small lakes and negligible for large lakes. Currently hardwired off. - logical, public :: lake_use_old_fcrit_minz0 = .false. - - ! used in LakeTemperature - ! Increase mixing by a large factor for deep lakes - ! Crude but enhanced performance at all 4 deep lakes tested. - ! See Subin et al 2011 (JAMES) for details - - ! (m) minimum lake depth to invoke deepmixing - real(r8), public :: deepmixing_depthcrit = 25._r8 - - ! factor to increase mixing by - real(r8), public :: deepmixing_mixfact = 10._r8 - - ! true => Suppress enhanced diffusion. Small differences. - ! Currently hardwired .false. - ! See Subin et al 2011 for details. - ! Enhanced diffusion is intended for under ice and at large depths. - ! It is a much smaller change on its own than the "deepmixing" - ! above, but it increases the effect of deepmixing under ice and for large depths. - logical, public :: lake_no_ed = .false. - - ! puddling (not extensively tested and currently hardwired off) - ! used in LakeTemperature and SurfaceAlbedo - - ! true => suppress convection when greater than minimum amount - ! of ice is present. This also effectively sets lake_no_melt_icealb. - logical, public :: lakepuddling = .false. - - ! (m) minimum amount of total ice nominal thickness before - ! convection is suppressed - real(r8), public :: lake_puddle_thick = 0.2_r8 - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine LakeConInit() - ! - ! !DESCRIPTION: - ! Initialize time invariant variables for S Lake code - !------------------------------------------------------------------------ - - if (masterproc) write (iulog,*) 'Attempting to initialize time invariant variables for lakes' - - ! Set LakeCon constants according to namelist fields - if (lake_use_old_fcrit_minz0) then - ! critical dimensionless fetch for Charnock parameter. From Vickers & Mahrt 1997 - ! but converted to use u instead of u* (Form used in Subin et al. 2011) - fcrit = 22._r8 - - ! (m) Minimum allowed roughness length for unfrozen lakes. - ! (Used in Subin et al. 2011) - minz0lake = 1.e-5_r8 - else - ! Vickers & Mahrt 1997 - fcrit = 100._r8 - - ! (m) Minimum allowed roughness length for unfrozen lakes. - ! Now set low so it is only to avoid floating point exceptions. - minz0lake = 1.e-10_r8 - end if - - if (lakepuddling) then - ! (m) Minimum total ice thickness required to allow lake puddling. Default is 0.2m. - ! This option has not been extensively tested. - ! This option turns on lake_no_melt_icealb, as the decrease in albedo will be based - ! on whether there is water over nice, not purely a function of ice top temperature. - pudz = lake_puddle_thick - end if - - ! (m) Depth beneath which to increase mixing. See discussion in Subin et al. 2011 - depthcrit = deepmixing_depthcrit - - ! Mixing increase factor. ! Defaults are 25 m, increase by 10. - ! Note some other namelists will be used directly in lake physics during model integration. - mixfact = deepmixing_mixfact - - if (masterproc) write (iulog,*) 'Successfully initialized time invariant variables for lakes' - - end subroutine LakeConInit - -end module LakeCon diff --git a/src/biogeophys/LakeStateType.F90 b/src/biogeophys/LakeStateType.F90 deleted file mode 100644 index f440a819..00000000 --- a/src/biogeophys/LakeStateType.F90 +++ /dev/null @@ -1,296 +0,0 @@ -module LakeStateType - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Lake data types and associated procesures - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - use clm_varcon , only : spval, grlnd - use decompMod , only : bounds_type - use spmdMod , only : masterproc - use abortUtils , only : endrun - use LandunitType , only : lun - use ColumnType , only : col - ! - implicit none - save - private - ! - ! !PUBLIC TYPES: - type, public :: lakestate_type - ! Time constant variables - real(r8), pointer :: lakefetch_col (:) ! col lake fetch from surface data (m) - real(r8), pointer :: etal_col (:) ! col lake extinction coefficient from surface data (1/m) - - ! Time varying variables - real(r8), pointer :: lake_raw_col (:) ! col aerodynamic resistance for moisture (s/m) - real(r8), pointer :: ks_col (:) ! col coefficient for calculation of decay of eddy diffusivity with depth - real(r8), pointer :: ws_col (:) ! col surface friction velocity (m/s) - real(r8), pointer :: ust_lake_col (:) ! col friction velocity (m/s) - real(r8), pointer :: betaprime_col (:) ! col effective beta: sabg_lyr(p,jtop) for snow layers, beta otherwise - real(r8), pointer :: savedtke1_col (:) ! col top level eddy conductivity from previous timestep (W/mK) - real(r8), pointer :: lake_icefrac_col (:,:) ! col mass fraction of lake layer that is frozen - real(r8), pointer :: lake_icefracsurf_col(:) ! col mass fraction of surface lake layer that is frozen - real(r8), pointer :: lake_icethick_col (:) ! col ice thickness (m) (integrated if lakepuddling) - real(r8), pointer :: lakeresist_col (:) ! col [s/m] (Needed for calc. of grnd_ch4_cond) - real(r8), pointer :: ram1_lake_patch (:) ! patch aerodynamical resistance (s/m) - - contains - - procedure, public :: Init - procedure, public :: Restart - procedure, private :: InitAllocate - procedure, private :: InitHistory - procedure, private :: InitCold - - end type lakestate_type - !----------------------------------------------------------------------- - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, bounds) - - class(lakestate_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: - ! Allocate module variables and data structures - ! - ! !USES: - use shr_infnan_mod, only: nan => shr_infnan_nan, assignment(=) - use clm_varpar , only: nlevlak, nlevsno - ! - ! !ARGUMENTS: - class(lakestate_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begp, endp - integer :: begc, endc - !--------------------------------------------------------------------- - - ! Initialize savedtke1 to spval so that c->g averaging will be done correctly - ! TODO: can this be now be set to nan??? - ! Initialize ust_lake to spval to detect input from restart file if not arbinit - ! TODO: can this be removed now??? - - begp = bounds%begp; endp= bounds%endp - begc = bounds%begc; endc = bounds%endc - - allocate(this%etal_col (begc:endc)) ; this%etal_col (:) = nan - allocate(this%lakefetch_col (begc:endc)) ; this%lakefetch_col (:) = nan - allocate(this%lakeresist_col (begc:endc)) ; this%lakeresist_col (:) = nan - allocate(this%savedtke1_col (begc:endc)) ; this%savedtke1_col (:) = spval - allocate(this%lake_icefrac_col (begc:endc,1:nlevlak)) ; this%lake_icefrac_col (:,:) = nan - allocate(this%lake_icefracsurf_col (begc:endc)) ; this%lake_icefracsurf_col (:) = nan - allocate(this%lake_icethick_col (begc:endc)) ; this%lake_icethick_col (:) = nan - allocate(this%ust_lake_col (begc:endc)) ; this%ust_lake_col (:) = spval - allocate(this%ram1_lake_patch (begp:endp)) ; this%ram1_lake_patch (:) = nan - allocate(this%lake_raw_col (begc:endc)) ; this%lake_raw_col (:) = nan - allocate(this%ks_col (begc:endc)) ; this%ks_col (:) = nan - allocate(this%ws_col (begc:endc)) ; this%ws_col (:) = nan - allocate(this%betaprime_col (begc:endc)) ; this%betaprime_col (:) = 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(lakestate_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 - - this%lake_icefrac_col(begc:endc,:) = spval - call hist_addfld2d (fname='LAKEICEFRAC', units='unitless', type2d='levlak', & - avgflag='A', long_name='lake layer ice mass fraction', & - ptr_col=this%lake_icefrac_col, default='inactive') - - this%lake_icefracsurf_col(begc:endc) = spval - call hist_addfld1d (fname='LAKEICEFRAC_SURF', units='unitless', & - avgflag='A', long_name='surface lake layer ice mass fraction', & - ptr_col=this%lake_icefracsurf_col, set_nolake=spval, default='inactive') - - this%lake_icethick_col(begc:endc) = spval ! This will be more useful than LAKEICEFRAC for many users. - call hist_addfld1d (fname='LAKEICETHICK', units='m', & - avgflag='A', long_name='thickness of lake ice (including physical expansion on freezing)', & - ptr_col=this%lake_icethick_col, set_nolake=spval, default='inactive') - - this%savedtke1_col(begc:endc) = spval - call hist_addfld1d (fname='TKE1', units='W/(mK)', & - avgflag='A', long_name='top lake level eddy thermal conductivity', & - ptr_col=this%savedtke1_col, default='inactive') - - this%ram1_lake_patch(begp:endp) = spval - call hist_addfld1d (fname='RAM_LAKE', units='s/m', & - avgflag='A', long_name='aerodynamic resistance for momentum (lakes only)', & - ptr_patch=this%ram1_lake_patch, set_nolake=spval, default='inactive') - - this%ust_lake_col(begc:endc) = spval - call hist_addfld1d (fname='UST_LAKE', units='m/s', & - avgflag='A', long_name='friction velocity (lakes only)', & - ptr_col=this%ust_lake_col, set_nolake=spval, default='inactive') - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine InitCold(this, bounds) - ! - ! !DESCRIPTION: - ! Initialize time constant and time varying module variables - ! - ! !USES: - use clm_varctl , only : fsurdat - use clm_varctl , only : iulog - use clm_varpar , only : nlevlak - use clm_varcon , only : tkwat - use fileutils , only : getfil - use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_double, ncd_int, ncd_inqvdlen - use ncdio_pio , only : ncd_pio_openfile, ncd_inqfdims, ncd_pio_closefile, ncd_inqdid, ncd_inqdlen - ! - ! !ARGUMENTS: - class(lakestate_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: c,g,i,j,l,lev - logical :: readvar - type(file_desc_t) :: ncid ! netcdf id - character(len=256) :: locfn ! local filename - real(r8) :: depthratio ! ratio of lake depth to standard deep lake depth - real(r8) ,pointer :: lakefetch_in (:) ! read in - lakefetch - real(r8) ,pointer :: etal_in (:) ! read in - etal - !----------------------------------------------------------------------- - - !------------------------------------------------- - ! Initialize time constant variables - !------------------------------------------------- - - call getfil (fsurdat, locfn, 0) - call ncd_pio_openfile (ncid, locfn, 0) - - ! Read lake eta - allocate(etal_in(bounds%begg:bounds%endg)) - call ncd_io(ncid=ncid, varname='ETALAKE', flag='read', data=etal_in, dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - if (masterproc) then - write(iulog,*) 'WARNING:: ETALAKE not found on surface data set. All lake columns will have eta', & - ' set equal to default value as a function of depth.' - end if - etal_in(:) = -1._r8 - end if - do c = bounds%begc, bounds%endc - g = col%gridcell(c) - this%etal_col(c) = etal_in(g) - end do - deallocate(etal_in) - - ! Read lake fetch - allocate(lakefetch_in(bounds%begg:bounds%endg)) - call ncd_io(ncid=ncid, varname='LAKEFETCH', flag='read', data=lakefetch_in, dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - if (masterproc) then - write(iulog,*) 'WARNING:: LAKEFETCH not found on surface data set. All lake columns will have fetch', & - ' set equal to default value as a function of depth.' - end if - lakefetch_in(:) = -1._r8 - end if - do c = bounds%begc, bounds%endc - g = col%gridcell(c) - this%lakefetch_col(c) = lakefetch_in(g) - end do - deallocate(lakefetch_in) - - call ncd_pio_closefile(ncid) - - !------------------------------------------------- - ! Initialize time varying variables - !------------------------------------------------- - - do c = bounds%begc, bounds%endc - l = col%landunit(c) - if (lun%lakpoi(l)) then - - ! Set lake ice fraction and top eddy conductivity from previous timestep - ! Always initialize with no ice to prevent excessive ice sheets from forming when - ! starting with old lake model that has unrealistically cold lake conseratures. - ! Keep lake temperature as is, and the energy deficit below freezing (which is no smaller - ! than it would have been with prognostic ice, as the temperature would then have been higher - ! and more heat would have flowed out of the lake) will be converted to ice in the first timestep. - this%lake_icefrac_col(c,1:nlevlak) = 0._r8 - - ! Set lake top eddy conductivity from previous timestep - this%savedtke1_col(c) = tkwat - - ! Set column friction vlocity - this%ust_lake_col(c) = 0.1_r8 - end if - end do - - 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_defvar, ncd_io, ncd_double, ncd_int, ncd_inqvdlen - use restUtilMod - ! - ! !ARGUMENTS: - class(lakestate_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='LAKE_ICEFRAC', xtype=ncd_double, & - dim1name='column', dim2name='levlak', switchdim=.true., & - long_name='lake layer ice fraction', units='kg/kg', & - interpinic_flag='interp', readvar=readvar, data=this%lake_icefrac_col) - - call restartvar(ncid=ncid, flag=flag, varname='SAVEDTKE1', xtype=ncd_double, & - dim1name='column', & - long_name='top lake layer eddy conductivity', units='W/(m K)', & - interpinic_flag='interp', readvar=readvar, data=this%savedtke1_col) - - call restartvar(ncid=ncid, flag=flag, varname='USTLAKE', xtype=ncd_double, & - dim1name='column', & - long_name='friction velocity for lakes', units='m/s', & - interpinic_flag='interp', readvar=readvar, data=this%ust_lake_col) - - end subroutine Restart - -end module LakeStateType - diff --git a/src/biogeophys/OzoneBaseMod.F90 b/src/biogeophys/OzoneBaseMod.F90 deleted file mode 100644 index c50818f3..00000000 --- a/src/biogeophys/OzoneBaseMod.F90 +++ /dev/null @@ -1,146 +0,0 @@ -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/src/biogeophys/OzoneFactoryMod.F90 b/src/biogeophys/OzoneFactoryMod.F90 deleted file mode 100644 index 2b28587a..00000000 --- a/src/biogeophys/OzoneFactoryMod.F90 +++ /dev/null @@ -1,53 +0,0 @@ -module OzoneFactoryMod - - !--------------------------------------------------------------------------- - ! !DESCRIPTION: - ! Factory to create an instance of ozone_base_type. This module figures out the - ! particular type to return. - ! - ! !USES: - use decompMod , only : bounds_type - - implicit none - save - private - - ! - ! !PUBLIC ROUTINES: - public :: create_and_init_ozone_type ! create an object of class ozone_base_type - -contains - - !----------------------------------------------------------------------- - function create_and_init_ozone_type(bounds) result(ozone) - ! - ! !DESCRIPTION: - ! Create and initialize an object of ozone_base_type, and return this object. The - ! particular type is determined based on the use_ozone namelist parameter. - ! - ! !USES: - use clm_varctl , only : use_ozone - use OzoneBaseMod , only : ozone_base_type - use OzoneOffMod , only : ozone_off_type - use OzoneMod , only : ozone_type - ! - ! !ARGUMENTS: - class(ozone_base_type), allocatable :: ozone ! function result - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'create_and_init_ozone_type' - !----------------------------------------------------------------------- - - if (use_ozone) then - allocate(ozone, source = ozone_type()) - else - allocate(ozone, source = ozone_off_type()) - end if - - call ozone%Init(bounds) - - end function create_and_init_ozone_type - -end module OzoneFactoryMod diff --git a/src/biogeophys/OzoneMod.F90 b/src/biogeophys/OzoneMod.F90 deleted file mode 100644 index 6c0e3577..00000000 --- a/src/biogeophys/OzoneMod.F90 +++ /dev/null @@ -1,543 +0,0 @@ -module OzoneMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Calculates ozone-induced stress. - ! - ! Note that the ozone calculations need to happen AFTER rssun and rsshade are computed - ! by the Photosynthesis routine. However, Photosynthesis also uses the ozone stress - ! computed here. Thus, the ozone stress computed in timestep i is applied in timestep - ! (i+1), requiring these stresses to be saved on the restart file. - ! - ! Developed by Danica Lombardozzi. - ! - ! !USES: -#include "shr_assert.h" - use shr_kind_mod, only : r8 => shr_kind_r8 - use decompMod , only : bounds_type - use clm_varcon , only : spval - use shr_log_mod , only : errMsg => shr_log_errMsg - use OzoneBaseMod, only : ozone_base_type - use abortutils , only : endrun - - implicit none - save - private - - ! !PUBLIC TYPES: - type, extends(ozone_base_type), public :: ozone_type - private - ! Private data members - real(r8), pointer :: o3uptakesha_patch(:) ! ozone dose, shaded leaves (mmol O3/m^2) - real(r8), pointer :: o3uptakesun_patch(:) ! ozone dose, sunlit leaves (mmol O3/m^2) - - ! NOTE(wjs, 2014-09-29) tlai_old_patch really belongs alongside tlai_patch in - ! CanopyStateType. But there are problems with any way I can think to implement - ! that: - ! - ! - Updating tlai_old from a call in clm_driver, just before tlai is updated: This - ! is problematic to do correctly because tlai is updated in different places - ! depending on whether you're using SP, CN or ED. - ! - ! - Updating tlai_old within each routine that updates tlai: This feels fragile, - ! since it depends on each scheme remembering to do this update at the correct - ! time. - ! - ! - Making tlai a private member of CanopyFluxes, with getter and setter methods. - ! Then the setter method would also set tlai_old. This feels like the most robust - ! solution, but we don't have any precedent for using getters and setters for data - ! arrays. - real(r8), pointer :: tlai_old_patch(:) ! tlai from last time step - - contains - ! Public routines - procedure, public :: Init - procedure, public :: Restart - procedure, public :: CalcOzoneStress - - ! Private routines - procedure, private :: InitAllocate - procedure, private :: InitHistory - procedure, private :: InitCold - - ! Calculate ozone stress for a single point, for just sunlit or shaded leaves - procedure, private, nopass :: CalcOzoneStressOnePoint - end type ozone_type - - interface ozone_type - module procedure constructor - end interface ozone_type - - ! !PRIVATE TYPES: - - ! TODO(wjs, 2014-09-29) This parameter will eventually become a spatially-varying - ! value, obtained from ATM - real(r8), parameter :: forc_ozone = 100._r8 * 1.e-9_r8 ! ozone partial pressure [mol/mol] - - ! TODO(wjs, 2014-09-29) The following parameters should eventually be moved to the - ! params file. Parameters differentiated on veg type should be put on the params file - ! with a pft dimension. - - ! o3:h2o resistance ratio defined by Sitch et al. 2007 - real(r8), parameter :: ko3 = 1.67_r8 - - ! LAI threshold for LAIs that asymptote and don't reach 0 - real(r8), parameter :: lai_thresh = 0.5_r8 - - ! threshold below which o3flux is set to 0 (nmol m^-2 s^-1) - real(r8), parameter :: o3_flux_threshold = 0.8_r8 - - ! o3 intercepts and slopes for photosynthesis - real(r8), parameter :: needleleafPhotoInt = 0.8390_r8 ! units = unitless - real(r8), parameter :: needleleafPhotoSlope = 0._r8 ! units = per mmol m^-2 - real(r8), parameter :: broadleafPhotoInt = 0.8752_r8 ! units = unitless - real(r8), parameter :: broadleafPhotoSlope = 0._r8 ! units = per mmol m^-2 - real(r8), parameter :: nonwoodyPhotoInt = 0.8021_r8 ! units = unitless - real(r8), parameter :: nonwoodyPhotoSlope = -0.0009_r8 ! units = per mmol m^-2 - - ! o3 intercepts and slopes for conductance - real(r8), parameter :: needleleafCondInt = 0.7823_r8 ! units = unitless - real(r8), parameter :: needleleafCondSlope = 0.0048_r8 ! units = per mmol m^-2 - real(r8), parameter :: broadleafCondInt = 0.9125_r8 ! units = unitless - real(r8), parameter :: broadleafCondSlope = 0._r8 ! units = per mmol m^-2 - real(r8), parameter :: nonwoodyCondInt = 0.7511_r8 ! units = unitless - real(r8), parameter :: nonwoodyCondSlope = 0._r8 ! units = per mmol m^-2 - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - ! ======================================================================== - ! Infrastructure routines (initialization, restart, etc.) - ! ======================================================================== - - !----------------------------------------------------------------------- - function constructor() result(ozone) - ! - ! !DESCRIPTION: - ! Return an instance of ozone_type - ! - ! !USES: - ! - ! !ARGUMENTS: - type(ozone_type) :: ozone ! function result - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'constructor' - !----------------------------------------------------------------------- - - ! DO NOTHING (simply return a variable of the appropriate type) - - ! Eventually this should call the Init routine (or replace the Init routine - ! entirely). But I think it would be confusing to do that until we switch everything - ! to use a constructor rather than the init routine. - - end function constructor - - - !----------------------------------------------------------------------- - subroutine Init(this, bounds) - ! - ! !DESCRIPTION: - ! Initialize ozone data structure - ! - ! !ARGUMENTS: - class(ozone_type), intent(inout) :: 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: - ! Allocate memory for ozone data structure - ! - ! !USES: - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - ! - ! !ARGUMENTS: - class(ozone_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begp, endp - !----------------------------------------------------------------------- - - begp = bounds%begp - endp = bounds%endp - - call this%InitAllocateBase(bounds) - - allocate(this%o3uptakesha_patch(begp:endp)) ; this%o3uptakesha_patch(:) = nan - allocate(this%o3uptakesun_patch(begp:endp)) ; this%o3uptakesun_patch(:) = nan - allocate(this%tlai_old_patch(begp:endp)) ; this%tlai_old_patch(:) = nan - - end subroutine InitAllocate - - !----------------------------------------------------------------------- - subroutine InitHistory(this, bounds) - ! - ! !DESCRIPTION: - ! Initialize ozone history variables - ! - ! !USES: - use histFileMod , only : hist_addfld1d - ! - ! !ARGUMENTS: - class(ozone_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%o3uptakesun_patch(begp:endp) = spval - call hist_addfld1d (fname='O3UPTAKESUN', units='mmol/m^2', & - avgflag='A', long_name='total ozone flux into sunlit leaves', & - ptr_patch=this%o3uptakesun_patch, default='inactive') - - this%o3uptakesha_patch(begp:endp) = spval - call hist_addfld1d (fname='O3UPTAKESHA', units='mmol/m^2', & - avgflag='A', long_name='total ozone flux into shaded leaves', & - ptr_patch=this%o3uptakesha_patch, default='inactive') - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine InitCold(this, bounds) - ! - ! !DESCRIPTION: - ! Perform cold-start initialization for ozone - ! - ! !ARGUMENTS: - class(ozone_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begp, endp - - character(len=*), parameter :: subname = 'InitCold' - !----------------------------------------------------------------------- - - begp = bounds%begp - endp = bounds%endp - - call this%InitColdBase(bounds) - - this%o3uptakesha_patch(begp:endp) = 0._r8 - this%o3uptakesun_patch(begp:endp) = 0._r8 - this%tlai_old_patch(begp:endp) = 0._r8 - - end subroutine InitCold - - !----------------------------------------------------------------------- - subroutine Restart(this, bounds, ncid, flag) - ! - ! !DESCRIPTION: - ! Handle restart of ozone variables. - ! - ! !USES: - use ncdio_pio , only : file_desc_t, ncd_inqvdlen, ncd_double - use restUtilMod - ! - ! !ARGUMENTS: - class(ozone_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' - ! - ! !LOCAL VARIABLES: - logical :: readvar - - character(len=*), parameter :: subname = 'Restart' - !----------------------------------------------------------------------- - - call restartvar(ncid=ncid, flag=flag, varname='o3_tlaiold', xtype=ncd_double, & - dim1name='pft', & - long_name='one-sided leaf area index, from previous timestep, for ozone calculations', units='', & - readvar=readvar, interpinic_flag='interp', data=this%tlai_old_patch) - - call restartvar(ncid=ncid, flag=flag, varname='o3uptakesha', xtype=ncd_double, & - dim1name='pft', & - long_name='ozone uptake for shaded leaves', units='mmol m^-3', & - readvar=readvar, interpinic_flag='interp', data=this%o3uptakesha_patch) - - call restartvar(ncid=ncid, flag=flag, varname='o3uptakesun', xtype=ncd_double, & - dim1name='pft', & - long_name='ozone uptake for sunlit leaves', units='mmol m^-3', & - readvar=readvar, interpinic_flag='interp', data=this%o3uptakesun_patch) - - call restartvar(ncid=ncid, flag=flag, varname='o3coefvsun', xtype=ncd_double, & - dim1name='pft', & - long_name='ozone coefficient for photosynthesis for sunlit leaves', units='unitless', & - readvar=readvar, interpinic_flag='interp', data=this%o3coefvsun_patch) - - call restartvar(ncid=ncid, flag=flag, varname='o3coefgsun', xtype=ncd_double, & - dim1name='pft', & - long_name='ozone coefficient for stomatal conductance for sunlit leaves', units='unitless', & - readvar=readvar, interpinic_flag='interp', data=this%o3coefgsun_patch) - - call restartvar(ncid=ncid, flag=flag, varname='o3coefvsha', xtype=ncd_double, & - dim1name='pft', & - long_name='ozone coefficient for photosynthesis for shaded leaves', units='unitless', & - readvar=readvar, interpinic_flag='interp', data=this%o3coefvsha_patch) - - call restartvar(ncid=ncid, flag=flag, varname='o3coefgsha', xtype=ncd_double, & - dim1name='pft', & - long_name='ozone coefficient for stomatal conductance for shaded leaves', units='unitless', & - readvar=readvar, interpinic_flag='interp', data=this%o3coefgsha_patch) - - end subroutine Restart - - ! ======================================================================== - ! Science routines - ! ======================================================================== - - !----------------------------------------------------------------------- - subroutine CalcOzoneStress(this, bounds, num_exposedvegp, filter_exposedvegp, & - forc_pbot, forc_th, rssun, rssha, rb, ram, tlai) - ! - ! !DESCRIPTION: - ! Calculate ozone stress. - ! - ! !USES: - use PatchType , only : patch - ! - ! !ARGUMENTS: - class(ozone_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 - ! - ! !LOCAL VARIABLES: - integer :: fp ! filter index - integer :: p ! patch index - integer :: c ! column index - - character(len=*), parameter :: subname = 'CalcOzoneStress' - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - SHR_ASSERT_ALL((ubound(forc_pbot) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(forc_th) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(rssun) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(rssha) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(rb) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(ram) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(tlai) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - - associate( & - o3coefvsha => this%o3coefvsha_patch , & ! Output: [real(r8) (:)] ozone coef - o3coefvsun => this%o3coefvsun_patch , & ! Output: [real(r8) (:)] ozone coef - o3coefgsha => this%o3coefgsha_patch , & ! Output: [real(r8) (:)] ozone coef - o3coefgsun => this%o3coefgsun_patch , & ! Output: [real(r8) (:)] ozone coef - o3uptakesha => this%o3uptakesha_patch , & ! Output: [real(r8) (:)] ozone dose - o3uptakesun => this%o3uptakesun_patch , & ! Output: [real(r8) (:)] ozone dose - tlai_old => this%tlai_old_patch & ! Output: [real(r8) (:)] tlai from last time step - ) - - do fp = 1, num_exposedvegp - p = filter_exposedvegp(fp) - c = patch%column(p) - -! if (.not.patch%is_fates(p)) then ! When FATES coexists with other vegetation, - ! or when it has an ozone compatible module, this - ! logic will likely come into play - - ! Ozone stress for shaded leaves - call CalcOzoneStressOnePoint( & - forc_ozone=forc_ozone, forc_pbot=forc_pbot(c), forc_th=forc_th(c), & - rs=rssha(p), rb=rb(p), ram=ram(p), & - tlai=tlai(p), tlai_old=tlai_old(p), pft_type=patch%itype(p), & - o3uptake=o3uptakesha(p), o3coefv=o3coefvsha(p), o3coefg=o3coefgsha(p)) - - ! Ozone stress for sunlit leaves - call CalcOzoneStressOnePoint( & - forc_ozone=forc_ozone, forc_pbot=forc_pbot(c), forc_th=forc_th(c), & - rs=rssun(p), rb=rb(p), ram=ram(p), & - tlai=tlai(p), tlai_old=tlai_old(p), pft_type=patch%itype(p), & - o3uptake=o3uptakesun(p), o3coefv=o3coefvsun(p), o3coefg=o3coefgsun(p)) - - tlai_old(p) = tlai(p) - -! else -! ! FATES is fundamentlaly incompatible with this type of patch-level -! ! association with plant functional type, so for the time -! ! being, fates patches will just push these values to invalid -! o3uptakesha(p) = spval -! o3coefvsha(p) = spval -! o3coefgsha(p) = spval -! o3uptakesun(p) = spval -! o3coefvsun(p) = spval -! o3coefgsun(p) = spval -! -! end if - -! else -! ! FATES is fundamentlaly incompatible with this type of patch-level -! ! association with plant functional type, so for the time -! ! being, fates patches will just push these values to invalid -! o3uptakesha(p) = spval -! o3coefvsha(p) = spval -! o3coefgsha(p) = spval -! o3uptakesun(p) = spval -! o3coefvsun(p) = spval -! o3coefgsun(p) = spval -! -! end if - - end do - - end associate - - end subroutine CalcOzoneStress - - !----------------------------------------------------------------------- - subroutine CalcOzoneStressOnePoint( & - forc_ozone, forc_pbot, forc_th, & - rs, rb, ram, & - tlai, tlai_old, pft_type, & - o3uptake, o3coefv, o3coefg) - ! - ! !DESCRIPTION: - ! Calculates ozone stress for a single point, for just sunlit or shaded leaves - ! - ! !USES: - use shr_const_mod , only : SHR_CONST_RGAS - use pftconMod , only : pftcon - use clm_time_manager , only : get_step_size - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: forc_ozone ! ozone partial pressure (mol/mol) - real(r8) , intent(in) :: forc_pbot ! atmospheric pressure (Pa) - real(r8) , intent(in) :: forc_th ! atmospheric potential temperature (K) - real(r8) , intent(in) :: rs ! leaf stomatal resistance (s/m) - real(r8) , intent(in) :: rb ! boundary layer resistance (s/m) - real(r8) , intent(in) :: ram ! aerodynamical resistance (s/m) - real(r8) , intent(in) :: tlai ! one-sided leaf area index, no burying by snow - real(r8) , intent(in) :: tlai_old ! tlai from last time step - integer , intent(in) :: pft_type ! vegetation type, for indexing into pftvarcon arrays - real(r8) , intent(inout) :: o3uptake ! ozone entering the leaf - real(r8) , intent(out) :: o3coefv ! ozone coefficient for photosynthesis (0 - 1) - real(r8) , intent(out) :: o3coefg ! ozone coefficient for conductance (0 - 1) - ! - ! !LOCAL VARIABLES: - integer :: dtime ! land model time step (sec) - real(r8) :: dtimeh ! time step in hours - real(r8) :: o3concnmolm3 ! o3 concentration (nmol/m^3) - real(r8) :: o3flux ! instantaneous o3 flux (nmol m^-2 s^-1) - real(r8) :: o3fluxcrit ! instantaneous o3 flux beyond threshold (nmol m^-2 s^-1) - real(r8) :: o3fluxperdt ! o3 flux per timestep (mmol m^-2) - real(r8) :: heal ! o3uptake healing rate based on % of new leaves growing (mmol m^-2) - real(r8) :: leafturn ! leaf turnover time / mortality rate (per hour) - real(r8) :: decay ! o3uptake decay rate based on leaf lifetime (mmol m^-2) - real(r8) :: photoInt ! intercept for photosynthesis - real(r8) :: photoSlope ! slope for photosynthesis - real(r8) :: condInt ! intercept for conductance - real(r8) :: condSlope ! slope for conductance - - character(len=*), parameter :: subname = 'CalcOzoneStressOnePoint' - !----------------------------------------------------------------------- - - ! convert o3 from mol/mol to nmol m^-3 - o3concnmolm3 = forc_ozone * 1.e9_r8 * (forc_pbot/(forc_th*SHR_CONST_RGAS*0.001_r8)) - - ! calculate instantaneous flux - o3flux = o3concnmolm3/ (ko3*rs+ rb + ram) - - ! apply o3 flux threshold - if (o3flux < o3_flux_threshold) then - o3fluxcrit = 0._r8 - else - o3fluxcrit = o3flux - o3_flux_threshold - endif - - dtime = get_step_size() - dtimeh = dtime / 3600._r8 - - ! calculate o3 flux per timestep - o3fluxperdt = o3fluxcrit * dtime * 0.000001_r8 - - if (tlai > lai_thresh) then - ! checking if new leaf area was added - if (tlai - tlai_old > 0) then - ! minimizing o3 damage to new leaves - heal = max(0._r8,(((tlai-tlai_old)/tlai)*o3fluxperdt)) - else - heal = 0._r8 - endif - - if (pftcon%evergreen(pft_type) == 1) then - leafturn = 1._r8/(pftcon%leaf_long(pft_type)*365._r8*24._r8) - else - leafturn = 0._r8 - endif - - ! o3 uptake decay based on leaf lifetime for evergreen plants - decay = o3uptake * leafturn * dtimeh - !cumulative uptake (mmol m^-2) - o3uptake = max(0._r8, o3uptake + o3fluxperdt - decay - heal) - - else - o3uptake = 0._r8 - end if - - - if (o3uptake == 0._r8) then - ! No o3 damage if no o3 uptake - o3coefv = 1._r8 - o3coefg = 1._r8 - else - ! Determine parameter values for this pft - ! TODO(wjs, 2014-10-01) Once these parameters are moved into the params file, this - ! logic can be removed. - if (pft_type>3) then - if (pftcon%woody(pft_type)==0) then - photoInt = nonwoodyPhotoInt - photoSlope = nonwoodyPhotoSlope - condInt = nonwoodyCondInt - condSlope = nonwoodyCondSlope - else - photoInt = broadleafPhotoInt - photoSlope = broadleafPhotoSlope - condInt = broadleafCondInt - condSlope = broadleafCondSlope - end if - else - photoInt = needleleafPhotoInt - photoSlope = needleleafPhotoSlope - condInt = needleleafCondInt - condSlope = needleleafCondSlope - end if - - ! Apply parameter values to compute o3 coefficients - o3coefv = max(0._r8, min(1._r8, photoInt + photoSlope * o3uptake)) - o3coefg = max(0._r8, min(1._r8, condInt + condSlope * o3uptake)) - - end if - - end subroutine CalcOzoneStressOnePoint - - -end module OzoneMod diff --git a/src/biogeophys/OzoneOffMod.F90 b/src/biogeophys/OzoneOffMod.F90 deleted file mode 100644 index 8d0df71f..00000000 --- a/src/biogeophys/OzoneOffMod.F90 +++ /dev/null @@ -1,118 +0,0 @@ -module OzoneOffMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Provides an implementatio of ozone_base_type for the ozone-off case. Note that very - ! little needs to be done in this case, so this module mainly provides empty - ! implementations to satisfy the interface. - ! - ! !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 OzoneBaseMod, only : ozone_base_type - - implicit none - save - private - - ! !PUBLIC TYPES: - type, extends(ozone_base_type), public :: ozone_off_type - private - contains - procedure, public :: Init - procedure, public :: Restart - procedure, public :: CalcOzoneStress - end type ozone_off_type - - interface ozone_off_type - module procedure constructor - end interface ozone_off_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - !----------------------------------------------------------------------- - function constructor() result(ozone_off) - ! - ! !DESCRIPTION: - ! Return an instance of ozone_off_type - ! - ! !USES: - ! - ! !ARGUMENTS: - type(ozone_off_type) :: ozone_off ! function result - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'constructor' - !----------------------------------------------------------------------- - - ! DO NOTHING (simply return a variable of the appropriate type) - - ! Eventually this should call the Init routine (or replace the Init routine - ! entirely). But I think it would be confusing to do that until we switch everything - ! to use a constructor rather than the init routine. - - end function constructor - - - subroutine Init(this, bounds) - class(ozone_off_type) , intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - - call this%InitAllocateBase(bounds) - call this%InitColdBase(bounds) - end subroutine Init - - subroutine Restart(this, bounds, ncid, flag) - use ncdio_pio , only : file_desc_t - - class(ozone_off_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' - - ! DO NOTHING - - end subroutine Restart - - subroutine CalcOzoneStress(this, bounds, num_exposedvegp, filter_exposedvegp, & - forc_pbot, forc_th, rssun, rssha, rb, ram, tlai) - - class(ozone_off_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 - - ! Enforce expected array sizes (mainly so that a debug-mode threaded test with - ! ozone-off can pick up problems with the call to this routine) - SHR_ASSERT_ALL((ubound(forc_pbot) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(forc_th) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(rssun) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(rssha) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(rb) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(ram) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(tlai) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - - ! Explicitly set outputs to 1. This isn't really needed, because they should still be - ! at 1 from cold-start initialization, but do this for clarity here. - - this%o3coefvsha_patch(bounds%begp:bounds%endp) = 1._r8 - this%o3coefvsun_patch(bounds%begp:bounds%endp) = 1._r8 - this%o3coefgsha_patch(bounds%begp:bounds%endp) = 1._r8 - this%o3coefgsun_patch(bounds%begp:bounds%endp) = 1._r8 - - end subroutine CalcOzoneStress - -end module OzoneOffMod diff --git a/src/biogeophys/PhotosynthesisMod.F90 b/src/biogeophys/PhotosynthesisMod.F90 deleted file mode 100644 index 311780b6..00000000 --- a/src/biogeophys/PhotosynthesisMod.F90 +++ /dev/null @@ -1,612 +0,0 @@ -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_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, spval - use decompMod , only : bounds_type - use pftconMod , only : pftcon - use atm2lndType , only : atm2lnd_type - use CanopyStateType , only : canopystate_type - use WaterStateType , only : waterstate_type - use WaterfluxType , only : waterflux_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 - ! - ! !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), allocatable, public :: krmax (:) - real(r8), allocatable, private :: kmax (:,:) - real(r8), allocatable, private :: psi50 (:,:) - real(r8), allocatable, private :: ck (:,:) - real(r8), allocatable, public :: psi_soil_ref (:) - real(r8), allocatable, private :: lmr_intercept_atkin(:) - 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, private :: gs_mol_sun_patch (:,:) ! patch sunlit leaf stomatal conductance (umol H2O/m**2/s) - real(r8), pointer, private :: gs_mol_sha_patch (:,:) ! patch shaded leaf stomatal conductance (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 :: theta_cj_patch (:) ! patch empirical curvature parameter for ac, aj photosynthesis co-limitation - 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 :: alphapsnsun_patch (:) ! patch sunlit 13c fractionation ([]) - real(r8), pointer, private :: alphapsnsha_patch (:) ! patch shaded 13c fractionation ([]) - - 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, 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 :: 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 :: ReadParams - - ! 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%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%theta_cj_patch (begp:endp)) ; this%theta_cj_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%psnsun_patch (begp:endp)) ; this%psnsun_patch (:) = nan - allocate(this%psnsha_patch (begp:endp)) ; this%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%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%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%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, default='inactive') - - ! 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/m2s', & - avgflag='A', long_name='photosynthesis', & - ptr_patch=this%fpsn_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_wc_patch(begp:endp) = spval - call hist_addfld1d (fname='FPSN_WC', units='umol/m2s', & - 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/m2s', & - 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/m2s', & - 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, default='inactive') - - 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, default='inactive') - end if - - 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, set_lake=spval, set_urb=spval, default='inactive') - - 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, set_lake=spval, set_urb=spval, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - call hist_addfld2d (fname='Jmx25Z', units='umol/m2/s', type2d='nlevcan', & - avgflag='A', long_name='canopy profile of vcmax25 predicted by LUNA model', & - ptr_patch=this%jmx25_z_patch, default='inactive') - - 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, default='inactive') - ptr_1d => this%jmx25_z_patch(:,1) - call hist_addfld1d (fname='Jmx25Z', units='umol/m2/s',& - avgflag='A', long_name='canopy profile of vcmax25 predicted by LUNA model', & - ptr_patch=ptr_1d, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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 - 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%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 - allocate( this%psi_soil_ref(0:mxpft) ) ; this%psi_soil_ref(:) = 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 - 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 = "psi_soil_ref" - 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%psi_soil_ref=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 = "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 - - end subroutine readParams - - !------------------------------------------------------------------------ - 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 - !----------------------------------------------------------------------- - - 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='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 carboxylation rate at 25 celcius for canopy layers', units='umol CO2/m**2/s', & - interpinic_flag='interp', readvar=readvar, data=this%jmx25_z_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) - - end subroutine Restart - -end module PhotosynthesisMod diff --git a/src/biogeophys/QSatMod.F90 b/src/biogeophys/QSatMod.F90 index 0b1819e4..3400efab 100644 --- a/src/biogeophys/QSatMod.F90 +++ b/src/biogeophys/QSatMod.F90 @@ -11,8 +11,8 @@ module QSatMod private ! ! !PUBLIC MEMBER FUNCTIONS: + public :: QSatOld public :: QSat - public :: rhoSat !----------------------------------------------------------------------- ! For water vapor (temperature range 0C-100C) @@ -57,10 +57,8 @@ module QSatMod real(r8), parameter :: d8 = 0.498070196e-16_r8 contains - - !----------------------------------------------------------------------- - subroutine QSat (T, p, es, esdT, qs, qsdT) + subroutine QSatOld (T, p, es, esdT, qs, qsdT) ! ! !DESCRIPTION: ! Computes saturation mixing ratio and the change in saturation @@ -121,10 +119,77 @@ subroutine QSat (T, p, es, esdT, qs, qsdT) qsdT = esdT * vp2 * p ! 1 / K - end subroutine QSat + end subroutine QSatOld + + !----------------------------------------------------------------------- + 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 - !------------------------------------------------------------------------------- subroutine rhoSat(T, rho, rhodT) ! compute the saturated vapor pressure density and its derivative against the temperature @@ -164,4 +229,5 @@ subroutine rhoSat(T, rho, rhodT) rho = es/(rwat*T) !kg m^-3 if(present(rhodT))rhodT= esdT/(rwat*T)-rho/T !kg m^-3 K^-1 end subroutine rhoSat + end module QSatMod diff --git a/src/biogeophys/RootBiophysMod.F90 b/src/biogeophys/RootBiophysMod.F90 deleted file mode 100644 index 65a2666b..00000000 --- a/src/biogeophys/RootBiophysMod.F90 +++ /dev/null @@ -1,332 +0,0 @@ -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 - write(iulog,*) "Could not find 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_assert_mod , only : shr_assert - 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((ubound(rootfr) == (/bounds%endp, nlevgrnd/)), errMsg(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_assert_mod , only : shr_assert - 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_assert_mod , only : shr_assert - 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_assert_mod , only : shr_assert - 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/src/biogeophys/SnowSnicarMod.F90 b/src/biogeophys/SnowSnicarMod.F90 deleted file mode 100644 index fe731e51..00000000 --- a/src/biogeophys/SnowSnicarMod.F90 +++ /dev/null @@ -1,300 +0,0 @@ -module SnowSnicarMod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Calculate albedo of snow containing impurities - ! and the evolution of snow effective radius - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_flush - use shr_log_mod , only : errMsg => shr_log_errMsg - use clm_varctl , only : iulog - use clm_varcon , only : namec , tfrz - use shr_const_mod , only : SHR_CONST_RHOICE - use abortutils , only : endrun - use decompMod , only : bounds_type - use AerosolMod , only : snw_rds_min - ! - implicit none - save - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: SnowAge_init ! Initial read in of snow-aging file - public :: SnowOptics_init ! Initial read in of snow-optics file - ! - ! !PUBLIC DATA MEMBERS: - integer, public, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack - ! (indices described above) [nbr] - logical, public, parameter :: DO_SNO_OC = .false. ! parameter to include organic carbon (OC) - ! in snowpack radiative calculations - logical, public, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations - - ! !PRIVATE DATA MEMBERS: - integer, parameter :: numrad_snw = 5 ! number of spectral bands used in snow model [nbr] - integer, parameter :: nir_bnd_bgn = 2 ! first band index in near-IR spectrum [idx] - integer, parameter :: nir_bnd_end = 5 ! ending near-IR band index [idx] - - integer, parameter :: idx_Mie_snw_mx = 1471 ! number of effective radius indices used in Mie lookup table [idx] - integer, parameter :: idx_T_max = 11 ! maxiumum temperature index used in aging lookup table [idx] - integer, parameter :: idx_T_min = 1 ! minimum temperature index used in aging lookup table [idx] - integer, parameter :: idx_Tgrd_max = 31 ! maxiumum temperature gradient index used in aging lookup table [idx] - integer, parameter :: idx_Tgrd_min = 1 ! minimum temperature gradient index used in aging lookup table [idx] - integer, parameter :: idx_rhos_max = 8 ! maxiumum snow density index used in aging lookup table [idx] - integer, parameter :: idx_rhos_min = 1 ! minimum snow density index used in aging lookup table [idx] - - integer, parameter :: snw_rds_max_tbl = 1500 ! maximum effective radius defined in Mie lookup table [microns] - integer, parameter :: snw_rds_min_tbl = 30 ! minimium effective radius defined in Mie lookup table [microns] - integer, parameter :: snw_rds_min_int = nint(snw_rds_min) ! minimum allowed snow effective radius as integer [microns] - real(r8), parameter :: snw_rds_max = 1500._r8 ! maximum allowed snow effective radius [microns] - real(r8), parameter :: snw_rds_refrz = 1000._r8 ! effective radius of re-frozen snow [microns] - - real(r8), parameter :: min_snw = 1.0E-30_r8 ! minimum snow mass required for SNICAR RT calculation [kg m-2] - - !real(r8), parameter :: C1_liq_Brun89 = 1.28E-17_r8 ! constant for liquid water grain growth [m3 s-1], - ! from Brun89 - real(r8), parameter :: C1_liq_Brun89 = 0._r8 ! constant for liquid water grain growth [m3 s-1], - ! from Brun89: zeroed to accomodate dry snow aging - real(r8), parameter :: C2_liq_Brun89 = 4.22E-13_r8 ! constant for liquid water grain growth [m3 s-1], - ! from Brun89: corrected for LWC in units of percent - - real(r8), parameter :: tim_cns_bc_rmv = 2.2E-8_r8 ! time constant for removal of BC in snow on sea-ice - ! [s-1] (50% mass removal/year) - real(r8), parameter :: tim_cns_oc_rmv = 2.2E-8_r8 ! time constant for removal of OC in snow on sea-ice - ! [s-1] (50% mass removal/year) - real(r8), parameter :: tim_cns_dst_rmv = 2.2E-8_r8 ! time constant for removal of dust in snow on sea-ice - ! [s-1] (50% mass removal/year) - - ! scaling of the snow aging rate (tuning option): - logical :: flg_snoage_scl = .false. ! flag for scaling the snow aging rate by some arbitrary factor - real(r8), parameter :: xdrdt = 1.0_r8 ! arbitrary factor applied to snow aging rate - - ! snow and aerosol Mie parameters: - ! (arrays declared here, but are set in iniTimeConst) - ! (idx_Mie_snw_mx is number of snow radii with defined parameters (i.e. from 30um to 1500um)) - - ! direct-beam weighted ice optical properties - real(r8) :: ss_alb_snw_drc(idx_Mie_snw_mx,numrad_snw) - real(r8) :: asm_prm_snw_drc(idx_Mie_snw_mx,numrad_snw) - real(r8) :: ext_cff_mss_snw_drc(idx_Mie_snw_mx,numrad_snw) - - ! diffuse radiation weighted ice optical properties - real(r8) :: ss_alb_snw_dfs(idx_Mie_snw_mx,numrad_snw) - real(r8) :: asm_prm_snw_dfs(idx_Mie_snw_mx,numrad_snw) - real(r8) :: ext_cff_mss_snw_dfs(idx_Mie_snw_mx,numrad_snw) - - ! hydrophiliic BC - real(r8) :: ss_alb_bc1(numrad_snw) - real(r8) :: asm_prm_bc1(numrad_snw) - real(r8) :: ext_cff_mss_bc1(numrad_snw) - - ! hydrophobic BC - real(r8) :: ss_alb_bc2(numrad_snw) - real(r8) :: asm_prm_bc2(numrad_snw) - real(r8) :: ext_cff_mss_bc2(numrad_snw) - - ! hydrophobic OC - real(r8) :: ss_alb_oc1(numrad_snw) - real(r8) :: asm_prm_oc1(numrad_snw) - real(r8) :: ext_cff_mss_oc1(numrad_snw) - - ! hydrophilic OC - real(r8) :: ss_alb_oc2(numrad_snw) - real(r8) :: asm_prm_oc2(numrad_snw) - real(r8) :: ext_cff_mss_oc2(numrad_snw) - - ! dust species 1: - real(r8) :: ss_alb_dst1(numrad_snw) - real(r8) :: asm_prm_dst1(numrad_snw) - real(r8) :: ext_cff_mss_dst1(numrad_snw) - - ! dust species 2: - real(r8) :: ss_alb_dst2(numrad_snw) - real(r8) :: asm_prm_dst2(numrad_snw) - real(r8) :: ext_cff_mss_dst2(numrad_snw) - - ! dust species 3: - real(r8) :: ss_alb_dst3(numrad_snw) - real(r8) :: asm_prm_dst3(numrad_snw) - real(r8) :: ext_cff_mss_dst3(numrad_snw) - - ! dust species 4: - real(r8) :: ss_alb_dst4(numrad_snw) - real(r8) :: asm_prm_dst4(numrad_snw) - real(r8) :: ext_cff_mss_dst4(numrad_snw) - - ! best-fit parameters for snow aging defined over: - ! 11 temperatures from 225 to 273 K - ! 31 temperature gradients from 0 to 300 K/m - ! 8 snow densities from 0 to 350 kg/m3 - ! (arrays declared here, but are set in iniTimeConst) - real(r8), pointer :: snowage_tau(:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) - real(r8), pointer :: snowage_kappa(:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) - real(r8), pointer :: snowage_drdt0(:,:,:) ! idx_rhos_max,idx_Tgrd_max,idx_T_max) - ! - ! !REVISION HISTORY: - ! Created by Mark Flanner - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine SnowOptics_init( ) - - use fileutils , only : getfil - use CLM_varctl , only : fsnowoptics - use spmdMod , only : masterproc - use ncdio_pio , only : file_desc_t, ncd_io, ncd_pio_openfile, ncd_pio_closefile - - type(file_desc_t) :: ncid ! netCDF file id - character(len=256) :: locfn ! local filename - character(len= 32) :: subname = 'SnowOptics_init' ! subroutine name - integer :: ier ! error status - - return ! return early - ! - ! Open optics file: - if(masterproc) write(iulog,*) 'Attempting to read snow optical properties .....' - call getfil (fsnowoptics, locfn, 0) - call ncd_pio_openfile(ncid, locfn, 0) - if(masterproc) write(iulog,*) subname,trim(fsnowoptics) - - ! direct-beam snow Mie parameters: - call ncd_io('ss_alb_ice_drc', ss_alb_snw_drc, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_ice_drc',asm_prm_snw_drc, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_ice_drc', ext_cff_mss_snw_drc, 'read', ncid, posNOTonfile=.true.) - - ! diffuse snow Mie parameters - call ncd_io( 'ss_alb_ice_dfs', ss_alb_snw_dfs, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_ice_dfs', asm_prm_snw_dfs, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_ice_dfs', ext_cff_mss_snw_dfs, 'read', ncid, posNOTonfile=.true.) - - ! BC species 1 Mie parameters - call ncd_io( 'ss_alb_bcphil', ss_alb_bc1, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_bcphil', asm_prm_bc1, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_bcphil', ext_cff_mss_bc1, 'read', ncid, posNOTonfile=.true.) - - ! BC species 2 Mie parameters - call ncd_io( 'ss_alb_bcphob', ss_alb_bc2, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_bcphob', asm_prm_bc2, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_bcphob', ext_cff_mss_bc2, 'read', ncid, posNOTonfile=.true.) - - ! OC species 1 Mie parameters - call ncd_io( 'ss_alb_ocphil', ss_alb_oc1, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_ocphil', asm_prm_oc1, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_ocphil', ext_cff_mss_oc1, 'read', ncid, posNOTonfile=.true.) - - ! OC species 2 Mie parameters - call ncd_io( 'ss_alb_ocphob', ss_alb_oc2, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_ocphob', asm_prm_oc2, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_ocphob', ext_cff_mss_oc2, 'read', ncid, posNOTonfile=.true.) - - ! dust species 1 Mie parameters - call ncd_io( 'ss_alb_dust01', ss_alb_dst1, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_dust01', asm_prm_dst1, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_dust01', ext_cff_mss_dst1, 'read', ncid, posNOTonfile=.true.) - - ! dust species 2 Mie parameters - call ncd_io( 'ss_alb_dust02', ss_alb_dst2, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_dust02', asm_prm_dst2, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_dust02', ext_cff_mss_dst2, 'read', ncid, posNOTonfile=.true.) - - ! dust species 3 Mie parameters - call ncd_io( 'ss_alb_dust03', ss_alb_dst3, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_dust03', asm_prm_dst3, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_dust03', ext_cff_mss_dst3, 'read', ncid, posNOTonfile=.true.) - - ! dust species 4 Mie parameters - call ncd_io( 'ss_alb_dust04', ss_alb_dst4, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'asm_prm_dust04', asm_prm_dst4, 'read', ncid, posNOTonfile=.true.) - call ncd_io( 'ext_cff_mss_dust04', ext_cff_mss_dst4, 'read', ncid, posNOTonfile=.true.) - - - call ncd_pio_closefile(ncid) - if (masterproc) then - - write(iulog,*) 'Successfully read snow optical properties' - ! print some diagnostics: - write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & - ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & - ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for diffuse ice, rds=100um: ', & - ss_alb_snw_dfs(71,1), ss_alb_snw_dfs(71,2), ss_alb_snw_dfs(71,3), & - ss_alb_snw_dfs(71,4), ss_alb_snw_dfs(71,5) - if (DO_SNO_OC) then - write (iulog,*) 'SNICAR: Including OC aerosols from snow radiative transfer calculations' - else - write (iulog,*) 'SNICAR: Excluding OC aerosols from snow radiative transfer calculations' - endif - write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & - ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & - ss_alb_bc2(1), ss_alb_bc2(2), ss_alb_bc2(3), ss_alb_bc2(4), ss_alb_bc2(5) - if (DO_SNO_OC) then - write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & - ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic OC: ', & - ss_alb_oc2(1), ss_alb_oc2(2), ss_alb_oc2(3), ss_alb_oc2(4), ss_alb_oc2(5) - endif - write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 1: ', & - ss_alb_dst1(1), ss_alb_dst1(2), ss_alb_dst1(3), ss_alb_dst1(4), ss_alb_dst1(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 2: ', & - ss_alb_dst2(1), ss_alb_dst2(2), ss_alb_dst2(3), ss_alb_dst2(4), ss_alb_dst2(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 3: ', & - ss_alb_dst3(1), ss_alb_dst3(2), ss_alb_dst3(3), ss_alb_dst3(4), ss_alb_dst3(5) - write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 4: ', & - ss_alb_dst4(1), ss_alb_dst4(2), ss_alb_dst4(3), ss_alb_dst4(4), ss_alb_dst4(5) - write(iulog,*) - end if - - end subroutine SnowOptics_init - - !----------------------------------------------------------------------- - subroutine SnowAge_init( ) - use CLM_varctl , only : fsnowaging - use fileutils , only : getfil - use spmdMod , only : masterproc - use ncdio_pio , only : file_desc_t, ncd_io, ncd_pio_openfile, ncd_pio_closefile - - type(file_desc_t) :: ncid ! netCDF file id - character(len=256) :: locfn ! local filename - character(len= 32) :: subname = 'SnowOptics_init' ! subroutine name - integer :: varid ! netCDF id's - integer :: ier ! error status - - ! Open snow aging (effective radius evolution) file: - allocate(snowage_tau(idx_rhos_max,idx_Tgrd_max,idx_T_max)) - allocate(snowage_kappa(idx_rhos_max,idx_Tgrd_max,idx_T_max)) - allocate(snowage_drdt0(idx_rhos_max,idx_Tgrd_max,idx_T_max)) - - return ! return early - if(masterproc) write(iulog,*) 'Attempting to read snow aging parameters .....' - call getfil (fsnowaging, locfn, 0) - call ncd_pio_openfile(ncid, locfn, 0) - if(masterproc) write(iulog,*) subname,trim(fsnowaging) - - ! snow aging parameters - - call ncd_io('tau', snowage_tau, 'read', ncid, posNOTonfile=.true.) - call ncd_io('kappa', snowage_kappa, 'read', ncid, posNOTonfile=.true.) - call ncd_io('drdsdt0', snowage_drdt0, 'read', ncid, posNOTonfile=.true.) - - call ncd_pio_closefile(ncid) - if (masterproc) then - - write(iulog,*) 'Successfully read snow aging properties' - - ! print some diagnostics: - write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) - write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) - write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) - endif - - end subroutine SnowAge_init - - end module SnowSnicarMod diff --git a/src/biogeophys/SoilHydrologyInitTimeConstMod.F90 b/src/biogeophys/SoilHydrologyInitTimeConstMod.F90 deleted file mode 100644 index b399b104..00000000 --- a/src/biogeophys/SoilHydrologyInitTimeConstMod.F90 +++ /dev/null @@ -1,565 +0,0 @@ -module SoilHydrologyInitTimeConstMod - - !------------------------------------------------------------------------------ - ! DESCRIPTION: - ! Initialize time constant variables for SoilHydrologyType - ! - ! !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 SoilHydrologyType , only : soilhydrology_type - use LandunitType , only : lun - use ColumnType , only : col - ! - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: SoilHydrologyInitTimeConst - ! - ! !PRIVATE MEMBER FUNCTIONS: - private :: initSoilParVIC ! Convert default CLM soil properties to VIC parameters - private :: initCLMVICMap ! Initialize map from VIC to CLM layers - private :: linear_interp ! function for linear interperation - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - ! -contains - - !----------------------------------------------------------------------- - subroutine SoilHydrologyInitTimeConst(bounds, soilhydrology_inst) - ! - ! !USES: - use shr_const_mod , only : shr_const_pi - use shr_spfn_mod , only : shr_spfn_erf - use abortutils , only : endrun - use clm_varctl , only : fsurdat, paramfile, iulog, use_vichydro, soil_layerstruct - use clm_varpar , only : nlevsoifl, toplev_equalspace - use clm_varpar , only : nlevsoi, nlevgrnd, nlevsno, nlevlak, nlevurb, nlayer, nlayert - use clm_varcon , only : zsoi, dzsoi, zisoi, spval, nlvic, dzvic, pc, grlnd - use clm_varcon , only : aquifer_water_baseline - use landunit_varcon , only : istwet, istsoil, istdlak, istcrop, istice_mec - use column_varcon , only : icol_shadewall, icol_road_perv, icol_road_imperv, icol_roof, icol_sunwall - use fileutils , only : getfil - use organicFileMod , only : organicrd - use ncdio_pio , only : file_desc_t, ncd_io, ncd_pio_openfile, ncd_pio_closefile - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - type(soilhydrology_type) , intent(inout) :: soilhydrology_inst - ! - ! !LOCAL VARIABLES: - integer :: p,c,j,l,g,lev,nlevs - integer :: ivic,ivicstrt,ivicend - real(r8) :: maxslope, slopemax, minslope - real(r8) :: d, fd, dfdd, slope0,slopebeta - real(r8) ,pointer :: tslope(:) - logical :: readvar - type(file_desc_t) :: ncid - character(len=256) :: locfn - real(r8) :: clay,sand ! temporaries - real(r8) :: om_frac ! organic matter fraction - real(r8) :: organic_max ! organic matter (kg/m3) where soil is assumed to act like peat - real(r8) ,pointer :: b2d (:) ! read in - VIC b - real(r8) ,pointer :: ds2d (:) ! read in - VIC Ds - real(r8) ,pointer :: dsmax2d (:) ! read in - VIC Dsmax - real(r8) ,pointer :: ws2d (:) ! read in - VIC Ws - real(r8), pointer :: sandcol (:,:) ! column level sand fraction for calculating VIC parameters - real(r8), pointer :: claycol (:,:) ! column level clay fraction for calculating VIC parameters - real(r8), pointer :: om_fraccol (:,:) ! column level organic matter fraction for calculating VIC parameters - real(r8) ,pointer :: sand3d (:,:) ! read in - soil texture: percent sand - real(r8) ,pointer :: clay3d (:,:) ! read in - soil texture: percent clay - real(r8) ,pointer :: organic3d (:,:) ! read in - organic matter: kg/m3 - real(r8) ,pointer :: zisoifl (:) ! original soil interface depth - real(r8) ,pointer :: zsoifl (:) ! original soil midpoint - real(r8) ,pointer :: dzsoifl (:) ! original soil thickness - !----------------------------------------------------------------------- - ! ----------------------------------------------------------------- - ! Initialize frost table - ! ----------------------------------------------------------------- - - soilhydrology_inst%wa_col(bounds%begc:bounds%endc) = aquifer_water_baseline - soilhydrology_inst%zwt_col(bounds%begc:bounds%endc) = 0._r8 - - 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 constants (on the next two lines) - ! seem implicitly related to aquifer_water_baseline - soilhydrology_inst%wa_col(c) = 4800._r8 - soilhydrology_inst%zwt_col(c) = (25._r8 + col%zi(c,nlevsoi)) - soilhydrology_inst%wa_col(c)/0.2_r8 /1000._r8 ! One meter below soil column - else - soilhydrology_inst%wa_col(c) = spval - soilhydrology_inst%zwt_col(c) = spval - end if - ! initialize frost_table, zwt_perched - soilhydrology_inst%zwt_perched_col(c) = spval - soilhydrology_inst%frost_table_col(c) = spval - else - ! Note that the following hard-coded constants (on the next two lines) seem - ! implicitly related to aquifer_water_baseline - soilhydrology_inst%wa_col(c) = 4000._r8 - soilhydrology_inst%zwt_col(c) = (25._r8 + col%zi(c,nlevsoi)) - soilhydrology_inst%wa_col(c)/0.2_r8 /1000._r8 ! One meter below soil column - ! initialize frost_table, zwt_perched to bottom of soil column - soilhydrology_inst%zwt_perched_col(c) = col%zi(c,nlevsoi) - soilhydrology_inst%frost_table_col(c) = col%zi(c,nlevsoi) - end if - end if - end do - - ! Initialize VIC variables - - if (use_vichydro) then - - allocate(b2d (bounds%begg:bounds%endg)) - allocate(ds2d (bounds%begg:bounds%endg)) - allocate(dsmax2d (bounds%begg:bounds%endg)) - allocate(ws2d (bounds%begg:bounds%endg)) - allocate(sandcol (bounds%begc:bounds%endc,1:nlevgrnd )) - allocate(claycol (bounds%begc:bounds%endc,1:nlevgrnd )) - allocate(om_fraccol (bounds%begc:bounds%endc,1:nlevgrnd )) - - call getfil (fsurdat, locfn, 0) - call ncd_pio_openfile (ncid, locfn, 0) - call ncd_io(ncid=ncid, varname='binfl', flag='read', data=b2d, dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun(msg=' ERROR: binfl NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - end if - call ncd_io(ncid=ncid, varname='Ds', flag='read', data=ds2d, dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun(msg=' ERROR: Ds NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - end if - call ncd_io(ncid=ncid, varname='Dsmax', flag='read', data=dsmax2d, dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun(msg=' ERROR: Dsmax NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - end if - call ncd_io(ncid=ncid, varname='Ws', flag='read', data=ws2d, dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun(msg=' ERROR: Ws NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - end if - call ncd_pio_closefile(ncid) - - !define the depth of VIC soil layers here - nlvic(1) = 3 - nlvic(2) = toplev_equalspace - nlvic(1) - nlvic(3) = nlevsoi - (nlvic(1) + nlvic(2)) - - dzvic(:) = 0._r8 - ivicstrt = 1 - - do ivic = 1,nlayer - ivicend = ivicstrt+nlvic(ivic)-1 - do j = ivicstrt,ivicend - dzvic(ivic) = dzvic(ivic)+dzsoi(j) - end do - ivicstrt = ivicend+1 - end do - - do c = bounds%begc, bounds%endc - g = col%gridcell(c) - soilhydrology_inst%b_infil_col(c) = b2d(g) - soilhydrology_inst%ds_col(c) = ds2d(g) - soilhydrology_inst%dsmax_col(c) = dsmax2d(g) - soilhydrology_inst%Wsvic_col(c) = ws2d(g) - end do - - do c = bounds%begc, bounds%endc - soilhydrology_inst%max_infil_col(c) = spval - soilhydrology_inst%i_0_col(c) = spval - do lev = 1, nlayer - soilhydrology_inst%ice_col(c,lev) = spval - soilhydrology_inst%moist_col(c,lev) = spval - soilhydrology_inst%moist_vol_col(c,lev) = spval - soilhydrology_inst%max_moist_col(c,lev) = spval - soilhydrology_inst%porosity_col(c,lev) = spval - soilhydrology_inst%expt_col(c,lev) = spval - soilhydrology_inst%ksat_col(c,lev) = spval - soilhydrology_inst%phi_s_col(c,lev) = spval - soilhydrology_inst%depth_col(c,lev) = spval - sandcol(c,lev) = spval - claycol(c,lev) = spval - om_fraccol(c,lev) = spval - end do - end do - - allocate(sand3d(bounds%begg:bounds%endg,nlevsoifl)) - allocate(clay3d(bounds%begg:bounds%endg,nlevsoifl)) - allocate(organic3d(bounds%begg:bounds%endg,nlevsoifl)) - - call organicrd(organic3d) - - call getfil (fsurdat, locfn, 0) - call ncd_pio_openfile (ncid, locfn, 0) - 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 - call ncd_pio_closefile(ncid) - - ! Determine organic_max - 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 ) then - call endrun(msg=' ERROR: organic_max not on param file'//errMsg(sourcefile, __LINE__)) - end if - call ncd_pio_closefile(ncid) - - ! get original soil depths to be used in interpolation of sand and clay - allocate(zsoifl(1:nlevsoifl), zisoifl(0:nlevsoifl), dzsoifl(1:nlevsoifl)) - do j = 1, nlevsoifl - zsoifl(j) = 0.025*(exp(0.5_r8*(j-0.5_r8))-1._r8) !node depths - enddo - - dzsoifl(1) = 0.5_r8*(zsoifl(1)+zsoifl(2)) !thickness b/n two interfaces - do j = 2,nlevsoifl-1 - dzsoifl(j)= 0.5_r8*(zsoifl(j+1)-zsoifl(j-1)) - enddo - dzsoifl(nlevsoifl) = zsoifl(nlevsoifl)-zsoifl(nlevsoifl-1) - - zisoifl(0) = 0._r8 - do j = 1, nlevsoifl-1 - zisoifl(j) = 0.5_r8*(zsoifl(j)+zsoifl(j+1)) !interface depths - enddo - zisoifl(nlevsoifl) = zsoifl(nlevsoifl) + 0.5_r8*dzsoifl(nlevsoifl) - - do c = bounds%begc, bounds%endc - g = col%gridcell(c) - l = col%landunit(c) - - if (lun%itype(l) /= istdlak) then ! soil columns of both urban and non-urban types - if (lun%itype(l)==istwet .or. lun%itype(l)==istice_mec) then - ! do nothing - else if (lun%urbpoi(l) .and. (col%itype(c) /= icol_road_perv) .and. (col%itype(c) /= icol_road_imperv) )then - ! do nothing - else - do lev = 1,nlevgrnd - if ( soil_layerstruct /= '10SL_3.5m' )then - write(iulog,*) 'Setting clay, sand, organic, in Soil Hydrology for VIC' - 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 - do j = 1,nlevsoifl-1 - if (zisoi(lev) >= zisoifl(j) .AND. zisoi(lev) < zisoifl(j+1)) then - clay = clay3d(g,j+1) - sand = sand3d(g,j+1) - om_frac = organic3d(g,j+1)/organic_max - endif - end do - else - clay = clay3d(g,nlevsoifl) - sand = sand3d(g,nlevsoifl) - om_frac = 0._r8 - endif - else - ! duplicate clay and sand values from 10th soil layer - if (lev <= nlevsoi) then - clay = clay3d(g,lev) - sand = sand3d(g,lev) - om_frac = (organic3d(g,lev)/organic_max)**2._r8 - else - clay = clay3d(g,nlevsoi) - sand = sand3d(g,nlevsoi) - om_frac = 0._r8 - endif - end if - - if (lun%urbpoi(l)) om_frac = 0._r8 - claycol(c,lev) = clay - sandcol(c,lev) = sand - om_fraccol(c,lev) = om_frac - end do - end if - end if ! end of if not lake - - if (lun%itype(l) /= istdlak) then ! soil columns of both urban and non-urban types - if (lun%urbpoi(l)) then - if (col%itype(c)==icol_sunwall .or. col%itype(c)==icol_shadewall .or. col%itype(c)==icol_roof) then - ! do nothing - else - soilhydrology_inst%depth_col(c, 1:nlayer) = dzvic - soilhydrology_inst%depth_col(c, nlayer+1:nlayert) = col%dz(c, nlevsoi+1:nlevgrnd) - - ! create weights to map soil moisture profiles (10 layer) to 3 layers for VIC hydrology, M.Huang - call initCLMVICMap(c, soilhydrology_inst) - call initSoilParVIC(c, claycol, sandcol, om_fraccol, soilhydrology_inst) - end if - else - soilhydrology_inst%depth_col(c, 1:nlayer) = dzvic - soilhydrology_inst%depth_col(c, nlayer+1:nlayert) = col%dz(c, nlevsoi+1:nlevgrnd) - - ! create weights to map soil moisture profiles (10 layer) to 3 layers for VIC hydrology, M.Huang - call initCLMVICMap(c, soilhydrology_inst) - call initSoilParVIC(c, claycol, sandcol, om_fraccol, soilhydrology_inst) - end if - end if ! end of if not lake - - end do ! end of loop over columns - - deallocate(b2d, ds2d, dsmax2d, ws2d) - deallocate(sandcol, claycol, om_fraccol) - deallocate(sand3d, clay3d, organic3d) - deallocate(zisoifl, zsoifl, dzsoifl) - - end if ! end of if use_vichydro - - associate(micro_sigma => col%micro_sigma) - do c = bounds%begc, bounds%endc - - ! determine h2osfc threshold ("fill & spill" concept) - ! set to zero for no h2osfc (w/frac_infclust =large) - - soilhydrology_inst%h2osfc_thresh_col(c) = 0._r8 - if (micro_sigma(c) > 1.e-6_r8 .and. (soilhydrology_inst%h2osfcflag /= 0)) then - d = 0.0 - do p = 1,4 - fd = 0.5*(1.0_r8+shr_spfn_erf(d/(micro_sigma(c)*sqrt(2.0)))) - pc - dfdd = exp(-d**2/(2.0*micro_sigma(c)**2))/(micro_sigma(c)*sqrt(2.0*shr_const_pi)) - d = d - fd/dfdd - enddo - soilhydrology_inst%h2osfc_thresh_col(c) = 0.5*d*(1.0_r8+shr_spfn_erf(d/(micro_sigma(c)*sqrt(2.0)))) + & - micro_sigma(c)/sqrt(2.0*shr_const_pi)*exp(-d**2/(2.0*micro_sigma(c)**2)) - soilhydrology_inst%h2osfc_thresh_col(c) = 1.e3_r8 * soilhydrology_inst%h2osfc_thresh_col(c) !convert to mm from meters - else - soilhydrology_inst%h2osfc_thresh_col(c) = 0._r8 - endif - - if (soilhydrology_inst%h2osfcflag == 0) then - soilhydrology_inst%h2osfc_thresh_col(c) = 0._r8 ! set to zero for no h2osfc (w/frac_infclust =large) - endif - - ! set decay factor - soilhydrology_inst%hkdepth_col(c) = 1._r8/2.5_r8 - - end do - end associate - - end subroutine SoilhydrologyInitTimeConst - - !----------------------------------------------------------------------- - subroutine initSoilParVIC(c, claycol, sandcol, om_fraccol, soilhydrology_inst) - ! - ! !DESCRIPTION: - ! Convert default CLM soil properties to VIC parameters - ! to be used for runoff simulations (added by M. Huang) - ! - ! !USES: - use clm_varpar, only : nlevsoi, nlayert, nlayer - ! - ! !ARGUMENTS: - integer , intent(in) :: c ! column index - real(r8) , pointer :: sandcol(:,:) ! read in - soil texture: percent sand - real(r8) , pointer :: claycol(:,:) ! read in - soil texture: percent clay - real(r8) , pointer :: om_fraccol(:,:) ! read in - organic matter: kg/m3 - type(soilhydrology_type) , intent(inout) :: soilhydrology_inst - - ! !LOCAL VARIABLES: - real(r8) :: om_watsat = 0.9_r8 ! porosity of organic soil - real(r8) :: om_hksat = 0.1_r8 ! saturated hydraulic conductivity of organic soil [mm/s] - real(r8) :: om_tkm = 0.25_r8 ! thermal conductivity of organic soil (Farouki, 1986) [W/m/K] - real(r8) :: om_sucsat = 10.3_r8 ! saturated suction for organic matter (Letts, 2000) - real(r8) :: om_csol = 2.5_r8 ! heat capacity of peat soil *10^6 (J/K m3) (Farouki, 1986) - real(r8) :: om_tkd = 0.05_r8 ! thermal conductivity of dry organic soil (Farouki, 1981) - real(r8) :: om_b = 2.7_r8 ! Clapp Hornberger paramater for oragnic soil (Letts, 2000) - real(r8) :: om_expt = 3._r8+2._r8*2.7_r8 ! soil expt for VIC - real(r8) :: csol_bedrock = 2.0e6_r8 ! vol. heat capacity of granite/sandstone J/(m3 K)(Shabbir, 2000) - real(r8) :: pc = 0.5_r8 ! percolation threshold - real(r8) :: pcbeta = 0.139_r8 ! percolation exponent - real(r8) :: xksat ! maximum hydraulic conductivity of soil [mm/s] - 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) :: temp_sum_frac ! sum of node fractions in each VIC layer - real(r8) :: sandvic(1:nlayert) ! temporary, weighted averaged sand% for VIC layers - real(r8) :: clayvic(1:nlayert) ! temporary, weighted averaged clay% for VIC layers - real(r8) :: om_fracvic(1:nlayert) ! temporary, weighted averaged organic matter fract for VIC layers - integer :: i, j ! indices - !------------------------------------------------------------------------------------------- - - ! soilhydrology_inst%depth_col(:,:) Output: layer depth of upper layer(m) - ! soilhydrology_inst%vic_clm_fract_col(:,:,:) Output: fraction of VIC layers in CLM layers - ! soilhydrology_inst%c_param_col(:) Output: baseflow exponent (Qb) - ! soilhydrology_inst%expt_col(:,:) Output: pore-size distribution related paramter(Q12) - ! soilhydrology_inst%ksat_col(:,:) Output: Saturated hydrologic conductivity (mm/s) - ! soilhydrology_inst%phi_s_col(:,:) Output: soil moisture dissusion parameter - ! soilhydrology_inst%porosity_col(:,:) Output: soil porosity - ! soilhydrology_inst%max_moist_col(:,:) Output: maximum soil moisture (ice + liq) - - ! map parameters between VIC layers and CLM layers - soilhydrology_inst%c_param_col(c) = 2._r8 - - ! map the CLM layers to VIC layers - do i = 1, nlayer - - sandvic(i) = 0._r8 - clayvic(i) = 0._r8 - om_fracvic(i) = 0._r8 - temp_sum_frac = 0._r8 - do j = 1, nlevsoi - sandvic(i) = sandvic(i) + sandcol(c,j) * soilhydrology_inst%vic_clm_fract_col(c,i,j) - clayvic(i) = clayvic(i) + claycol(c,j) * soilhydrology_inst%vic_clm_fract_col(c,i,j) - om_fracvic(i) = om_fracvic(i) + om_fraccol(c,j) * soilhydrology_inst%vic_clm_fract_col(c,i,j) - temp_sum_frac = temp_sum_frac + soilhydrology_inst%vic_clm_fract_col(c,i,j) - end do - - !average soil properties, M.Huang, 08/11/2010 - sandvic(i) = sandvic(i)/temp_sum_frac - clayvic(i) = clayvic(i)/temp_sum_frac - om_fracvic(i) = om_fracvic(i)/temp_sum_frac - - !make sure sand, clay and om fractions are between 0 and 100% - sandvic(i) = min(100._r8 , sandvic(i)) - clayvic(i) = min(100._r8 , clayvic(i)) - om_fracvic(i) = min(100._r8 , om_fracvic(i)) - sandvic(i) = max(0._r8 , sandvic(i)) - clayvic(i) = max(0._r8 , clayvic(i)) - om_fracvic(i) = max(0._r8 , om_fracvic(i)) - - !calculate other parameters based on teh percentages - soilhydrology_inst%porosity_col(c, i) = 0.489_r8 - 0.00126_r8*sandvic(i) - soilhydrology_inst%expt_col(c, i) = 3._r8+ 2._r8*(2.91_r8 + 0.159_r8*clayvic(i)) - xksat = 0.0070556 *( 10.**(-0.884+0.0153*sandvic(i)) ) - - !consider organic matter, M.Huang - soilhydrology_inst%expt_col(c, i) = & - (1._r8 - om_fracvic(i))*soilhydrology_inst%expt_col(c, i) + om_fracvic(i)*om_expt - soilhydrology_inst%porosity_col(c,i) = & - (1._r8 - om_fracvic(i))*soilhydrology_inst%porosity_col(c,i) + om_watsat*om_fracvic(i) - - ! perc_frac is zero unless perf_frac greater than percolation threshold - if (om_fracvic(i) > pc) then - perc_norm=(1._r8 - pc)**(-pcbeta) - perc_frac=perc_norm*(om_fracvic(i) - pc)**pcbeta - else - perc_frac=0._r8 - endif - ! uncon_frac is fraction of mineral soil plus fraction of "nonpercolating" organic soil - uncon_frac=(1._r8-om_fracvic(i))+(1._r8-perc_frac)*om_fracvic(i) - - ! uncon_hksat is series addition of mineral/organic conductivites - if (om_fracvic(i) < 1._r8) then - uncon_hksat=uncon_frac/((1._r8-om_fracvic(i))/xksat & - +((1._r8-perc_frac)*om_fracvic(i))/om_hksat) - else - uncon_hksat = 0._r8 - end if - - soilhydrology_inst%ksat_col(c,i) = & - uncon_frac*uncon_hksat + (perc_frac*om_fracvic(i))*om_hksat - - soilhydrology_inst%max_moist_col(c,i) = & - soilhydrology_inst%porosity_col(c,i) * soilhydrology_inst%depth_col(c,i) * 1000._r8 !in mm! - - soilhydrology_inst%phi_s_col(c,i) = & - -(exp((1.54_r8 - 0.0095_r8*sandvic(i) + & - 0.0063_r8*(100.0_r8-sandvic(i)-clayvic(i)))*log(10.0_r8))*9.8e-5_r8) - - end do ! end of loop over layers - - end subroutine initSoilParVIC - - !----------------------------------------------------------------------- - subroutine initCLMVICMap(c, soilhydrology_inst) - ! - ! !DESCRIPTION: - ! Calculates mapping between CLM and VIC layers - ! added by AWang, modified by M.Huang for CLM4 - ! NOTE: in CLM h2osoil_liq unit is kg/m2, in VIC moist is mm - ! h2osoi_ice is actually water equavlent ice content. - ! - ! !USES: - use clm_varpar , only : nlevsoi, nlayer - ! - ! !ARGUMENTS: - integer , intent(in) :: c - type(soilhydrology_type), intent(inout) :: soilhydrology_inst - ! - ! !REVISION HISTORY: - ! Created by Maoyi Huang - ! 11/13/2012, Maoyi Huang: rewrite the mapping modules in CLM4VIC - ! - ! !LOCAL VARIABLES - real(r8) :: sum_frac(1:nlayer) ! sum of fraction for each layer - real(r8) :: deltal(1:nlayer+1) ! temporary - real(r8) :: zsum ! temporary - real(r8) :: lsum ! temporary - real(r8) :: temp ! temporary - integer :: i, j, fc - !----------------------------------------------------------------------- - - associate( & - dz => col%dz , & ! Input: [real(r8) (:,:) ] layer depth (m) - zi => col%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) - z => col%z , & ! Input: [real(r8) (:,:) ] layer thickness (m) - - depth => soilhydrology_inst%depth_col , & ! Input: [real(r8) (:,:) ] layer depth of VIC (m) - vic_clm_fract => soilhydrology_inst%vic_clm_fract_col & ! Output: [real(r8) (:,:,:) ] fraction of VIC layers in clm layers - ) - - ! set fraction of VIC layer in each CLM layer - - lsum = 0._r8 - do i = 1, nlayer - deltal(i) = depth(c,i) - end do - do i = 1, nlayer - zsum = 0._r8 - sum_frac(i) = 0._r8 - do j = 1, nlevsoi - if( (zsum < lsum) .and. (zsum + dz(c,j) >= lsum )) then - call linear_interp(lsum, temp, zsum, zsum + dz(c,j), 0._r8, 1._r8) - vic_clm_fract(c,i,j) = 1._r8 - temp - if(lsum + deltal(i) < zsum + dz(c,j)) then - call linear_interp(lsum + deltal(i), temp, zsum, zsum + dz(c,j), 1._r8, 0._r8) - vic_clm_fract(c,i,j) = vic_clm_fract(c,i,j) - temp - end if - else if( (zsum < lsum + deltal(i)) .and. (zsum + dz(c,j) >= lsum + deltal(i)) ) then - call linear_interp(lsum + deltal(i), temp, zsum, zsum + dz(c,j), 0._r8, 1._r8) - vic_clm_fract(c,i,j) = temp - if(zsum<=lsum) then - call linear_interp(lsum, temp, zsum, zsum + dz(c,j), 0._r8, 1._r8) - vic_clm_fract(c,i,j) = vic_clm_fract(c,i,j) - temp - end if - else if( (zsum >= lsum .and. zsum + dz(c,j) <= lsum + deltal(i)) ) then - vic_clm_fract(c,i,j) = 1._r8 - else - vic_clm_fract(c,i,j) = 0._r8 - end if - zsum = zsum + dz(c,j) - sum_frac(i) = sum_frac(i) + vic_clm_fract(c,i,j) - end do ! end CLM layer calculation - lsum = lsum + deltal(i) - end do ! end VIC layer calcultion - - end associate - - end subroutine initCLMVICMap - - !------------------------------------------------------------------- - subroutine linear_interp(x,y, x0, x1, y0, y1) - ! - ! !DESCRIPTION: - ! Provides linear interpolation - ! - ! !ARGUMENTS: - real(r8), intent(in) :: x, x0, y0, x1, y1 - real(r8), intent(out) :: y - !------------------------------------------------------------------- - - y = y0 + (x - x0) * (y1 - y0) / (x1 - x0) - - end subroutine linear_interp - -end module SoilHydrologyInitTimeConstMod diff --git a/src/biogeophys/SoilHydrologyType.F90 b/src/biogeophys/SoilHydrologyType.F90 deleted file mode 100644 index e3e893a4..00000000 --- a/src/biogeophys/SoilHydrologyType.F90 +++ /dev/null @@ -1,338 +0,0 @@ -Module SoilHydrologyType - - 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, nlayer, nlayert, nlevsoi - use clm_varcon , only : spval - use clm_varctl , only : iulog - use LandunitType , only : lun - use ColumnType , only : col - ! - ! !PUBLIC TYPES: - implicit none - save - ! - type, public :: soilhydrology_type - - integer :: h2osfcflag ! true => surface water is active (namelist) - integer :: origflag ! used to control soil hydrology properties (namelist) - - real(r8), pointer :: num_substeps_col (:) ! col adaptive timestep counter - ! NON-VIC - real(r8), pointer :: frost_table_col (:) ! col frost table depth - real(r8), pointer :: zwt_col (:) ! col water table depth - real(r8), pointer :: zwts_col (:) ! col water table depth, the shallower of the two water depths - real(r8), pointer :: zwt_perched_col (:) ! col perched water table depth - real(r8), pointer :: wa_col (:) ! col water in the unconfined aquifer (mm) - real(r8), pointer :: qcharge_col (:) ! col aquifer recharge rate (mm/s) - real(r8), pointer :: fracice_col (:,:) ! col fractional impermeability (-) - real(r8), pointer :: icefrac_col (:,:) ! col fraction of ice - real(r8), pointer :: fcov_col (:) ! col fractional impermeable area - real(r8), pointer :: fsat_col (:) ! col fractional area with water table at surface - real(r8), pointer :: h2osfc_thresh_col (:) ! col level at which h2osfc "percolates" (time constant) - - ! VIC - real(r8), pointer :: hkdepth_col (:) ! col VIC decay factor (m) (time constant) - real(r8), pointer :: b_infil_col (:) ! col VIC b infiltration parameter (time constant) - real(r8), pointer :: ds_col (:) ! col VIC fracton of Dsmax where non-linear baseflow begins (time constant) - real(r8), pointer :: dsmax_col (:) ! col VIC max. velocity of baseflow (mm/day) (time constant) - real(r8), pointer :: Wsvic_col (:) ! col VIC fraction of maximum soil moisutre where non-liear base flow occurs (time constant) - real(r8), pointer :: porosity_col (:,:) ! col VIC porosity (1-bulk_density/soil_density) - real(r8), pointer :: vic_clm_fract_col (:,:,:) ! col VIC fraction of VIC layers in CLM layers - real(r8), pointer :: depth_col (:,:) ! col VIC layer depth of upper layer - real(r8), pointer :: c_param_col (:) ! col VIC baseflow exponent (Qb) - real(r8), pointer :: expt_col (:,:) ! col VIC pore-size distribution related paramter(Q12) - real(r8), pointer :: ksat_col (:,:) ! col VIC Saturated hydrologic conductivity - real(r8), pointer :: phi_s_col (:,:) ! col VIC soil moisture dissusion parameter - real(r8), pointer :: moist_col (:,:) ! col VIC soil moisture (kg/m2) for VIC soil layers - real(r8), pointer :: moist_vol_col (:,:) ! col VIC volumetric soil moisture for VIC soil layers - real(r8), pointer :: max_moist_col (:,:) ! col VIC max layer moist + ice (mm) - real(r8), pointer :: max_infil_col (:) ! col VIC maximum infiltration rate calculated in VIC - real(r8), pointer :: i_0_col (:) ! col VIC average saturation in top soil layers - real(r8), pointer :: ice_col (:,:) ! col VIC soil ice (kg/m2) for VIC soil layers - - contains - - ! Public routines - procedure, public :: Init - procedure, public :: Restart - - ! Private routines - procedure, private :: InitAllocate - procedure, private :: InitHistory - procedure, private :: InitCold - procedure, private :: ReadNL - - end type soilhydrology_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, bounds, NLFilename) - - class(soilhydrology_type) :: this - type(bounds_type), intent(in) :: bounds - character(len=*), intent(in) :: NLFilename - - call this%ReadNL(NLFilename) - call this%InitAllocate(bounds) - call this%InitHistory(bounds) - 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(soilhydrology_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%num_substeps_col (begc:endc)) ; this%num_substeps_col (:) = nan - allocate(this%frost_table_col (begc:endc)) ; this%frost_table_col (:) = nan - allocate(this%zwt_col (begc:endc)) ; this%zwt_col (:) = nan - allocate(this%zwt_perched_col (begc:endc)) ; this%zwt_perched_col (:) = nan - allocate(this%zwts_col (begc:endc)) ; this%zwts_col (:) = nan - - allocate(this%wa_col (begc:endc)) ; this%wa_col (:) = nan - allocate(this%qcharge_col (begc:endc)) ; this%qcharge_col (:) = nan - allocate(this%fracice_col (begc:endc,nlevgrnd)) ; this%fracice_col (:,:) = nan - allocate(this%icefrac_col (begc:endc,nlevgrnd)) ; this%icefrac_col (:,:) = nan - allocate(this%fcov_col (begc:endc)) ; this%fcov_col (:) = nan - allocate(this%fsat_col (begc:endc)) ; this%fsat_col (:) = nan - allocate(this%h2osfc_thresh_col (begc:endc)) ; this%h2osfc_thresh_col (:) = nan - - allocate(this%hkdepth_col (begc:endc)) ; this%hkdepth_col (:) = nan - allocate(this%b_infil_col (begc:endc)) ; this%b_infil_col (:) = nan - allocate(this%ds_col (begc:endc)) ; this%ds_col (:) = nan - allocate(this%dsmax_col (begc:endc)) ; this%dsmax_col (:) = nan - allocate(this%Wsvic_col (begc:endc)) ; this%Wsvic_col (:) = nan - allocate(this%depth_col (begc:endc,nlayert)) ; this%depth_col (:,:) = nan - allocate(this%porosity_col (begc:endc,nlayer)) ; this%porosity_col (:,:) = nan - allocate(this%vic_clm_fract_col (begc:endc,nlayer, nlevsoi)) ; this%vic_clm_fract_col (:,:,:) = nan - allocate(this%c_param_col (begc:endc)) ; this%c_param_col (:) = nan - allocate(this%expt_col (begc:endc,nlayer)) ; this%expt_col (:,:) = nan - allocate(this%ksat_col (begc:endc,nlayer)) ; this%ksat_col (:,:) = nan - allocate(this%phi_s_col (begc:endc,nlayer)) ; this%phi_s_col (:,:) = nan - allocate(this%moist_col (begc:endc,nlayert)) ; this%moist_col (:,:) = nan - allocate(this%moist_vol_col (begc:endc,nlayert)) ; this%moist_vol_col (:,:) = nan - allocate(this%max_moist_col (begc:endc,nlayer)) ; this%max_moist_col (:,:) = nan - allocate(this%max_infil_col (begc:endc)) ; this%max_infil_col (:) = nan - allocate(this%i_0_col (begc:endc)) ; this%i_0_col (:) = nan - allocate(this%ice_col (begc:endc,nlayert)) ; this%ice_col (:,:) = nan - - end subroutine InitAllocate - - !------------------------------------------------------------------------ - subroutine InitHistory(this, bounds) - ! - ! !USES: - use histFileMod , only : hist_addfld1d - ! - ! !ARGUMENTS: - class(soilhydrology_type) :: 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%wa_col(begc:endc) = spval - call hist_addfld1d (fname='WA', units='mm', & - avgflag='A', long_name='water in the unconfined aquifer (vegetated landunits only)', & - ptr_col=this%wa_col, l2g_scale_type='veg', default='inactive') - - this%qcharge_col(begc:endc) = spval - call hist_addfld1d (fname='QCHARGE', units='mm/s', & - avgflag='A', long_name='aquifer recharge rate (vegetated landunits only)', & - ptr_col=this%qcharge_col, l2g_scale_type='veg', default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - this%num_substeps_col(begc:endc) = spval - call hist_addfld1d (fname='NSUBSTEPS', units='unitless', & - avgflag='A', long_name='number of adaptive timesteps in CLM timestep', & - ptr_col=this%num_substeps_col, l2g_scale_type='veg', & - default='inactive') - - this%frost_table_col(begc:endc) = spval - call hist_addfld1d (fname='FROST_TABLE', units='m', & - avgflag='A', long_name='frost table depth (vegetated landunits only)', & - ptr_col=this%frost_table_col, l2g_scale_type='veg', default='inactive') - - this%zwt_col(begc:endc) = spval - call hist_addfld1d (fname='ZWT', units='m', & - avgflag='A', long_name='water table depth (vegetated landunits only)', & - ptr_col=this%zwt_col, l2g_scale_type='veg', default='inactive') - - this%zwt_perched_col(begc:endc) = spval - call hist_addfld1d (fname='ZWT_PERCH', units='m', & - avgflag='A', long_name='perched water table depth (vegetated landunits only)', & - ptr_col=this%zwt_perched_col, l2g_scale_type='veg', default='inactive') - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine InitCold(this, bounds) - ! - ! !USES: - ! - ! !ARGUMENTS: - class(soilhydrology_type) :: this - type(bounds_type) , intent(in) :: bounds - ! !LOCAL VARIABLES: - integer :: c ! indices - - !----------------------------------------------------------------------- - - ! Nothing for now - - ! needs to be initialized to spval to avoid problems when - ! averaging for the accum field - do c = bounds%begc, bounds%endc - this%num_substeps_col(c) = spval - end do - - end subroutine InitCold - - !------------------------------------------------------------------------ - subroutine Restart(this, bounds, ncid, flag) - ! - ! !USES: - use ncdio_pio , only : file_desc_t, ncd_io, ncd_double - use restUtilMod - ! - ! !ARGUMENTS: - class(soilhydrology_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='FROST_TABLE', xtype=ncd_double, & - dim1name='column', & - long_name='frost table depth', units='m', & - interpinic_flag='interp', readvar=readvar, data=this%frost_table_col) - if (flag == 'read' .and. .not. readvar) then - this%frost_table_col(bounds%begc:bounds%endc) = col%zi(bounds%begc:bounds%endc,nlevsoi) - end if - - call restartvar(ncid=ncid, flag=flag, varname='WA', xtype=ncd_double, & - dim1name='column', & - long_name='water in the unconfined aquifer', units='mm', & - interpinic_flag='interp', readvar=readvar, data=this%wa_col) - - call restartvar(ncid=ncid, flag=flag, varname='ZWT', xtype=ncd_double, & - dim1name='column', & - long_name='water table depth', units='m', & - interpinic_flag='interp', readvar=readvar, data=this%zwt_col) - - call restartvar(ncid=ncid, flag=flag, varname='ZWT_PERCH', xtype=ncd_double, & - dim1name='column', & - long_name='perched water table depth', units='m', & - interpinic_flag='interp', readvar=readvar, data=this%zwt_perched_col) - if (flag == 'read' .and. .not. readvar) then - this%zwt_perched_col(bounds%begc:bounds%endc) = col%zi(bounds%begc:bounds%endc,nlevsoi) - end if - - end subroutine Restart - - !----------------------------------------------------------------------- - subroutine ReadNL( this, NLFilename ) - ! - ! !DESCRIPTION: - ! Read namelist for SoilHydrology - ! - ! !USES: - use shr_mpi_mod , only : shr_mpi_bcast - use shr_log_mod , only : errMsg => shr_log_errMsg - use spmdMod , only : masterproc, mpicom - use fileutils , only : getavu, relavu, opnfil - use clm_nlUtilsMod , only : find_nlgroup_name - use clm_varctl , only : iulog - use abortutils , only : endrun - ! - ! !ARGUMENTS: - class(soilhydrology_type) :: this - character(len=*), intent(IN) :: NLFilename ! Namelist filename - ! - ! !LOCAL VARIABLES: - integer :: ierr ! error code - integer :: unitn ! unit for namelist file - integer :: origflag=0 !use to control soil hydraulic properties - integer :: h2osfcflag=1 !If surface water is active or not - character(len=32) :: subname = 'SoilHydrology_readnl' ! subroutine name - !----------------------------------------------------------------------- - - namelist / clm_soilhydrology_inparm / h2osfcflag, origflag - - ! preset values - - origflag = 0 - h2osfcflag = 1 - - if ( masterproc )then - - unitn = getavu() - write(iulog,*) 'Read in clm_soilhydrology_inparm namelist' - call opnfil (NLFilename, unitn, 'F') - call find_nlgroup_name(unitn, 'clm_soilhydrology_inparm', status=ierr) - if (ierr == 0) then - read(unitn, clm_soilhydrology_inparm, iostat=ierr) - if (ierr /= 0) then - call endrun(msg="ERROR reading clm_soilhydrology_inparm namelist"//errmsg(sourcefile, __LINE__)) - end if - else - write(iulog,*) "Could not find clm_soilhydrology_inparm namelist" - end if - call relavu( unitn ) - - end if - - call shr_mpi_bcast(h2osfcflag, mpicom) - call shr_mpi_bcast(origflag, mpicom) - - this%h2osfcflag = h2osfcflag - this%origflag = origflag - - end subroutine ReadNL - -end Module SoilHydrologyType diff --git a/src/biogeophys/SoilStateInitTimeConstMod.F90 b/src/biogeophys/SoilStateInitTimeConstMod.F90 deleted file mode 100644 index 1fcfffb3..00000000 --- a/src/biogeophys/SoilStateInitTimeConstMod.F90 +++ /dev/null @@ -1,630 +0,0 @@ -module SoilStateInitTimeConstMod - - !------------------------------------------------------------------------------ - ! DESCRIPTION: - ! Set hydraulic and thermal properties - ! - ! !USES - 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 - ! - ! !PRIVATE MEMBER FUNCTIONS: - private :: ReadNL - ! - ! !PRIVATE DATA: - ! 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 - write(iulog,*) "Could not find '//nl_name//' namelist" - end if - call relavu( unitn ) - - end if - - call shr_mpi_bcast(organic_frac_squared, mpicom) - - end subroutine ReadNL - - !----------------------------------------------------------------------- - subroutine SoilStateInitTimeConst(bounds, soilstate_inst, nlfilename) - ! - ! !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 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 : numpft, numrad - use clm_varpar , only : nlevsoi, nlevgrnd, nlevlak, nlevsoifl, nlayer, nlayert, nlevurb, 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_fates - use clm_varctl , only : iulog, fsurdat, paramfile, soil_layerstruct - 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_tkm = 0.25_r8 ! thermal conductivity of organic soil (Farouki, 1986) [W/m/K] - 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_csol = 2.5_r8 ! heat capacity of peat soil *10^6 (J/K m3) (Farouki, 1986) - real(r8) :: om_tkd = 0.05_r8 ! thermal conductivity of dry organic soil (Farouki, 1981) - real(r8) :: om_b ! 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) :: organic_max ! organic matter (kg/m3) where soil is assumed to act like peat - 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 :: dzsoifl (:) ! Output: [real(r8) (:)] original soil thickness - 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 - !----------------------------------------------------------------------- - - 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 - ! -------------------------------------------------------------------- - - allocate(zsoifl(1:nlevsoifl), zisoifl(0:nlevsoifl), dzsoifl(1:nlevsoifl)) - do j = 1, nlevsoifl - zsoifl(j) = 0.025*(exp(0.5_r8*(j-0.5_r8))-1._r8) !node depths - enddo - - dzsoifl(1) = 0.5_r8*(zsoifl(1)+zsoifl(2)) !thickness b/n two interfaces - do j = 2,nlevsoifl-1 - dzsoifl(j)= 0.5_r8*(zsoifl(j+1)-zsoifl(j-1)) - enddo - dzsoifl(nlevsoifl) = zsoifl(nlevsoifl)-zsoifl(nlevsoifl-1) - - zisoifl(0) = 0._r8 - do j = 1, nlevsoifl-1 - zisoifl(j) = 0.5_r8*(zsoifl(j)+zsoifl(j+1)) !interface depths - enddo - zisoifl(nlevsoifl) = zsoifl(nlevsoifl) + 0.5_r8*dzsoifl(nlevsoifl) - - ! -------------------------------------------------------------------- - ! 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) - - if (lun%itype(l)==istwet .or. lun%itype(l)==istice_mec) then - - do lev = 1,nlevgrnd - soilstate_inst%bsw_col(c,lev) = spval - soilstate_inst%watsat_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 if (lun%urbpoi(l) .and. (col%itype(c) /= icol_road_perv) .and. (col%itype(c) /= icol_road_imperv) )then - - ! Urban Roof, sunwall, shadewall properties set to special value - do lev = 1,nlevgrnd - soilstate_inst%watsat_col(c,lev) = spval - soilstate_inst%watfc_col(c,lev) = spval - soilstate_inst%bsw_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 - ! DML - this if statement could probably be removed and just the - ! top part used for all soil layer structures - if ( soil_layerstruct /= '10SL_3.5m' )then ! apply soil texture from 10 layer input dataset - 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 - do j = 1,nlevsoifl-1 - if (zisoi(lev) >= zisoifl(j) .AND. zisoi(lev) < zisoifl(j+1)) then - clay = clay3d(g,j+1) - sand = sand3d(g,j+1) - om_frac = organic3d(g,j+1)/organic_max - endif - end do - else - clay = clay3d(g,nlevsoifl) - sand = sand3d(g,nlevsoifl) - om_frac = 0._r8 - endif - else - if (lev <= nlevsoi) then ! duplicate clay and sand values from 10th soil layer - clay = clay3d(g,lev) - sand = sand3d(g,lev) - if ( organic_frac_squared )then - om_frac = (organic3d(g,lev)/organic_max)**2._r8 - else - om_frac = organic3d(g,lev)/organic_max - end if - else - clay = clay3d(g,nlevsoi) - sand = sand3d(g,nlevsoi) - om_frac = 0._r8 - endif - end if - - if (lun%itype(l) == istdlak) then - - if (lev <= nlevsoi) then - soilstate_inst%cellsand_col(c,lev) = sand - soilstate_inst%cellclay_col(c,lev) = clay - soilstate_inst%cellorg_col(c,lev) = om_frac*organic_max - end if - - else if (lun%itype(l) /= istdlak) then ! soil columns of both urban and non-urban types - - if (lun%urbpoi(l)) then - om_frac = 0._r8 ! No organic matter for urban - end if - - if (lev <= nlevsoi) then - soilstate_inst%cellsand_col(c,lev) = sand - soilstate_inst%cellclay_col(c,lev) = clay - soilstate_inst%cellorg_col(c,lev) = om_frac*organic_max - end if - - ! 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))*2.7e3_r8 - soilstate_inst%watsat_col(c,lev) = (1._r8 - om_frac) * soilstate_inst%watsat_col(c,lev) + om_watsat*om_frac - tkm = (1._r8-om_frac) * (8.80_r8*sand+2.92_r8*clay)/(sand+clay)+om_tkm*om_frac ! W/(m K) - soilstate_inst%bsw_col(c,lev) = (1._r8-om_frac) * (2.91_r8 + 0.159_r8*clay) + om_frac*om_b - soilstate_inst%sucsat_col(c,lev) = (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) = 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) / & - (2.7e3_r8 - 0.947_r8*soilstate_inst%bd_col(c,lev)))*(1._r8-om_frac) + om_tkd*om_frac - - soilstate_inst%csol_col(c,lev) = ((1._r8-om_frac)*(2.128_r8*sand+2.385_r8*clay) / (sand+clay) + & - om_csol*om_frac)*1.e6_r8 ! J/(m3 K) - - 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))*2.7e3_r8 - - soilstate_inst%watsat_col(c,lev) = (1._r8 - om_frac)*soilstate_inst%watsat_col(c,lev) + om_watsat_lake * om_frac - - tkm = (1._r8-om_frac)*(8.80_r8*sand+2.92_r8*clay)/(sand+clay) + om_tkm * om_frac ! W/(m K) - - soilstate_inst%bsw_col(c,lev) = (1._r8-om_frac)*(2.91_r8 + 0.159_r8*clay) + om_frac * om_b_lake - - soilstate_inst%sucsat_col(c,lev) = (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) = 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) / (2.7e3_r8 - 0.947_r8*bd))*(1._r8-om_frac) + & - om_tkd * om_frac - soilstate_inst%csol_col(c,lev) = ((1._r8-om_frac)*(2.128_r8*sand+2.385_r8*clay) / (sand+clay) + & - om_csol * om_frac)*1.e6_r8 ! J/(m3 K) - 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, dzsoifl) - - end subroutine SoilStateInitTimeConst - -end module SoilStateInitTimeConstMod diff --git a/src/biogeophys/SoilStateType.F90 b/src/biogeophys/SoilStateType.F90 deleted file mode 100644 index 763165a3..00000000 --- a/src/biogeophys/SoilStateType.F90 +++ /dev/null @@ -1,409 +0,0 @@ -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 - use clm_varcon , only : spval - use clm_varctl , only : use_hydrstress, use_cn, use_dynroot - 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 (nlevgrnd) - real(r8), pointer :: rootr_col (:,:) ! col effective fraction of roots in each soil layer (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,nlevgrnd)) ; 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:nlevgrnd)) ; 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 - - - active = "inactive" - - call hist_addfld2d (fname='SMP', units='mm', type2d='levgrnd', & - avgflag='A', long_name='soil matric potential (vegetated landunits only)', & - ptr_col=this%smp_l_col, set_spec=spval, l2g_scale_type='veg', default='inactive') - - 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='inactive') - 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, default='inactive' ) - 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', & - ptr_patch=this%rootr_patch, default='inactive') - end if - - if (use_cn) then - 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', & - ptr_col=this%rootr_col, default='inactive') - - end if - - if (use_cn) 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 (vegetated 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, default='inactive') - - 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, default='inactive') - - 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='root_depth', xtype=ncd_double, & - dim1name='pft', & - long_name='root depth', units='m', & - interpinic_flag='interp', readvar=readvar, data=this%root_depth_patch) - - 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/src/biogeophys/SoilWaterMovementMod.F90 b/src/biogeophys/SoilWaterMovementMod.F90 deleted file mode 100644 index e26cfa45..00000000 --- a/src/biogeophys/SoilWaterMovementMod.F90 +++ /dev/null @@ -1,194 +0,0 @@ -module SoilWaterMovementMod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - ! DESCRIPTION - ! module contains different subroutines to couple soil and root water interactions - ! - ! created by Jinyun Tang, Mar 12, 2014 - use shr_log_mod , only : errMsg => shr_log_errMsg - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_flush - - ! - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: init_soilwater_movement - ! - ! !PUBLIC DATA MEMBERS: - - ! !PRIVATE DATA MEMBERS: - - ! Solution method - integer, parameter :: zengdecker_2009 = 0 - integer, parameter :: moisture_form = 1 - integer, parameter :: mixed_form = 2 - integer, parameter :: head_form = 3 - - ! Boundary conditions - integer, parameter :: bc_head = 0 - integer, parameter :: bc_flux = 1 - integer, parameter :: bc_zero_flux = 2 - integer, parameter :: bc_waterTable = 3 - integer, parameter :: bc_aquifer = 4 - - ! Soil hydraulic properties - integer, parameter :: soil_hp_clapphornberg_1978=0 - integer, parameter :: soil_hp_vanGenuchten_1980=1 - - real(r8),parameter :: m_to_mm = 1.e3_r8 !convert meters to mm - - integer :: soilwater_movement_method ! method for solving richards equation - integer :: upper_boundary_condition ! named variable for the boundary condition - integer :: lower_boundary_condition ! named variable for the boundary condition - - ! Adaptive time stepping algorithmic control parameters - real(r8) :: dtmin ! minimum time step length (seconds) - real(r8) :: verySmall ! a very small number: used to check for sub step completion - real(r8) :: xTolerUpper ! tolerance to halve length of substep - real(r8) :: xTolerLower ! tolerance to double length of substep - integer :: expensive - integer :: inexpensive - integer :: flux_calculation - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - - !----------------------------------------------------------------------- - -contains - -!#1 - !----------------------------------------------------------------------- - subroutine init_soilwater_movement() - ! - !DESCRIPTION - !specify method for doing soil&root water interactions - ! - ! !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_bedrock - use controlMod , only : NLFilename - use clm_nlUtilsMod , only : find_nlgroup_name - - ! !ARGUMENTS: - !------------------------------------------------------------------------------ - implicit none - integer :: nu_nml ! unit for namelist file - integer :: nml_error ! namelist i/o error flag - character(*), parameter :: subName = "('init_soilwater_movement')" - - !----------------------------------------------------------------------- - -! MUST agree with name in namelist and read statement - namelist /soilwater_movement_inparm/ & - soilwater_movement_method, & - upper_boundary_condition, & - lower_boundary_condition, & - dtmin, & - verySmall, & - xTolerUpper, & - xTolerLower, & - expensive, & - inexpensive, & - flux_calculation - - ! Default values for namelist - - soilwater_movement_method = zengdecker_2009 - upper_boundary_condition = bc_flux - lower_boundary_condition = bc_aquifer - - dtmin=60._r8 - verySmall=1.e-8_r8 - xTolerUpper=1.e-1_r8 - xTolerLower=1.e-2_r8 - expensive=42 - inexpensive=1 - flux_calculation=inexpensive - - ! Read soilwater_movement namelist - if (masterproc) then - nu_nml = getavu() - open( nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) - call find_nlgroup_name(nu_nml, 'soilwater_movement_inparm', status=nml_error) - if (nml_error == 0) then - read(nu_nml, nml=soilwater_movement_inparm,iostat=nml_error) - if (nml_error /= 0) then - call endrun(subname // ':: ERROR reading soilwater_movement namelist') - end if - else - write(iulog,*) 'Could not read soilwater_movement namelist' - end if - close(nu_nml) - call relavu( nu_nml ) - -! test for namelist consistency - if((soilwater_movement_method == zengdecker_2009) .and. & - (lower_boundary_condition /= bc_aquifer)) then - call endrun(subname // ':: ERROR inconsistent soilwater_movement namelist: ZD09 must use bc_aquifer lbc') - endif - if((use_bedrock) .and. (lower_boundary_condition /= bc_zero_flux)) then - call endrun(subname // ':: ERROR inconsistent soilwater_movement namelist: use_bedrock requires bc_zero_flux lbc') - endif - endif - - call shr_mpi_bcast(soilwater_movement_method, mpicom) - call shr_mpi_bcast(upper_boundary_condition, mpicom) - call shr_mpi_bcast(lower_boundary_condition, mpicom) - call shr_mpi_bcast(dtmin, mpicom) - call shr_mpi_bcast(verySmall, mpicom) - call shr_mpi_bcast(xTolerUpper, mpicom) - call shr_mpi_bcast(xTolerLower, mpicom) - call shr_mpi_bcast(expensive, mpicom) - call shr_mpi_bcast(inexpensive, mpicom) - call shr_mpi_bcast(flux_calculation, mpicom) - - - if (masterproc) then - - write(iulog,*) ' ' - write(iulog,*) 'soilwater_movement settings:' - write(iulog,*) ' soilwater_movement_method = ',soilwater_movement_method - write(iulog,*) ' upper_boundary_condition = ',upper_boundary_condition - write(iulog,*) ' lower_boundary_condition = ',lower_boundary_condition - - write(iulog,*) ' use_bedrock = ',use_bedrock - write(iulog,*) ' dtmin = ',dtmin - write(iulog,*) ' verySmall = ',verySmall - write(iulog,*) ' xTolerUpper = ',xTolerUpper - write(iulog,*) ' xTolerLower = ',xTolerLower - write(iulog,*) ' expensive = ',expensive - write(iulog,*) ' inexpensive = ',inexpensive - write(iulog,*) ' flux_calculation = ',flux_calculation - endif - - end subroutine init_soilwater_movement - - -!#2 - !------------------------------------------------------------------------------ - function use_aquifer_layer() result(lres) - ! - !DESCRIPTION - ! return true if an aquifer layer is used - ! otherwise false - implicit none - logical :: lres - - if(lower_boundary_condition == bc_aquifer .or. lower_boundary_condition == bc_watertable)then - lres=.true. - else - lres=.false. - endif - return - - end function use_aquifer_layer - - end module SoilWaterMovementMod diff --git a/src/biogeophys/SoilWaterPlantSinkMod.F90 b/src/biogeophys/SoilWaterPlantSinkMod.F90 deleted file mode 100644 index 32854a3b..00000000 --- a/src/biogeophys/SoilWaterPlantSinkMod.F90 +++ /dev/null @@ -1,444 +0,0 @@ -module SoilWaterPlantSinkMod - - use clm_varctl , only : use_hydrstress - use decompMod , only : bounds_type - 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 landunit_varcon , only : istsoil,istcrop - use column_varcon , only : icol_road_perv - implicit none - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - subroutine Compute_EffecRootFrac_And_VertTranSink(bounds, num_hydrologyc, & - filter_hydrologyc, soilstate_inst, canopystate_inst, waterflux_inst, energyflux_inst) - - ! --------------------------------------------------------------------------------- - ! This is a wrapper for calculating the effective root fraction and soil - ! water sink due to plant transpiration. - ! Calculate Soil Water Sink to Roots over different types - ! of columns and for different process modules - ! The super-set of all columns that should have a root water sink - ! is filter_hydrologyc - ! There are three groups of columns: - ! 1) impervious roads, 2) non-natural vegetation and 3) natural vegetation - ! There are several methods available. - ! 1) the default version, 2) hydstress version and 3) fates boundary conditions - ! - ! There are only two quantities that are the result of this routine, and its - ! children: - ! waterflux_inst%qflx_rootsoi_col(c,j) - ! soilstate_inst%rootr_col(c,j) - ! - ! - ! --------------------------------------------------------------------------------- - - use SoilStateType , only : soilstate_type - use WaterFluxType , only : waterflux_type - use CanopyStateType , only : canopystate_type - use EnergyFluxType , only : energyflux_type - use ColumnType , only : col - use LandunitType , only : lun - - ! Arguments - type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter - integer , intent(in) :: filter_hydrologyc(num_hydrologyc) ! column filter for soil points - type(soilstate_type) , intent(inout) :: soilstate_inst - type(waterflux_type) , intent(inout) :: waterflux_inst - type(canopystate_type) , intent(in) :: canopystate_inst - type(energyflux_type) , intent(in) :: energyflux_inst - - ! Local Variables - integer :: filterc(bounds%endc-bounds%begc+1) !column filter - integer :: num_filterc - integer :: num_filterc_tot - integer :: fc - integer :: c - integer :: l - - num_filterc_tot = 0 - - ! 1) pervious roads - num_filterc = 0 - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - if (col%itype(c) == icol_road_perv) then - num_filterc = num_filterc + 1 - filterc(num_filterc) = c - end if - end do - num_filterc_tot = num_filterc_tot+num_filterc - if(use_hydrstress) then - call Compute_EffecRootFrac_And_VertTranSink_HydStress_Roads(bounds, & - num_filterc,filterc, soilstate_inst, waterflux_inst) - else - call Compute_EffecRootFrac_And_VertTranSink_Default(bounds, & - num_filterc,filterc, soilstate_inst, waterflux_inst) - end if - - - ! Note: 2 and 3 really don't need to be split. But I am leaving - ! it split in case someone wants to calculate uptake in a special - ! way for a specific LU or coverage type (RGK 04/2017). Feel - ! free to consolidate if there are no plans to do such a thing. - - - ! 2) not ( pervious road or natural vegetation) , everything else - num_filterc = 0 - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - l = col%landunit(c) - if ( (col%itype(c) /= icol_road_perv) .and. (lun%itype(l) /= istsoil) ) then - num_filterc = num_filterc + 1 - filterc(num_filterc) = c - end if - end do - num_filterc_tot = num_filterc_tot+num_filterc - if(use_hydrstress) then - call Compute_EffecRootFrac_And_VertTranSink_HydStress(bounds, & - num_filterc, filterc, waterflux_inst, soilstate_inst, & - canopystate_inst, energyflux_inst) - else - call Compute_EffecRootFrac_And_VertTranSink_Default(bounds, & - num_filterc,filterc, soilstate_inst, waterflux_inst) - end if - - - ! 3) Natural vegetation - num_filterc = 0 - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - l = col%landunit(c) - if ( (lun%itype(l) == istsoil) ) then - num_filterc = num_filterc + 1 - filterc(num_filterc) = c - end if - end do - num_filterc_tot = num_filterc_tot+num_filterc - if (use_hydrstress) then - call Compute_EffecRootFrac_And_VertTranSink_HydStress(bounds, & - num_filterc, filterc, waterflux_inst, soilstate_inst, & - canopystate_inst,energyflux_inst) - else - call Compute_EffecRootFrac_And_VertTranSink_Default(bounds, & - num_filterc,filterc, soilstate_inst, waterflux_inst) - end if - - if (num_hydrologyc /= num_filterc_tot) then - write(iulog,*) 'The total number of columns flagged to root water uptake' - write(iulog,*) 'did not match the total number calculated' - write(iulog,*) 'This is likely a problem with the interpretation of column/lu filters.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - return - end subroutine Compute_EffecRootFrac_And_VertTranSink - - ! ==================================================================================== - - subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress_Roads(bounds, & - num_filterc,filterc, soilstate_inst, waterflux_inst) - - use SoilStateType , only : soilstate_type - use WaterFluxType , only : waterflux_type - use clm_varpar , only : nlevsoi - use clm_varpar , only : max_patch_per_col - use PatchType , only : patch - use ColumnType , only : col - - ! Arguments - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_filterc - integer , intent(in) :: filterc(:) - type(soilstate_type) , intent(inout) :: soilstate_inst - type(waterflux_type) , intent(inout) :: waterflux_inst - - ! Locals - integer :: j - integer :: c - integer :: fc - integer :: pi - integer :: p - real(r8) :: temp(bounds%begc:bounds%endc) ! accumulator for rootr weighting - - - associate(& - qflx_rootsoi_col => waterflux_inst%qflx_rootsoi_col , & ! Output: [real(r8) (:,:) ] - ! vegetation/soil water exchange (mm H2O/s) (+ = to atm) - qflx_tran_veg_patch => waterflux_inst%qflx_tran_veg_patch , & ! Input: [real(r8) (:) ] - ! vegetation transpiration (mm H2O/s) (+ = to atm) - qflx_tran_veg_col => waterflux_inst%qflx_tran_veg_col , & ! Input: [real(r8) (:) ] - ! vegetation transpiration (mm H2O/s) (+ = to atm) - rootr_patch => soilstate_inst%rootr_patch , & ! Input: [real(r8) (:,:) ] - ! effective fraction of roots in each soil layer - rootr_col => soilstate_inst%rootr_col & ! Output: [real(r8) (:,:) ] - !effective fraction of roots in each soil layer - ) - - ! First step is to calculate the column-level effective rooting - ! fraction in each soil layer. This is done outside the usual - ! PATCH-to-column averaging routines because it is not a simple - ! weighted average of the PATCH level rootr arrays. Instead, the - ! weighting depends on both the per-unit-area transpiration - ! of the PATCH and the PATCHEs area relative to all PATCHES. - - temp(bounds%begc : bounds%endc) = 0._r8 - - - do j = 1, nlevsoi - do fc = 1, num_filterc - c = filterc(fc) - rootr_col(c,j) = 0._r8 - end do - end do - - do pi = 1,max_patch_per_col - do j = 1,nlevsoi - do fc = 1, num_filterc - c = filterc(fc) - if (pi <= col%npatches(c)) then - p = col%patchi(c) + pi - 1 - if (patch%active(p)) then - rootr_col(c,j) = rootr_col(c,j) + rootr_patch(p,j) * & - qflx_tran_veg_patch(p) * patch%wtcol(p) - end if - end if - end do - end do - do fc = 1, num_filterc - c = filterc(fc) - if (pi <= col%npatches(c)) then - p = col%patchi(c) + pi - 1 - if (patch%active(p)) then - temp(c) = temp(c) + qflx_tran_veg_patch(p) * patch%wtcol(p) - end if - end if - end do - end do - - - do j = 1, nlevsoi - do fc = 1, num_filterc - c = filterc(fc) - if (temp(c) /= 0._r8) then - rootr_col(c,j) = rootr_col(c,j)/temp(c) - end if - qflx_rootsoi_col(c,j) = rootr_col(c,j)*qflx_tran_veg_col(c) - end do - end do - end associate - return - end subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress_Roads - - ! ================================================================================== - - subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress( bounds, & - num_filterc, filterc, waterflux_inst, soilstate_inst, & - canopystate_inst, energyflux_inst) - - - ! - !USES: - use decompMod , only : bounds_type - use clm_varpar , only : nlevsoi - use clm_varpar , only : max_patch_per_col - use SoilStateType , only : soilstate_type - use WaterFluxType , only : waterflux_type - use CanopyStateType , only : canopystate_type - use PatchType , only : patch - use ColumnType , only : col - use clm_varctl , only : iulog - use PhotosynthesisMod, only : params_inst - use column_varcon , only : icol_road_perv - use shr_infnan_mod , only : isnan => shr_infnan_isnan - use EnergyFluxType , only : energyflux_type - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: num_filterc ! number of column soil points in column filter - integer , intent(in) :: filterc(:) ! column filter for soil points - type(waterflux_type) , intent(inout) :: waterflux_inst - type(soilstate_type) , intent(inout) :: soilstate_inst - type(canopystate_type) , intent(in) :: canopystate_inst - type(energyflux_type), intent(in) :: energyflux_inst - ! - ! !LOCAL VARIABLES: - integer :: p,c,fc,j ! do loop indices - integer :: pi ! patch index - real(r8) :: temp(bounds%begc:bounds%endc) ! accumulator for rootr weighting - real(r8) :: grav2 ! soil layer gravitational potential relative to surface (mm H2O) - integer , parameter :: soil=1,root=4 ! index values - !----------------------------------------------------------------------- - - associate(& - k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] - ! soil-root interface conductance (mm/s) - qflx_phs_neg_col => waterflux_inst%qflx_phs_neg_col , & ! Input: [real(r8) (:) ] n - ! net neg hydraulic redistribution flux(mm H2O/s) - qflx_tran_veg_col => waterflux_inst%qflx_tran_veg_col , & ! Input: [real(r8) (:) ] - ! vegetation transpiration (mm H2O/s) (+ = to atm) - qflx_tran_veg_patch => waterflux_inst%qflx_tran_veg_patch , & ! Input: [real(r8) (:) ] - ! vegetation transpiration (mm H2O/s) (+ = to atm) - qflx_rootsoi_col => waterflux_inst%qflx_rootsoi_col , & ! Output: [real(r8) (:) ] - ! col root and soil water - ! exchange [mm H2O/s] [+ into root] - rootr_col => soilstate_inst%rootr_col , & ! Input: [real(r8) (:,:) ] - ! effective fraction of roots in each soil layer - rootr_patch => soilstate_inst%rootr_patch , & ! Input: [real(r8) (:,:) ] - ! effective fraction of roots in each soil layer - smp => soilstate_inst%smp_l_col , & ! Input: [real(r8) (:,:) ] soil matrix pot. [mm] - frac_veg_nosno => canopystate_inst%frac_veg_nosno_patch , & ! Input: [integer (:) ] - ! fraction of vegetation not - ! covered by snow (0 OR 1) [-] - z => col%z , & ! Input: [real(r8) (:,:) ] layer node depth (m) - vegwp => canopystate_inst%vegwp_patch & ! Input: [real(r8) (:,:) ] vegetation water - ! matric potential (mm) - ) - - do fc = 1, num_filterc - c = filterc(fc) - qflx_phs_neg_col(c) = 0._r8 - - do j = 1, nlevsoi - grav2 = z(c,j) * 1000._r8 - temp(c) = 0._r8 - do pi = 1,max_patch_per_col - if (pi <= col%npatches(c)) then - p = col%patchi(c) + pi - 1 - if (patch%active(p).and.frac_veg_nosno(p)>0) then - if (patch%wtcol(p) > 0._r8) then - temp(c) = temp(c) + k_soil_root(p,j) & - * (smp(c,j) - vegwp(p,4) - grav2)* patch%wtcol(p) - endif - end if - end if - end do - qflx_rootsoi_col(c,j)= temp(c) - - if (temp(c) < 0._r8) qflx_phs_neg_col(c) = qflx_phs_neg_col(c) + temp(c) - end do - - ! Back out the effective root density - if( sum(qflx_rootsoi_col(c,:))>0.0_r8 ) then - do j = 1, nlevsoi - rootr_col(c,j) = qflx_rootsoi_col(c,j)/sum( qflx_rootsoi_col(c,:)) - end do - else - rootr_col(c,:) = 0.0_r8 - end if - end do - - end associate - - return - end subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress - - ! ================================================================================== - - subroutine Compute_EffecRootFrac_And_VertTranSink_Default(bounds, num_filterc, & - filterc, soilstate_inst, waterflux_inst) - - ! - ! Generic routine to apply transpiration as a sink condition that - ! is vertically distributed over the soil column. Should be - ! applicable to any Richards solver that is not coupled to plant - ! hydraulics. - ! - !USES: - use decompMod , only : bounds_type - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varpar , only : nlevsoi, max_patch_per_col - use SoilStateType , only : soilstate_type - use WaterFluxType , only : waterflux_type - use PatchType , only : patch - use ColumnType , only : col - use clm_varctl , only : use_hydrstress - use column_varcon , only : icol_road_perv - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: num_filterc ! number of column soil points in column filter - integer , intent(in) :: filterc(num_filterc) ! column filter for soil points - type(waterflux_type) , intent(inout) :: waterflux_inst - type(soilstate_type) , intent(inout) :: soilstate_inst - ! - ! !LOCAL VARIABLES: - integer :: p,c,fc,j ! do loop indices - integer :: pi ! patch index - real(r8) :: temp(bounds%begc:bounds%endc) ! accumulator for rootr weighting - associate(& - qflx_rootsoi_col => waterflux_inst%qflx_rootsoi_col , & ! Output: [real(r8) (:,:) ] - ! vegetation/soil water exchange (m H2O/s) (+ = to atm) - qflx_tran_veg_patch => waterflux_inst%qflx_tran_veg_patch , & ! Input: [real(r8) (:) ] - ! vegetation transpiration (mm H2O/s) (+ = to atm) - qflx_tran_veg_col => waterflux_inst%qflx_tran_veg_col , & ! Input: [real(r8) (:) ] - ! vegetation transpiration (mm H2O/s) (+ = to atm) - rootr_patch => soilstate_inst%rootr_patch , & ! Input: [real(r8) (:,:) ] - ! effective fraction of roots in each soil layer - rootr_col => soilstate_inst%rootr_col & ! Output: [real(r8) (:,:) ] - ! effective fraction of roots in each soil layer - ) - - ! First step is to calculate the column-level effective rooting - ! fraction in each soil layer. This is done outside the usual - ! PATCH-to-column averaging routines because it is not a simple - ! weighted average of the PATCH level rootr arrays. Instead, the - ! weighting depends on both the per-unit-area transpiration - ! of the PATCH and the PATCHEs area relative to all PATCHES. - - temp(bounds%begc : bounds%endc) = 0._r8 - - do j = 1, nlevsoi - do fc = 1, num_filterc - c = filterc(fc) - rootr_col(c,j) = 0._r8 - end do - end do - - do pi = 1,max_patch_per_col - do j = 1,nlevsoi - do fc = 1, num_filterc - c = filterc(fc) - if (pi <= col%npatches(c)) then - p = col%patchi(c) + pi - 1 - if (patch%active(p)) then - rootr_col(c,j) = rootr_col(c,j) + rootr_patch(p,j) * & - qflx_tran_veg_patch(p) * patch%wtcol(p) - end if - end if - end do - end do - do fc = 1, num_filterc - c = filterc(fc) - if (pi <= col%npatches(c)) then - p = col%patchi(c) + pi - 1 - if (patch%active(p)) then - temp(c) = temp(c) + qflx_tran_veg_patch(p) * patch%wtcol(p) - end if - end if - end do - end do - - do j = 1, nlevsoi - do fc = 1, num_filterc - c = filterc(fc) - if (temp(c) /= 0._r8) then - rootr_col(c,j) = rootr_col(c,j)/temp(c) - end if - qflx_rootsoi_col(c,j) = rootr_col(c,j)*qflx_tran_veg_col(c) - - end do - end do - end associate - return - end subroutine Compute_EffecRootFrac_And_VertTranSink_Default - -end module SoilWaterPlantSinkMod - diff --git a/src/biogeophys/SoilWaterRetentionCurveClappHornberg1978Mod.F90 b/src/biogeophys/SoilWaterRetentionCurveClappHornberg1978Mod.F90 deleted file mode 100644 index c82e27d8..00000000 --- a/src/biogeophys/SoilWaterRetentionCurveClappHornberg1978Mod.F90 +++ /dev/null @@ -1,162 +0,0 @@ -module SoilWaterRetentionCurveClappHornberg1978Mod - - !--------------------------------------------------------------------------- - ! !DESCRIPTION: - ! Implementation of soil_water_retention_curve_type using the Clapp-Hornberg 1978 - ! parameterizations. - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use SoilWaterRetentionCurveMod, only : soil_water_retention_curve_type - implicit none - save - private - ! - ! !PUBLIC TYPES: - public :: soil_water_retention_curve_clapp_hornberg_1978_type - - type, extends(soil_water_retention_curve_type) :: & - soil_water_retention_curve_clapp_hornberg_1978_type - private - contains - procedure :: soil_hk ! compute hydraulic conductivity - procedure :: soil_suction ! compute soil suction potential - procedure :: soil_suction_inverse ! compute relative saturation at which soil suction is equal to a target value - end type soil_water_retention_curve_clapp_hornberg_1978_type - - interface soil_water_retention_curve_clapp_hornberg_1978_type - ! initialize a new soil_water_retention_curve_clapp_hornberg_1978_type object - module procedure constructor - end interface soil_water_retention_curve_clapp_hornberg_1978_type - -contains - - !----------------------------------------------------------------------- - type(soil_water_retention_curve_clapp_hornberg_1978_type) function constructor() - ! - ! !DESCRIPTION: - ! Creates an object of type soil_water_retention_curve_clapp_hornberg_1978_type. - ! For now, this is simply a place-holder. - !----------------------------------------------------------------------- - - end function constructor - - !----------------------------------------------------------------------- - subroutine soil_hk(this, c, j, s, imped, soilstate_inst, hk, dhkds) - ! - ! !DESCRIPTION: - ! Compute hydraulic conductivity - ! - ! !USES: - use SoilStateType , only : soilstate_type - ! - ! !ARGUMENTS: - class(soil_water_retention_curve_clapp_hornberg_1978_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] - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'soil_hk' - !----------------------------------------------------------------------- - - associate(& - hksat => soilstate_inst%hksat_col(c,j) , & ! Input: [real(r8) (:,:) ] hydraulic conductivity at saturation (mm H2O /s) - bsw => soilstate_inst%bsw_col(c,j) & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" - ) - - - !compute hydraulic conductivity - hk=imped*hksat*s**(2._r8*bsw+3._r8) - - !compute the derivative - if(present(dhkds))then - dhkds=(2._r8*bsw+3._r8)*hk/s - endif - - end associate - - end subroutine soil_hk - - !----------------------------------------------------------------------- - subroutine soil_suction(this, c, j, s, soilstate_inst, smp, dsmpds) - ! - ! !DESCRIPTION: - ! Compute soil suction potential - ! - ! !USES: - use SoilStateType , only : soilstate_type - ! - ! !ARGUMENTS: - class(soil_water_retention_curve_clapp_hornberg_1978_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] - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'soil_suction' - !----------------------------------------------------------------------- - - associate(& - bsw => soilstate_inst%bsw_col(c,j) , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" - sucsat => soilstate_inst%sucsat_col(c,j) & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) - ) - - !compute soil suction potential, negative - smp = -sucsat*s**(-bsw) - - !compute derivative - if(present(dsmpds))then - dsmpds=-bsw*smp/s - endif - - end associate - - end subroutine soil_suction - - !----------------------------------------------------------------------- - subroutine soil_suction_inverse(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 SoilStateType , only : soilstate_type - ! - ! !ARGUMENTS: - class(soil_water_retention_curve_clapp_hornberg_1978_type), intent(in) :: this - integer, intent(in) :: c !column index - integer, intent(in) :: j !level index - type(soilstate_type), intent(in) :: soilstate_inst - real(r8) , intent(in) :: smp_target ! target soil suction, negative [mm] - real(r8) , intent(out) :: s_target ! relative saturation at which smp = smp_target [0,1] - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'soil_suction_inverse' - !----------------------------------------------------------------------- - - associate(& - bsw => soilstate_inst%bsw_col(c,j) , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" - sucsat => soilstate_inst%sucsat_col(c,j) & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) - ) - - s_target = (-smp_target/sucsat)**(-1._r8/bsw) - - end associate - - end subroutine soil_suction_inverse - -end module SoilWaterRetentionCurveClappHornberg1978Mod - diff --git a/src/biogeophys/SoilWaterRetentionCurveFactoryMod.F90 b/src/biogeophys/SoilWaterRetentionCurveFactoryMod.F90 deleted file mode 100644 index 61e579dd..00000000 --- a/src/biogeophys/SoilWaterRetentionCurveFactoryMod.F90 +++ /dev/null @@ -1,71 +0,0 @@ -module SoilWaterRetentionCurveFactoryMod - - !--------------------------------------------------------------------------- - ! !DESCRIPTION: - ! Factory to create an instance of soil_water_retention_curve_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_soil_water_retention_curve ! create an object of class soil_water_retention_curve_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - !----------------------------------------------------------------------- - function create_soil_water_retention_curve() result(soil_water_retention_curve) - ! - ! !DESCRIPTION: - ! Create and return an object of soil_water_retention_curve_type. The particular type - ! is determined based on a namelist parameter. - ! - ! !USES: - use SoilWaterRetentionCurveMod, only : soil_water_retention_curve_type - use SoilWaterRetentionCurveClappHornberg1978Mod, only : soil_water_retention_curve_clapp_hornberg_1978_type - use SoilWaterRetentionCurveVanGenuchten1980Mod, only : soil_water_retention_curve_vangenuchten_1980_type - ! - ! !ARGUMENTS: - class(soil_water_retention_curve_type), allocatable :: soil_water_retention_curve ! function result - ! - ! !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). -!scs character(len=*), parameter :: method = "clapphornberg_1978" - character(len=256) :: method - - character(len=*), parameter :: subname = 'create_soil_water_retention_curve' - !----------------------------------------------------------------------- - - method = "clapphornberg_1978" !scs: placeholder until bld scripts changed - - select case (trim(method)) - - case ("clapphornberg_1978") - allocate(soil_water_retention_curve, & - source=soil_water_retention_curve_clapp_hornberg_1978_type()) - - case ("vangenuchten_1980") - allocate(soil_water_retention_curve, & - source=soil_water_retention_curve_vangenuchten_1980_type()) - - case default - write(iulog,*) subname//' ERROR: unknown method: ', method - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end select - - end function create_soil_water_retention_curve - -end module SoilWaterRetentionCurveFactoryMod diff --git a/src/biogeophys/SoilWaterRetentionCurveMod.F90 b/src/biogeophys/SoilWaterRetentionCurveMod.F90 deleted file mode 100644 index 74f8299d..00000000 --- a/src/biogeophys/SoilWaterRetentionCurveMod.F90 +++ /dev/null @@ -1,111 +0,0 @@ -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/src/biogeophys/SoilWaterRetentionCurveVanGenuchten1980Mod.F90 b/src/biogeophys/SoilWaterRetentionCurveVanGenuchten1980Mod.F90 deleted file mode 100644 index c8dacccb..00000000 --- a/src/biogeophys/SoilWaterRetentionCurveVanGenuchten1980Mod.F90 +++ /dev/null @@ -1,162 +0,0 @@ -module SoilWaterRetentionCurveVanGenuchten1980Mod - - !--------------------------------------------------------------------------- - ! !DESCRIPTION: - ! Implementation of soil_water_retention_curve_type using the Clapp-Hornberg 1978 - ! parameterizations. - ! - ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use SoilWaterRetentionCurveMod, only : soil_water_retention_curve_type - implicit none - save - private - ! - ! !PUBLIC TYPES: - public :: soil_water_retention_curve_vangenuchten_1980_type - - type, extends(soil_water_retention_curve_type) :: & - soil_water_retention_curve_vangenuchten_1980_type - private - contains - procedure :: soil_hk ! compute hydraulic conductivity - procedure :: soil_suction ! compute soil suction potential - procedure :: soil_suction_inverse ! compute relative saturation at which soil suction is equal to a target value - end type soil_water_retention_curve_vangenuchten_1980_type - - interface soil_water_retention_curve_vangenuchten_1980_type - ! initialize a new soil_water_retention_curve_vangenuchten_1980_type object - module procedure constructor - end interface soil_water_retention_curve_vangenuchten_1980_type - -contains - - !----------------------------------------------------------------------- - type(soil_water_retention_curve_vangenuchten_1980_type) function constructor() - ! - ! !DESCRIPTION: - ! Creates an object of type soil_water_retention_curve_vangenuchten_1980_type. - ! For now, this is simply a place-holder. - !----------------------------------------------------------------------- - - end function constructor - - !----------------------------------------------------------------------- - subroutine soil_hk(this, c, j, s, imped, soilstate_inst, hk, dhkds) - ! - ! !DESCRIPTION: - ! Compute hydraulic conductivity - ! - ! !USES: - use SoilStateType , only : soilstate_type - ! - ! !ARGUMENTS: - class(soil_water_retention_curve_vangenuchten_1980_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] - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'soil_hk' - !----------------------------------------------------------------------- - - associate(& - hksat => soilstate_inst%hksat_col(c,j) , & ! Input: [real(r8) (:,:) ] hydraulic conductivity at saturation (mm H2O /s) - bsw => soilstate_inst%bsw_col(c,j) & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" - ) - - - !compute hydraulic conductivity - hk=imped*hksat*s**(2._r8*bsw+3._r8) - - !compute the derivative - if(present(dhkds))then - dhkds=(2._r8*bsw+3._r8)*hk/s - endif - - end associate - - end subroutine soil_hk - - !----------------------------------------------------------------------- - subroutine soil_suction(this, c, j, s, soilstate_inst, smp, dsmpds) - !j, - ! !DESCRIPTION: - ! Compute soil suction potential - ! - ! !USES: - use SoilStateType , only : soilstate_type - ! - ! !ARGUMENTS: - class(soil_water_retention_curve_vangenuchten_1980_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] - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'soil_suction' - !----------------------------------------------------------------------- - - associate(& - bsw => soilstate_inst%bsw_col(c,j) , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" - sucsat => soilstate_inst%sucsat_col(c,j) & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) - ) - - !compute soil suction potential, negative - smp = -sucsat*s**(-bsw) - - !compute derivative - if(present(dsmpds))then - dsmpds=-bsw*smp/s - endif - - end associate - - end subroutine soil_suction - - !----------------------------------------------------------------------- - subroutine soil_suction_inverse(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 SoilStateType , only : soilstate_type - ! - ! !ARGUMENTS: - class(soil_water_retention_curve_vangenuchten_1980_type), intent(in) :: this - integer, intent(in) :: c !column index - integer, intent(in) :: j !level index - type(soilstate_type), intent(in) :: soilstate_inst - real(r8) , intent(in) :: smp_target ! target soil suction, negative [mm] - real(r8) , intent(out) :: s_target ! relative saturation at which smp = smp_target [0,1] - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'soil_suction_inverse' - !----------------------------------------------------------------------- - - associate(& - bsw => soilstate_inst%bsw_col(c,j) , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" - sucsat => soilstate_inst%sucsat_col(c,j) & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) - ) - - s_target = (-smp_target/sucsat)**(-1._r8/bsw) - - end associate - - end subroutine soil_suction_inverse - -end module SoilWaterRetentionCurveVanGenuchten1980Mod - - diff --git a/src/biogeophys/SolarAbsorbedType.F90 b/src/biogeophys/SolarAbsorbedType.F90 deleted file mode 100644 index e167fb3a..00000000 --- a/src/biogeophys/SolarAbsorbedType.F90 +++ /dev/null @@ -1,423 +0,0 @@ -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) - - ! 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) - - 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%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 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', default='inactive') - - 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', default='inactive') - ! 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', default='inactive') - - 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', default='inactive') - - 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, default='inactive') - - ! 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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, default='inactive') - - 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/src/biogeophys/SurfaceAlbedoMod.F90 b/src/biogeophys/SurfaceAlbedoMod.F90 deleted file mode 100644 index 93caf268..00000000 --- a/src/biogeophys/SurfaceAlbedoMod.F90 +++ /dev/null @@ -1,143 +0,0 @@ -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 landunit_varcon , only : istsoil, istcrop - use clm_varcon , only : grlnd, namep - use clm_varpar , only : numrad, nlevcan, nlevsno, nlevcan - use clm_varctl , only : fsurdat, iulog, use_snicar_frc - use pftconMod , only : pftcon - use ColumnType , only : col - ! - implicit none - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: SurfaceAlbedoInitTimeConst - ! - ! !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/) - - ! 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: - - ! !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 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 - ! if number of soil color classes is not on input dataset set it to 8 - - 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 ) mxsoil_color = 8 - - 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 - -end module SurfaceAlbedoMod diff --git a/src/biogeophys/SurfaceAlbedoType.F90 b/src/biogeophys/SurfaceAlbedoType.F90 deleted file mode 100644 index 1540d9f9..00000000 --- a/src/biogeophys/SurfaceAlbedoType.F90 +++ /dev/null @@ -1,636 +0,0 @@ -module SurfaceAlbedoType - -#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 clm_varpar , only : numrad, nlevcan, nlevsno - use abortutils , only : endrun - ! - ! !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 :: 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 - ! - ! !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%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_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 - !--------------------------------------------------------------------- - - 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') - - 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='inactive', 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='inactive', 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 - - 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((ubound(tlai_patch) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(tsai_patch) == (/bounds%endp/)), errMsg(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) - - 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/src/biogeophys/SurfaceRadiationMod.F90 b/src/biogeophys/SurfaceRadiationMod.F90 deleted file mode 100644 index f021c6fd..00000000 --- a/src/biogeophys/SurfaceRadiationMod.F90 +++ /dev/null @@ -1,304 +0,0 @@ -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 WaterstateType , only : waterstate_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 - - ! - ! !PRIVATE TYPES: - implicit none - private - - logical :: DEBUG = .false. ! for debugging this module - - ! - ! !PUBLIC MEMBER FUNCTIONS: - - ! - ! !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) - - 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%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 - ! - ! !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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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', default='inactive') - - 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', default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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', default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - - 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 - -end module SurfaceRadiationMod diff --git a/src/biogeophys/SurfaceResistanceMod.F90 b/src/biogeophys/SurfaceResistanceMod.F90 deleted file mode 100644 index 76813b71..00000000 --- a/src/biogeophys/SurfaceResistanceMod.F90 +++ /dev/null @@ -1,294 +0,0 @@ -module SurfaceResistanceMod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Module holding routines for calculation of surface resistances of the different tracers - ! transported with BeTR. The surface here refers to water and soil, not including canopy - ! - ! !USES: - use shr_kind_mod , only: r8 => shr_kind_r8 - use shr_const_mod , only: SHR_CONST_TKFRZ - use clm_varctl , only: iulog - use SoilStateType , only: soilstate_type - use WaterStateType, only: waterstate_type - use TemperatureType , only : temperature_type - implicit none - save - private - integer :: soil_resis_method !choose the method for soil resistance calculation - - integer, parameter :: leepielke_1992 = 0 ! - integer, parameter :: sl_14 = 1 - - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: calc_soilevap_resis - public :: do_soilevap_beta, do_soil_resistance_sl14 - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - ! - ! !REVISION HISTORY: - ! 6/25/2013 Created by Jinyun Tang - !----------------------------------------------------------------------- - -contains - - !------------------------------------------------------------------------------ - subroutine calc_soilevap_resis(bounds, num_nolakec, filter_nolakec, & - soilstate_inst, waterstate_inst, temperature_inst) - ! - ! DESCRIPTIONS - ! compute the resis factor for soil evaporation calculation - ! - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_const_mod , only : SHR_CONST_PI - use decompMod , only : bounds_type - use ColumnType , only : col - use LandunitType , only : lun - use abortutils , only : endrun - ! - ! !ARGUMENTS: - implicit none - type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: num_nolakec - integer , intent(in) :: filter_nolakec(:) - type(soilstate_type) , intent(inout) :: soilstate_inst - type(waterstate_type) , intent(in) :: waterstate_inst - type(temperature_type), intent(in) :: temperature_inst - character(len=32) :: subname = 'calc_soilevap_resis' ! subroutine name - associate( & - soilbeta => soilstate_inst%soilbeta_col , & ! Output: [real(r8) (:)] factor that reduces ground evaporation - dsl => soilstate_inst%dsl_col , & ! Output: [real(r8) (:)] soil dry surface layer thickness - soilresis => soilstate_inst%soilresis_col & ! Output: [real(r8) (:)] soil evaporative resistance - ) - - !select the right method and do the calculation - select case (soil_resis_method) - - case (leepielke_1992) - call calc_beta_leepielke1992(bounds, num_nolakec, filter_nolakec, & - soilstate_inst, waterstate_inst, soilbeta(bounds%begc:bounds%endc)) - - case (sl_14) - call calc_soil_resistance_sl14(bounds, num_nolakec, filter_nolakec, & - soilstate_inst, waterstate_inst,temperature_inst, & - dsl(bounds%begc:bounds%endc), soilresis(bounds%begc:bounds%endc)) - case default - call endrun(subname // ':: a soilevap resis function must be specified!') - end select - - end associate - - end subroutine calc_soilevap_resis - - !------------------------------------------------------------------------------ - subroutine calc_beta_leepielke1992(bounds, num_nolakec, filter_nolakec, & - soilstate_inst, waterstate_inst, soilbeta) - ! - ! DESCRIPTION - ! compute the lee-pielke beta factor to scal actual soil evaporation from potential evaporation - ! - ! USES - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_const_mod , only : SHR_CONST_PI - 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 clm_varcon , only : denh2o, denice - use landunit_varcon , only : istice_mec, istwet, istsoil, istcrop - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use column_varcon , only : icol_road_imperv, icol_road_perv - use ColumnType , only : col - use LandunitType , only : lun - ! - implicit none - type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: num_nolakec - integer , intent(in) :: filter_nolakec(:) - type(soilstate_type) , intent(in) :: soilstate_inst - type(waterstate_type) , intent(in) :: waterstate_inst - real(r8) , intent(inout) :: soilbeta(bounds%begc:bounds%endc) - - !local variables - real(r8) :: fac, fac_fc, wx !temporary variables - integer :: c, l, fc !indices - - SHR_ASSERT_ALL((ubound(soilbeta) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - associate( & - watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:)] volumetric soil water at saturation (porosity) - watfc => soilstate_inst%watfc_col , & ! Input: [real(r8) (:,:)] volumetric soil water at field capacity - - h2osoi_ice => waterstate_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:)] ice lens (kg/m2) - h2osoi_liq => waterstate_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:)] liquid water (kg/m2) - frac_sno => waterstate_inst%frac_sno_col , & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) - frac_h2osfc => waterstate_inst%frac_h2osfc_col & ! Input: [real(r8) (:)] fraction of ground covered by surface water (0 to 1) - ) - - do fc = 1,num_nolakec - c = filter_nolakec(fc) - l = col%landunit(c) - if (lun%itype(l)/=istwet .AND. lun%itype(l)/=istice_mec) then - if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then - wx = (h2osoi_liq(c,1)/denh2o+h2osoi_ice(c,1)/denice)/col%dz(c,1) - fac = min(1._r8, wx/watsat(c,1)) - fac = max( fac, 0.01_r8 ) - !! Lee and Pielke 1992 beta, added by K.Sakaguchi - if (wx < watfc(c,1) ) then !when water content of ths top layer is less than that at F.C. - fac_fc = min(1._r8, wx/watfc(c,1)) !eqn5.66 but divided by theta at field capacity - fac_fc = max( fac_fc, 0.01_r8 ) - ! modify soil beta by snow cover. soilbeta for snow surface is one - soilbeta(c) = (1._r8-frac_sno(c)-frac_h2osfc(c)) & - *0.25_r8*(1._r8 - cos(SHR_CONST_PI*fac_fc))**2._r8 & - + frac_sno(c)+ frac_h2osfc(c) - else !when water content of ths top layer is more than that at F.C. - soilbeta(c) = 1._r8 - end if - else if (col%itype(c) == icol_road_perv) then - soilbeta(c) = 0._r8 - else if (col%itype(c) == icol_sunwall .or. col%itype(c) == icol_shadewall) then - soilbeta(c) = 0._r8 - else if (col%itype(c) == icol_roof .or. col%itype(c) == icol_road_imperv) then - soilbeta(c) = 0._r8 - endif - else - soilbeta(c) = 1._r8 - endif - enddo - - end associate - - end subroutine calc_beta_leepielke1992 - - !------------------------------------------------------------------------------ - function do_soilevap_beta()result(lres) - ! - !DESCRIPTION - ! return true if the moisture stress for soil evaporation is computed as beta factor - ! otherwise false - implicit none - logical :: lres - - if(soil_resis_method==leepielke_1992)then - lres=.true. - else - lres=.false. - endif - return - - end function do_soilevap_beta - - !------------------------------------------------------------------------------ - subroutine calc_soil_resistance_sl14(bounds, num_nolakec, filter_nolakec, & - soilstate_inst, waterstate_inst, temperature_inst, dsl, soilresis) - ! - ! DESCRIPTION - ! compute the lee-pielke beta factor to scal actual soil evaporation from potential evaporation - ! - ! USES - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_const_mod , only : SHR_CONST_PI - 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 clm_varcon , only : denh2o, denice - use landunit_varcon , only : istice_mec, istwet, istsoil, istcrop - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use column_varcon , only : icol_road_imperv, icol_road_perv - use ColumnType , only : col - use LandunitType , only : lun - ! - implicit none - type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: num_nolakec - integer , intent(in) :: filter_nolakec(:) - type(soilstate_type) , intent(in) :: soilstate_inst - type(waterstate_type) , intent(in) :: waterstate_inst - type(temperature_type), intent(in) :: temperature_inst - real(r8) , intent(inout) :: dsl(bounds%begc:bounds%endc) - real(r8) , intent(inout) :: soilresis(bounds%begc:bounds%endc) - - !local variables - real(r8) :: aird, eps, dg, d0, vwc_liq - real(r8) :: eff_por_top - integer :: c, l, fc !indices - - SHR_ASSERT_ALL((ubound(dsl) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(soilresis) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - associate( & - dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) - watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:)] volumetric soil water at saturation (porosity) - bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" - sucsat => soilstate_inst%sucsat_col , & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) -! eff_porosity => soilstate_inst%eff_porosity_col , & ! Input: [real(r8) (:,:) ] effective porosity = porosity - vol_ice - t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) - - h2osoi_ice => waterstate_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:)] ice lens (kg/m2) - h2osoi_liq => waterstate_inst%h2osoi_liq_col & ! Input: [real(r8) (:,:)] liquid water (kg/m2) - ) - - do fc = 1,num_nolakec - c = filter_nolakec(fc) - l = col%landunit(c) - if (lun%itype(l)/=istwet .AND. lun%itype(l)/=istice_mec) then - if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then - vwc_liq = max(h2osoi_liq(c,1),1.0e-6_r8)/(dz(c,1)*denh2o) -! eff_porosity not calculated til SoilHydrology - eff_por_top = max(0.01_r8,watsat(c,1)-min(watsat(c,1), h2osoi_ice(c,1)/(dz(c,1)*denice))) - -! calculate diffusivity and air free pore space - aird = watsat(c,1)*(sucsat(c,1)/1.e7_r8)**(1./bsw(c,1)) - d0 = 2.12e-5*(t_soisno(c,1)/273.15)**1.75 ![Bitelli et al., JH, 08] - eps = watsat(c,1) - aird - dg = eps*d0*(eps/watsat(c,1))**(3._r8/max(3._r8,bsw(c,1))) - -! dsl(c) = dzmm(c,1)*max(0.001_r8,(0.8*eff_porosity(c,1) - vwc_liq)) & -! try arbitrary scaling (not top layer thickness) -! dsl(c) = 15._r8*max(0.001_r8,(0.8*eff_porosity(c,1) - vwc_liq)) & - dsl(c) = 15._r8*max(0.001_r8,(0.8*eff_por_top - vwc_liq)) & - ! /max(0.001_r8,(watsat(c,1)- aird)) - /max(0.001_r8,(0.8*watsat(c,1)- aird)) - - dsl(c)=max(dsl(c),0._r8) - dsl(c)=min(dsl(c),200._r8) - - soilresis(c) = dsl(c)/(dg*eps*1.e3) + 20._r8 - soilresis(c) = min(1.e6_r8,soilresis(c)) - - else if (col%itype(c) == icol_road_perv) then - soilresis(c) = 1.e6_r8 - else if (col%itype(c) == icol_sunwall .or. col%itype(c) == icol_shadewall) then - soilresis(c) = 1.e6_r8 - else if (col%itype(c) == icol_roof .or. col%itype(c) == icol_road_imperv) then - soilresis(c) = 1.e6_r8 - endif - else - soilresis(c) = 0._r8 - endif - enddo - end associate - end subroutine calc_soil_resistance_sl14 - - !------------------------------------------------------------------------------ - function do_soil_resistance_sl14()result(lres) - ! - !DESCRIPTION - ! return true if the soil evaporative resistance is computed using a DSL - ! otherwise false - implicit none - logical :: lres - - if(soil_resis_method==sl_14)then - lres=.true. - else - lres=.false. - endif - return - - end function do_soil_resistance_sl14 - -end module SurfaceResistanceMod diff --git a/src/biogeophys/TemperatureType.F90 b/src/biogeophys/TemperatureType.F90 deleted file mode 100644 index a98c1430..00000000 --- a/src/biogeophys/TemperatureType.F90 +++ /dev/null @@ -1,1474 +0,0 @@ -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 clm_varpar , only : nlevsno, nlevgrnd, nlevlak, nlevlak, nlevurb - 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_veg_patch (:) ! patch vegetation 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 :: 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_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 :: 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 [-] - 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_veg_patch (begp:endp)) ; this%t_veg_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:nlevgrnd)) ; this%t_ssbef_col (:,:) = nan - allocate(this%t_soisno_col (begc:endc,-nlevsno+1:nlevgrnd)) ; 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%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%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%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:nlevgrnd)) ; 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:nlevgrnd)) ; 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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') - - 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, default='inactive') - - 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', default='inactive') - - 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 (vegetated landunits only)', & - ptr_col=this%t_soisno_col, l2g_scale_type='veg', default='inactive') - - 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', default='inactive') - - 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, default='inactive') - - if (use_cndv .or. use_crop) then - active = "active" - else - active = "active" - 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') - - if (use_cn .and. use_crop )then - 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') - end if - - 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', default='inactive') - - 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, default='inactive') - call hist_addfld1d (fname='HEAT_CONTENT1_VEG', units='J/m^2', & - avgflag='A', long_name='initial gridcell total heat content - vegetated 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((ubound(em_roof_lun) == (/bounds%endl/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(em_wall_lun) == (/bounds%endl/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(em_improad_lun) == (/bounds%endl/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(em_perroad_lun) == (/bounds%endl/)), errMsg(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:nlevgrnd) = 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 - - 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 - - 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 - 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='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) - - 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_double, & - 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_double, & - 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 - 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() - - 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) - - 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) - - 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) - 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) - - if (use_crop) then - call extract_accum_field ('TDM10', rbufslp, nstep) - this%t_a10min_patch(begp:endp)= rbufslp(begp:endp) - - call extract_accum_field ('TDM5', rbufslp, nstep) - this%t_a5min_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) - - 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 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) - - ! 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/src/biogeophys/TridiagonalMod.F90 b/src/biogeophys/TridiagonalMod.F90 deleted file mode 100644 index 68dbd71c..00000000 --- a/src/biogeophys/TridiagonalMod.F90 +++ /dev/null @@ -1,118 +0,0 @@ -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 shr_log_mod , only : errMsg => shr_log_errMsg - use clm_varpar , only : nlevurb - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - 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 - integer , intent(in) :: filter(:) ! filter - 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((ubound(jtop) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(a) == (/bounds%endc, ubj/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(b) == (/bounds%endc, ubj/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(c) == (/bounds%endc, ubj/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(r) == (/bounds%endc, ubj/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(u) == (/bounds%endc, ubj/)), errMsg(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 ((col%itype(ci) == icol_sunwall .or. col%itype(ci) == icol_shadewall & - .or. col%itype(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 (col%itype(ci) /= icol_sunwall .and. col%itype(ci) /= icol_shadewall & - .and. col%itype(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 ((col%itype(ci) == icol_sunwall .or. col%itype(ci) == icol_shadewall & - .or. col%itype(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 (col%itype(ci) /= icol_sunwall .and. col%itype(ci) /= icol_shadewall & - .and. col%itype(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/src/biogeophys/UrbBuildTempOleson2015Mod.F90 b/src/biogeophys/UrbBuildTempOleson2015Mod.F90 deleted file mode 100644 index eaf1c14c..00000000 --- a/src/biogeophys/UrbBuildTempOleson2015Mod.F90 +++ /dev/null @@ -1,938 +0,0 @@ -module UrbBuildTempOleson2015Mod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Calculates internal building air temperature - ! - ! !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 perf_mod , only : t_startf, t_stopf - use clm_varctl , only : iulog - use UrbanParamsType , only : urbanparams_type - use UrbanTimeVarType , only : urbantv_type - use EnergyFluxType , only : energyflux_type - use TemperatureType , only : temperature_type - use LandunitType , only : lun - use ColumnType , only : col - ! - ! !PUBLIC TYPES: - implicit none - save - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: BuildingTemperature ! Calculation of interior building air temperature, inner - ! surface temperatures of walls and roof, and floor temperature - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: BuildingTemperature -! -! !INTERFACE: - subroutine BuildingTemperature (bounds, num_urbanl, filter_urbanl, num_nolakec, & - filter_nolakec, tk, urbanparams_inst, temperature_inst, & - energyflux_inst, urbantv_inst) -! -! !DESCRIPTION: -! Solve for t_building, inner surface temperatures of roof, sunw, shdw, and floor temperature -! Five equations, five unknowns (t_roof_inner,t_sunw_inner,t_shdw_inner,t_floor,t_building at n+1) -! Derived from energy balance equations at each surface and building air -! rd (radiation), cd (conduction), cv (convection) -! qrd_roof + qcd_roof + qcv_roof = 0 -! qrd_sunw + qcd_sunw + qcv_sunw = 0 -! qrd_shdw + qcd_shdw + qcv_shdw = 0 -! qrd_floor + qcd_floor + qcv_floor = 0 -! Vbld*rho_dair*cpair*(dt_building/dt) = sum(Asfc*hcv_sfc*(t_sfc - t_building) -! + Vvent*rho_dair*cpair*(taf - t_building) -! where Vlbd is volume of building air, -! rho_dair is density of dry air at t_building (kg m-3), -! cpair is specific heat of dry air (J kg-1 K-1), -! dt_building is change in interior building temperature (K), -! dt is timestep (s), -! Asfc is surface area of roof, sunw, shdw, floor (m2) -! hcv_sfc is convective heat transfer coefficient for roof, sunw, shdw, floor (W m-2 K-1) -! t_sfc is inner surface temperature of roof, sunw, shdw, floor (K) -! t_building is interior building temperature (K) -! Vvent is ventilation airflow rate (m3 s-1) -! taf is urban canyon air temperature (K) -! -! This methodology was introduced as part of CLM5.0. -! -! Conduction fluxes are obtained from terms of soil temperature equations -! Radiation fluxes are obtained from linearizing the longwave radiation equations taking into -! account view factors for each surface. - -! qrd is positive away from the surface toward room air, so qrd = emitted - absorbed, -! so positive qrd will result in a decrease in temperature -! qcd_floor is positive away from surface toward room air, so positive -! qcd will result in a decrease in temperature -! qcv is positive toward room air, so positive qcv (t_surface > t_room) will -! result in a decrease in temperature - -! The LAPACK routine DGESV is used to compute the solution to the real system of linear equations -! a * x = b, -! where a is an n-by-n matrix and x and b are n-by-nrhs matrices. -! -! The LU decomposition with partial pivoting and row interchanges is -! used to factor a as -! a = P * L * U, -! where P is a permutation matrix, L is unit lower triangular, and U is -! upper triangular. The factored form of a is then used to solve the -! system of equations a * x = b. - -! The following is from LAPACK documentation -! DGESV computes the solution to system of linear equations A * X = B for GE matrices -! -! =========== DOCUMENTATION =========== -! -! Online html documentation available at -! http://www.netlib.org/lapack/explore-html/ -! -! Download DGESV + dependencies -! -! [TGZ] -! -! [ZIP] -! -! [TXT] -! -! Definition: -! =========== -! -! SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -! -! .. Scalar Arguments .. -! INTEGER INFO, LDA, LDB, N, NRHS -! .. -! .. Array Arguments .. -! INTEGER IPIV( * ) -! DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -! .. -! -! -! ============= -! -! -! DGESV computes the solution to a real system of linear equations -! A * X = B, -! where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -! -! The LU decomposition with partial pivoting and row interchanges is -! used to factor A as -! A = P * L * U, -! where P is a permutation matrix, L is unit lower triangular, and U is -! upper triangular. The factored form of A is then used to solve the -! system of equations A * X = B. -! -! Arguments: -! ========== -! -! \param[in] N -! N is INTEGER -! The number of linear equations, i.e., the order of the -! matrix A. N >= 0. -! -! \param[in] NRHS -! NRHS is INTEGER -! The number of right hand sides, i.e., the number of columns -! of the matrix B. NRHS >= 0. -! -! \param[in,out] A -! A is DOUBLE PRECISION array, dimension (LDA,N) -! On entry, the N-by-N coefficient matrix A. -! On exit, the factors L and U from the factorization -! A = P*L*U; the unit diagonal elements of L are not stored. -! -! \param[in] LDA -! LDA is INTEGER -! The leading dimension of the array A. LDA >= max(1,N). -! -! \param[out] IPIV -! IPIV is INTEGER array, dimension (N) -! The pivot indices that define the permutation matrix P; -! row i of the matrix was interchanged with row IPIV(i). -! -! \param[in,out] B -! B is DOUBLE PRECISION array, dimension (LDB,NRHS) -! On entry, the N-by-NRHS matrix of right hand side matrix B. -! On exit, if INFO = 0, the N-by-NRHS solution matrix X. -! -! \param[in] LDB -! LDB is INTEGER -! The leading dimension of the array B. LDB >= max(1,N). -! -! \param[out] INFO -! INFO is INTEGER -! = 0: successful exit -! < 0: if INFO = -i, the i-th argument had an illegal value -! > 0: if INFO = i, U(i,i) is exactly zero. The factorization -! has been completed, but the factor U is exactly -! singular, so the solution could not be computed. -! -! Authors: -! ======== -! -! \author Univ. of Tennessee -! \author Univ. of California Berkeley -! \author Univ. of Colorado Denver -! \author NAG Ltd. -! -! \date November 2011 -! -! \ingroup doubleGEsolve - -! !CALLED FROM: -! subroutine SoilTemperature in this module -! -! !REVISION HISTORY: -! 08/17/12 Keith Oleson: Initial code - -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_time_manager, only : get_step_size - use clm_varcon , only : rair, pstd, cpair, sb, hcv_roof, hcv_roof_enhanced, & - hcv_floor, hcv_floor_enhanced, hcv_sunw, hcv_shdw, & - em_roof_int, em_floor_int, em_sunw_int, em_shdw_int, & - dz_floor, dens_floor, cp_floor, vent_ach - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use clm_varctl , only : iulog - use abortutils , only : endrun - use clm_varpar , only : nlevurb, nlevsno, nlevgrnd - use UrbanParamsType , only : urban_hac, urban_hac_off, urban_hac_on, urban_wasteheat_on -! -! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! 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_urbanl ! number of urban landunits in clump - integer , intent(in) :: filter_urbanl(:) ! urban landunit filter - real(r8), intent(in) :: tk(bounds%begc: , -nlevsno+1: ) ! thermal conductivity (W m-1 K-1) [col, j] - type(urbanparams_type), intent(in) :: urbanparams_inst ! urban parameters - type(temperature_type), intent(inout) :: temperature_inst ! temperature variables - type(energyflux_type) , intent(inout) :: energyflux_inst ! energy flux variables - type(urbantv_type) , intent(in) :: urbantv_inst ! urban time varying variables -! -! !LOCAL VARIABLES: - integer, parameter :: neq = 5 ! number of equation/unknowns - integer :: fc,fl,c,l ! indices - real(r8) :: dtime ! land model time step (s) - real(r8) :: t_roof_inner_bef(bounds%begl:bounds%endl) ! roof inside surface temperature at previous time step (K) - real(r8) :: t_sunw_inner_bef(bounds%begl:bounds%endl) ! sunwall inside surface temperature at previous time step (K) - real(r8) :: t_shdw_inner_bef(bounds%begl:bounds%endl) ! shadewall inside surface temperature at previous time step (K) - real(r8) :: t_floor_bef(bounds%begl:bounds%endl) ! floor temperature at previous time step (K) - real(r8) :: t_building_bef(bounds%begl:bounds%endl) ! internal building air temperature at previous time step [K] - real(r8) :: t_building_bef_hac(bounds%begl:bounds%endl)! internal building air temperature before applying HAC [K] - real(r8) :: hcv_roofi(bounds%begl:bounds%endl) ! roof convective heat transfer coefficient (W m-2 K-1) - real(r8) :: hcv_sunwi(bounds%begl:bounds%endl) ! sunwall convective heat transfer coefficient (W m-2 K-1) - real(r8) :: hcv_shdwi(bounds%begl:bounds%endl) ! shadewall convective heat transfer coefficient (W m-2 K-1) - real(r8) :: hcv_floori(bounds%begl:bounds%endl) ! floor convective heat transfer coefficient (W m-2 K-1) - real(r8) :: em_roofi(bounds%begl:bounds%endl) ! roof inside surface emissivity (-) - real(r8) :: em_sunwi(bounds%begl:bounds%endl) ! sunwall inside surface emissivity (-) - real(r8) :: em_shdwi(bounds%begl:bounds%endl) ! shadewall inside surface emissivity (-) - real(r8) :: em_floori(bounds%begl:bounds%endl) ! floor inside surface emissivity (-) - real(r8) :: dz_floori(bounds%begl:bounds%endl) ! concrete floor thickness (m) - real(r8) :: cp_floori(bounds%begl:bounds%endl) ! concrete floor volumetric heat capacity (J m-3 K-1) - real(r8) :: cv_floori(bounds%begl:bounds%endl) ! intermediate calculation for concrete floor (W m-2 K-1) - real(r8) :: rho_dair(bounds%begl:bounds%endl) ! density of dry air at standard pressure and t_building (kg m-3) - real(r8) :: vf_rf(bounds%begl:bounds%endl) ! view factor of roof for floor (-) - real(r8) :: vf_fr(bounds%begl:bounds%endl) ! view factor of floor for roof (-) - real(r8) :: vf_wf(bounds%begl:bounds%endl) ! view factor of wall for floor (-) - real(r8) :: vf_fw(bounds%begl:bounds%endl) ! view factor of floor for wall (-) - real(r8) :: vf_rw(bounds%begl:bounds%endl) ! view factor of roof for wall (-) - real(r8) :: vf_wr(bounds%begl:bounds%endl) ! view factor of wall for roof (-) - real(r8) :: vf_ww(bounds%begl:bounds%endl) ! view factor of wall for wall (-) - real(r8) :: zi_roof_innerl(bounds%begl:bounds%endl) ! interface depth of nlevurb roof (m) - real(r8) :: z_roof_innerl(bounds%begl:bounds%endl) ! node depth of nlevurb roof (m) - real(r8) :: zi_sunw_innerl(bounds%begl:bounds%endl) ! interface depth of nlevurb sunwall (m) - real(r8) :: z_sunw_innerl(bounds%begl:bounds%endl) ! node depth of nlevurb sunwall (m) - real(r8) :: zi_shdw_innerl(bounds%begl:bounds%endl) ! interface depth of nlevurb shadewall (m) - real(r8) :: z_shdw_innerl(bounds%begl:bounds%endl) ! node depth of nlevurb shadewall (m) - real(r8) :: t_roof_innerl_bef(bounds%begl:bounds%endl) ! roof temperature at nlevurb node depth at previous time step (K) - real(r8) :: t_sunw_innerl_bef(bounds%begl:bounds%endl) ! sunwall temperature at nlevurb node depth at previous time step (K) - real(r8) :: t_shdw_innerl_bef(bounds%begl:bounds%endl) ! shadewall temperature at nlevurb node depth at previous time step (K) - real(r8) :: t_roof_innerl(bounds%begl:bounds%endl) ! roof temperature at nlevurb node depth (K) - real(r8) :: t_sunw_innerl(bounds%begl:bounds%endl) ! sunwall temperature at nlevurb node depth (K) - real(r8) :: t_shdw_innerl(bounds%begl:bounds%endl) ! shadewall temperature at nlevurb node depth (K) - real(r8) :: tk_roof_innerl(bounds%begl:bounds%endl) ! roof thermal conductivity at nlevurb interface depth (W m-1 K-1) - real(r8) :: tk_sunw_innerl(bounds%begl:bounds%endl) ! sunwall thermal conductivity at nlevurb interface depth (W m-1 K-1) - real(r8) :: tk_shdw_innerl(bounds%begl:bounds%endl) ! shadewall thermal conductivity at nlevurb interface depth (W m-1 K-1) - real(r8) :: qrd_roof(bounds%begl:bounds%endl) ! roof inside net longwave for energy balance check (W m-2) - real(r8) :: qrd_sunw(bounds%begl:bounds%endl) ! sunwall inside net longwave for energy balance check (W m-2) - real(r8) :: qrd_shdw(bounds%begl:bounds%endl) ! shadewall inside net longwave for energy balance check (W m-2) - real(r8) :: qrd_floor(bounds%begl:bounds%endl) ! floor inside net longwave for energy balance check (W m-2) - real(r8) :: qrd_building(bounds%begl:bounds%endl) ! building inside net longwave for energy balance check (W m-2) - real(r8) :: qcv_roof(bounds%begl:bounds%endl) ! roof inside convection flux for energy balance check (W m-2) - real(r8) :: qcv_sunw(bounds%begl:bounds%endl) ! sunwall inside convection flux for energy balance check (W m-2) - real(r8) :: qcv_shdw(bounds%begl:bounds%endl) ! shadewall inside convection flux for energy balance check (W m-2) - real(r8) :: qcv_floor(bounds%begl:bounds%endl) ! floor inside convection flux for energy balance check (W m-2) - real(r8) :: qcd_roof(bounds%begl:bounds%endl) ! roof inside conduction flux for energy balance check (W m-2) - real(r8) :: qcd_sunw(bounds%begl:bounds%endl) ! sunwall inside conduction flux for energy balance check (W m-2) - real(r8) :: qcd_shdw(bounds%begl:bounds%endl) ! shadewall inside conduction flux for energy balance check (W m-2) - real(r8) :: qcd_floor(bounds%begl:bounds%endl) ! floor inside conduction flux for energy balance check (W m-2) - real(r8) :: enrgy_bal_roof(bounds%begl:bounds%endl) ! roof inside energy balance (W m-2) - real(r8) :: enrgy_bal_sunw(bounds%begl:bounds%endl) ! sunwall inside energy balance (W m-2) - real(r8) :: enrgy_bal_shdw(bounds%begl:bounds%endl) ! shadewall inside energy balance (W m-2) - real(r8) :: enrgy_bal_floor(bounds%begl:bounds%endl) ! floor inside energy balance (W m-2) - real(r8) :: enrgy_bal_buildair(bounds%begl:bounds%endl)! building air energy balance (W m-2) - real(r8) :: sum ! sum of view factors for floor, wall, roof - integer :: n ! number of linear equations (= neq) - integer :: nrhs ! number of right hand sides (= 1) - real(r8) :: a(neq,neq) ! n-by-n coefficient matrix a - integer :: lda ! leading dimension of the matrix a - integer :: ldb ! leading dimension of the matrix b - real(r8) :: result(neq) ! on entry, the right hand side of matrix b - ! on exit, if info = 0, the n-by-nrhs solution matrix x - integer :: info ! exit information for LAPACK routine dgesv - integer :: ipiv(neq) ! the pivot indices that define the permutation matrix P -!EOP -!----------------------------------------------------------------------- - - ! Enforce expected array sizes - SHR_ASSERT_ALL((ubound(tk) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - - associate(& - clandunit => col%landunit , & ! Input: [integer (:)] column's landunit - ctype => col%itype , & ! Input: [integer (:)] column type - zi => col%zi , & ! Input: [real(r8) (:,:)] interface level below a "z" level (m) - z => col%z , & ! Input: [real(r8) (:,:)] layer thickness (m) - - ht_roof => lun%ht_roof , & ! Input: [real(r8) (:)] height of urban roof (m) - canyon_hwr => lun%canyon_hwr , & ! Input: [real(r8) (:)] ratio of building height to street hwidth (-) - wtlunit_roof => lun%wtlunit_roof , & ! Input: [real(r8) (:)] weight of roof with respect to landunit - urbpoi => lun%urbpoi , & ! Input: [logical (:)] true => landunit is an urban point - - taf => temperature_inst%taf_lun , & ! Input: [real(r8) (:)] urban canopy air temperature (K) - tssbef => temperature_inst%t_ssbef_col , & ! Input: [real(r8) (:,:)] temperature at previous time step (K) - t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:)] soil temperature (K) - t_roof_inner => temperature_inst%t_roof_inner_lun , & ! InOut: [real(r8) (:)] roof inside surface temperature (K) - t_sunw_inner => temperature_inst%t_sunw_inner_lun , & ! InOut: [real(r8) (:)] sunwall inside surface temperature (K) - t_shdw_inner => temperature_inst%t_shdw_inner_lun , & ! InOut: [real(r8) (:)] shadewall inside surface temperature (K) - t_floor => temperature_inst%t_floor_lun , & ! InOut: [real(r8) (:)] floor temperature (K) - t_building => temperature_inst%t_building_lun , & ! InOut: [real(r8) (:)] internal building air temperature (K) - - t_building_max => urbantv_inst%t_building_max , & ! Input: [real(r8) (:)] maximum internal building air temperature (K) - t_building_min => urbanparams_inst%t_building_min , & ! Input: [real(r8) (:)] minimum internal building air temperature (K) - - eflx_building => energyflux_inst%eflx_building_lun , & ! Output: [real(r8) (:)] building heat flux from change in interior building air temperature (W/m**2) - eflx_urban_ac => energyflux_inst%eflx_urban_ac_lun , & ! Output: [real(r8) (:)] urban air conditioning flux (W/m**2) - eflx_urban_heat => energyflux_inst%eflx_urban_heat_lun & ! Output: [real(r8) (:)] urban heating flux (W/m**2) - ) - - ! Get step size - - dtime = get_step_size() - - ! 1. Save t_* at previous time step - ! 2. Set convective heat transfer coefficients (Bueno et al. 2012, GMD). - ! An alternative is Salamanca et al. 2010, TAC, where they are all set to 8 W m-2 K-1. - ! See clm_varcon.F90 - ! 3. Set inner surface emissivities (Bueno et al. 2012, GMD). - ! 4. Set concrete floor properties (Salamanca et al. 2010, TAC). - do fl = 1,num_urbanl - l = filter_urbanl(fl) - if (urbpoi(l)) then - t_roof_inner_bef(l) = t_roof_inner(l) - t_sunw_inner_bef(l) = t_sunw_inner(l) - t_shdw_inner_bef(l) = t_shdw_inner(l) - t_floor_bef(l) = t_floor(l) - t_building_bef(l) = t_building(l) - if (t_roof_inner_bef(l) .le. t_building_bef(l)) then - hcv_roofi(l) = hcv_roof_enhanced - else - hcv_roofi(l) = hcv_roof - end if - if (t_floor_bef(l) .ge. t_building_bef(l)) then - hcv_floori(l) = hcv_floor_enhanced - else - hcv_floori(l) = hcv_floor - end if - hcv_sunwi(l) = hcv_sunw - hcv_shdwi(l) = hcv_shdw - em_roofi(l) = em_roof_int - em_sunwi(l) = em_sunw_int - em_shdwi(l) = em_shdw_int - em_floori(l) = em_floor_int - ! Concrete floor thickness (m) - dz_floori(l) = dz_floor - ! Concrete floor volumetric heat capacity (J m-3 K-1) - cp_floori(l) = cp_floor - ! Intermediate calculation for concrete floor (W m-2 K-1) - cv_floori(l) = (dz_floori(l) * cp_floori(l)) / dtime - ! Density of dry air at standard pressure and t_building (kg m-3) - rho_dair(l) = pstd / (rair*t_building_bef(l)) - end if - end do - - ! Get terms from soil temperature equations to compute conduction flux - ! Negative is toward surface - heat added - ! Note that the conduction flux here is in W m-2 wall area but for purposes of solving the set of - ! simultaneous equations this must be converted to W m-2 ground area. This is done below when - ! setting up the equation coefficients. - - do fc = 1,num_nolakec - c = filter_nolakec(fc) - l = clandunit(c) - if (urbpoi(l)) then - if (ctype(c) == icol_roof) then - zi_roof_innerl(l) = zi(c,nlevurb) - z_roof_innerl(l) = z(c,nlevurb) - t_roof_innerl_bef(l) = tssbef(c,nlevurb) - t_roof_innerl(l) = t_soisno(c,nlevurb) - tk_roof_innerl(l) = tk(c,nlevurb) - else if (ctype(c) == icol_sunwall) then - zi_sunw_innerl(l) = zi(c,nlevurb) - z_sunw_innerl(l) = z(c,nlevurb) - t_sunw_innerl_bef(l) = tssbef(c,nlevurb) - t_sunw_innerl(l) = t_soisno(c,nlevurb) - tk_sunw_innerl(l) = tk(c,nlevurb) - else if (ctype(c) == icol_shadewall) then - zi_shdw_innerl(l) = zi(c,nlevurb) - z_shdw_innerl(l) = z(c,nlevurb) - t_shdw_innerl_bef(l) = tssbef(c,nlevurb) - t_shdw_innerl(l) = t_soisno(c,nlevurb) - tk_shdw_innerl(l) = tk(c,nlevurb) - end if - end if - end do - - ! Calculate view factors - do fl = 1,num_urbanl - l = filter_urbanl(fl) - if (urbpoi(l)) then - - vf_rf(l) = sqrt(1._r8 + canyon_hwr(l)**2._r8) - canyon_hwr(l) - vf_fr(l) = vf_rf(l) - - ! This view factor implicitly converts from per unit wall area to per unit floor area - vf_wf(l) = 0.5_r8*(1._r8 - vf_rf(l)) - - ! This view factor implicitly converts from per unit floor area to per unit wall area - vf_fw(l) = vf_wf(l) / canyon_hwr(l) - - ! This view factor implicitly converts from per unit roof area to per unit wall area - vf_rw(l) = vf_fw(l) - - ! This view factor implicitly converts from per unit wall area to per unit roof area - vf_wr(l) = vf_wf(l) - - vf_ww(l) = 1._r8 - vf_rw(l) - vf_fw(l) - - end if - end do - - ! error check -- make sure view factor sums to one for floor, wall, and roof - - do fl = 1,num_urbanl - l = filter_urbanl(fl) - if (urbpoi(l)) then - - sum = vf_rf(l) + 2._r8*vf_wf(l) - if (abs(sum-1._r8) > 1.e-06_r8 ) then - write (iulog,*) 'urban floor view factor error',sum - write (iulog,*) 'clm model is stopping' - call endrun() - endif - sum = vf_rw(l) + vf_fw(l) + vf_ww(l) - if (abs(sum-1._r8) > 1.e-06_r8 ) then - write (iulog,*) 'urban wall view factor error',sum - write (iulog,*) 'clm model is stopping' - call endrun() - endif - sum = vf_fr(l) + vf_wr(l) + vf_wr(l) - if (abs(sum-1._r8) > 1.e-06_r8 ) then - write (iulog,*) 'urban roof view factor error',sum - write (iulog,*) 'clm model is stopping' - call endrun() - endif - - endif - end do - - n = neq - nrhs = 1 - lda = neq - ldb = neq - - do fl = 1,num_urbanl - l = filter_urbanl(fl) - if (urbpoi(l)) then - - ! ROOF - a(1,1) = 0.5_r8*hcv_roofi(l) & - + 0.5_r8*tk_roof_innerl(l)/(zi_roof_innerl(l) - z_roof_innerl(l)) & - + 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8 & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(1._r8-em_shdwi(l))*vf_wr(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rf(l)*(1._r8-em_floori(l))*vf_fr(l) - - a(1,2) = - 4._r8*em_roofi(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wr(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_ww(l)*(1._r8-em_shdwi(l))*vf_wr(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fr(l) - - a(1,3) = - 4._r8*em_roofi(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wr(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_ww(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fr(l) - - a(1,4) = - 4._r8*em_roofi(l)*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fr(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(1._r8-em_shdwi(l))*vf_wr(l) - - a(1,5) = - 0.5_r8*hcv_roofi(l) - - result(1) = 0.5_r8*tk_roof_innerl(l)*t_roof_innerl(l)/(zi_roof_innerl(l) - z_roof_innerl(l)) & - - 0.5_r8*tk_roof_innerl(l)*(t_roof_inner_bef(l)-t_roof_innerl_bef(l))/(zi_roof_innerl(l) & - - z_roof_innerl(l)) & - - 3._r8*em_roofi(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wr(l) & - - 3._r8*em_roofi(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wr(l) & - - 3._r8*em_roofi(l)*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fr(l) & - + 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8 & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l)*(1._r8-em_shdwi(l))*vf_wr(l) & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rf(l)*(1._r8-em_floori(l))*vf_fr(l) & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_ww(l)*(1._r8-em_shdwi(l))*vf_wr(l) & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fr(l) & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_ww(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fr(l) & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l)*(1._r8-em_shdwi(l))*vf_wr(l) & - - 0.5_r8*hcv_roofi(l)*(t_roof_inner_bef(l) - t_building_bef(l)) - - ! SUNWALL - a(2,1) = - 4._r8*em_sunwi(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(1._r8-em_shdwi(l))*vf_ww(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rf(l)*(1._r8-em_floori(l))*vf_fw(l) - - a(2,2) = 0.5_r8*hcv_sunwi(l)*canyon_hwr(l) & - + 0.5_r8*tk_sunw_innerl(l)/(zi_sunw_innerl(l) - z_sunw_innerl(l))*canyon_hwr(l) & - + 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8 & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_ww(l)*(1._r8-em_shdwi(l))*vf_ww(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) - - a(2,3) = - 4._r8*em_sunwi(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_ww(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) - - a(2,4) = - 4._r8*em_sunwi(l)*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(1._r8-em_shdwi(l))*vf_ww(l) - a(2,5) = - 0.5_r8*hcv_sunwi(l)*canyon_hwr(l) - - result(2) = 0.5_r8*tk_sunw_innerl(l)*t_sunw_innerl(l)/(zi_sunw_innerl(l) - z_sunw_innerl(l))*canyon_hwr(l) & - - 0.5_r8*tk_sunw_innerl(l)*(t_sunw_inner_bef(l)-t_sunw_innerl_bef(l))/(zi_sunw_innerl(l) & - - z_sunw_innerl(l))*canyon_hwr(l) & - - 3._r8*em_sunwi(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l) & - - 3._r8*em_sunwi(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_ww(l) & - - 3._r8*em_sunwi(l)*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l) & - + 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8 & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_ww(l)*(1._r8-em_shdwi(l))*vf_ww(l) & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l)*(1._r8-em_shdwi(l))*vf_ww(l) & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l)*(1._r8-em_shdwi(l))*vf_ww(l) & - - 0.5_r8*hcv_sunwi(l)*(t_sunw_inner_bef(l) - t_building_bef(l))*canyon_hwr(l) - - ! SHADEWALL - a(3,1) = - 4._r8*em_shdwi(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(1._r8-em_sunwi(l))*vf_ww(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rf(l)*(1._r8-em_floori(l))*vf_fw(l) - - a(3,2) = - 4._r8*em_shdwi(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_ww(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) - - a(3,3) = 0.5_r8*hcv_shdwi(l)*canyon_hwr(l) & - + 0.5_r8*tk_shdw_innerl(l)/(zi_shdw_innerl(l) - z_shdw_innerl(l))*canyon_hwr(l) & - + 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8 & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_ww(l)*(1._r8-em_sunwi(l))*vf_ww(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) - - a(3,4) = - 4._r8*em_shdwi(l)*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(1._r8-em_sunwi(l))*vf_ww(l) - - a(3,5) = - 0.5_r8*hcv_shdwi(l)*canyon_hwr(l) - - result(3) = 0.5_r8*tk_shdw_innerl(l)*t_shdw_innerl(l)/(zi_shdw_innerl(l) - z_shdw_innerl(l))*canyon_hwr(l) & - - 0.5_r8*tk_shdw_innerl(l)*(t_shdw_inner_bef(l)-t_shdw_innerl_bef(l))/(zi_shdw_innerl(l) & - - z_shdw_innerl(l))*canyon_hwr(l) & - - 3._r8*em_shdwi(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l) & - - 3._r8*em_shdwi(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_ww(l) & - - 3._r8*em_shdwi(l)*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l) & - + 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8 & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_ww(l)*(1._r8-em_sunwi(l))*vf_ww(l) & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l)*(1._r8-em_sunwi(l))*vf_ww(l) & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l)*(1._r8-em_sunwi(l))*vf_ww(l) & - - 0.5_r8*hcv_shdwi(l)*(t_shdw_inner_bef(l) - t_building_bef(l))*canyon_hwr(l) - - ! FLOOR - a(4,1) = - 4._r8*em_floori(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rf(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(1._r8-em_sunwi(l))*vf_wf(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(1._r8-em_shdwi(l))*vf_wf(l) - - a(4,2) = - 4._r8*em_floori(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wf(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_ww(l)*(1._r8-em_shdwi(l))*vf_wf(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rf(l) - - a(4,3) = - 4._r8*em_floori(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wf(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rf(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_ww(l)*(1._r8-em_sunwi(l))*vf_wf(l) - - a(4,4) = (cv_floori(l) + 0.5_r8*hcv_floori(l)) & - + 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8 & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fr(l)*(1._r8-em_roofi(l))*vf_rf(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(1._r8-em_sunwi(l))*vf_wf(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(1._r8-em_shdwi(l))*vf_wf(l) - - a(4,5) = - 0.5_r8*hcv_floori(l) - - result(4) = cv_floori(l)*t_floor_bef(l) & - - 3._r8*em_floori(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rf(l) & - - 3._r8*em_floori(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wf(l) & - - 3._r8*em_floori(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wf(l) & - + 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8 & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fr(l)*(1._r8-em_roofi(l))*vf_rf(l) & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l)*(1._r8-em_sunwi(l))*vf_wf(l) & - - 3._r8*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l)*(1._r8-em_shdwi(l))*vf_wf(l) & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_ww(l)*(1._r8-em_shdwi(l))*vf_wf(l) & - - 3._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rf(l) & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wr(l)*(1._r8-em_roofi(l))*vf_rf(l) & - - 3._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_ww(l)*(1._r8-em_sunwi(l))*vf_wf(l) & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l)*(1._r8-em_sunwi(l))*vf_wf(l) & - - 3._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l)*(1._r8-em_shdwi(l))*vf_wf(l) & - - 0.5_r8*hcv_floori(l)*(t_floor_bef(l) - t_building_bef(l)) - - ! Building air temperature - a(5,1) = - 0.5_r8*hcv_roofi(l) - a(5,2) = - 0.5_r8*hcv_sunwi(l)*canyon_hwr(l) - - a(5,3) = - 0.5_r8*hcv_shdwi(l)*canyon_hwr(l) - - a(5,4) = - 0.5_r8*hcv_floori(l) - - a(5,5) = ((ht_roof(l)*rho_dair(l)*cpair)/dtime) + & - ((ht_roof(l)*vent_ach)/3600._r8)*rho_dair(l)*cpair + & - 0.5_r8*hcv_roofi(l) + & - 0.5_r8*hcv_sunwi(l)*canyon_hwr(l) + & - 0.5_r8*hcv_shdwi(l)*canyon_hwr(l) + & - 0.5_r8*hcv_floori(l) - - result(5) = (ht_roof(l)*rho_dair(l)*cpair/dtime)*t_building_bef(l) & - + ((ht_roof(l)*vent_ach)/3600._r8)*rho_dair(l)*cpair*taf(l) & - + 0.5_r8*hcv_roofi(l)*(t_roof_inner_bef(l) - t_building_bef(l)) & - + 0.5_r8*hcv_sunwi(l)*(t_sunw_inner_bef(l) - t_building_bef(l))*canyon_hwr(l) & - + 0.5_r8*hcv_shdwi(l)*(t_shdw_inner_bef(l) - t_building_bef(l))*canyon_hwr(l) & - + 0.5_r8*hcv_floori(l)*(t_floor_bef(l) - t_building_bef(l)) - - ! Solve equations - call dgesv(n, nrhs, a, lda, ipiv, result, ldb, info) - - ! If dgesv fails, abort - if (info /= 0) then - write(iulog,*)'fl: ',fl - write(iulog,*)'l: ',l - write(iulog,*)'dgesv info: ',info - write (iulog,*) 'dgesv error' - write (iulog,*) 'clm model is stopping' - call endrun() - end if - ! Assign new temperatures - t_roof_inner(l) = result(1) - t_sunw_inner(l) = result(2) - t_shdw_inner(l) = result(3) - t_floor(l) = result(4) - t_building(l) = result(5) - end if - end do - - ! Energy balance checks - do fl = 1,num_urbanl - l = filter_urbanl(fl) - if (urbpoi(l)) then - qrd_roof(l) = - em_roofi(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wr(l) & - - 4._r8*em_roofi(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wr(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - em_roofi(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wr(l) & - - 4._r8*em_roofi(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wr(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - em_roofi(l)*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fr(l) & - - 4._r8*em_roofi(l)*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fr(l)*(t_floor(l) - t_floor_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rw(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(1._r8-em_sunwi(l))*vf_wr(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rw(l)*(1._r8-em_shdwi(l))*vf_wr(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(1._r8-em_shdwi(l))*vf_wr(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rf(l)*(1._r8-em_floori(l))*vf_fr(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rf(l)*(1._r8-em_floori(l))*vf_fr(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_ww(l)*(1._r8-em_shdwi(l))*vf_wr(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_ww(l)*(1._r8-em_shdwi(l))*vf_wr(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_wf(l)*(1._r8-em_floori(l))*vf_fr(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fr(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_ww(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_ww(l)*(1._r8-em_sunwi(l))*vf_wr(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_wf(l)*(1._r8-em_floori(l))*vf_fr(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wf(l)*(1._r8-em_floori(l))*vf_fr(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fw(l)*(1._r8-em_sunwi(l))*vf_wr(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(1._r8-em_sunwi(l))*vf_wr(l)*(t_floor(l) & - - t_floor_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fw(l)*(1._r8-em_shdwi(l))*vf_wr(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(1._r8-em_shdwi(l))*vf_wr(l)*(t_floor(l) & - - t_floor_bef(l)) & - + em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8 & - + 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*(t_roof_inner(l) - t_roof_inner_bef(l)) - - qrd_sunw(l) = - em_sunwi(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l) & - - 4._r8*em_sunwi(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - em_sunwi(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_ww(l) & - - 4._r8*em_sunwi(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_ww(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - em_sunwi(l)*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l) & - - 4._r8*em_sunwi(l)*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(t_floor(l) - t_floor_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3.*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_ww(l)*(1._r8-em_shdwi(l))*vf_ww(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3.*vf_ww(l)*(1._r8-em_shdwi(l))*vf_ww(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3.*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3.*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3.*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rw(l)*(1._r8-em_shdwi(l))*vf_ww(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3.*vf_rw(l)*(1._r8-em_shdwi(l))*vf_ww(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3.*vf_rf(l)*(1._r8-em_floori(l))*vf_fw(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3.*vf_fr(l)*(1._r8-em_roofi(l))*vf_rw(l)*(t_floor(l) & - - t_floor_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fw(l)*(1._r8-em_shdwi(l))*vf_ww(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3.*vf_fw(l)*(1._r8-em_shdwi(l))*vf_ww(l)*(t_floor(l) & - - t_floor_bef(l)) & - + em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8 & - + 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*(t_sunw_inner(l) - t_sunw_inner_bef(l)) - - qrd_shdw(l) = - em_shdwi(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rw(l) & - - 4._r8*em_shdwi(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rw(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - em_shdwi(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_ww(l) & - - 4._r8*em_shdwi(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_ww(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - em_shdwi(l)*em_floori(l)*sb*t_floor_bef(l)**4._r8*vf_fw(l) & - - 4._r8*em_shdwi(l)*em_floori(l)*sb*t_floor_bef(l)**3._r8*vf_fw(l)*(t_floor(l) - t_floor_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3.*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_ww(l)*(1._r8-em_sunwi(l))*vf_ww(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3.*vf_ww(l)*(1._r8-em_sunwi(l))*vf_ww(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3.*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3.*vf_wf(l)*(1._r8-em_floori(l))*vf_fw(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3.*vf_wr(l)*(1._r8-em_roofi(l))*vf_rw(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rw(l)*(1._r8-em_sunwi(l))*vf_ww(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3.*vf_rw(l)*(1._r8-em_sunwi(l))*vf_ww(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rf(l)*(1._r8-em_floori(l))*vf_fw(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3.*vf_rf(l)*(1._r8-em_floori(l))*vf_fw(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fr(l)*(1._r8-em_roofi(l))*vf_rw(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3.*vf_fr(l)*(1._r8-em_roofi(l))*vf_rw(l)*(t_floor(l) & - - t_floor_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fw(l)*(1._r8-em_sunwi(l))*vf_ww(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3.*vf_fw(l)*(1._r8-em_sunwi(l))*vf_ww(l)*(t_floor(l) & - - t_floor_bef(l)) & - + em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8 & - + 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*(t_shdw_inner(l) - t_shdw_inner_bef(l)) - - qrd_floor(l) = - em_floori(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8*vf_rf(l) & - - 4._r8*em_floori(l)*em_roofi(l)*sb*t_roof_inner_bef(l)**3._r8*vf_rf(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - em_floori(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8*vf_wf(l) & - - 4._r8*em_floori(l)*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3._r8*vf_wf(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - em_floori(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8*vf_wf(l) & - - 4._r8*em_floori(l)*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3._r8*vf_wf(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fr(l)*(1._r8-em_roofi(l))*vf_rf(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3.*vf_fr(l)*(1._r8-em_roofi(l))*vf_rf(l)*(t_floor(l) & - - t_floor_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fw(l)*(1._r8-em_sunwi(l))*vf_wf(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3.*vf_fw(l)*(1._r8-em_sunwi(l))*vf_wf(l)*(t_floor(l) & - - t_floor_bef(l)) & - - (em_floori(l)*sb*t_floor_bef(l)**4._r8)*vf_fw(l)*(1._r8-em_shdwi(l))*vf_wf(l) & - - 4._r8*em_floori(l)*sb*t_floor_bef(l)**3.*vf_fw(l)*(1._r8-em_shdwi(l))*vf_wf(l)*(t_floor(l) & - - t_floor_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_ww(l)*(1._r8-em_shdwi(l))*vf_wf(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3.*vf_ww(l)*(1._r8-em_shdwi(l))*vf_wf(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_sunwi(l)*sb*t_sunw_inner_bef(l)**4._r8)*vf_wr(l)*(1._r8-em_roofi(l))*vf_rf(l) & - - 4._r8*em_sunwi(l)*sb*t_sunw_inner_bef(l)**3.*vf_wr(l)*(1._r8-em_roofi(l))*vf_rf(l)*(t_sunw_inner(l) & - - t_sunw_inner_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_wr(l)*(1._r8-em_roofi(l))*vf_rf(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3.*vf_wr(l)*(1._r8-em_roofi(l))*vf_rf(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_shdwi(l)*sb*t_shdw_inner_bef(l)**4._r8)*vf_ww(l)*(1._r8-em_sunwi(l))*vf_wf(l) & - - 4._r8*em_shdwi(l)*sb*t_shdw_inner_bef(l)**3.*vf_ww(l)*(1._r8-em_sunwi(l))*vf_wf(l)*(t_shdw_inner(l) & - - t_shdw_inner_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rw(l)*(1._r8-em_sunwi(l))*vf_wf(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3.*vf_rw(l)*(1._r8-em_sunwi(l))*vf_wf(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - - (em_roofi(l)*sb*t_roof_inner_bef(l)**4._r8)*vf_rw(l)*(1._r8-em_shdwi(l))*vf_wf(l) & - - 4._r8*em_roofi(l)*sb*t_roof_inner_bef(l)**3.*vf_rw(l)*(1._r8-em_shdwi(l))*vf_wf(l)*(t_roof_inner(l) & - - t_roof_inner_bef(l)) & - + em_floori(l)*sb*t_floor_bef(l)**4._r8 & - + 4._r8*em_floori(l)*sb*t_floor_bef(l)**3.*(t_floor(l) - t_floor_bef(l)) - - qrd_building(l) = qrd_roof(l) + canyon_hwr(l)*(qrd_sunw(l) + qrd_shdw(l)) + qrd_floor(l) - - if (abs(qrd_building(l)) > .10_r8 ) then - write (iulog,*) 'urban inside building net longwave radiation balance error ',qrd_building(l) - write (iulog,*) 'clm model is stopping' - call endrun() - end if - - qcv_roof(l) = 0.5_r8*hcv_roofi(l)*(t_roof_inner(l) - t_building(l)) + 0.5_r8*hcv_roofi(l)*(t_roof_inner_bef(l) & - - t_building_bef(l)) - qcd_roof(l) = 0.5_r8*tk_roof_innerl(l)*(t_roof_inner(l) - t_roof_innerl(l))/(zi_roof_innerl(l) - z_roof_innerl(l)) & - + 0.5_r8*tk_roof_innerl(l)*(t_roof_inner_bef(l) - t_roof_innerl_bef(l))/(zi_roof_innerl(l) & - - z_roof_innerl(l)) - enrgy_bal_roof(l) = qrd_roof(l) + qcv_roof(l) + qcd_roof(l) - if (abs(enrgy_bal_roof(l)) > .10_r8 ) then - write (iulog,*) 'urban inside roof energy balance error ',enrgy_bal_roof(l) - write (iulog,*) 'clm model is stopping' - call endrun() - end if - - qcv_sunw(l) = 0.5_r8*hcv_sunwi(l)*(t_sunw_inner(l) - t_building(l)) + 0.5_r8*hcv_sunwi(l)*(t_sunw_inner_bef(l) & - - t_building_bef(l)) - qcd_sunw(l) = 0.5_r8*tk_sunw_innerl(l)*(t_sunw_inner(l) - t_sunw_innerl(l))/(zi_sunw_innerl(l) - z_sunw_innerl(l)) & - + 0.5_r8*tk_sunw_innerl(l)*(t_sunw_inner_bef(l) - t_sunw_innerl_bef(l))/(zi_sunw_innerl(l) & - - z_sunw_innerl(l)) - enrgy_bal_sunw(l) = qrd_sunw(l) + qcv_sunw(l)*canyon_hwr(l) + qcd_sunw(l)*canyon_hwr(l) - if (abs(enrgy_bal_sunw(l)) > .10_r8 ) then - write (iulog,*) 'urban inside sunwall energy balance error ',enrgy_bal_sunw(l) - write (iulog,*) 'clm model is stopping' - call endrun() - end if - - qcv_shdw(l) = 0.5_r8*hcv_shdwi(l)*(t_shdw_inner(l) - t_building(l)) + 0.5_r8*hcv_shdwi(l)*(t_shdw_inner_bef(l) & - - t_building_bef(l)) - qcd_shdw(l) = 0.5_r8*tk_shdw_innerl(l)*(t_shdw_inner(l) - t_shdw_innerl(l))/(zi_shdw_innerl(l) - z_shdw_innerl(l)) & - + 0.5_r8*tk_shdw_innerl(l)*(t_shdw_inner_bef(l) - t_shdw_innerl_bef(l))/(zi_shdw_innerl(l) & - - z_shdw_innerl(l)) - enrgy_bal_shdw(l) = qrd_shdw(l) + qcv_shdw(l)*canyon_hwr(l) + qcd_shdw(l)*canyon_hwr(l) - if (abs(enrgy_bal_shdw(l)) > .10_r8 ) then - write (iulog,*) 'urban inside shadewall energy balance error ',enrgy_bal_shdw(l) - write (iulog,*) 'clm model is stopping' - call endrun() - end if - - qcv_floor(l) = 0.5_r8*hcv_floori(l)*(t_floor(l) - t_building(l)) + 0.5_r8*hcv_floori(l)*(t_floor_bef(l) & - - t_building_bef(l)) - qcd_floor(l) = cv_floori(l)*(t_floor(l) - t_floor_bef(l)) - enrgy_bal_floor(l) = qrd_floor(l) + qcv_floor(l) + qcd_floor(l) - if (abs(enrgy_bal_floor(l)) > .10_r8 ) then - write (iulog,*) 'urban inside floor energy balance error ',enrgy_bal_floor(l) - write (iulog,*) 'clm model is stopping' - call endrun() - end if - - enrgy_bal_buildair(l) = (ht_roof(l)*rho_dair(l)*cpair/dtime)*(t_building(l) - t_building_bef(l)) & - - ht_roof(l)*(vent_ach/3600._r8)*rho_dair(l)*cpair*(taf(l) - t_building(l)) & - - 0.5_r8*hcv_roofi(l)*(t_roof_inner(l) - t_building(l)) & - - 0.5_r8*hcv_roofi(l)*(t_roof_inner_bef(l) - t_building_bef(l)) & - - 0.5_r8*hcv_sunwi(l)*(t_sunw_inner(l) - t_building(l))*canyon_hwr(l) & - - 0.5_r8*hcv_sunwi(l)*(t_sunw_inner_bef(l) - t_building_bef(l))*canyon_hwr(l) & - - 0.5_r8*hcv_shdwi(l)*(t_shdw_inner(l) - t_building(l))*canyon_hwr(l) & - - 0.5_r8*hcv_shdwi(l)*(t_shdw_inner_bef(l) - t_building_bef(l))*canyon_hwr(l) & - - 0.5_r8*hcv_floori(l)*(t_floor(l) - t_building(l)) & - - 0.5_r8*hcv_floori(l)*(t_floor_bef(l) - t_building_bef(l)) - if (abs(enrgy_bal_buildair(l)) > .10_r8 ) then - write (iulog,*) 'urban building air energy balance error ',enrgy_bal_buildair(l) - write (iulog,*) 'clm model is stopping' - call endrun() - end if - end if - end do - - ! Restrict internal building air temperature to between min and max - ! Calculate heating or air conditioning flux from energy required to change - ! internal building air temperature to t_building_min or t_building_max. - - do fl = 1,num_urbanl - l = filter_urbanl(fl) - if (urbpoi(l)) then - if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then - t_building_bef_hac(l) = t_building(l) -! rho_dair(l) = pstd / (rair*t_building(l)) - - if (t_building_bef_hac(l) > t_building_max(l)) then - t_building(l) = t_building_max(l) - eflx_urban_ac(l) = wtlunit_roof(l) * abs( (ht_roof(l) * rho_dair(l) * cpair / dtime) * t_building(l) & - - (ht_roof(l) * rho_dair(l) * cpair / dtime) * t_building_bef_hac(l) ) - else if (t_building_bef_hac(l) < t_building_min(l)) then - t_building(l) = t_building_min(l) - eflx_urban_heat(l) = wtlunit_roof(l) * abs( (ht_roof(l) * rho_dair(l) * cpair / dtime) * t_building(l) & - - (ht_roof(l) * rho_dair(l) * cpair / dtime) * t_building_bef_hac(l) ) - else - eflx_urban_ac(l) = 0._r8 - eflx_urban_heat(l) = 0._r8 - end if - else - eflx_urban_ac(l) = 0._r8 - eflx_urban_heat(l) = 0._r8 - end if - eflx_building(l) = wtlunit_roof(l) * (ht_roof(l) * rho_dair(l)*cpair/dtime) * (t_building(l) - t_building_bef(l)) - end if - end do - - end associate - end subroutine BuildingTemperature - - !----------------------------------------------------------------------- - -end module UrbBuildTempOleson2015Mod diff --git a/src/biogeophys/UrbanParamsType.F90 b/src/biogeophys/UrbanParamsType.F90 deleted file mode 100644 index c3c25b0f..00000000 --- a/src/biogeophys/UrbanParamsType.F90 +++ /dev/null @@ -1,961 +0,0 @@ -module UrbanParamsType - - !------------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Urban Constants - ! - ! !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 : iulog, fsurdat - use clm_varcon , only : namel, grlnd, spval - use LandunitType , only : lun - ! - implicit none - save - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: UrbanReadNML ! Read in the urban namelist items - public :: UrbanInput ! Read in urban input data - public :: CheckUrban ! Check validity of urban points - public :: IsSimpleBuildTemp ! If using the simple building temperature method - public :: IsProgBuildTemp ! If using the prognostic building temperature method - ! - ! !PRIVATE TYPE - type urbinp_type - real(r8), pointer :: canyon_hwr (:,:) - real(r8), pointer :: wtlunit_roof (:,:) - real(r8), pointer :: wtroad_perv (:,:) - real(r8), pointer :: em_roof (:,:) - real(r8), pointer :: em_improad (:,:) - real(r8), pointer :: em_perroad (:,:) - real(r8), pointer :: em_wall (:,:) - real(r8), pointer :: alb_roof_dir (:,:,:) - real(r8), pointer :: alb_roof_dif (:,:,:) - real(r8), pointer :: alb_improad_dir (:,:,:) - real(r8), pointer :: alb_improad_dif (:,:,:) - real(r8), pointer :: alb_perroad_dir (:,:,:) - real(r8), pointer :: alb_perroad_dif (:,:,:) - real(r8), pointer :: alb_wall_dir (:,:,:) - real(r8), pointer :: alb_wall_dif (:,:,:) - real(r8), pointer :: ht_roof (:,:) - real(r8), pointer :: wind_hgt_canyon (:,:) - real(r8), pointer :: tk_wall (:,:,:) - real(r8), pointer :: tk_roof (:,:,:) - real(r8), pointer :: tk_improad (:,:,:) - real(r8), pointer :: cv_wall (:,:,:) - real(r8), pointer :: cv_roof (:,:,:) - real(r8), pointer :: cv_improad (:,:,:) - real(r8), pointer :: thick_wall (:,:) - real(r8), pointer :: thick_roof (:,:) - integer, pointer :: nlev_improad (:,:) - real(r8), pointer :: t_building_min (:,:) - end type urbinp_type - type (urbinp_type), public :: urbinp ! urban input derived type - - ! !PUBLIC TYPE - type, public :: urbanparams_type - real(r8), allocatable :: wind_hgt_canyon (:) ! lun height above road at which wind in canyon is to be computed (m) - real(r8), allocatable :: em_roof (:) ! lun roof emissivity - real(r8), allocatable :: em_improad (:) ! lun impervious road emissivity - real(r8), allocatable :: em_perroad (:) ! lun pervious road emissivity - real(r8), allocatable :: em_wall (:) ! lun wall emissivity - real(r8), allocatable :: alb_roof_dir (:,:) ! lun direct roof albedo - real(r8), allocatable :: alb_roof_dif (:,:) ! lun diffuse roof albedo - real(r8), allocatable :: alb_improad_dir (:,:) ! lun direct impervious road albedo - real(r8), allocatable :: alb_improad_dif (:,:) ! lun diffuse impervious road albedo - real(r8), allocatable :: alb_perroad_dir (:,:) ! lun direct pervious road albedo - real(r8), allocatable :: alb_perroad_dif (:,:) ! lun diffuse pervious road albedo - real(r8), allocatable :: alb_wall_dir (:,:) ! lun direct wall albedo - real(r8), allocatable :: alb_wall_dif (:,:) ! lun diffuse wall albedo - - integer , pointer :: nlev_improad (:) ! lun number of impervious road layers (-) - real(r8), pointer :: tk_wall (:,:) ! lun thermal conductivity of urban wall (W/m/K) - real(r8), pointer :: tk_roof (:,:) ! lun thermal conductivity of urban roof (W/m/K) - real(r8), pointer :: tk_improad (:,:) ! lun thermal conductivity of urban impervious road (W/m/K) - real(r8), pointer :: cv_wall (:,:) ! lun heat capacity of urban wall (J/m^3/K) - real(r8), pointer :: cv_roof (:,:) ! lun heat capacity of urban roof (J/m^3/K) - real(r8), pointer :: cv_improad (:,:) ! lun heat capacity of urban impervious road (J/m^3/K) - real(r8), pointer :: thick_wall (:) ! lun total thickness of urban wall (m) - real(r8), pointer :: thick_roof (:) ! lun total thickness of urban roof (m) - - real(r8), pointer :: vf_sr (:) ! lun view factor of sky for road - real(r8), pointer :: vf_wr (:) ! lun view factor of one wall for road - real(r8), pointer :: vf_sw (:) ! lun view factor of sky for one wall - real(r8), pointer :: vf_rw (:) ! lun view factor of road for one wall - real(r8), pointer :: vf_ww (:) ! lun view factor of opposing wall for one wall - - real(r8), pointer :: t_building_min (:) ! lun minimum internal building air temperature (K) - real(r8), pointer :: eflx_traffic_factor (:) ! lun multiplicative traffic factor for sensible heat flux from urban traffic (-) - contains - - procedure, public :: Init - - end type urbanparams_type - ! - ! !Urban control variables - character(len= *), parameter, public :: urban_hac_off = 'OFF' - character(len= *), parameter, public :: urban_hac_on = 'ON' - character(len= *), parameter, public :: urban_wasteheat_on = 'ON_WASTEHEAT' - character(len= 16), public :: urban_hac = urban_hac_off - logical, public :: urban_traffic = .false. ! urban traffic fluxes - - ! !PRIVATE MEMBER DATA: - logical, private :: ReadNamelist = .false. ! If namelist was read yet or not - integer, parameter, private :: BUILDING_TEMP_METHOD_SIMPLE = 0 ! Simple method introduced in CLM4.5 - integer, parameter, private :: BUILDING_TEMP_METHOD_PROG = 1 ! Prognostic method introduced in CLM5.0 - integer, private :: building_temp_method = BUILDING_TEMP_METHOD_PROG ! Method to calculate the building temperature - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine Init(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, nlevgrnd, nlevurb - use clm_varpar , only : nlevsoi, nlevgrnd - use clm_varctl , only : use_vancouver, use_mexicocity - use clm_varcon , only : vkc - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use column_varcon , only : icol_road_perv, icol_road_imperv, icol_road_perv - use landunit_varcon , only : isturb_MIN - ! - ! !ARGUMENTS: - class(urbanparams_type) :: this - type(bounds_type) , intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: j,l,c,p,g ! indices - integer :: nc,fl,ib ! indices - integer :: dindx ! urban density type index - integer :: ier ! error status - real(r8) :: sumvf ! sum of view factors for wall or road - real(r8), parameter :: alpha = 4.43_r8 ! coefficient used to calculate z_d_town - real(r8), parameter :: beta = 1.0_r8 ! coefficient used to calculate z_d_town - real(r8), parameter :: C_d = 1.2_r8 ! drag coefficient as used in Grimmond and Oke (1999) - real(r8) :: plan_ai ! plan area index - ratio building area to plan area (-) - real(r8) :: frontal_ai ! frontal area index of buildings (-) - real(r8) :: build_lw_ratio ! building short/long side ratio (-) - integer :: begl, endl - integer :: begc, endc - integer :: begp, endp - 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 urbanparams data structure - - if ( nlevurb > 0 )then - allocate(this%tk_wall (begl:endl,nlevurb)) ; this%tk_wall (:,:) = nan - allocate(this%tk_roof (begl:endl,nlevurb)) ; this%tk_roof (:,:) = nan - allocate(this%cv_wall (begl:endl,nlevurb)) ; this%cv_wall (:,:) = nan - allocate(this%cv_roof (begl:endl,nlevurb)) ; this%cv_roof (:,:) = nan - end if - allocate(this%t_building_min (begl:endl)) ; this%t_building_min (:) = nan - allocate(this%tk_improad (begl:endl,nlevurb)) ; this%tk_improad (:,:) = nan - allocate(this%cv_improad (begl:endl,nlevurb)) ; this%cv_improad (:,:) = nan - allocate(this%thick_wall (begl:endl)) ; this%thick_wall (:) = nan - allocate(this%thick_roof (begl:endl)) ; this%thick_roof (:) = nan - allocate(this%nlev_improad (begl:endl)) ; this%nlev_improad (:) = huge(1) - allocate(this%vf_sr (begl:endl)) ; this%vf_sr (:) = nan - allocate(this%vf_wr (begl:endl)) ; this%vf_wr (:) = nan - allocate(this%vf_sw (begl:endl)) ; this%vf_sw (:) = nan - allocate(this%vf_rw (begl:endl)) ; this%vf_rw (:) = nan - allocate(this%vf_ww (begl:endl)) ; this%vf_ww (:) = nan - allocate(this%wind_hgt_canyon (begl:endl)) ; this%wind_hgt_canyon (:) = nan - allocate(this%em_roof (begl:endl)) ; this%em_roof (:) = nan - allocate(this%em_improad (begl:endl)) ; this%em_improad (:) = nan - allocate(this%em_perroad (begl:endl)) ; this%em_perroad (:) = nan - allocate(this%em_wall (begl:endl)) ; this%em_wall (:) = nan - allocate(this%alb_roof_dir (begl:endl,numrad)) ; this%alb_roof_dir (:,:) = nan - allocate(this%alb_roof_dif (begl:endl,numrad)) ; this%alb_roof_dif (:,:) = nan - allocate(this%alb_improad_dir (begl:endl,numrad)) ; this%alb_improad_dir (:,:) = nan - allocate(this%alb_perroad_dir (begl:endl,numrad)) ; this%alb_perroad_dir (:,:) = nan - allocate(this%alb_improad_dif (begl:endl,numrad)) ; this%alb_improad_dif (:,:) = nan - allocate(this%alb_perroad_dif (begl:endl,numrad)) ; this%alb_perroad_dif (:,:) = nan - allocate(this%alb_wall_dir (begl:endl,numrad)) ; this%alb_wall_dir (:,:) = nan - allocate(this%alb_wall_dif (begl:endl,numrad)) ; this%alb_wall_dif (:,:) = nan - allocate(this%eflx_traffic_factor (begl:endl)) ; this%eflx_traffic_factor (:) = nan - - ! Initialize time constant urban variables - - 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 - - g = lun%gridcell(l) - dindx = lun%itype(l) - isturb_MIN + 1 - - this%wind_hgt_canyon(l) = urbinp%wind_hgt_canyon(g,dindx) - do ib = 1,numrad - this%alb_roof_dir (l,ib) = urbinp%alb_roof_dir (g,dindx,ib) - this%alb_roof_dif (l,ib) = urbinp%alb_roof_dif (g,dindx,ib) - this%alb_improad_dir(l,ib) = urbinp%alb_improad_dir(g,dindx,ib) - this%alb_perroad_dir(l,ib) = urbinp%alb_perroad_dir(g,dindx,ib) - this%alb_improad_dif(l,ib) = urbinp%alb_improad_dif(g,dindx,ib) - this%alb_perroad_dif(l,ib) = urbinp%alb_perroad_dif(g,dindx,ib) - this%alb_wall_dir (l,ib) = urbinp%alb_wall_dir (g,dindx,ib) - this%alb_wall_dif (l,ib) = urbinp%alb_wall_dif (g,dindx,ib) - end do - this%em_roof (l) = urbinp%em_roof (g,dindx) - this%em_improad(l) = urbinp%em_improad(g,dindx) - this%em_perroad(l) = urbinp%em_perroad(g,dindx) - this%em_wall (l) = urbinp%em_wall (g,dindx) - - ! Landunit level initialization for urban wall and roof layers and interfaces - - lun%canyon_hwr(l) = urbinp%canyon_hwr(g,dindx) - lun%wtroad_perv(l) = urbinp%wtroad_perv(g,dindx) - lun%ht_roof(l) = urbinp%ht_roof(g,dindx) - lun%wtlunit_roof(l) = urbinp%wtlunit_roof(g,dindx) - - this%tk_wall(l,:) = urbinp%tk_wall(g,dindx,:) - this%tk_roof(l,:) = urbinp%tk_roof(g,dindx,:) - this%tk_improad(l,:) = urbinp%tk_improad(g,dindx,:) - this%cv_wall(l,:) = urbinp%cv_wall(g,dindx,:) - this%cv_roof(l,:) = urbinp%cv_roof(g,dindx,:) - this%cv_improad(l,:) = urbinp%cv_improad(g,dindx,:) - this%thick_wall(l) = urbinp%thick_wall(g,dindx) - this%thick_roof(l) = urbinp%thick_roof(g,dindx) - this%nlev_improad(l) = urbinp%nlev_improad(g,dindx) - this%t_building_min(l) = urbinp%t_building_min(g,dindx) - - ! Inferred from Sailor and Lu 2004 - if (urban_traffic) then - this%eflx_traffic_factor(l) = 3.6_r8 * (lun%canyon_hwr(l)-0.5_r8) + 1.0_r8 - else - this%eflx_traffic_factor(l) = 0.0_r8 - end if - - if (use_vancouver .or. use_mexicocity) then - ! Freely evolving - this%t_building_min(l) = 200.00_r8 - else - if (urban_hac == urban_hac_off) then - ! Overwrite values read in from urbinp by freely evolving values - this%t_building_min(l) = 200.00_r8 - end if - end if - - !---------------------------------------------------------------------------------- - ! View factors for road and one wall in urban canyon (depends only on canyon_hwr) - ! --------------------------------------------------------------------------------------- - ! WALL | - ! ROAD | - ! wall | - ! -----\ /----- - - |\----------/ - ! | \ vsr / | | r | | \ vww / s - ! | \ / | h o w | \ / k - ! wall | \ / | wall | a | | \ / y - ! |vwr \ / vwr| | d | |vrw \ / vsw - ! ------\/------ - - |-----\/----- - ! road wall | - ! <----- w ----> | - ! <---- h --->| - ! - ! vsr = view factor of sky for road vrw = view factor of road for wall - ! vwr = view factor of one wall for road vww = view factor of opposing wall for wall - ! vsw = view factor of sky for wall - ! vsr + vwr + vwr = 1 vrw + vww + vsw = 1 - ! - ! Source: Masson, V. (2000) A physically-based scheme for the urban energy budget in - ! atmospheric models. Boundary-Layer Meteorology 94:357-397 - ! - ! - Calculate urban land unit aerodynamic constants using Macdonald (1998) as used in - ! Grimmond and Oke (1999) - ! --------------------------------------------------------------------------------------- - - ! road -- sky view factor -> 1 as building height -> 0 - ! and -> 0 as building height -> infinity - - this%vf_sr(l) = sqrt(lun%canyon_hwr(l)**2 + 1._r8) - lun%canyon_hwr(l) - this%vf_wr(l) = 0.5_r8 * (1._r8 - this%vf_sr(l)) - - ! one wall -- sky view factor -> 0.5 as building height -> 0 - ! and -> 0 as building height -> infinity - - this%vf_sw(l) = 0.5_r8 * (lun%canyon_hwr(l) + 1._r8 - sqrt(lun%canyon_hwr(l)**2+1._r8)) / lun%canyon_hwr(l) - this%vf_rw(l) = this%vf_sw(l) - this%vf_ww(l) = 1._r8 - this%vf_sw(l) - this%vf_rw(l) - - ! error check -- make sure view factor sums to one for road and wall - sumvf = this%vf_sr(l) + 2._r8*this%vf_wr(l) - if (abs(sumvf-1._r8) > 1.e-06_r8 ) then - write (iulog,*) 'urban road view factor error',sumvf - write (iulog,*) 'clm model is stopping' - call endrun(decomp_index=l, clmlevel=namel, msg=errmsg(sourcefile, __LINE__)) - endif - sumvf = this%vf_sw(l) + this%vf_rw(l) + this%vf_ww(l) - if (abs(sumvf-1._r8) > 1.e-06_r8 ) then - write (iulog,*) 'urban wall view factor error',sumvf - write (iulog,*) 'clm model is stopping' - call endrun(decomp_index=l, clmlevel=namel, msg=errmsg(sourcefile, __LINE__)) - endif - - !---------------------------------------------------------------------------------- - ! Calculate urban land unit aerodynamic constants using Macdonald (1998) as used in - ! Grimmond and Oke (1999) - !---------------------------------------------------------------------------------- - - ! Calculate plan area index - plan_ai = lun%canyon_hwr(l)/(lun%canyon_hwr(l) + 1._r8) - - ! Building shape shortside/longside ratio (e.g. 1 = square ) - ! This assumes the building occupies the entire canyon length - build_lw_ratio = plan_ai - - ! Calculate frontal area index - frontal_ai = (1._r8 - plan_ai) * lun%canyon_hwr(l) - - ! Adjust frontal area index for different building configuration - frontal_ai = frontal_ai * sqrt(1/build_lw_ratio) * sqrt(plan_ai) - - ! Calculate displacement height - if (use_vancouver) then - lun%z_d_town(l) = 3.5_r8 - else if (use_mexicocity) then - lun%z_d_town(l) = 10.9_r8 - else - lun%z_d_town(l) = (1._r8 + alpha**(-plan_ai) * (plan_ai - 1._r8)) * lun%ht_roof(l) - end if - - ! Calculate the roughness length - if (use_vancouver) then - lun%z_0_town(l) = 0.35_r8 - else if (use_mexicocity) then - lun%z_0_town(l) = 2.2_r8 - else - lun%z_0_town(l) = lun%ht_roof(l) * (1._r8 - lun%z_d_town(l) / lun%ht_roof(l)) * & - exp(-1.0_r8 * (0.5_r8 * beta * C_d / vkc**2 * & - (1 - lun%z_d_town(l) / lun%ht_roof(l)) * frontal_ai)**(-0.5_r8)) - end if - - else ! Not urban point - - this%eflx_traffic_factor(l) = spval - this%t_building_min(l) = spval - - this%vf_sr(l) = spval - this%vf_wr(l) = spval - this%vf_sw(l) = spval - this%vf_rw(l) = spval - this%vf_ww(l) = spval - - end if - end do - - ! Deallocate memory for urbinp datatype - - call UrbanInput(bounds%begg, bounds%endg, mode='finalize') - - end subroutine Init - - !----------------------------------------------------------------------- - subroutine UrbanInput(begg, endg, mode) - ! - ! !DESCRIPTION: - ! Allocate memory and read in urban input data - ! - ! !USES: - use clm_varpar , only : numrad, nlevurb - use landunit_varcon , only : numurbl - use fileutils , only : getavu, relavu, getfil, opnfil - use spmdMod , only : masterproc - use domainMod , only : ldomain - use ncdio_pio , only : file_desc_t, ncd_io, ncd_inqvdlen, ncd_inqfdims - use ncdio_pio , only : ncd_pio_openfile, ncd_pio_closefile, ncd_inqdid, ncd_inqdlen - ! - ! !ARGUMENTS: - implicit none - integer, intent(in) :: begg, endg - character(len=*), intent(in) :: mode - ! - ! !LOCAL VARIABLES: - character(len=256) :: locfn ! local file name - type(file_desc_t) :: ncid ! netcdf id - integer :: dimid ! netCDF id - integer :: nw,n,k,i,j,ni,nj,ns ! indices - integer :: nlevurb_i ! input grid: number of urban vertical levels - integer :: numrad_i ! input grid: number of solar bands (VIS/NIR) - integer :: numurbl_i ! input grid: number of urban landunits - integer :: ier,ret ! error status - logical :: isgrid2d ! true => file is 2d - logical :: readvar ! true => variable is on dataset - logical :: has_numurbl ! true => numurbl dimension is on dataset - character(len=32) :: subname = 'UrbanInput' ! subroutine name - !----------------------------------------------------------------------- - - if ( nlevurb == 0 ) return - - if (mode == 'initialize') then - - ! Read urban data - - if (masterproc) then - write(iulog,*)' Reading in urban input data from fsurdat file ...' - end if - - call getfil (fsurdat, locfn, 0) - call ncd_pio_openfile (ncid, locfn, 0) - - if (masterproc) then - write(iulog,*) subname,trim(fsurdat) - end if - - ! Check whether this file has new-format urban data - call ncd_inqdid(ncid, 'numurbl', dimid, dimexist=has_numurbl) - - ! If file doesn't have numurbl, then it is old-format urban; - ! in this case, set nlevurb to zero - if (.not. has_numurbl) then - nlevurb = 0 - if (masterproc) write(iulog,*)'PCT_URBAN is not multi-density, nlevurb set to 0' - end if - - if ( nlevurb == 0 ) return - - ! Allocate dynamic memory - allocate(urbinp%canyon_hwr(begg:endg, numurbl), & - urbinp%wtlunit_roof(begg:endg, numurbl), & - urbinp%wtroad_perv(begg:endg, numurbl), & - urbinp%em_roof(begg:endg, numurbl), & - urbinp%em_improad(begg:endg, numurbl), & - urbinp%em_perroad(begg:endg, numurbl), & - urbinp%em_wall(begg:endg, numurbl), & - urbinp%alb_roof_dir(begg:endg, numurbl, numrad), & - urbinp%alb_roof_dif(begg:endg, numurbl, numrad), & - urbinp%alb_improad_dir(begg:endg, numurbl, numrad), & - urbinp%alb_perroad_dir(begg:endg, numurbl, numrad), & - urbinp%alb_improad_dif(begg:endg, numurbl, numrad), & - urbinp%alb_perroad_dif(begg:endg, numurbl, numrad), & - urbinp%alb_wall_dir(begg:endg, numurbl, numrad), & - urbinp%alb_wall_dif(begg:endg, numurbl, numrad), & - urbinp%ht_roof(begg:endg, numurbl), & - urbinp%wind_hgt_canyon(begg:endg, numurbl), & - urbinp%tk_wall(begg:endg, numurbl,nlevurb), & - urbinp%tk_roof(begg:endg, numurbl,nlevurb), & - urbinp%tk_improad(begg:endg, numurbl,nlevurb), & - urbinp%cv_wall(begg:endg, numurbl,nlevurb), & - urbinp%cv_roof(begg:endg, numurbl,nlevurb), & - urbinp%cv_improad(begg:endg, numurbl,nlevurb), & - urbinp%thick_wall(begg:endg, numurbl), & - urbinp%thick_roof(begg:endg, numurbl), & - urbinp%nlev_improad(begg:endg, numurbl), & - urbinp%t_building_min(begg:endg, numurbl), & - stat=ier) - if (ier /= 0) then - call endrun(msg="Allocation error "//errmsg(sourcefile, __LINE__)) - endif - - call ncd_inqfdims (ncid, isgrid2d, ni, nj, ns) - if (ldomain%ns /= ns .or. ldomain%ni /= ni .or. ldomain%nj /= nj) then - write(iulog,*)trim(subname), 'ldomain and input file do not match dims ' - write(iulog,*)trim(subname), 'ldomain%ni,ni,= ',ldomain%ni,ni - write(iulog,*)trim(subname), 'ldomain%nj,nj,= ',ldomain%nj,nj - write(iulog,*)trim(subname), 'ldomain%ns,ns,= ',ldomain%ns,ns - call endrun(msg=errmsg(sourcefile, __LINE__)) - end if - - call ncd_inqdid(ncid, 'nlevurb', dimid) - call ncd_inqdlen(ncid, dimid, nlevurb_i) - if (nlevurb_i /= nlevurb) then - write(iulog,*)trim(subname)// ': parameter nlevurb= ',nlevurb, & - 'does not equal input dataset nlevurb= ',nlevurb_i - call endrun(msg=errmsg(sourcefile, __LINE__)) - endif - - call ncd_inqdid(ncid, 'numrad', dimid) - call ncd_inqdlen(ncid, dimid, numrad_i) - if (numrad_i /= numrad) then - write(iulog,*)trim(subname)// ': parameter numrad= ',numrad, & - 'does not equal input dataset numrad= ',numrad_i - call endrun(msg=errmsg(sourcefile, __LINE__)) - endif - call ncd_inqdid(ncid, 'numurbl', dimid) - call ncd_inqdlen(ncid, dimid, numurbl_i) - if (numurbl_i /= numurbl) then - write(iulog,*)trim(subname)// ': parameter numurbl= ',numurbl, & - 'does not equal input dataset numurbl= ',numurbl_i - call endrun(msg=errmsg(sourcefile, __LINE__)) - endif - call ncd_io(ncid=ncid, varname='CANYON_HWR', flag='read', data=urbinp%canyon_hwr,& - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg='ERROR: CANYON_HWR NOT on fsurdat file '//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='WTLUNIT_ROOF', flag='read', data=urbinp%wtlunit_roof, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: WTLUNIT_ROOF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='WTROAD_PERV', flag='read', data=urbinp%wtroad_perv, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: WTROAD_PERV NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='EM_ROOF', flag='read', data=urbinp%em_roof, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: EM_ROOF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='EM_IMPROAD', flag='read', data=urbinp%em_improad, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: EM_IMPROAD NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='EM_PERROAD', flag='read', data=urbinp%em_perroad, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: EM_PERROAD NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='EM_WALL', flag='read', data=urbinp%em_wall, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: EM_WALL NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='HT_ROOF', flag='read', data=urbinp%ht_roof, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: HT_ROOF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='WIND_HGT_CANYON', flag='read', data=urbinp%wind_hgt_canyon, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: WIND_HGT_CANYON NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='THICK_WALL', flag='read', data=urbinp%thick_wall, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: THICK_WALL NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='THICK_ROOF', flag='read', data=urbinp%thick_roof, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: THICK_ROOF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='NLEV_IMPROAD', flag='read', data=urbinp%nlev_improad, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: NLEV_IMPROAD NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='T_BUILDING_MIN', flag='read', data=urbinp%t_building_min, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: T_BUILDING_MIN NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='ALB_IMPROAD_DIR', flag='read', data=urbinp%alb_improad_dir, & - dim1name=grlnd, readvar=readvar) - if (.not.readvar) then - call endrun( msg=' ERROR: ALB_IMPROAD_DIR NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='ALB_IMPROAD_DIF', flag='read', data=urbinp%alb_improad_dif, & - dim1name=grlnd, readvar=readvar) - if (.not.readvar) then - call endrun( msg=' ERROR: ALB_IMPROAD_DIF NOT on fsurdat file'//errmsg(sourcefile, __LINE__) ) - end if - - call ncd_io(ncid=ncid, varname='ALB_PERROAD_DIR', flag='read',data=urbinp%alb_perroad_dir, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: ALB_PERROAD_DIR NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='ALB_PERROAD_DIF', flag='read',data=urbinp%alb_perroad_dif, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: ALB_PERROAD_DIF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='ALB_ROOF_DIR', flag='read', data=urbinp%alb_roof_dir, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: ALB_ROOF_DIR NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='ALB_ROOF_DIF', flag='read', data=urbinp%alb_roof_dif, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: ALB_ROOF_DIF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='ALB_WALL_DIR', flag='read', data=urbinp%alb_wall_dir, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: ALB_WALL_DIR NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='ALB_WALL_DIF', flag='read', data=urbinp%alb_wall_dif, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: ALB_WALL_DIF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='TK_IMPROAD', flag='read', data=urbinp%tk_improad, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: TK_IMPROAD NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='TK_ROOF', flag='read', data=urbinp%tk_roof, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: TK_ROOF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='TK_WALL', flag='read', data=urbinp%tk_wall, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: TK_WALL NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='CV_IMPROAD', flag='read', data=urbinp%cv_improad, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: CV_IMPROAD NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='CV_ROOF', flag='read', data=urbinp%cv_roof, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: CV_ROOF NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_io(ncid=ncid, varname='CV_WALL', flag='read', data=urbinp%cv_wall, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun( msg=' ERROR: CV_WALL NOT on fsurdat file'//errmsg(sourcefile, __LINE__)) - end if - - call ncd_pio_closefile(ncid) - if (masterproc) then - write(iulog,*)' Sucessfully read urban input data' - write(iulog,*) - end if - - else if (mode == 'finalize') then - - if ( nlevurb == 0 ) return - - deallocate(urbinp%canyon_hwr, & - urbinp%wtlunit_roof, & - urbinp%wtroad_perv, & - urbinp%em_roof, & - urbinp%em_improad, & - urbinp%em_perroad, & - urbinp%em_wall, & - urbinp%alb_roof_dir, & - urbinp%alb_roof_dif, & - urbinp%alb_improad_dir, & - urbinp%alb_perroad_dir, & - urbinp%alb_improad_dif, & - urbinp%alb_perroad_dif, & - urbinp%alb_wall_dir, & - urbinp%alb_wall_dif, & - urbinp%ht_roof, & - urbinp%wind_hgt_canyon, & - urbinp%tk_wall, & - urbinp%tk_roof, & - urbinp%tk_improad, & - urbinp%cv_wall, & - urbinp%cv_roof, & - urbinp%cv_improad, & - urbinp%thick_wall, & - urbinp%thick_roof, & - urbinp%nlev_improad, & - urbinp%t_building_min, & - stat=ier) - if (ier /= 0) then - call endrun(msg='initUrbanInput: deallocation error '//errmsg(sourcefile, __LINE__)) - end if - else - write(iulog,*)'initUrbanInput error: mode ',trim(mode),' not supported ' - call endrun(msg=errmsg(sourcefile, __LINE__)) - end if - - end subroutine UrbanInput - - !----------------------------------------------------------------------- - subroutine CheckUrban(begg, endg, pcturb, caller) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Confirm that we have valid urban data for all points with pct urban > 0. If this isn't - ! true, abort with a message. - ! - ! !USES: - use clm_instur , only : urban_valid - use landunit_varcon , only : numurbl - ! - ! !ARGUMENTS: - implicit none - integer , intent(in) :: begg, endg ! beg & end grid cell indices - real(r8) , intent(in) :: pcturb(begg:,:) ! % urban - character(len=*), intent(in) :: caller ! identifier of caller, for more meaningful error messages - ! - ! !REVISION HISTORY: - ! Created by Bill Sacks 7/2013, mostly by moving code from surfrd_special - ! - ! !LOCAL VARIABLES: - logical :: found - integer :: nl, n - integer :: nindx, dindx - integer :: nlev - !----------------------------------------------------------------------- - - found = .false. - do nl = begg,endg - do n = 1, numurbl - if ( pcturb(nl,n) > 0.0_r8 ) then - if ( .not. urban_valid(nl) .or. & - urbinp%canyon_hwr(nl,n) <= 0._r8 .or. & - urbinp%em_improad(nl,n) <= 0._r8 .or. & - urbinp%em_perroad(nl,n) <= 0._r8 .or. & - urbinp%em_roof(nl,n) <= 0._r8 .or. & - urbinp%em_wall(nl,n) <= 0._r8 .or. & - urbinp%ht_roof(nl,n) <= 0._r8 .or. & - urbinp%thick_roof(nl,n) <= 0._r8 .or. & - urbinp%thick_wall(nl,n) <= 0._r8 .or. & - urbinp%t_building_min(nl,n) <= 0._r8 .or. & - urbinp%wind_hgt_canyon(nl,n) <= 0._r8 .or. & - urbinp%wtlunit_roof(nl,n) <= 0._r8 .or. & - urbinp%wtroad_perv(nl,n) <= 0._r8 .or. & - any(urbinp%alb_improad_dir(nl,n,:) <= 0._r8) .or. & - any(urbinp%alb_improad_dif(nl,n,:) <= 0._r8) .or. & - any(urbinp%alb_perroad_dir(nl,n,:) <= 0._r8) .or. & - any(urbinp%alb_perroad_dif(nl,n,:) <= 0._r8) .or. & - any(urbinp%alb_roof_dir(nl,n,:) <= 0._r8) .or. & - any(urbinp%alb_roof_dif(nl,n,:) <= 0._r8) .or. & - any(urbinp%alb_wall_dir(nl,n,:) <= 0._r8) .or. & - any(urbinp%alb_wall_dif(nl,n,:) <= 0._r8) .or. & - any(urbinp%tk_roof(nl,n,:) <= 0._r8) .or. & - any(urbinp%tk_wall(nl,n,:) <= 0._r8) .or. & - any(urbinp%cv_roof(nl,n,:) <= 0._r8) .or. & - any(urbinp%cv_wall(nl,n,:) <= 0._r8)) then - found = .true. - nindx = nl - dindx = n - exit - else - if (urbinp%nlev_improad(nl,n) > 0) then - nlev = urbinp%nlev_improad(nl,n) - if ( any(urbinp%tk_improad(nl,n,1:nlev) <= 0._r8) .or. & - any(urbinp%cv_improad(nl,n,1:nlev) <= 0._r8)) then - found = .true. - nindx = nl - dindx = n - exit - end if - end if - end if - if (found) exit - end if - end do - end do - if ( found ) then - write(iulog,*) trim(caller), ' ERROR: no valid urban data for nl=',nindx - write(iulog,*)'density type: ',dindx - write(iulog,*)'urban_valid: ',urban_valid(nindx) - write(iulog,*)'canyon_hwr: ',urbinp%canyon_hwr(nindx,dindx) - write(iulog,*)'em_improad: ',urbinp%em_improad(nindx,dindx) - write(iulog,*)'em_perroad: ',urbinp%em_perroad(nindx,dindx) - write(iulog,*)'em_roof: ',urbinp%em_roof(nindx,dindx) - write(iulog,*)'em_wall: ',urbinp%em_wall(nindx,dindx) - write(iulog,*)'ht_roof: ',urbinp%ht_roof(nindx,dindx) - write(iulog,*)'thick_roof: ',urbinp%thick_roof(nindx,dindx) - write(iulog,*)'thick_wall: ',urbinp%thick_wall(nindx,dindx) - write(iulog,*)'t_building_min: ',urbinp%t_building_min(nindx,dindx) - write(iulog,*)'wind_hgt_canyon: ',urbinp%wind_hgt_canyon(nindx,dindx) - write(iulog,*)'wtlunit_roof: ',urbinp%wtlunit_roof(nindx,dindx) - write(iulog,*)'wtroad_perv: ',urbinp%wtroad_perv(nindx,dindx) - write(iulog,*)'alb_improad_dir: ',urbinp%alb_improad_dir(nindx,dindx,:) - write(iulog,*)'alb_improad_dif: ',urbinp%alb_improad_dif(nindx,dindx,:) - write(iulog,*)'alb_perroad_dir: ',urbinp%alb_perroad_dir(nindx,dindx,:) - write(iulog,*)'alb_perroad_dif: ',urbinp%alb_perroad_dif(nindx,dindx,:) - write(iulog,*)'alb_roof_dir: ',urbinp%alb_roof_dir(nindx,dindx,:) - write(iulog,*)'alb_roof_dif: ',urbinp%alb_roof_dif(nindx,dindx,:) - write(iulog,*)'alb_wall_dir: ',urbinp%alb_wall_dir(nindx,dindx,:) - write(iulog,*)'alb_wall_dif: ',urbinp%alb_wall_dif(nindx,dindx,:) - write(iulog,*)'tk_roof: ',urbinp%tk_roof(nindx,dindx,:) - write(iulog,*)'tk_wall: ',urbinp%tk_wall(nindx,dindx,:) - write(iulog,*)'cv_roof: ',urbinp%cv_roof(nindx,dindx,:) - write(iulog,*)'cv_wall: ',urbinp%cv_wall(nindx,dindx,:) - if (urbinp%nlev_improad(nindx,dindx) > 0) then - nlev = urbinp%nlev_improad(nindx,dindx) - write(iulog,*)'tk_improad: ',urbinp%tk_improad(nindx,dindx,1:nlev) - write(iulog,*)'cv_improad: ',urbinp%cv_improad(nindx,dindx,1:nlev) - end if - call endrun(msg=errmsg(sourcefile, __LINE__)) - end if - - end subroutine CheckUrban - - !----------------------------------------------------------------------- - - !----------------------------------------------------------------------- - !BOP - ! - ! !IROUTINE: UrbanReadNML - ! - ! !INTERFACE: - ! - subroutine UrbanReadNML ( NLFilename ) - ! - ! !DESCRIPTION: - ! - ! Read in the urban 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 - implicit none - ! - ! !ARGUMENTS: - character(len=*), intent(IN) :: NLFilename ! Namelist filename - ! - ! !LOCAL VARIABLES: - integer :: ierr ! error code - integer :: unitn ! unit for namelist file - character(len=32) :: subname = 'UrbanReadNML' ! subroutine name - - namelist / clmu_inparm / urban_hac, urban_traffic, building_temp_method - !EOP - !----------------------------------------------------------------------- - - ! ---------------------------------------------------------------------- - ! Read namelist from input namelist filename - ! ---------------------------------------------------------------------- - - if ( masterproc )then - - unitn = getavu() - write(iulog,*) 'Read in clmu_inparm namelist' - call opnfil (NLFilename, unitn, 'F') - call shr_nl_find_group_name(unitn, 'clmu_inparm', status=ierr) - if (ierr == 0) then - read(unitn, clmu_inparm, iostat=ierr) - if (ierr /= 0) then - call endrun(msg="ERROR reading clmu_inparm namelist"//errmsg(sourcefile, __LINE__)) - end if - else - write(iulog,*) "Could not find clmu_inparm namelist" - end if - call relavu( unitn ) - - end if - - ! Broadcast namelist variables read in - call shr_mpi_bcast(urban_hac, mpicom) - call shr_mpi_bcast(urban_traffic, mpicom) - call shr_mpi_bcast(building_temp_method, mpicom) - - ! - if (urban_traffic) then - write(iulog,*)'Urban traffic fluxes are not implemented currently' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - ! - if ( masterproc )then - write(iulog,*) ' urban air conditioning/heating and wasteheat = ', urban_hac - write(iulog,*) ' urban traffic flux = ', urban_traffic - end if - - ReadNamelist = .true. - - end subroutine UrbanReadNML - - !----------------------------------------------------------------------- - - !----------------------------------------------------------------------- - !BOP - ! - ! !IROUTINE: IsSimpleBuildTemp - ! - ! !INTERFACE: - ! - logical function IsSimpleBuildTemp( ) - ! - ! !DESCRIPTION: - ! - ! If the simple building temperature method is being used - ! - ! !USES: - implicit none - !EOP - !----------------------------------------------------------------------- - - if ( .not. ReadNamelist )then - write(iulog,*)'Testing on building_temp_method before urban namelist was read in' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - IsSimpleBuildTemp = building_temp_method == BUILDING_TEMP_METHOD_SIMPLE - - end function IsSimpleBuildTemp - - !----------------------------------------------------------------------- - - !----------------------------------------------------------------------- - !BOP - ! - ! !IROUTINE: IsProgBuildTemp - ! - ! !INTERFACE: - ! - logical function IsProgBuildTemp( ) - ! - ! !DESCRIPTION: - ! - ! If the prognostic building temperature method is being used - ! - ! !USES: - implicit none - !EOP - !----------------------------------------------------------------------- - - if ( .not. ReadNamelist )then - write(iulog,*)'Testing on building_temp_method before urban namelist was read in' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - IsProgBuildTemp = building_temp_method == BUILDING_TEMP_METHOD_PROG - - end function IsProgBuildTemp - - !----------------------------------------------------------------------- - -end module UrbanParamsType - - - - diff --git a/src/biogeophys/UrbanTimeVarType.F90 b/src/biogeophys/UrbanTimeVarType.F90 deleted file mode 100644 index 600f506f..00000000 --- a/src/biogeophys/UrbanTimeVarType.F90 +++ /dev/null @@ -1,168 +0,0 @@ -module UrbanTimeVarType - - !------------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Urban Time Varying 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 abortutils , only : endrun - use decompMod , only : bounds_type - use clm_varctl , only : iulog - use landunit_varcon , only : isturb_MIN, isturb_MAX - use clm_varcon , only : spval - use LandunitType , only : lun - use GridcellType , only : grc - use mct_mod - use shr_strdata_mod , only : shr_strdata_type - ! - implicit none - save - private - ! - ! - - ! !PUBLIC TYPE - type, public :: urbantv_type - - real(r8), public, pointer :: t_building_max(:) ! lun maximum internal building air temperature (K) - type(shr_strdata_type) :: sdat_urbantv ! urban time varying input data stream - contains - - ! !PUBLIC MEMBER FUNCTIONS: - procedure, public :: Init ! Allocate and initialize urbantv - procedure, public :: urbantv_interp ! Interpolate urban time varying stream - - end type urbantv_type - - !----------------------------------------------------------------------- - character(15), private :: stream_var_name(isturb_MIN:isturb_MAX) - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - !----------------------------------------------------------------------- - subroutine Init(this, bounds, NLFilename) - ! - ! Allocate module variables and data structures - ! - ! !USES: - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use histFileMod , only : hist_addfld1d - ! - ! !ARGUMENTS: - class(urbantv_type) :: this - type(bounds_type) , intent(in) :: bounds - character(len=*) , intent(in) :: NLFilename ! Namelist filename - ! - ! !LOCAL VARIABLES: - integer :: begl, endl - !--------------------------------------------------------------------- - - begl = bounds%begl; endl = bounds%endl - - ! Allocate urbantv data structure - - allocate(this%t_building_max (begl:endl)) ; this%t_building_max (:) = nan - - call this%urbantv_interp(bounds) - - ! Add history fields - call hist_addfld1d (fname='TBUILD_MAX', units='K', & - avgflag='A', long_name='prescribed maximum interior building temperature', & - ptr_lunit=this%t_building_max, default='inactive', set_nourb=spval, & - l2g_scale_type='unity') - - - end subroutine Init - - !----------------------------------------------------------------------- - subroutine urbantv_interp(this, bounds) - ! - ! !DESCRIPTION: - ! Interpolate data stream information for urban time varying data. - ! - ! !USES: - use clm_time_manager, only : get_curr_date - use spmdMod , only : mpicom - use shr_strdata_mod , only : shr_strdata_advance - use clm_instur , only : urban_valid - ! - ! !ARGUMENTS: - class(urbantv_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - logical :: found - integer :: l, glun, ig, g, ip - 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) - integer :: lindx ! landunit index - integer :: gindx ! gridcell index - !----------------------------------------------------------------------- - - call get_curr_date(year, mon, day, sec) - mcdate = year*10000 + mon*100 + day - - call shr_strdata_advance(this%sdat_urbantv, mcdate, sec, mpicom, 'urbantvdyn') - - do l = bounds%begl,bounds%endl - if (lun%urbpoi(l)) then - glun = lun%gridcell(l) - ip = mct_aVect_indexRA(this%sdat_urbantv%avs(1),trim(stream_var_name(lun%itype(l)))) - ! - ! Determine vector index corresponding to glun - ! - ig = 0 - do g = bounds%begg,bounds%endg - ig = ig+1 - if (g == glun) exit - end do - - this%t_building_max(l) = this%sdat_urbantv%avs(1)%rAttr(ip,ig) - else - this%t_building_max(l) = spval - end if - end do - - found = .false. - do l = bounds%begl,bounds%endl - if (lun%urbpoi(l)) then - glun = lun%gridcell(l) - ! - ! Determine vector index corresponding to glun - ! - ig = 0 - do g = bounds%begg,bounds%endg - ig = ig+1 - if (g == glun) exit - end do - - if ( .not. urban_valid(g) .or. (this%t_building_max(l) <= 0._r8)) then - found = .true. - gindx = g - lindx = l - exit - end if - end if - end do - if ( found ) then - write(iulog,*)'ERROR: no valid urban data for g= ',gindx - write(iulog,*)'landunit type: ',lun%itype(l) - write(iulog,*)'urban_valid: ',urban_valid(gindx) - write(iulog,*)'t_building_max: ',this%t_building_max(lindx) - call endrun(msg=errmsg(sourcefile, __LINE__)) - end if - - - end subroutine urbantv_interp - - !----------------------------------------------------------------------- - -end module UrbanTimeVarType diff --git a/src/biogeophys/WaterStateType.F90 b/src/biogeophys/WaterStateType.F90 deleted file mode 100644 index 4615e22f..00000000 --- a/src/biogeophys/WaterStateType.F90 +++ /dev/null @@ -1,1122 +0,0 @@ -module WaterstateType - -#include "shr_assert.h" - - !------------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Module variables for hydrology - ! - ! !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_varctl , only : use_vancouver, use_mexicocity, use_cn, iulog, use_luna - use clm_varpar , only : nlevgrnd, nlevurb, nlevsno - use clm_varcon , only : spval - use LandunitType , only : lun - use ColumnType , only : col - ! - implicit none - save - private - ! - ! !PUBLIC TYPES: - type, public :: waterstate_type - - real(r8), pointer :: snow_depth_col (:) ! col snow height of snow covered area (m) - real(r8), pointer :: snow_persistence_col (:) ! col length of time that ground has had non-zero snow thickness (sec) - real(r8), pointer :: snowdp_col (:) ! col area-averaged snow height (m) - real(r8), pointer :: snowice_col (:) ! col average snow ice lens - real(r8), pointer :: snowliq_col (:) ! col average snow liquid water - real(r8), pointer :: int_snow_col (:) ! col integrated snowfall (mm H2O) - 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 :: h2osno_col (:) ! col snow water (mm H2O) - real(r8), pointer :: h2osno_old_col (:) ! col snow mass for previous time step (kg/m2) (new) - 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_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 :: h2osoi_liqice_10cm_col (:) ! col liquid water + ice lens in top 10cm of soil (kg/m2) - real(r8), pointer :: h2osoi_vol_col (:,:) ! col volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (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 :: h2ocan_patch (:) ! patch canopy water (mm H2O) - 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 :: snounload_patch (:) ! Canopy snow unloading (mm H2O) - real(r8), pointer :: swe_old_col (:,:) ! col initial snow water - real(r8), pointer :: liq1_grc (:) ! grc initial gridcell total h2o liq content - real(r8), pointer :: liq2_grc (:) ! grc post land cover change total liq content - real(r8), pointer :: ice1_grc (:) ! grc initial gridcell total h2o ice content - real(r8), pointer :: ice2_grc (:) ! grc post land cover change total ice content - real(r8), pointer :: tws_grc (:) ! grc total water storage (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 :: 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 :: q_ref2m_patch (:) ! patch 2 m height surface specific humidity (kg/kg) - 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 :: 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 :: dqgdT_col (:) ! col d(qg)/dT - real(r8), pointer :: qaf_lun (:) ! lun urban canopy air specific humidity (kg/kg) - - ! 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) - 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) - - ! Balance Checks - - real(r8), pointer :: begwb_col (:) ! water mass begining of the time step - real(r8), pointer :: endwb_col (:) ! water mass end of the time step - real(r8), pointer :: errh2o_patch (:) ! water conservation error (mm H2O) - real(r8), pointer :: errh2o_col (:) ! water conservation error (mm H2O) - real(r8), pointer :: errh2osno_col (:) ! snow water conservation error(mm H2O) - - contains - - procedure :: Init - procedure :: Restart - procedure, public :: Reset - procedure, private :: InitAllocate - procedure, private :: InitHistory - procedure, private :: InitCold - - end type waterstate_type - - ! 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 Init(this, bounds, & - h2osno_input_col, snow_depth_input_col, watsat_col, t_soisno_col) - - class(waterstate_type) :: this - type(bounds_type) , intent(in) :: bounds - real(r8) , intent(inout) :: h2osno_input_col(bounds%begc:) - real(r8) , intent(inout) :: snow_depth_input_col(bounds%begc:) - real(r8) , intent(inout) :: watsat_col(bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) - real(r8) , intent(inout) :: t_soisno_col(bounds%begc:, -nlevsno+1:) ! col soil temperature (Kelvin) - -#ifdef __PGI -# if __PGIC__ == 14 && __PGIC_MINOR__ == 7 - ! COMPILER_BUG(bja, 2015-04, pgi 14.7-?) occurs at: call this%InitCold(...) - ! PGF90-F-0000-Internal compiler error. normalize_forall_array: non-conformable - ! not sure why this fixes things.... - real(r8), allocatable :: workaround_for_pgi_internal_compiler_error(:) -# endif -#endif - - call this%InitAllocate(bounds) - - call this%InitHistory(bounds) - - call this%InitCold(bounds, & - h2osno_input_col, snow_depth_input_col, watsat_col, t_soisno_col) - - 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(waterstate_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%snow_depth_col (begc:endc)) ; this%snow_depth_col (:) = nan - allocate(this%snow_persistence_col (begc:endc)) ; this%snow_persistence_col (:) = nan - allocate(this%snowdp_col (begc:endc)) ; this%snowdp_col (:) = nan - allocate(this%snowice_col (begc:endc)) ; this%snowice_col (:) = nan - allocate(this%snowliq_col (begc:endc)) ; this%snowliq_col (:) = nan - allocate(this%int_snow_col (begc:endc)) ; this%int_snow_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%h2osno_col (begc:endc)) ; this%h2osno_col (:) = nan - allocate(this%h2osno_old_col (begc:endc)) ; this%h2osno_old_col (:) = nan - allocate(this%h2osoi_liqice_10cm_col (begc:endc)) ; this%h2osoi_liqice_10cm_col (:) = nan - allocate(this%h2osoi_vol_col (begc:endc, 1:nlevgrnd)) ; this%h2osoi_vol_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_col (begc:endc,-nlevsno+1:nlevgrnd)) ; this%h2osoi_ice_col (:,:) = nan - allocate(this%h2osoi_liq_col (begc:endc,-nlevsno+1:nlevgrnd)) ; this%h2osoi_liq_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%h2ocan_patch (begp:endp)) ; this%h2ocan_patch (:) = nan - allocate(this%snocan_patch (begp:endp)) ; this%snocan_patch (:) = nan - allocate(this%liqcan_patch (begp:endp)) ; this%liqcan_patch (:) = nan - allocate(this%snounload_patch (begp:endp)) ; this%snounload_patch (:) = nan - allocate(this%h2osfc_col (begc:endc)) ; this%h2osfc_col (:) = nan - allocate(this%swe_old_col (begc:endc,-nlevsno+1:0)) ; this%swe_old_col (:,:) = nan - allocate(this%liq1_grc (begg:endg)) ; this%liq1_grc (:) = nan - allocate(this%liq2_grc (begg:endg)) ; this%liq2_grc (:) = nan - allocate(this%ice1_grc (begg:endg)) ; this%ice1_grc (:) = nan - allocate(this%ice2_grc (begg:endg)) ; this%ice2_grc (:) = nan - allocate(this%tws_grc (begg:endg)) ; this%tws_grc (:) = nan - - allocate(this%total_plant_stored_h2o_col(begc:endc)) ; this%total_plant_stored_h2o_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%qg_snow_col (begc:endc)) ; this%qg_snow_col (:) = nan - allocate(this%qg_soil_col (begc:endc)) ; this%qg_soil_col (:) = nan - allocate(this%qg_h2osfc_col (begc:endc)) ; this%qg_h2osfc_col (:) = nan - allocate(this%qg_col (begc:endc)) ; this%qg_col (:) = nan - allocate(this%dqgdT_col (begc:endc)) ; this%dqgdT_col (:) = nan - allocate(this%qaf_lun (begl:endl)) ; this%qaf_lun (:) = nan - allocate(this%q_ref2m_patch (begp:endp)) ; this%q_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)) ; - 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%begwb_col (begc:endc)) ; this%begwb_col (:) = nan - allocate(this%endwb_col (begc:endc)) ; this%endwb_col (:) = nan - allocate(this%errh2o_patch (begp:endp)) ; this%errh2o_patch (:) = nan - allocate(this%errh2o_col (begc:endc)) ; this%errh2o_col (:) = nan - allocate(this%errh2osno_col (begc:endc)) ; this%errh2osno_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 clm_varctl , only : use_cn - use clm_varctl , only : hist_wrtch4diag - use clm_varpar , only : nlevsno, nlevsoi - use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal, no_snow_zero - ! - ! !ARGUMENTS: - class(waterstate_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begp, endp - integer :: begc, endc - integer :: begg, endg - 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 - begg = bounds%begg; endg= bounds%endg - - ! h2osno also includes snow that is part of the soil column (an - ! initial snow layer is only created if h2osno > 10mm). - - data2dptr => this%h2osoi_liq_col(:,-nlevsno+1:0) - call hist_addfld2d (fname='SNO_LIQH2O', units='kg/m2', type2d='levsno', & - avgflag='A', long_name='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='SNO_ICE', units='kg/m2', type2d='levsno', & - avgflag='A', long_name='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='H2OSOI', units='mm3/mm3', type2d='levsoi', & - avgflag='A', long_name='volumetric soil water (vegetated landunits only)', & - ptr_col=this%h2osoi_vol_col, l2g_scale_type='veg', default='inactive') - -! this%h2osoi_liq_col(begc:endc,:) = spval -! call hist_addfld2d (fname='SOILLIQ', units='kg/m2', type2d='levgrnd', & -! avgflag='A', long_name='soil liquid water (vegetated 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='SOILLIQ', units='kg/m2', type2d='levsoi', & - avgflag='A', long_name='soil liquid water (vegetated landunits only)', & - ptr_col=data2dptr, l2g_scale_type='veg', default='inactive') - - data2dptr => this%h2osoi_ice_col(begc:endc,1:nlevsoi) - call hist_addfld2d (fname='SOILICE', units='kg/m2', type2d='levsoi', & - avgflag='A', long_name='soil ice (vegetated landunits only)', & - ptr_col=data2dptr, l2g_scale_type='veg', default='inactive') - - this%h2osoi_liqice_10cm_col(begc:endc) = spval - call hist_addfld1d (fname='SOILWATER_10CM', units='kg/m2', & - avgflag='A', long_name='soil liquid water + ice in top 10cm of soil (veg landunits only)', & - ptr_col=this%h2osoi_liqice_10cm_col, set_urb=spval, set_lake=spval, l2g_scale_type='veg', default='inactive') - - this%h2osoi_liq_tot_col(begc:endc) = spval - call hist_addfld1d (fname='TOTSOILLIQ', units='kg/m2', & - avgflag='A', long_name='vertically summed soil liquid water (veg landunits only)', & - ptr_col=this%h2osoi_liq_tot_col, set_urb=spval, set_lake=spval, l2g_scale_type='veg', default='inactive') - - this%h2osoi_ice_tot_col(begc:endc) = spval - call hist_addfld1d (fname='TOTSOILICE', units='kg/m2', & - avgflag='A', long_name='vertically summed soil cie (veg landunits only)', & - ptr_col=this%h2osoi_ice_tot_col, set_urb=spval, set_lake=spval, l2g_scale_type='veg', default='inactive') - - this%h2ocan_patch(begp:endp) = spval - call hist_addfld1d (fname='H2OCAN', units='mm', & - avgflag='A', long_name='intercepted water', & - ptr_patch=this%h2ocan_patch, set_lake=0._r8, default='inactive') - - this%snocan_patch(begp:endp) = spval - call hist_addfld1d (fname='SNOCAN', units='mm', & - avgflag='A', long_name='intercepted snow', & - ptr_patch=this%snocan_patch, set_lake=0._r8, default='inactive') - - this%liqcan_patch(begp:endp) = spval - call hist_addfld1d (fname='LIQCAN', units='mm', & - avgflag='A', long_name='intercepted liquid water', & - ptr_patch=this%liqcan_patch, set_lake=0._r8, default='inactive') - - this%snounload_patch(begp:endp) = spval - call hist_addfld1d (fname='SNOUNLOAD', units='mm', & - avgflag='A', long_name='Canopy snow unloading', & - ptr_patch=this%snounload_patch, set_lake=0._r8, default='inactive') - - call hist_addfld1d (fname='H2OSNO', units='mm', & - avgflag='A', long_name='snow depth (liquid water)', & - ptr_col=this%h2osno_col, c2l_scale_type='urbanf', default='inactive') - - call hist_addfld1d (fname='H2OSNO_ICE', units='mm', & - avgflag='A', long_name='snow depth (liquid water, ice landunits only)', & - ptr_col=this%h2osno_col, c2l_scale_type='urbanf', l2g_scale_type='ice', & - default='inactive') - - this%liq1_grc(begg:endg) = spval - call hist_addfld1d (fname='LIQUID_CONTENT1', units='mm', & - avgflag='A', long_name='initial gridcell total liq content', & - ptr_lnd=this%liq1_grc, default='inactive') - - this%liq2_grc(begg:endg) = spval - call hist_addfld1d (fname='LIQUID_CONTENT2', units='mm', & - avgflag='A', long_name='post landuse change gridcell total liq content', & - ptr_lnd=this%liq2_grc, default='inactive') - - this%ice1_grc(begg:endg) = spval - call hist_addfld1d (fname='ICE_CONTENT1', units='mm', & - avgflag='A', long_name='initial gridcell total ice content', & - ptr_lnd=this%ice1_grc, default='inactive') - - this%ice2_grc(begg:endg) = spval - call hist_addfld1d (fname='ICE_CONTENT2', units='mm', & - avgflag='A', long_name='post land cover change total ice content', & - ptr_lnd=this%ice2_grc, default='inactive') - - this%h2osfc_col(begc:endc) = spval - call hist_addfld1d (fname='H2OSFC', units='mm', & - avgflag='A', long_name='surface water depth', & - ptr_col=this%h2osfc_col, default='inactive') - - this%tws_grc(begg:endg) = spval - call hist_addfld1d (fname='TWS', units='mm', & - avgflag='A', long_name='total water storage', & - ptr_lnd=this%tws_grc, default='inactive') - - ! (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. - - ! Humidity - - this%q_ref2m_patch(begp:endp) = spval - call hist_addfld1d (fname='Q2M', units='kg/kg', & - avgflag='A', long_name='2m specific humidity', & - ptr_patch=this%q_ref2m_patch, default='inactive') - - this%rh_ref2m_patch(begp:endp) = spval - call hist_addfld1d (fname='RH2M', units='%', & - avgflag='A', long_name='2m relative humidity', & - ptr_patch=this%rh_ref2m_patch, default='inactive') - - this%rh_ref2m_r_patch(begp:endp) = spval - call hist_addfld1d (fname='RH2M_R', units='%', & - avgflag='A', long_name='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='RH2M_U', units='%', & - avgflag='A', long_name='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='RHAF', units='fraction', & - avgflag='A', long_name='fractional humidity of canopy air', & - ptr_patch=this%rh_af_patch, set_spec=spval, default='inactive') - - if(use_luna)then - call hist_addfld1d (fname='RHAF10', units='fraction', & - avgflag='A', long_name='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='FH2OSFC', units='unitless', & - avgflag='A', long_name='fraction of ground covered by surface water', & - ptr_col=this%frac_h2osfc_col, default='inactive') - - this%frac_h2osfc_nosnow_col(begc:endc) = spval - call hist_addfld1d (fname='FH2OSFC_NOSNOW', units='unitless', & - avgflag='A', & - long_name='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='FSNO', units='unitless', & - avgflag='A', long_name='fraction of ground covered by snow', & - ptr_col=this%frac_sno_col, c2l_scale_type='urbanf', default='inactive') - - this%frac_sno_eff_col(begc:endc) = spval - call hist_addfld1d (fname='FSNO_EFF', units='unitless', & - avgflag='A', long_name='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='FWET', units='proportion', & - avgflag='A', long_name='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='FCANSNO', units='proportion', & - avgflag='A', long_name='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='FDRY', units='proportion', & - avgflag='A', long_name='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='FRAC_ICEOLD', units='proportion', type2d='levgrnd', & - avgflag='A', long_name='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='SNOW_DEPTH', units='m', & - avgflag='A', long_name='snow height of snow covered area', & - ptr_col=this%snow_depth_col, c2l_scale_type='urbanf', default='inactive') - - call hist_addfld1d (fname='SNOW_DEPTH_ICE', units='m', & - avgflag='A', long_name='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='SNOWDP', units='m', & - avgflag='A', long_name='gridcell mean snow height', & - ptr_col=this%snowdp_col, c2l_scale_type='urbanf', default='inactive') - - this%snowliq_col(begc:endc) = spval - call hist_addfld1d (fname='SNOWLIQ', units='kg/m2', & - avgflag='A', long_name='snow liquid water', & - ptr_col=this%snowliq_col, default='inactive') - - this%snowice_col(begc:endc) = spval - call hist_addfld1d (fname='SNOWICE', units='kg/m2', & - avgflag='A', long_name='snow ice', & - ptr_col=this%snowice_col, default='inactive') - - this%int_snow_col(begc:endc) = spval - call hist_addfld1d (fname='INT_SNOW', units='mm', & - avgflag='A', long_name='accumulated swe (vegetated landunits only)', & - ptr_col=this%int_snow_col, l2g_scale_type='veg', & - default='inactive') - - call hist_addfld1d (fname='INT_SNOW_ICE', units='mm', & - avgflag='A', long_name='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='SNOW_PERSISTENCE', units='seconds', & - avgflag='I', long_name='Length of time of continuous snow cover (nat. veg. landunits only)', & - ptr_col=this%snow_persistence_col, l2g_scale_type='natveg', default='inactive') - - if (use_cn) then - this%wf_col(begc:endc) = spval - call hist_addfld1d (fname='WF', units='proportion', & - avgflag='A', long_name='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='H2OSNO_TOP', units='kg/m2', & - avgflag='A', long_name='mass of snow in top snow layer', & - ptr_col=this%h2osno_top_col, set_urb=spval, default='inactive') - - this%snw_rds_top_col(begc:endc) = spval - call hist_addfld1d (fname='SNORDSL', units='m^-6', & - avgflag='A', long_name='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='SNOLIQFL', units='fraction', & - avgflag='A', long_name='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='SNO_EXISTENCE', units='unitless', type2d='levsno', & - avgflag='A', long_name='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='SNO_BW', units='kg/m3', type2d='levsno', & - avgflag='A', long_name='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='SNO_BW_ICE', units='kg/m3', type2d='levsno', & - avgflag='A', long_name='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='SNO_GS', units='Microns', type2d='levsno', & - avgflag='A', long_name='Mean snow grain size', & - ptr_col=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') - - call hist_addfld2d (fname='SNO_GS_ICE', units='Microns', type2d='levsno', & - avgflag='A', long_name='Mean snow grain size (ice landunits only)', & - ptr_col=data2dptr, no_snow_behavior=no_snow_normal, & - l2g_scale_type='ice', default='inactive') - - this%errh2o_col(begc:endc) = spval - call hist_addfld1d (fname='ERRH2O', units='mm', & - avgflag='A', long_name='total water conservation error', & - ptr_col=this%errh2o_col, default='inactive') - - this%errh2osno_col(begc:endc) = spval - call hist_addfld1d (fname='ERRH2OSNO', units='mm', & - avgflag='A', long_name='imbalance in snow depth (liquid water)', & - ptr_col=this%errh2osno_col, c2l_scale_type='urbanf', default='inactive') - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine InitCold(this, bounds, & - h2osno_input_col, snow_depth_input_col, watsat_col, t_soisno_col) - ! - ! !DESCRIPTION: - ! Initialize time constant variables and cold start conditions - ! - ! !USES: - use shr_const_mod , only : shr_const_pi - use shr_log_mod , only : errMsg => shr_log_errMsg - use shr_spfn_mod , only : shr_spfn_erf - 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 landunit_varcon , only : istwet, istsoil, istdlak, istcrop, istice_mec - use column_varcon , only : icol_shadewall, icol_road_perv - use column_varcon , only : icol_road_imperv, icol_roof, icol_sunwall - use clm_varcon , only : denice, denh2o, spval, sb, bdsno - use clm_varcon , only : zlnd, tfrz, spval, pc - use clm_varctl , only : fsurdat, iulog - use clm_varctl , only : use_bedrock - use spmdMod , only : masterproc - use abortutils , only : endrun - use fileutils , only : getfil - use ncdio_pio , only : file_desc_t, ncd_io - ! - ! !ARGUMENTS: - class(waterstate_type) :: this - type(bounds_type) , intent(in) :: bounds - real(r8) , intent(in) :: h2osno_input_col(bounds%begc:) - real(r8) , intent(in) :: snow_depth_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) - ! - ! !LOCAL VARIABLES: - integer :: p,c,j,l,g,lev,nlevs - real(r8) :: maxslope, slopemax, minslope - real(r8) :: d, fd, dfdd, slope0,slopebeta - real(r8) ,pointer :: std (:) - logical :: readvar - type(file_desc_t) :: ncid - character(len=256) :: locfn - real(r8) :: snowbd ! temporary calculation of snow bulk density (kg/m3) - real(r8) :: fmelt ! snowbd/100 - integer :: nbedrock - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(h2osno_input_col) == (/bounds%endc/)) , errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(snow_depth_input_col) == (/bounds%endc/)) , errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(watsat_col) == (/bounds%endc,nlevgrnd/)) , errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(t_soisno_col) == (/bounds%endc,nlevgrnd/)) , errMsg(sourcefile, __LINE__)) - - ! The first three arrays are initialized from the input argument - do c = bounds%begc,bounds%endc - this%h2osno_col(c) = h2osno_input_col(c) - this%int_snow_col(c) = h2osno_input_col(c) - this%snow_depth_col(c) = snow_depth_input_col(c) - this%snow_persistence_col(c) = 0._r8 - 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 - - do l = bounds%begl, bounds%endl - if (lun%urbpoi(l)) then - if (use_vancouver) then - this%qaf_lun(l) = 0.0111_r8 - else if (use_mexicocity) then - this%qaf_lun(l) = 0.00248_r8 - else - this%qaf_lun(l) = 1.e-4_r8 ! Arbitrary set since forc_q is not yet available - end if - end if - end do - - ! 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 - - - associate(snl => col%snl) - - this%h2osfc_col(bounds%begc:bounds%endc) = 0._r8 - this%h2ocan_patch(bounds%begp:bounds%endp) = 0._r8 - this%snocan_patch(bounds%begp:bounds%endp) = 0._r8 - this%liqcan_patch(bounds%begp:bounds%endp) = 0._r8 - this%snounload_patch(bounds%begp:bounds%endp) = 0._r8 - 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 - !-------------------------------------------- - ! 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, this%h2osno_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 * 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 (this%h2osno_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 - - !-------------------------------------------- - ! 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_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 - this%h2osoi_vol_col(c,j) = 0.15_r8 - 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 - 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 - 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 - end do - endif - do j = 1, nlevs - this%h2osoi_vol_col(c,j) = min(this%h2osoi_vol_col(c,j), watsat_col(c,j)) - 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) - 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) - endif - end do - do j = -nlevsno+1, 0 - if (j > snl(c)) then - this%h2osoi_ice_col(c,j) = col%dz(c,j)*250._r8 - 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 - do j = -nlevsno+1, 0 - if (j > snl(c)) then - this%h2osoi_ice_col(c,j) = col%dz(c,j)*bdsno - 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) - 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,nlevgrnd - 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) - 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) - endif - end if - end do - end do - - end associate - - end subroutine InitCold - - !------------------------------------------------------------------------ - subroutine Restart(this, bounds, ncid, flag, & - watsat_col) - ! - ! !DESCRIPTION: - ! Read/Write module information to/from restart file. - ! - ! !USES: - use spmdMod , only : masterproc - use clm_varcon , only : denice, denh2o, pondmx, watmin, spval, nameg - 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 - use clm_varctl , only : bound_h2osoi - use ncdio_pio , only : file_desc_t, ncd_io, ncd_double - use restUtilMod - ! - ! !ARGUMENTS: - class(waterstate_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) :: watsat_col (bounds%begc:, 1:) ! volumetric soil water at saturation (porosity) - ! - ! !LOCAL VARIABLES: - integer :: 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((ubound(watsat_col) == (/bounds%endc,nlevgrnd/)) , errMsg(sourcefile, __LINE__)) - - call restartvar(ncid=ncid, flag=flag, varname='INT_SNOW', xtype=ncd_double, & - dim1name='column', & - long_name='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='H2OSFC', xtype=ncd_double, & - dim1name='column', & - long_name='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='H2OSNO', xtype=ncd_double, & - dim1name='column', & - long_name='snow water', units='kg/m2', & - interpinic_flag='interp', readvar=readvar, data=this%h2osno_col) - - call restartvar(ncid=ncid, flag=flag, varname='H2OSOI_LIQ', xtype=ncd_double, & - dim1name='column', dim2name='levtot', switchdim=.true., & - long_name='liquid water', units='kg/m2', & - interpinic_flag='interp', readvar=readvar, data=this%h2osoi_liq_col) - - call restartvar(ncid=ncid, flag=flag, varname='H2OSOI_ICE', xtype=ncd_double, & - dim1name='column', dim2name='levtot', switchdim=.true., & - long_name='ice lens', units='kg/m2', & - interpinic_flag='interp', readvar=readvar, data=this%h2osoi_ice_col) - - call restartvar(ncid=ncid, flag=flag, varname='H2OCAN', xtype=ncd_double, & - dim1name='pft', & - long_name='canopy water', units='kg/m2', & - interpinic_flag='interp', readvar=readvar, data=this%h2ocan_patch) - - call restartvar(ncid=ncid, flag=flag, varname='SNOCAN', xtype=ncd_double, & - dim1name='pft', & - long_name='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='LIQCAN:H2OCAN', xtype=ncd_double, & - dim1name='pft', & - long_name='canopy liquid water', units='kg/m2', & - interpinic_flag='interp', readvar=readvar, data=this%liqcan_patch) - - call restartvar(ncid=ncid, flag=flag, varname='SNOUNLOAD', xtype=ncd_double, & - dim1name='pft', & - long_name='Canopy snow unloading', units='kg/m2', & - interpinic_flag='interp', readvar=readvar, data=this%snounload_patch) - - ! TWS is needed when methane is on and the TWS_inversion is used to get exact - ! restart. - call restartvar(ncid=ncid, flag=flag, varname='TWS', xtype=ncd_double, & - dim1name=nameg, & - long_name='Total Water Storage', units='mm', & - interpinic_flag='interp', readvar=readvar, data=this%tws_grc) - - if(use_luna)then - call restartvar(ncid=ncid, flag=flag, varname='rh10', xtype=ncd_double, & - dim1name='pft', long_name='10-day mean boundary layer relatie humidity', units='unitless', & - interpinic_flag='interp', readvar=readvar, data=this%rh10_af_patch) - endif - - ! 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 - - call restartvar(ncid=ncid, flag=flag, varname='FH2OSFC', xtype=ncd_double, & - dim1name='column',& - long_name='fraction of ground covered by h2osfc (0 to 1)', units='', & - interpinic_flag='interp', readvar=readvar, data=this%frac_h2osfc_col) - if (flag == 'read' .and. .not. readvar) then - this%frac_h2osfc_col(bounds%begc:bounds%endc) = 0.0_r8 - end if - - call restartvar(ncid=ncid, flag=flag, varname='SNOW_DEPTH', xtype=ncd_double, & - dim1name='column', & - long_name='snow depth', units='m', & - interpinic_flag='interp', readvar=readvar, data=this%snow_depth_col) - - call restartvar(ncid=ncid, flag=flag, varname='SNOW_PERS', xtype=ncd_double, & - dim1name='column', & - long_name='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 - - call restartvar(ncid=ncid, flag=flag, varname='frac_sno_eff', xtype=ncd_double, & - dim1name='column', & - long_name='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='frac_sno', xtype=ncd_double, & - dim1name='column', & - long_name='fraction of ground covered by snow (0 to 1)',units='unitless',& - interpinic_flag='interp', readvar=readvar, data=this%frac_sno_col) - - call restartvar(ncid=ncid, flag=flag, varname='FWET', xtype=ncd_double, & - dim1name='pft', & - long_name='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='FCANSNO', xtype=ncd_double, & - dim1name='pft', & - long_name='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='snw_rds', xtype=ncd_double, & - dim1name='column', dim2name='levsno', switchdim=.true., lowerb2=-nlevsno+1, upperb2=0, & - long_name='snow layer effective radius', units='um', & - interpinic_flag='interp', readvar=readvar, data=this%snw_rds_col) - if (flag == 'read' .and. .not. readvar) then - - ! initial run, not restart: initialize snw_rds - 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. Initialize snow " // & - "effective radius to fresh snow value, and snow/aerosol masses to zero." - endif - - do c= bounds%begc, bounds%endc - if (col%snl(c) < 0) then - this%snw_rds_col(c,col%snl(c)+1:0) = snw_rds_min - this%snw_rds_col(c,-nlevsno+1:col%snl(c)) = 0._r8 - this%snw_rds_top_col(c) = snw_rds_min - this%sno_liq_top_col(c) = this%h2osoi_liq_col(c,col%snl(c)+1) / & - (this%h2osoi_liq_col(c,col%snl(c)+1)+this%h2osoi_ice_col(c,col%snl(c)+1)) - elseif (this%h2osno_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 - enddo - endif - - call restartvar(ncid=ncid, flag=flag, varname='qaf', xtype=ncd_double, dim1name='landunit', & - long_name='urban canopy specific humidity', units='kg/kg', & - interpinic_flag='interp', readvar=readvar, data=this%qaf_lun) - - if (use_cn) then - call restartvar(ncid=ncid, flag=flag, varname='wf', xtype=ncd_double, & - dim1name='column', & - long_name='', units='', & - interpinic_flag='interp', readvar=readvar, data=this%wf_col) - end if - - - - end subroutine Restart - - !----------------------------------------------------------------------- - subroutine Reset(this, column) - ! - ! !DESCRIPTION: - ! Intitialize SNICAR variables for fresh snow column - ! - ! !ARGUMENTS: - class(waterstate_type) :: this - integer , intent(in) :: column ! column index - !----------------------------------------------------------------------- - - this%snw_rds_col(column,0) = snw_rds_min - - end subroutine Reset - -end module WaterstateType diff --git a/src/biogeophys/WaterfluxType.F90 b/src/biogeophys/WaterfluxType.F90 deleted file mode 100644 index 5541ab39..00000000 --- a/src/biogeophys/WaterfluxType.F90 +++ /dev/null @@ -1,721 +0,0 @@ -module WaterfluxType - - !------------------------------------------------------------------------------ - ! !DESCRIPTION: - ! - ! !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 LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch - use CNSharedParamsMod , only : use_fun - ! - implicit none - private - ! - ! !PUBLIC TYPES: - type, public :: waterflux_type - - ! water fluxes are in units or mm/s - - real(r8), pointer :: qflx_prec_grnd_patch (:) ! patch water onto ground including canopy runoff [kg/(m2 s)] - real(r8), pointer :: qflx_prec_grnd_col (:) ! col water onto ground including canopy runoff [kg/(m2 s)] - real(r8), pointer :: qflx_rain_grnd_patch (:) ! patch rain on ground after interception (mm H2O/s) [+] - real(r8), pointer :: qflx_rain_grnd_col (:) ! col rain on ground after interception (mm H2O/s) [+] - real(r8), pointer :: qflx_snow_grnd_patch (:) ! patch snow 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_sub_snow_patch (:) ! patch sublimation rate from snow pack (mm H2O /s) [+] - real(r8), pointer :: qflx_sub_snow_col (:) ! col sublimation rate from snow pack (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_evap_grnd_patch (:) ! patch ground surface evaporation rate (mm H2O/s) [+] - real(r8), pointer :: qflx_evap_grnd_col (:) ! col ground surface evaporation rate (mm H2O/s) [+] - real(r8), pointer :: qflx_phs_neg_col (:) ! col sum of negative hydraulic redistribution fluxes (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_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_dew_snow_patch (:) ! patch surface dew added to snow pack (mm H2O /s) [+] - real(r8), pointer :: qflx_dew_snow_col (:) ! col surface dew added to snow pack (mm H2O /s) [+] - real(r8), pointer :: qflx_dew_grnd_patch (:) ! patch ground surface dew formation (mm H2O /s) [+] - real(r8), pointer :: qflx_dew_grnd_col (:) ! col ground surface dew formation (mm H2O /s) [+] (+ = to atm); usually eflx_bot >= 0) - real(r8), pointer :: qflx_prec_intr_patch (:) ! patch interception of precipitation [mm/s] - real(r8), pointer :: qflx_prec_intr_col (:) ! col interception of precipitation [mm/s] - real(r8), pointer :: qflx_snowindunload_patch (:) ! patch canopy snow wind unloading (mm H2O /s) - real(r8), pointer :: qflx_snowindunload_col (:) ! col 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_snotempunload_col (:) ! col 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_infl_col (:) ! col infiltration (mm H2O /s) - real(r8), pointer :: qflx_surf_col (:) ! col surface runoff (mm H2O /s) - real(r8), pointer :: qflx_drain_col (:) ! col sub-surface runoff (mm H2O /s) - real(r8), pointer :: qflx_top_soil_col (:) ! col net water input into soil from top (mm/s) - real(r8), pointer :: qflx_h2osfc_to_ice_col (:) ! col conversion of h2osfc to ice - real(r8), pointer :: qflx_h2osfc_surf_col (:) ! col surface water runoff - real(r8), pointer :: qflx_snow_h2osfc_col (:) ! col snow falling on surface water - real(r8), pointer :: qflx_drain_perched_col (:) ! col sub-surface runoff from perched wt (mm H2O /s) - real(r8), pointer :: qflx_deficit_col (:) ! col water deficit to keep non-negative liquid water content (mm H2O) - 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_snomelt_lyr_col (:,:) ! col snow melt in each layer (mm H2O /s) - real(r8), pointer :: qflx_snow_drain_col (:) ! col drainage from snow pack - 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_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_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_drain_vr_col (:,:) ! col liquid water losted as drainage (m /time step) - real(r8), pointer :: snow_sources_col (:) ! col snow sources (mm H2O/s) - real(r8), pointer :: snow_sinks_col (:) ! col snow sinks (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 - - ! ET accumulation - real(r8), pointer :: AnnEt (:) ! Annual average ET flux mmH20/s - - - 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 waterflux_type - !------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, bounds) - - class(waterflux_type) :: this - type(bounds_type), intent(in) :: bounds - - call this%InitAllocate(bounds) ! same as "call initAllocate_type(hydro, bounds)" - call this%InitHistory(bounds) - call this%InitCold(bounds) - - end subroutine Init - - !------------------------------------------------------------------------ - subroutine InitAllocate(this, bounds) - ! - ! !DESCRIPTION: - ! Initialize module data structure - ! - ! !USES: - ! - ! !ARGUMENTS: - class(waterflux_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%qflx_prec_intr_patch (begp:endp)) ; this%qflx_prec_intr_patch (:) = nan - allocate(this%qflx_prec_grnd_patch (begp:endp)) ; this%qflx_prec_grnd_patch (:) = nan - allocate(this%qflx_rain_grnd_patch (begp:endp)) ; this%qflx_rain_grnd_patch (:) = nan - allocate(this%qflx_snow_grnd_patch (begp:endp)) ; this%qflx_snow_grnd_patch (:) = nan - allocate(this%qflx_sub_snow_patch (begp:endp)) ; this%qflx_sub_snow_patch (:) = 0.0_r8 - allocate(this%qflx_tran_veg_patch (begp:endp)) ; this%qflx_tran_veg_patch (:) = nan - - allocate(this%qflx_snowindunload_patch (begp:endp)) ; this%qflx_snowindunload_patch (:) = nan - allocate(this%qflx_snowindunload_col (begp:endp)) ; this%qflx_snowindunload_col (:) = nan - allocate(this%qflx_snotempunload_patch (begp:endp)) ; this%qflx_snotempunload_patch (:) = nan - allocate(this%qflx_snotempunload_col (begp:endp)) ; this%qflx_snotempunload_col (:) = nan - - allocate(this%qflx_dew_grnd_patch (begp:endp)) ; this%qflx_dew_grnd_patch (:) = nan - allocate(this%qflx_dew_snow_patch (begp:endp)) ; this%qflx_dew_snow_patch (:) = nan - - allocate(this%qflx_prec_intr_col (begc:endc)) ; this%qflx_prec_intr_col (:) = nan - allocate(this%qflx_prec_grnd_col (begc:endc)) ; this%qflx_prec_grnd_col (:) = nan - allocate(this%qflx_rain_grnd_col (begc:endc)) ; this%qflx_rain_grnd_col (:) = nan - allocate(this%qflx_snow_grnd_col (begc:endc)) ; this%qflx_snow_grnd_col (:) = nan - allocate(this%qflx_sub_snow_col (begc:endc)) ; this%qflx_sub_snow_col (:) = 0.0_r8 - allocate(this%qflx_snwcp_liq_col (begc:endc)) ; this%qflx_snwcp_liq_col (:) = nan - allocate(this%qflx_snwcp_ice_col (begc:endc)) ; this%qflx_snwcp_ice_col (:) = nan - allocate(this%qflx_snwcp_discarded_liq_col(begc:endc)) ; this%qflx_snwcp_discarded_liq_col(:) = nan - allocate(this%qflx_snwcp_discarded_ice_col(begc:endc)) ; this%qflx_snwcp_discarded_ice_col(:) = nan - allocate(this%qflx_tran_veg_col (begc:endc)) ; this%qflx_tran_veg_col (:) = nan - allocate(this%qflx_evap_veg_col (begc:endc)) ; this%qflx_evap_veg_col (:) = nan - allocate(this%qflx_evap_can_col (begc:endc)) ; this%qflx_evap_can_col (:) = nan - allocate(this%qflx_evap_soi_col (begc:endc)) ; this%qflx_evap_soi_col (:) = nan - allocate(this%qflx_evap_tot_col (begc:endc)) ; this%qflx_evap_tot_col (:) = nan - allocate(this%qflx_evap_grnd_col (begc:endc)) ; this%qflx_evap_grnd_col (:) = nan - allocate(this%qflx_dew_grnd_col (begc:endc)) ; this%qflx_dew_grnd_col (:) = nan - allocate(this%qflx_dew_snow_col (begc:endc)) ; this%qflx_dew_snow_col (:) = nan - allocate(this%qflx_evap_veg_patch (begp:endp)) ; this%qflx_evap_veg_patch (:) = nan - allocate(this%qflx_evap_can_patch (begp:endp)) ; this%qflx_evap_can_patch (:) = nan - allocate(this%qflx_evap_soi_patch (begp:endp)) ; this%qflx_evap_soi_patch (:) = nan - allocate(this%qflx_evap_tot_patch (begp:endp)) ; this%qflx_evap_tot_patch (:) = nan - allocate(this%qflx_evap_grnd_patch (begp:endp)) ; this%qflx_evap_grnd_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_infl_col (begc:endc)) ; this%qflx_infl_col (:) = nan - allocate(this%qflx_surf_col (begc:endc)) ; this%qflx_surf_col (:) = nan - allocate(this%qflx_drain_col (begc:endc)) ; this%qflx_drain_col (:) = nan - allocate(this%qflx_top_soil_col (begc:endc)) ; this%qflx_top_soil_col (:) = nan - allocate(this%qflx_h2osfc_to_ice_col (begc:endc)) ; this%qflx_h2osfc_to_ice_col (:) = nan - allocate(this%qflx_h2osfc_surf_col (begc:endc)) ; this%qflx_h2osfc_surf_col (:) = nan - allocate(this%qflx_snow_h2osfc_col (begc:endc)) ; this%qflx_snow_h2osfc_col (:) = nan - allocate(this%qflx_snomelt_col (begc:endc)) ; this%qflx_snomelt_col (:) = nan - allocate(this%qflx_snomelt_lyr_col (begc:endc,-nlevsno+1:0)) ; this%qflx_snomelt_lyr_col (:,:) = nan - allocate(this%qflx_snow_drain_col (begc:endc)) ; this%qflx_snow_drain_col (:) = nan - allocate(this%qflx_snofrz_col (begc:endc)) ; this%qflx_snofrz_col (:) = nan - allocate(this%qflx_snofrz_lyr_col (begc:endc,-nlevsno+1:0)) ; this%qflx_snofrz_lyr_col (:,:) = nan - allocate(this%qflx_qrgwl_col (begc:endc)) ; this%qflx_qrgwl_col (:) = nan - allocate(this%qflx_drain_perched_col (begc:endc)) ; this%qflx_drain_perched_col (:) = nan - allocate(this%qflx_deficit_col (begc:endc)) ; this%qflx_deficit_col (:) = nan - allocate(this%qflx_floodc_col (begc:endc)) ; this%qflx_floodc_col (:) = nan - allocate(this%qflx_sl_top_soil_col (begc:endc)) ; this%qflx_sl_top_soil_col (:) = nan - allocate(this%qflx_runoff_col (begc:endc)) ; this%qflx_runoff_col (:) = nan - allocate(this%qflx_runoff_r_col (begc:endc)) ; this%qflx_runoff_r_col (:) = nan - allocate(this%qflx_runoff_u_col (begc:endc)) ; this%qflx_runoff_u_col (:) = nan - allocate(this%qflx_ice_runoff_snwcp_col(begc:endc)) ; this%qflx_ice_runoff_snwcp_col(:) = nan - allocate(this%qflx_ice_runoff_xs_col (begc:endc)) ; this%qflx_ice_runoff_xs_col (:) = nan - allocate(this%qflx_rsub_sat_col (begc:endc)) ; this%qflx_rsub_sat_col (:) = nan - allocate(this%snow_sources_col (begc:endc)) ; this%snow_sources_col (:) = nan - allocate(this%snow_sinks_col (begc:endc)) ; this%snow_sinks_col (:) = nan - - allocate(this%qflx_liq_dynbal_grc (begg:endg)) ; this%qflx_liq_dynbal_grc (:) = nan - allocate(this%qflx_ice_dynbal_grc (begg:endg)) ; this%qflx_ice_dynbal_grc (:) = nan - allocate(this%AnnET (begc:endc)) ; this%AnnET (:) = nan - - end subroutine InitAllocate - - !------------------------------------------------------------------------ - subroutine InitHistory(this, bounds) - ! - ! !USES: - use clm_varctl , only : use_cn - use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal - ! - ! !ARGUMENTS: - class(waterflux_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begp, endp - integer :: begc, endc - integer :: begg, endg - 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 - begg = bounds%begg; endg= bounds%endg - - this%qflx_top_soil_col(begc:endc) = spval - call hist_addfld1d (fname='QTOPSOIL', units='mm/s', & - avgflag='A', long_name='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='QINFL', units='mm/s', & - avgflag='A', long_name='infiltration', & - ptr_col=this%qflx_infl_col, c2l_scale_type='urbanf', default='inactive') - - this%qflx_surf_col(begc:endc) = spval - call hist_addfld1d (fname='QOVER', units='mm/s', & - avgflag='A', long_name='surface runoff', & - ptr_col=this%qflx_surf_col, c2l_scale_type='urbanf', default='inactive') - - this%qflx_qrgwl_col(begc:endc) = spval - call hist_addfld1d (fname='QRGWL', units='mm/s', & - avgflag='A', & - long_name='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', default='inactive') - - this%qflx_drain_col(begc:endc) = spval - call hist_addfld1d (fname='QDRAI', units='mm/s', & - avgflag='A', long_name='sub-surface drainage', & - ptr_col=this%qflx_drain_col, c2l_scale_type='urbanf', default='inactive') - - this%qflx_liq_dynbal_grc(begg:endg) = spval - call hist_addfld1d (fname='QFLX_LIQ_DYNBAL', units='mm/s', & - avgflag='A', long_name='liq dynamic land cover change conversion runoff flux', & - ptr_lnd=this%qflx_liq_dynbal_grc, default='inactive') - - this%qflx_ice_dynbal_grc(begg:endg) = spval - call hist_addfld1d (fname='QFLX_ICE_DYNBAL', units='mm/s', & - avgflag='A', long_name='ice dynamic land cover change conversion runoff flux', & - ptr_lnd=this%qflx_ice_dynbal_grc, default='inactive') - - this%qflx_runoff_col(begc:endc) = spval - call hist_addfld1d (fname='QRUNOFF', units='mm/s', & - avgflag='A', & - long_name='total liquid runoff not including correction for land use change', & - ptr_col=this%qflx_runoff_col, c2l_scale_type='urbanf', default='inactive') - - call hist_addfld1d (fname='QRUNOFF_ICE', units='mm/s', avgflag='A', & - long_name='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', default='inactive') - - this%qflx_runoff_u_col(begc:endc) = spval - call hist_addfld1d (fname='QRUNOFF_U', units='mm/s', & - avgflag='A', long_name='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='QRUNOFF_R', units='mm/s', & - avgflag='A', long_name='Rural total runoff', & - ptr_col=this%qflx_runoff_r_col, set_spec=spval, default='inactive') - - this%qflx_snow_drain_col(begc:endc) = spval - call hist_addfld1d (fname='QFLX_SNOW_DRAIN', units='mm/s', & - avgflag='A', long_name='drainage from snow pack', & - ptr_col=this%qflx_snow_drain_col, c2l_scale_type='urbanf', default='inactive') - - call hist_addfld1d (fname='QFLX_SNOW_DRAIN_ICE', units='mm/s', & - avgflag='A', long_name='drainage from snow pack melt (ice landunits only)', & - ptr_col=this%qflx_snow_drain_col, c2l_scale_type='urbanf', l2g_scale_type='ice', default='inactive') - - this%qflx_snomelt_col(begc:endc) = spval - call hist_addfld1d (fname='QSNOMELT', units='mm/s', & - avgflag='A', long_name='snow melt rate', & - ptr_col=this%qflx_snomelt_col, c2l_scale_type='urbanf', default='inactive') - - call hist_addfld1d (fname='QSNOMELT_ICE', units='mm/s', & - avgflag='A', long_name='snow melt (ice landunits only)', & - ptr_col=this%qflx_snomelt_col, c2l_scale_type='urbanf', l2g_scale_type='ice', default='inactive') - - 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='SNO_MELT', units='mm/s', type2d='levsno', & - avgflag='A', long_name='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='SNO_MELT_ICE', units='mm/s', type2d='levsno', & - avgflag='A', long_name='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') - - this%qflx_snofrz_col(begc:endc) = spval - call hist_addfld1d (fname='QSNOFRZ', units='kg/m2/s', & - avgflag='A', long_name='column-integrated snow freezing rate', & - ptr_col=this%qflx_snofrz_col, set_lake=spval, c2l_scale_type='urbanf', default='inactive') - - call hist_addfld1d (fname='QSNOFRZ_ICE', units='mm/s', & - avgflag='A', long_name='column-integrated snow freezing rate (ice landunits only)', & - ptr_col=this%qflx_snofrz_col, c2l_scale_type='urbanf', l2g_scale_type='ice', default='inactive') - - 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='SNO_FRZ', units='kg/m2/s', type2d='levsno', & - avgflag='A', long_name='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='SNO_FRZ_ICE', units='mm/s', type2d='levsno', & - avgflag='A', long_name='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_h2osfc_to_ice_col(begc:endc) = spval - call hist_addfld1d (fname='QH2OSFC_TO_ICE', units='mm/s', & - avgflag='A', long_name='surface water converted to ice', & - ptr_col=this%qflx_h2osfc_to_ice_col, default='inactive') - - this%qflx_prec_intr_patch(begp:endp) = spval - call hist_addfld1d (fname='QINTR', units='mm/s', & - avgflag='A', long_name='interception', & - ptr_patch=this%qflx_prec_intr_patch, set_lake=0._r8, default='inactive') - - this%qflx_prec_grnd_patch(begp:endp) = spval - call hist_addfld1d (fname='QDRIP', units='mm/s', & - avgflag='A', long_name='throughfall', & - ptr_patch=this%qflx_prec_grnd_patch, c2l_scale_type='urbanf', default='inactive') - - this%qflx_evap_soi_patch(begp:endp) = spval - call hist_addfld1d (fname='QSOIL', units='mm/s', & - avgflag='A', long_name= 'Ground evaporation (soil/snow evaporation + soil/snow sublimation - dew)', & - ptr_patch=this%qflx_evap_soi_patch, c2l_scale_type='urbanf', default='inactive') - - call hist_addfld1d (fname='QSOIL_ICE', units='mm/s', & - avgflag='A', long_name='Ground evaporation (ice landunits only)', & - ptr_patch=this%qflx_evap_soi_patch, c2l_scale_type='urbanf', l2g_scale_type='ice', default='inactive') - - call hist_addfld2d (fname='QROOTSINK', units='mm/s', type2d='levsoi', & - avgflag='A', long_name='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_evap_can_patch(begp:endp) = spval - call hist_addfld1d (fname='QVEGE', units='mm/s', & - avgflag='A', long_name='canopy evaporation', & - ptr_patch=this%qflx_evap_can_patch, set_lake=0._r8, c2l_scale_type='urbanf', default='inactive') - - this%qflx_tran_veg_patch(begp:endp) = spval - call hist_addfld1d (fname='QVEGT', units='mm/s', & - avgflag='A', long_name='canopy transpiration', & - ptr_patch=this%qflx_tran_veg_patch, set_lake=0._r8, c2l_scale_type='urbanf', default='inactive') - - this%qflx_ev_snow_patch(begp:endp) = spval - call hist_addfld1d (fname='QSNOEVAP', units='mm/s', & - avgflag='A', long_name='evaporation from snow', & - ptr_patch=this%qflx_tran_veg_patch, set_lake=0._r8, c2l_scale_type='urbanf', default='inactive') - - this%qflx_snowindunload_patch(begp:endp) = spval - call hist_addfld1d (fname='QSNO_WINDUNLOAD', units='mm/s', & - avgflag='A', long_name='canopy snow wind unloading', & - ptr_patch=this%qflx_snowindunload_patch, set_lake=0._r8, c2l_scale_type='urbanf', default='inactive') - - this%qflx_snotempunload_patch(begp:endp) = spval - call hist_addfld1d (fname='QSNO_TEMPUNLOAD', units='mm/s', & - avgflag='A', long_name='canopy snow temp unloading', & - ptr_patch=this%qflx_snotempunload_patch, set_lake=0._r8, c2l_scale_type='urbanf', default='inactive') - - this%qflx_snwcp_liq_col(begc:endc) = spval - call hist_addfld1d (fname='QSNOCPLIQ', units='mm H2O/s', & - avgflag='A', long_name='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', default='inactive') - - this%qflx_snwcp_ice_col(begc:endc) = spval - call hist_addfld1d (fname='QSNWCPICE', units='mm H2O/s', & - avgflag='A', long_name='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', default='inactive') - - this%qflx_rain_grnd_patch(begp:endp) = spval - call hist_addfld1d (fname='QFLX_RAIN_GRND', units='mm H2O/s', & - avgflag='A', long_name='rain on ground after interception', & - ptr_patch=this%qflx_rain_grnd_patch, default='inactive', c2l_scale_type='urbanf') - - this%qflx_snow_grnd_patch(begp:endp) = spval - call hist_addfld1d (fname='QFLX_SNOW_GRND', units='mm H2O/s', & - avgflag='A', long_name='snow on ground after interception', & - ptr_patch=this%qflx_snow_grnd_patch, default='inactive', c2l_scale_type='urbanf') - - this%qflx_evap_grnd_patch(begp:endp) = spval - call hist_addfld1d (fname='QFLX_EVAP_GRND', units='mm H2O/s', & - avgflag='A', long_name='ground surface evaporation', & - ptr_patch=this%qflx_evap_grnd_patch, default='inactive', c2l_scale_type='urbanf') - - this%qflx_evap_veg_patch(begp:endp) = spval - call hist_addfld1d (fname='QFLX_EVAP_VEG', units='mm H2O/s', & - avgflag='A', long_name='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='QFLX_EVAP_TOT', units='mm H2O/s', & - avgflag='A', long_name='qflx_evap_soi + qflx_evap_can + qflx_tran_veg', & - ptr_patch=this%qflx_evap_tot_patch, c2l_scale_type='urbanf', default='inactive') - - this%qflx_dew_grnd_patch(begp:endp) = spval - call hist_addfld1d (fname='QFLX_DEW_GRND', units='mm H2O/s', & - avgflag='A', long_name='ground surface dew formation', & - ptr_patch=this%qflx_dew_grnd_patch, c2l_scale_type='urbanf', default='inactive') - - this%qflx_sub_snow_patch(begp:endp) = spval - call hist_addfld1d (fname='QFLX_SUB_SNOW', units='mm H2O/s', & - avgflag='A', long_name='sublimation rate from snow pack', & - ptr_patch=this%qflx_sub_snow_patch, c2l_scale_type='urbanf', default='inactive') - - this%qflx_dew_snow_patch(begp:endp) = spval - call hist_addfld1d (fname='QFLX_DEW_SNOW', units='mm H2O/s', & - avgflag='A', long_name='surface dew added to snow pacK', & - ptr_patch=this%qflx_dew_snow_patch, c2l_scale_type='urbanf', default='inactive') - - this%qflx_h2osfc_surf_col(begc:endc) = spval - call hist_addfld1d (fname='QH2OSFC', units='mm/s', & - avgflag='A', long_name='surface water runoff', & - ptr_col=this%qflx_h2osfc_surf_col, default='inactive') - - this%qflx_drain_perched_col(begc:endc) = spval - call hist_addfld1d (fname='QDRAI_PERCH', units='mm/s', & - avgflag='A', long_name='perched wt drainage', & - ptr_col=this%qflx_drain_perched_col, c2l_scale_type='urbanf', default='inactive') - - this%qflx_rsub_sat_col(begc:endc) = spval - call hist_addfld1d (fname='QDRAI_XS', units='mm/s', & - avgflag='A', long_name='saturation excess drainage', & - ptr_col=this%qflx_rsub_sat_col, c2l_scale_type='urbanf', default='inactive') - - this%qflx_phs_neg_col(begc:endc) = spval - call hist_addfld1d (fname='QPHSNEG', units='mm/s', & - avgflag='A', long_name='net negative hydraulic redistribution flux', & - ptr_col=this%qflx_phs_neg_col, default='inactive') - - ! As defined here, snow_sources - snow_sinks will equal the change in h2osno at any - ! given time step but only if there is at least one snow layer (for all landunits - ! except lakes). Also note that monthly average files of snow_sources and snow_sinks - ! sinks must be weighted by number of days in the month to diagnose, for example, an - ! annual value of the change in h2osno. - - this%snow_sources_col(begc:endc) = spval - call hist_addfld1d (fname='SNOW_SOURCES', units='mm/s', & - avgflag='A', long_name='snow sources (liquid water)', & - ptr_col=this%snow_sources_col, c2l_scale_type='urbanf', default='inactive') - - this%snow_sinks_col(begc:endc) = spval - call hist_addfld1d (fname='SNOW_SINKS', units='mm/s', & - avgflag='A', long_name='snow sinks (liquid water)', & - ptr_col=this%snow_sinks_col, c2l_scale_type='urbanf', default='inactive') - - this%AnnET(begc:endc) = spval - call hist_addfld1d (fname='AnnET', units='mm/s', & - avgflag='A', long_name='Annual ET', & - ptr_col=this%AnnET, c2l_scale_type='urbanf', default='inactive') - - 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(waterflux_type) :: 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(waterflux_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() - - if (use_fun) then - call extract_accum_field ('AnnET', rbufslp, nstep) - this%qflx_evap_tot_col(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(waterflux_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 :: 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 InitCold(this, bounds) - ! - ! !USES: - use landunit_varcon, only : istsoil, istcrop - ! - ! !ARGUMENTS: - class(waterflux_type) :: this - type(bounds_type) , intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: p,c,l - !----------------------------------------------------------------------- - - this%qflx_evap_grnd_patch(bounds%begp:bounds%endp) = 0.0_r8 - this%qflx_dew_grnd_patch (bounds%begp:bounds%endp) = 0.0_r8 - this%qflx_dew_snow_patch (bounds%begp:bounds%endp) = 0.0_r8 - - this%qflx_evap_grnd_col(bounds%begc:bounds%endc) = 0.0_r8 - this%qflx_dew_grnd_col (bounds%begc:bounds%endc) = 0.0_r8 - this%qflx_dew_snow_col (bounds%begc:bounds%endc) = 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 - 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 - - this%AnnEt(bounds%begc:bounds%endc) = 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) :: 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='qflx_snofrz_lyr', xtype=ncd_double, & - dim1name='column', dim2name='levsno', switchdim=.true., lowerb2=-nlevsno+1, upperb2=0, & - long_name='snow layer ice freezing rate', units='kg m-2 s-1', & - interpinic_flag='interp', readvar=readvar, data=this%qflx_snofrz_lyr_col) - if (flag == 'read' .and. .not. readvar) then - ! initial run, not restart: initialize qflx_snofrz_lyr to zero - this%qflx_snofrz_lyr_col(bounds%begc:bounds%endc,-nlevsno+1:0) = 0._r8 - endif - - call restartvar(ncid=ncid, flag=flag, varname='qflx_snow_drain:qflx_snow_melt', xtype=ncd_double, & - dim1name='column', & - long_name='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 restartvar(ncid=ncid, flag=flag, varname='AnnET', xtype=ncd_double, & - dim1name='column', & - long_name='Annual ET ', units='mm/s', & - interpinic_flag='interp', readvar=readvar, data=this%AnnET) - if (flag == 'read' .and. .not. readvar) then - ! initial run, not restart: initialize qflx_snow_drain to zero - this%AnnET(bounds%begc:bounds%endc) = 0._r8 - endif - - end subroutine Restart - -end module WaterfluxType diff --git a/src/main/mml_main.F90 b/src/biogeophys/mml_main.F90 similarity index 65% rename from src/main/mml_main.F90 rename to src/biogeophys/mml_main.F90 index f35cf64e..b5b89b6b 100644 --- a/src/main/mml_main.F90 +++ b/src/biogeophys/mml_main.F90 @@ -20,9 +20,12 @@ module mml_mainMod ! !USES: +#include "shr_assert.h" ! MML: bounds & data type +#include "shr_assert.h" use decompMod , only : bounds_type use spmdMod , only : masterproc + use shr_sys_mod, only : shr_sys_flush use atm2lndType, only : atm2lnd_type use lnd2atmType, only : lnd2atm_type ! MML: probably going to need a lnd2atm type ! to hand to the coupler as data coming from the land going to the atmosphere (l2x) @@ -37,11 +40,12 @@ module mml_mainMod use shr_kind_mod , only : r8 => shr_kind_r8 use shr_infnan_mod , only : isnan => shr_infnan_isnan - use QSatMod , only : QSat + use QSatMod , only : QSatOld use perf_mod ! for t_startf and t_stopf ! For using month-dependent values from forcing files - use clm_time_manager, only : get_curr_date, get_nstep, get_step_size + use clm_time_manager, only : get_curr_date, is_beg_curr_day, get_step_size + use clm_time_manager, only : is_first_step_of_this_run_segment ! For namelist var use clm_varctl , only: mml_surdat @@ -78,9 +82,10 @@ module mml_mainMod ! private :: satvap ! calculate saturation vapour pressure and deriv at given Ts ! oops, this was an old polynomial (just have looked at Gordon's old LSM code to figure out fortran polynomials, ! then used those coeffs instead of the more recent one!) Instead, I'm using the equivalent, but newer, clm - ! function QSat, and doing the lhflx calculations with specific humidity rather than saturation vapour pressure + ! function QSatOld, and doing the lhflx calculations with specific humidity rather than saturation vapour pressure - + character(len=*), parameter, private :: sourcefile = & + __FILE__ contains @@ -89,8 +94,9 @@ subroutine readnml_datasets( NLFilename ) use shr_mpi_mod , only : shr_mpi_bcast use spmdMod , only : mpicom use clm_nlUtilsMod , only : find_nlgroup_name - use clm_varctl , only : finidat, fatmlndfrc, finidat_interp_dest + use clm_varctl , only : finidat, fatmlndfrc, finidat_interp_dest, nsrest use clm_varctl , only : nrevsn, fname_len, mml_surdat, finidat_interp_source + use clm_varctl , only : nsrStartup, nsrContinue, nsrBranch implicit none @@ -141,16 +147,41 @@ subroutine readnml_datasets( NLFilename ) end if if (fatmlndfrc == ' ') then - write(iulog,*) ' fatmlndfrc not set, setting frac/mask to 1' + call endrun(subname // ':: ERROR fatmlndfrc was NOT set and needs to be' ) else write(iulog,*) ' land frac data = ',trim(fatmlndfrc) end if if (mml_surdat == ' ') then - write(iulog,*) ' mml_surdat NOT set, check that we are using the default' + call endrun(subname // ':: ERROR mml_surdat was NOT set and needs to be' ) else write(iulog,*) ' mml_surdat IS set, and = ',trim(mml_surdat) end if + + if (nsrest == nsrBranch .and. nrevsn == ' ') then + call endrun(msg=' ERROR: need to set restart data file name'//& + errMsg(sourcefile, __LINE__)) + end if + ! Consistency settings for nrevsn + + if (nsrest == nsrStartup ) nrevsn = ' ' + if (nsrest == nsrContinue) nrevsn = 'set by restart pointer file file' + if (nsrest /= nsrStartup .and. nsrest /= nsrContinue .and. nsrest /= nsrBranch ) then + call endrun(msg=' ERROR: nsrest NOT set to a valid value'//& + errMsg(sourcefile, __LINE__)) + end if + if (nsrest == nsrStartup) then + if (finidat /= ' ') then + write(iulog,*) ' initial data: ', trim(finidat) + else if (finidat_interp_source /= ' ') then + write(iulog,*) ' initial data interpolated from: ', trim(finidat_interp_source) + else + write(iulog,*) ' initial data created by model (cold start)' + end if + else + write(iulog,*) ' restart data = ',trim(nrevsn) + end if + end if end subroutine readnml_datasets @@ -196,6 +227,7 @@ end subroutine apply_use_init_interp !----------------------------------------------------------------------- subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst + use clm_varpar, only : numrad implicit none type(bounds_type), intent(in) :: bounds @@ -251,7 +283,6 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst 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) real(r8) :: dt ! length of time step, in seconds @@ -285,9 +316,6 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst !emiss(bounds%begg:bounds%endg) , & ! emissivity, from .nc file !glc_mask(bounds%begg:bounds%endg) , & ! mask on glaciated points (1 = glacier, 0 = not), from .nc file (aiming for greenalnd + antarctica) !dust(bounds%begg:bounds%endg,4) , & ! dust flux, land to atm, from .nc file lat x lon x 3 dust bins - zref_t(bounds%begg:bounds%endg) , & ! reference height temperature for lnd2atm - zref_u(bounds%begg:bounds%endg) , & ! reference height wind speed for lnd2atm - zref_q(bounds%begg:bounds%endg) , & ! reference height humidity for lnd2atm lwrad(bounds%begg:bounds%endg) , & ! incoming longwave radiation from atm lw_abs(bounds%begg:bounds%endg) , & ! absorbed longwave radiation (emissivity*incoming) lambda(bounds%begg:bounds%endg) , & ! latent heat of vaporization, or fusion, depending on phase @@ -327,9 +355,7 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst zeta(bounds%begg:bounds%endg) ! For the lhflx limitation - real(r8) :: pbot(bounds%begg:bounds%endg) , & ! [Pa] midpoint of bottom layer (from atm) - p2(bounds%begg:bounds%endg) , & ! [Pa] top boundary of bottom layer (calculate using hybrid coords) - qbot(bounds%begg:bounds%endg) , & ! [kg/kg] specific humidity in lowest level of atm (check units?) + real(r8) :: p2(bounds%begg:bounds%endg), & ! [Pa] top boundary of bottom layer (calculate using hybrid coords) dpbot(bounds%begg:bounds%endg) , & ! thickness in pressure of bottom layer, approximating as dpbot = 2*(psrf-pbot) q_avail(bounds%begg:bounds%endg) , & ! water available in lowest level lh_avail(bounds%begg:bounds%endg) , & ! latent heat available in lowest level @@ -349,8 +375,6 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst dtsoi(bounds%begg:bounds%endg,10) , & cp(bounds%begg:bounds%endg,10) , & dp(bounds%begg:bounds%endg,10) , & - fsds_dir(bounds%begg:bounds%endg,2) , & - fsds_dif(bounds%begg:bounds%endg,2) , & sw_abs_dir(bounds%begg:bounds%endg,2) , & sw_abs_dif(bounds%begg:bounds%endg,2) real(r8) :: fsds_tot ! Total solar @@ -369,111 +393,112 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst !lwdown_atm => atm2lnd_inst%forc_lwrad_not_downscaled_grc , & !swdown_atm => atm2lnd_inst%forc_solar_grc , & ! atm vars (need to grab them from atm portion, though... once this is written, can simplify by grabbing them right away) - fsds => atm2lnd_inst%mml_atm_fsds_grc , & - fsdsnd => atm2lnd_inst%mml_atm_fsdsnd_grc , & ! incoming shortwave nir direct - fsdsvd => atm2lnd_inst%mml_atm_fsdsvd_grc , & - fsdsni => atm2lnd_inst%mml_atm_fsdsni_grc , & - fsdsvi => atm2lnd_inst%mml_atm_fsdsvi_grc , & - lwdn => atm2lnd_inst%mml_atm_lwdn_grc , & - zref => atm2lnd_inst%mml_atm_zref_grc , & - tref => atm2lnd_inst%mml_atm_tbot_grc , & - thref => atm2lnd_inst%mml_atm_thref_grc , & - qref => atm2lnd_inst%mml_atm_qbot_grc , & - uref => atm2lnd_inst%mml_atm_uref_grc , & - eref => atm2lnd_inst%mml_atm_eref_grc , & - pref => atm2lnd_inst%mml_atm_pbot_grc , & - psrf => atm2lnd_inst%mml_atm_psrf_grc , & - rhomol => atm2lnd_inst%mml_atm_rhomol_grc , & - rhoair => atm2lnd_inst%mml_atm_rhoair_grc , & - cpair => atm2lnd_inst%mml_atm_cp_grc , & ! MML: this is in - pco2 => atm2lnd_inst%mml_atm_pco2 , & - prec_liq => atm2lnd_inst%mml_atm_prec_liq_grc , & ! MML: in mm/s - prec_frz => atm2lnd_inst%mml_atm_prec_frz_grc , & + ! slevis: these were later overwritten, so now I point them directly to + ! their final destination here + fsds => atm2lnd_inst%forc_solar_grc, & + fsds_dir => atm2lnd_inst%forc_solad_grc, & + fsds_dif => atm2lnd_inst%forc_solai_grc, & + lwdn => atm2lnd_inst%forc_lwrad_not_downscaled_grc, & + zref => atm2lnd_inst%forc_hgt_grc, & + tref => atm2lnd_inst%forc_t_not_downscaled_grc, & + thref => atm2lnd_inst%mml_atm_thref_grc, & + qref => atm2lnd_inst%forc_q_not_downscaled_grc, & + uref => atm2lnd_inst%forc_wind_grc, & + eref => atm2lnd_inst%forc_vp_grc, & + pref => atm2lnd_inst%forc_pbot_not_downscaled_grc, & + psrf => atm2lnd_inst%forc_psrf_grc, & ! surface pressure (Pa) + rhomol => atm2lnd_inst%mml_atm_rhomol_grc, & + rhoair => atm2lnd_inst%forc_rho_not_downscaled_grc, & + cpair => atm2lnd_inst%mml_atm_cp_grc, & ! MML: this is in + prec_liq => atm2lnd_inst%forc_rain_not_downscaled_grc, & + prec_frz => atm2lnd_inst%forc_snow_not_downscaled_grc, & ! lnd variables - tsrf => atm2lnd_inst%mml_lnd_ts_grc , & - qsrf => atm2lnd_inst%mml_lnd_qs_grc , & - radforc => atm2lnd_inst%mml_lnd_qa_grc , & - sw_abs => atm2lnd_inst%mml_lnd_swabs_grc , & - fsr => atm2lnd_inst%mml_lnd_fsr_grc , & - fsrnd => atm2lnd_inst%mml_lnd_fsrnd_grc , & - fsrni => atm2lnd_inst%mml_lnd_fsrni_grc , & - fsrvd => atm2lnd_inst%mml_lnd_fsrvd_grc , & - fsrvi => atm2lnd_inst%mml_lnd_fsrvi_grc , & - lwup => atm2lnd_inst%mml_lnd_lwup_grc , & - fsns => atm2lnd_inst%mml_lnd_fsns_grc , & - flns => atm2lnd_inst%mml_lnd_flns_grc , & - shflx => atm2lnd_inst%mml_lnd_shflx_grc , & - lhflx => atm2lnd_inst%mml_lnd_lhflx_grc , & - gsoi => atm2lnd_inst%mml_lnd_gsoi_grc , & - gsnow => atm2lnd_inst%mml_lnd_gsnow_grc , & - evap => atm2lnd_inst%mml_lnd_evap_grc , & - ustar => atm2lnd_inst%mml_lnd_ustar_grc , & - tstar => atm2lnd_inst%mml_lnd_tstar_grc , & - qstar => atm2lnd_inst%mml_lnd_qstar_grc , & - tvstar => atm2lnd_inst%mml_lnd_tvstar_grc , & - obu => atm2lnd_inst%mml_lnd_obu_grc , & - ram => atm2lnd_inst%mml_lnd_ram_grc , & - rah => atm2lnd_inst%mml_lnd_rah_grc , & - h_disp => atm2lnd_inst%mml_lnd_disp_grc , & - z0m => atm2lnd_inst%mml_lnd_z0m_grc , & - z0h => atm2lnd_inst%mml_lnd_z0h_grc , & - albedo_fin => atm2lnd_inst%mml_lnd_alb_grc , & - snow_melt => atm2lnd_inst%mml_lnd_snowmelt , & - taux => atm2lnd_inst%mml_out_taux , & - tauy => atm2lnd_inst%mml_out_tauy , & + tsrf => atm2lnd_inst%mml_lnd_ts_grc, & + qsrf => atm2lnd_inst%mml_lnd_qs_grc, & + radforc => atm2lnd_inst%mml_lnd_qa_grc, & + sw_abs => atm2lnd_inst%mml_lnd_swabs_grc, & + fsr => atm2lnd_inst%mml_lnd_fsr_grc, & + fsrnd => atm2lnd_inst%mml_lnd_fsrnd_grc, & + fsrni => atm2lnd_inst%mml_lnd_fsrni_grc, & + fsrvd => atm2lnd_inst%mml_lnd_fsrvd_grc, & + fsrvi => atm2lnd_inst%mml_lnd_fsrvi_grc, & + lwup => atm2lnd_inst%mml_lnd_lwup_grc, & + fsns => atm2lnd_inst%mml_lnd_fsns_grc, & + flns => atm2lnd_inst%mml_lnd_flns_grc, & + shflx => atm2lnd_inst%mml_lnd_shflx_grc, & + lhflx => atm2lnd_inst%mml_lnd_lhflx_grc, & + gsoi => atm2lnd_inst%mml_lnd_gsoi_grc, & + gsnow => atm2lnd_inst%mml_lnd_gsnow_grc, & + evap => atm2lnd_inst%mml_lnd_evap_grc, & + ustar => atm2lnd_inst%mml_lnd_ustar_grc, & + tstar => atm2lnd_inst%mml_lnd_tstar_grc, & + qstar => atm2lnd_inst%mml_lnd_qstar_grc, & + tvstar => atm2lnd_inst%mml_lnd_tvstar_grc, & + obu => atm2lnd_inst%mml_lnd_obu_grc, & + ram => atm2lnd_inst%mml_lnd_ram_grc, & + rah => atm2lnd_inst%mml_lnd_rah_grc, & + h_disp => atm2lnd_inst%mml_lnd_disp_grc, & + z0m => atm2lnd_inst%mml_lnd_z0m_grc, & + z0h => atm2lnd_inst%mml_lnd_z0h_grc, & + albedo_fin => atm2lnd_inst%mml_lnd_alb_grc, & + snow_melt => atm2lnd_inst%mml_lnd_snowmelt, & + taux => atm2lnd_inst%mml_out_taux, & + tauy => atm2lnd_inst%mml_out_tauy, & ! over-large dew: - lh_excess => atm2lnd_inst%mml_lh_excess , & - q_excess => atm2lnd_inst%mml_q_excess , & - lh_demand => atm2lnd_inst%mml_lh_demand , & - q_demand => atm2lnd_inst%mml_q_demand , & + lh_excess => atm2lnd_inst%mml_lh_excess, & + q_excess => atm2lnd_inst%mml_q_excess, & + lh_demand => atm2lnd_inst%mml_lh_demand, & + q_demand => atm2lnd_inst%mml_q_demand, & ! soil variables - tsoi => atm2lnd_inst%mml_soil_t_grc , & - soil_liq => atm2lnd_inst%mml_soil_liq_grc , & - soil_ice => atm2lnd_inst%mml_soil_ice_grc , & - soil_dz => atm2lnd_inst%mml_soil_dz_grc , & - soil_zh => atm2lnd_inst%mml_soil_zh_grc , & - soil_tk => atm2lnd_inst%mml_soil_tk_grc , & - soil_tk_1d => atm2lnd_inst%mml_soil_tk_1d_grc , & - soil_tkh => atm2lnd_inst%mml_soil_tkh_grc , & - soil_dtsoi => atm2lnd_inst%mml_soil_dtsoi_grc , & - soil_cv => atm2lnd_inst%mml_soil_cv_grc , & - soil_cv_1d => atm2lnd_inst%mml_soil_cv_1d_grc , & - glc_tk_1d => atm2lnd_inst%mml_glc_tk_1d_grc , & - glc_cv_1d => atm2lnd_inst%mml_glc_cv_1d_grc , & - water => atm2lnd_inst%mml_soil_water_grc , & - snow => atm2lnd_inst%mml_soil_snow_grc , & - runoff => atm2lnd_inst%mml_soil_runoff_grc , & + tsoi => atm2lnd_inst%mml_soil_t_grc, & + soil_liq => atm2lnd_inst%mml_soil_liq_grc, & + soil_ice => atm2lnd_inst%mml_soil_ice_grc, & + soil_dz => atm2lnd_inst%mml_soil_dz_grc, & + soil_zh => atm2lnd_inst%mml_soil_zh_grc, & + soil_tk => atm2lnd_inst%mml_soil_tk_grc, & + soil_tk_1d => atm2lnd_inst%mml_soil_tk_1d_grc, & + soil_tkh => atm2lnd_inst%mml_soil_tkh_grc, & + soil_dtsoi => atm2lnd_inst%mml_soil_dtsoi_grc, & + soil_cv => atm2lnd_inst%mml_soil_cv_grc, & + soil_cv_1d => atm2lnd_inst%mml_soil_cv_1d_grc, & + glc_tk_1d => atm2lnd_inst%mml_glc_tk_1d_grc, & + glc_cv_1d => atm2lnd_inst%mml_glc_cv_1d_grc, & + water => atm2lnd_inst%mml_soil_water_grc, & + snow => atm2lnd_inst%mml_soil_snow_grc, & + runoff => atm2lnd_inst%mml_soil_runoff_grc, & ! values from .nc file - albedo_gvd => atm2lnd_inst%mml_nc_alb_gvd_grc , & - albedo_svd => atm2lnd_inst%mml_nc_alb_svd_grc , & - albedo_gnd => atm2lnd_inst%mml_nc_alb_gnd_grc , & - albedo_snd => atm2lnd_inst%mml_nc_alb_snd_grc , & - albedo_gvf => atm2lnd_inst%mml_nc_alb_gvf_grc , & - albedo_svf => atm2lnd_inst%mml_nc_alb_svf_grc , & - albedo_gnf => atm2lnd_inst%mml_nc_alb_gnf_grc , & - albedo_snf => atm2lnd_inst%mml_nc_alb_snf_grc , & - snowmask => atm2lnd_inst%mml_nc_snowmask_grc , & - evaprs => atm2lnd_inst%mml_nc_evaprs_grc , & - bucket_cap => atm2lnd_inst%mml_nc_bucket_cap_grc , & - soil_maxice => atm2lnd_inst%mml_nc_soil_maxice_grc , & - soil_z => atm2lnd_inst%mml_nc_soil_levels_grc , & - soil_type => atm2lnd_inst%mml_nc_soil_type_grc , & - roughness => atm2lnd_inst%mml_nc_roughness_grc , & - emiss => atm2lnd_inst%mml_nc_emiss_grc , & - glc_mask => atm2lnd_inst%mml_nc_glcmask_grc , & - dust => atm2lnd_inst%mml_nc_dust_grc , & + albedo_gvd => atm2lnd_inst%mml_nc_alb_gvd_grc, & + albedo_svd => atm2lnd_inst%mml_nc_alb_svd_grc, & + albedo_gnd => atm2lnd_inst%mml_nc_alb_gnd_grc, & + albedo_snd => atm2lnd_inst%mml_nc_alb_snd_grc, & + albedo_gvf => atm2lnd_inst%mml_nc_alb_gvf_grc, & + albedo_svf => atm2lnd_inst%mml_nc_alb_svf_grc, & + albedo_gnf => atm2lnd_inst%mml_nc_alb_gnf_grc, & + albedo_snf => atm2lnd_inst%mml_nc_alb_snf_grc, & + snowmask => atm2lnd_inst%mml_nc_snowmask_grc, & + evaprs => atm2lnd_inst%mml_nc_evaprs_grc, & + bucket_cap => atm2lnd_inst%mml_nc_bucket_cap_grc, & + soil_maxice => atm2lnd_inst%mml_nc_soil_maxice_grc, & + soil_z => atm2lnd_inst%mml_nc_soil_levels_grc, & + soil_type => atm2lnd_inst%mml_nc_soil_type_grc, & + roughness => atm2lnd_inst%mml_nc_roughness_grc, & + emiss => atm2lnd_inst%mml_nc_emiss_grc, & + glc_mask => atm2lnd_inst%mml_nc_glcmask_grc, & + dust => atm2lnd_inst%mml_nc_dust_grc, & ! temporary diagnostics - diag1_1d => atm2lnd_inst%mml_diag1_1d_grc , & - diag2_1d => atm2lnd_inst%mml_diag2_1d_grc , & - diag3_1d => atm2lnd_inst%mml_diag3_1d_grc , & - diag1_2d => atm2lnd_inst%mml_diag1_2d_grc , & - diag2_2d => atm2lnd_inst%mml_diag2_2d_grc , & - diag3_2d => atm2lnd_inst%mml_diag3_2d_grc & + diag1_1d => atm2lnd_inst%mml_diag1_1d_grc, & + diag2_1d => atm2lnd_inst%mml_diag2_1d_grc, & + diag3_1d => atm2lnd_inst%mml_diag3_1d_grc, & + diag1_2d => atm2lnd_inst%mml_diag1_2d_grc, & + diag2_2d => atm2lnd_inst%mml_diag2_2d_grc, & + diag3_2d => atm2lnd_inst%mml_diag3_2d_grc & !ddvel_grc => lnd2atm_inst%ddvel_grc & ! lat x lon x 3 dust bins ) !----------------------------------------------------------------------- - - + + SHR_ASSERT_ALL((lbound(tref) == (/bounds%begg/)), errMsg(__FILE__, __LINE__)) + SHR_ASSERT_ALL((ubound(tref) == (/bounds%endg/)), errMsg(__FILE__, __LINE__)) + !----------------------------------------------------------------------- ! Assign local values @@ -557,29 +582,16 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst !----------------------------------------------------------------------- ! Re-assign atmospheric forcing data to simple land model equivalent ! (this is all the "forcing" data - fsds = atm2lnd_inst%forc_solar_grc - fsds_dir = atm2lnd_inst%forc_solad_grc - fsds_dif = atm2lnd_inst%forc_solai_grc - lwdn = atm2lnd_inst%forc_lwrad_not_downscaled_grc - zref = atm2lnd_inst%forc_hgt_grc ! Note, there is a u, t , and q height in atm2lnd... compare? + ! slevis: I pointed these to their final destinations in the associate + ! statment above and left all comments as I found them ! GBB: No need to use the separate values for t, u, q; only need zref ! MML: Keith said there are 3 separate ones for historical reasons, but all three should be the same as zref - zref_t = atm2lnd_inst%forc_hgt_t_grc - zref_u = atm2lnd_inst%forc_hgt_u_grc - zref_q = atm2lnd_inst%forc_hgt_q_grc - tref = atm2lnd_inst%forc_t_not_downscaled_grc ! is this right? or does atm have a ref height value? - uref = atm2lnd_inst%forc_wind_grc - eref = atm2lnd_inst%forc_vp_grc - qref = atm2lnd_inst%forc_q_not_downscaled_grc - pref = atm2lnd_inst%forc_pbot_not_downscaled_grc - rhoair = atm2lnd_inst%forc_rho_not_downscaled_grc - prec_liq = atm2lnd_inst%forc_rain_not_downscaled_grc - prec_frz = atm2lnd_inst%forc_snow_not_downscaled_grc - pco2 = atm2lnd_inst%forc_pco2_grc - ! For checking the big neg lhflx: - psrf = atm2lnd_inst%forc_psrf_grc ! surface pressure (Pa) - pbot = atm2lnd_inst%forc_pbot_not_downscaled_grc ! not downscaled atm pressure (Pa) - qbot = atm2lnd_inst%forc_q_not_downscaled_grc ! not downscaled atm specific humidity (kg/kg) + SHR_ASSERT(numrad == 2, errMsg(sourcefile, __LINE__)) + SHR_ASSERT_ALL((ubound(fsds_dir) == (/bounds%endg,numrad/)), errMsg(sourcefile, __LINE__)) + SHR_ASSERT_ALL((lbound(fsds_dir) == (/bounds%begg,1/)), errMsg(sourcefile, __LINE__)) + SHR_ASSERT_ALL((ubound(atm2lnd_inst%forc_solad_grc) == (/bounds%endg,numrad/)), errMsg(sourcefile, __LINE__)) + SHR_ASSERT_ALL((lbound(atm2lnd_inst%forc_solad_grc) == (/bounds%begg,1/)), errMsg(sourcefile, __LINE__)) + ! For checking the big neg lhflx: ! NOTE: this is NOT going to be consistent with CAM, still, if I use pbot and psrf as the "edges" of ! my lowest atm layer; cam uses the actual pressure levels at the edges of the lowermost ! atmospheric layer, but all I've got is pbot (which is likely in the middle of the lowest layer) @@ -590,25 +602,28 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! total layer thickness, in pressure, which I should then be able to plug in to their equation. ! Yes, lets do it that way! - ! Put direct/diffuse fsds vis/nir into right variable to be output: - fsdsnd = fsds_dir(:,2) - fsdsvd = fsds_dir(:,1) - fsdsni = fsds_dif(:,2) - fsdsvi = fsds_dif(:,1) ! I think? check... - - ! Theta = T + 0.0098 * z (Gamma = 0.0098) - thref = tref + 0.0098_r8 * zref - - ! Have to calculate rhomol from the vapor pressure, actual pressure, and actual temperature - rhomol = pref / (rgas*tref); - ! rho_mol = (pd + forcvar.eref)/(physcon.rgas * forcvar.tref) - ! rho_kg = ((pref - eref)*mmdry + eref*mmh2o)/(rgas*tref) - - ! MML: might need to move into g loop if I can't figure out how to allocate a matrix of size - ! begg:endg before I know begg and endg ... - ! calculate heat capacity based off specific humidity: - mmair = rhomol / rhoair ! mol/kg - cpair = cpd * (1._r8 + (cpw/cpd - 1._r8)*qref) ! J/kg/K + ! Put direct/diffuse fsds vis/nir into right variable to be output: + atm2lnd_inst%mml_atm_fsdsnd_grc(begg:endg) = fsds_dir(begg:endg,2) + atm2lnd_inst%mml_atm_fsdsvd_grc(begg:endg) = fsds_dir(begg:endg,1) + atm2lnd_inst%mml_atm_fsdsni_grc(begg:endg) = fsds_dif(begg:endg,2) + atm2lnd_inst%mml_atm_fsdsvi_grc(begg:endg) = fsds_dif(begg:endg,1) + ! slevis: Same for tbot and psrf + atm2lnd_inst%mml_atm_tbot_grc(begg:endg) = tref(begg:endg) + atm2lnd_inst%mml_atm_psrf_grc(begg:endg) = psrf(begg:endg) + + ! Theta = T + 0.0098 * z (Gamma = 0.0098) + thref(begg:endg) = tref(begg:endg) + 0.0098_r8 * zref(begg:endg) + + ! Have to calculate rhomol from the vapor pressure, actual pressure, and actual temperature + rhomol(begg:endg) = pref(begg:endg) / (rgas * tref(begg:endg)); + ! rho_mol = (pd + forcvar.eref)/(physcon.rgas * forcvar.tref) + ! rho_kg = ((pref - eref)*mmdry + eref*mmh2o)/(rgas*tref) + + ! MML: might need to move into g loop if I can't figure out how to allocate a matrix of size + ! begg:endg before I know begg and endg ... + ! calculate heat capacity based off specific humidity: + mmair(begg:endg) = rhomol(begg:endg) / rhoair(begg:endg) ! mol/kg + cpair(begg:endg) = cpd * (1._r8 + (cpw / cpd - 1._r8) * qref(begg:endg)) ! J/kg/K ! cpair = mmair * cpair_kg ! J/mol/K ! physcon.cpd * (1.0 + (physcon.cpw/physcon.cpd - 1.0) * forcvar.qref) (* mmair); @@ -626,8 +641,7 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! Get outside data !MML: Grab the current model time so we know what month we're in - call get_curr_date(year, mon, day, sec) ! Actually all I need for now is mon - mcdate = year*10000 + mon*100 + day + call get_curr_date(year, mon, day, sec) !write(iulog,*)subname, 'MML month = ', mon !write(iulog,*)subname, 'MML day = ', day @@ -654,45 +668,27 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! else ! soil_maxice(begg:endg,i) = 300._r8 ! end if - ! enddo - - ! write(iulog,*) 'MML: Yikes! Pre-nc reading, albedo_gvd at some point begg = ', albedo_gvd(begg) - call t_startf('mml_nc_import') - - ! ONLY actually run nc_import if we're on the first timestep of the first day of the month... - !if (sec <= 1800) then !( day == 1 .and. sec <= 1800) then - if ( day == 1 .and. sec .le. 1800 ) then - ! <= 1800 will read it in both first 2 time steps... but after a restart it - ! seems to start on 1800, not 0, so it needs to be able to read them then, too... - ! Is there a better way to say "if you haven't still got the last values, read these in?" - ! - ! Added the nc vars to the restart file, so maybe now I can revert to just saying if sec = 0? - ! (sec <1800) -> as long as that instance HAPPENS that would work... I think... - if ( masterproc ) write(iulog,*)'reading netcdf data for mon=',mon,', day=',day,', sec=',sec,')' - - call nc_import(begg, endg, mml_nsoi, lfsurdat, mon, & - albedo_gvd(begg:endg), albedo_svd(begg:endg), & - albedo_gnd(begg:endg), albedo_snd(begg:endg), & - albedo_gvf(begg:endg), albedo_svf(begg:endg), & - albedo_gnf(begg:endg), albedo_snf(begg:endg), & - snowmask(begg:endg), evaprs(begg:endg), & - bucket_cap(begg:endg), & - soil_type(begg:endg), roughness(begg:endg), & - emiss(begg:endg), glc_mask(begg:endg), dust(begg:endg,:), & - soil_tk_1d(begg:endg), soil_cv_1d(begg:endg), & - glc_tk_1d(begg:endg), glc_cv_1d(begg:endg) ) !, & - - !write(iulog,*)'read netcdf' - - end if - call t_stopf('mml_nc_import') - + call t_startf('mml_nc_import') + ! Read mml_surdat file at the beginning of a run and at the + ! beginning of the first day of every month + if (is_first_step_of_this_run_segment() .or. (day == 1 .and. sec == 0)) then + if ( masterproc ) write(iulog,*)'reading netcdf data for mon=',mon,', day=',day,', sec=',sec,')' + call nc_import(begg, endg, mml_nsoi, lfsurdat, mon, & + albedo_gvd(begg:endg), albedo_svd(begg:endg), & + albedo_gnd(begg:endg), albedo_snd(begg:endg), & + albedo_gvf(begg:endg), albedo_svf(begg:endg), & + albedo_gnf(begg:endg), albedo_snf(begg:endg), & + snowmask(begg:endg), evaprs(begg:endg), & + bucket_cap(begg:endg), & + soil_type(begg:endg), roughness(begg:endg), & + emiss(begg:endg), glc_mask(begg:endg), dust(begg:endg,:), & + soil_tk_1d(begg:endg), soil_cv_1d(begg:endg), & + glc_tk_1d(begg:endg), glc_cv_1d(begg:endg) ) + end if + call t_stopf('mml_nc_import') - ! Hard code snowmask and see if it'll run with the new files using that - !snowmask(begg:endg) = 100.0_r8 - ! ************************************************************* ! *** Start the simple model (science part) *** ! ************************************************************* @@ -708,31 +704,28 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst !write(iulog,*)'MML: Commence actually running the model!' - ! displacement height - ! for now, set equal to 0.7 * canopy height - h_disp = 0.7_r8 * roughness - - ! Roughness length for momentum - ! for now, set equal to 0.1 * canopy height - z0m = 0.1_r8 * roughness - - ! Roughness length for heat - ! for now, set equal to 0.1 * momentum roughness length - z0h = 0.1_r8 * z0m - - - - ! snow masking factor - ! SHOULD ALWAYS BE BETWEEN 0 AND 1!!!!! - - ! If snow is negative (it shouldn't be, but if it went a bit neg), set temp = 0 + begg_to_endg_0: do g = begg, endg + ! displacement height + ! for now, set equal to 0.7 * canopy height + h_disp(g) = 0.7_r8 * roughness(g) + + ! Roughness length for momentum + ! for now, set equal to 0.1 * canopy height + z0m(g) = 0.1_r8 * roughness(g) + + ! Roughness length for heat + ! for now, set equal to 0.1 * momentum roughness length + z0h(g) = 0.1_r8 * z0m(g) + + ! snow masking factor + ! SHOULD ALWAYS BE BETWEEN 0 AND 1!!!!! - !temp(begg:endg) = snow(begg:endg)/(snow(begg:endg) + snowmask(begg:endg)) ! snow masking factor - !diag3_1d = temp - + ! If snow is negative (it shouldn't be, but if it went a bit neg), set temp = 0 - - do g = begg, endg + !temp(begg:endg) = snow(begg:endg)/(snow(begg:endg) + snowmask(begg:endg)) ! snow masking factor + !diag3_1d = temp + + ! MML 2021.09.29: initialize temp as all zeros, otherwise it might just not have a value in some places! temp(g) = 0.0_r8 @@ -765,113 +758,103 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst 'Instead, snowmasking factor = ',temp(g) call endrun(msg=errmsg(__FILE__, __LINE__)) end if - - end do - ! ------------------------------------------------------------- - ! Albedo stuff - - ! Direct/Diffuse Visible/NIR - ! for consistent coding, shove vis and nir into a (:,2) sized matrix - alb_vis_dir(begg:endg) = (1._r8 - temp(begg:endg)) * albedo_gvd(begg:endg) + & - temp(begg:endg) * albedo_svd(begg:endg) - alb_nir_dir(begg:endg) = (1._r8 - temp(begg:endg)) * albedo_gnd(begg:endg) + & - temp(begg:endg) * albedo_snd(begg:endg) - alb_vis_dif(begg:endg) = (1._r8 - temp(begg:endg)) * albedo_gvf(begg:endg) + & - temp(begg:endg) * albedo_svf(begg:endg) - alb_nir_dif(begg:endg) = (1._r8 - temp(begg:endg)) * albedo_gnf(begg:endg) + & - temp(begg:endg) * albedo_snf(begg:endg) - - ! for now, output one of these as albedo_fin just so there is a value: - !albedo_fin = alb_vis_dir - diag2_1d = alb_vis_dir - - !diag3_1d = alb_vis_dif ! why is the albedo going to 1e22 in h0? try this one... - - ! Do something special for albedo where there is a glacier? - ! at present, I'm just feeding in albedos that already "make sense" for a glacier - - - !albedo_fin = 0.3_r8 ! see if that overwrites... - - ! ------------------------------------------------------------- - ! Net radiation - ! variables from atm: lwdn, fsds, fsds_dir, fsds_dif ! sw is handed as total, direct, and diffuse - ! variables to end up with: sw_abs, fsr, radforc (into ground) - ! - ! for lw, emissivity = absorptivity - ! alpha (albed0) = reflected, so (1-alpha) = absorbed - - ! longwave - lw_abs(begg:endg) = emiss(begg:endg)*lwdn(begg:endg) - lwup(begg:endg) = (1._r8 - emiss(begg:endg)) * lwdn(begg:endg) ! reflected longwave. Later, add surface emission - ! Shortwave direct visible - sw_abs_dir(begg:endg,1) = (1._r8 - alb_vis_dir(begg:endg)) * fsds_dir(begg:endg,1) - ! Shortwave direct NIR - sw_abs_dir(begg:endg,2) = (1._r8 - alb_nir_dir(begg:endg)) * fsds_dir(begg:endg,2) - ! Shortwave diffuse visible - sw_abs_dif(begg:endg,1) = (1._r8 - alb_vis_dif(begg:endg)) * fsds_dif(begg:endg,1) - ! Shortwave diffuse NIR - sw_abs_dif(begg:endg,2) = (1._r8 - alb_nir_dif(begg:endg)) * fsds_dif(begg:endg,2) - - !fsr(begg:endg) = alb_vis_dir(begg:endg) * fsds_dir(begg:endg,1) + & - ! alb_nir_dir(begg:endg) * fsds_dir(begg:endg,2) + & - ! alb_vis_dif(begg:endg) * fsds_dif(begg:endg,1) + & - ! alb_nir_dif(begg:endg) * fsds_dif(begg:endg,2) - - ! fsr by vis/nir/dir/dif - fsrnd = alb_nir_dir(begg:endg) * fsds_dir(begg:endg,2) - fsrni = alb_nir_dif(begg:endg) * fsds_dif(begg:endg,2) - fsrvd = alb_vis_dir(begg:endg) * fsds_dir(begg:endg,1) - fsrvi = alb_vis_dif(begg:endg) * fsds_dif(begg:endg,1) - - ! put sum of these in diag2, should equal fsr... well, it will. thats math. don't bother. - - - sw_abs(begg:endg) = sw_abs_dir(begg:endg,1) + sw_abs_dir(begg:endg,2) + & - sw_abs_dif(begg:endg,1) + sw_abs_dif(begg:endg,2) - - - ! should be able to write like: - fsr(:) = alb_vis_dir * fsds_dir(:,1) + & - alb_nir_dir * fsds_dir(:,2) + & - alb_vis_dif * fsds_dif(:,1) + & - alb_nir_dif * fsds_dif(:,2) - - sw_abs(:) = sw_abs_dir(:,1) + sw_abs_dir(:,2) + & - sw_abs_dif(:,1) + sw_abs_dif(:,2) - - - ! Make output albedo to be a combination of all 4 albedo streams: - albedo_fin(:) = 1.0e36_r8 - do g = begg, endg + ! ------------------------------------------------------------- + ! Albedo stuff + + ! Direct/Diffuse Visible/NIR + ! for consistent coding, shove vis and nir into a (:,2) sized matrix + alb_vis_dir(g) = (1._r8 - temp(g)) * albedo_gvd(g) + & + temp(g) * albedo_svd(g) + alb_nir_dir(g) = (1._r8 - temp(g)) * albedo_gnd(g) + & + temp(g) * albedo_snd(g) + alb_vis_dif(g) = (1._r8 - temp(g)) * albedo_gvf(g) + & + temp(g) * albedo_svf(g) + alb_nir_dif(g) = (1._r8 - temp(g)) * albedo_gnf(g) + & + temp(g) * albedo_snf(g) + + ! for now, output one of these as albedo_fin just so there is a value: + !albedo_fin = alb_vis_dir + diag2_1d(g) = alb_vis_dir(g) + + !diag3_1d = alb_vis_dif ! why is the albedo going to 1e22 in h0? try this one... + + ! Do something special for albedo where there is a glacier? + ! at present, I'm just feeding in albedos that already "make sense" for a glacier + + + !albedo_fin = 0.3_r8 ! see if that overwrites... + + ! ------------------------------------------------------------- + ! Net radiation + ! variables from atm: lwdn, fsds, fsds_dir, fsds_dif ! sw is handed as total, direct, and diffuse + ! variables to end up with: sw_abs, fsr, radforc (into ground) + ! + ! for lw, emissivity = absorptivity + ! alpha (albed0) = reflected, so (1-alpha) = absorbed + + ! longwave + lw_abs(g) = emiss(g) * lwdn(g) + lwup(g) = (1._r8 - emiss(g)) * lwdn(g) ! reflected longwave. Later, add surface emission + ! Shortwave direct visible + sw_abs_dir(g,1) = (1._r8 - alb_vis_dir(g)) * fsds_dir(g,1) + ! Shortwave direct NIR + sw_abs_dir(g,2) = (1._r8 - alb_nir_dir(g)) * fsds_dir(g,2) + ! Shortwave diffuse visible + sw_abs_dif(g,1) = (1._r8 - alb_vis_dif(g)) * fsds_dif(g,1) + ! Shortwave diffuse NIR + sw_abs_dif(g,2) = (1._r8 - alb_nir_dif(g)) * fsds_dif(g,2) + + !fsr(g) = alb_vis_dir(g) * fsds_dir(g,1) + & + ! alb_nir_dir(g) * fsds_dir(g,2) + & + ! alb_vis_dif(g) * fsds_dif(g,1) + & + ! alb_nir_dif(g) * fsds_dif(g,2) + + ! fsr by vis/nir/dir/dif + fsrnd(g) = alb_nir_dir(g) * fsds_dir(g,2) + fsrni(g) = alb_nir_dif(g) * fsds_dif(g,2) + fsrvd(g) = alb_vis_dir(g) * fsds_dir(g,1) + fsrvi(g) = alb_vis_dif(g) * fsds_dif(g,1) + + ! put sum of these in diag2, should equal fsr... well, it will. thats math. don't bother. + + sw_abs(g) = sw_abs_dir(g,1) + sw_abs_dir(g,2) + & + sw_abs_dif(g,1) + sw_abs_dif(g,2) + + ! should be able to write like: + fsr(g) = alb_vis_dir(g) * fsds_dir(g,1) + & + alb_nir_dir(g) * fsds_dir(g,2) + & + alb_vis_dif(g) * fsds_dif(g,1) + & + alb_nir_dif(g) * fsds_dif(g,2) + + sw_abs(g) = sw_abs_dir(g,1) + sw_abs_dir(g,2) + & + sw_abs_dif(g,1) + sw_abs_dif(g,2) + + ! Make output albedo to be a combination of all 4 albedo streams: fsds_tot = fsds_dir(g,1) + fsds_dir(g,2) + fsds_dif(g,1) + fsds_dif(g,2) if ( fsds_tot > 0.0_r8 )then albedo_fin(g) = fsr(g) / fsds_tot + else + albedo_fin(g) = 1.0e36_r8 end if - end do - ! temporary fix: - !lw_abs(begg:endg) = lwdn(begg:endg) - !sw_abs(begg:endg) = 0.7*fsds(begg:endg) - - - radforc(begg:endg) = lw_abs(begg:endg) + sw_abs(begg:endg) - - - !----------------------------------------------------------------------- - ! Initial Checks -> crash run if these fail - - do g = begg, endg - - if ( zref(g) < h_disp(g) ) then - write(iulog,*)'Error: Forcing height is below canopy displacement height (zref < h_disp) ' - call endrun(msg=errmsg(__FILE__, __LINE__)) - end if - - end do + + ! temporary fix: + !lw_abs(g) = lwdn(g) + !sw_abs(g) = 0.7*fsds(g) + radforc(g) = lw_abs(g) + sw_abs(g) + !----------------------------------------------------------------------- + ! Initial Checks -> crash run if these fail + + if ( zref(g) < h_disp(g) ) then + write(iulog,*)'Error: Forcing height is below canopy displacement height (zref < h_disp) ' + call endrun(msg=errmsg(__FILE__, __LINE__)) + end if + + end do begg_to_endg_0 + ! ------------------------------------------------------------- ! -------- Monin-Obukhov Stuff ! ------------------------------------------------------------- @@ -923,21 +906,20 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! calculate aerodynamic resistances for momentum (ram) and heat (rah) in [s/m], and ! the effective resistance combining ram with the canopy resistance (res) - ram(:) = uref / (ustar * ustar) ! [s/m] = [m/s] / ([m/s] * [m/s]) - rah(:) = (thref - tsrf) / (ustar * tstar) ! [s/m] = [K] / ([m/s] * [K]) - res(:) = (evaprs + rah) ! [s/m] + ram(begg:endg) = uref(begg:endg) / (ustar(begg:endg) * ustar(begg:endg)) ! [s/m] = [m/s] / ([m/s] * [m/s]) + rah(begg:endg) = (thref(begg:endg) - tsrf(begg:endg)) / (ustar(begg:endg) * tstar(begg:endg)) ! [s/m] = [K] / ([m/s] * [K]) + res(begg:endg) = (evaprs(begg:endg) + rah(begg:endg)) ! [s/m] ! cap res at 100,000 () - where ( res > 100000. ) - res(:) = 100000.0_r8 - end where - + where ( res(begg:endg) > 100000.0_r8 ) + res = 100000.0_r8 + end where ! GBB: See what GFDL does for its evaporative resistance; should be a function - ! of stomatal conductance and LAI - - ! Save initial temperature profile for energy conservation check: - tsoi0(:,:) = tsoi + ! of stomatal conductance and LAI + + ! Save initial temperature profile for energy conservation check: + tsoi0(begg:endg,:) = tsoi(begg:endg,:) ! Call soil thermal properties for this time step: (right now, it doesn't matter b/c ! it doesn't have water dependence, or soil type dependence, for that matter, @@ -970,23 +952,23 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! I'm after surface values here, so use tsrf, and psrf (assume psrf ~ pbot ? that ! looks like that CanopyTemperatureMod is doing - check with Gordon) - call QSat (tsrf(g), pref(g), esrf(g), desrf(g), qsrf(g), dqsrf(g)) + call QSatOld (tsrf(g), pref(g), esrf(g), desrf(g), qsrf(g), dqsrf(g)) ! Okay, this is giving an updated qsrf - so should I call it before MO section? ! otherwise MO uses the qsrf from the last time step, which is fine I guess, since this is ! using the tsrf from the last time step to get qsrf anyhow... think about this. ! ! ... also, I probably shouldn't have a variable called qsat if I'm also calling a function - ! called QSat (is fortran case-sensitive?)... for now, go rename qsat to qsrf + ! called QSatOld (is fortran case-sensitive?)... for now, go rename qsat to qsrf - ! call QSat (T, p, es, esdT, qs, qsdT) ! in: T,p ; out: es, esdT, qs, qsdT + ! call QSatOld (T, p, es, esdT, qs, qsdT) ! in: T,p ; out: es, esdT, qs, qsdT ! T = temperature (K) ! p = surface atmospheric pressure (pa) ! In CanopyFluxesMod: - ! call QSat(t_ref2m(p), forc_pbot(c), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT) + ! call QSatOld(t_ref2m(p), forc_pbot(c), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT) ! ! In CanopyTemperatureMod: - ! call QSat(t_grnd(c), forc_pbot(c), eg, degdT, qsatg, qsatgdT) + ! call QSatOld(t_grnd(c), forc_pbot(c), eg, degdT, qsatg, qsatgdT) ! where eg = ! water vapor pressure at temperature T [pa] !evap(g) = esat(g) ! lets see if satvap is our culprit... @@ -1006,30 +988,30 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! GBB: hsub is used if snow is on the ground (check GFDL code). Or CLM uses hvap ! (gfdl says sublimation if snow, CLM says sublimation if frozen... check and make sure, ! then choose one and run with it) - lambda(:) = hvap - where ( tsrf < tfrz) lambda(:) = hsub - - - ! Psychometric Constant [Pa/K] - gamma(:) = cpair(:) * pref(:) / lambda(:) ! [J/kg/K] * [Pa] / [J/kg] - - !lhflx(:) = lambda - + lambda(begg:endg) = hvap + where ( tsrf(begg:endg) < tfrz) lambda = hsub + + + ! Psychometric Constant [Pa/K] + gamma(begg:endg) = cpair(begg:endg) * pref(begg:endg) / lambda(begg:endg) ! [J/kg/K] * [Pa] / [J/kg] + + !lhflx(:) = lambda + ! -------------------------------------------------- - ! ---- Surface Fluxes - ! -------------------------------------------------- + ! ---- Surface Fluxes + ! -------------------------------------------------- ! Emitted longwave radiation from surface [W/m2] and temperature derivative [W/m2/K] - lwrad(:) = emiss * sigma * tsrf**4 - dlwrad(:) = 4.0_r8 * emiss * sigma * tsrf**3 - ! GBB: dlwrad(:) = 4.0_r8 * emiss * sigma * tsrf**3 - ! The exponents do not need to be real; but the factor 4 should be real - - ! Sensible heat flux [W/m2] and temperature derivative [W/m2/K] - ! GBB: Need to multiply by rhoair: J/s/m2 = kg/m3 * J/kg/K * K * m/s - shflx(:) = cpair * (tsrf - thref) / rah * rhoair ! [W/m2] = [J/kg/K] * [K] / [s/m] * [kg/m3] - dshflx(:) = cpair / rah * rhoair ! [W/m2/K] = [J/kg/K] / [s/m] * [ kg/m3] - + lwrad(begg:endg) = emiss(begg:endg) * sigma * tsrf(begg:endg)**4 + dlwrad(begg:endg) = 4.0_r8 * emiss(begg:endg) * sigma * tsrf(begg:endg)**3 + ! GBB: dlwrad(:) = 4.0_r8 * emiss * sigma * tsrf**3 + ! The exponents do not need to be real; but the factor 4 should be real + + ! Sensible heat flux [W/m2] and temperature derivative [W/m2/K] + ! GBB: Need to multiply by rhoair: J/s/m2 = kg/m3 * J/kg/K * K * m/s + shflx(begg:endg) = cpair(begg:endg) * (tsrf(begg:endg) - thref(begg:endg)) / rah(begg:endg) * rhoair(begg:endg) ! [W/m2] = [J/kg/K] * [K] / [s/m] * [kg/m3] + dshflx(begg:endg) = cpair(begg:endg) / rah(begg:endg) * rhoair(begg:endg) ! [W/m2/K] = [J/kg/K] / [s/m] * [ kg/m3] + ! Latent heat flux [W/m2] and temperature derivative [W/m2/K] ! (check if lhflx > water available in snow and soil, in which case limit lhflx ! to available water; also, if there is snow, don't use soil moisture as a factor) @@ -1050,275 +1032,263 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! this entire routine (see my comment below about satvap). See also the CLM4.5 ! technote, equations 5.157, 5.158 ! - ! MML: plan - use qsat instead of esat, by calling CLM function QSat. Modify these + ! MML: plan - use qsat instead of esat, by calling CLM function QSatOld. Modify these ! equations accordingly (and check units!!!!) - ! Initialize beta = 1.0 (no extra bucket resistance) everywhere. Overwrite with smaller values where appropriate. - beta(:) = 1.0_r8 - - ! similarly initialize mml_lnd_effective_res_grc and mml_lnd_res_grc to avoid nans - atm2lnd_inst%mml_lnd_effective_res_grc = 1.0_r8 !9999.99_r8 - atm2lnd_inst%mml_lnd_res_grc = 1.0_r8 ! 9999.99_r8 - - where ( snow <= 0 ) - beta(:) = min ( water/(.75 * bucket_cap) , 1.0_r8 ) ! scaling factor [unitless] - ! OH I bet the problem is that I only end up defining beta in places where snow<0 -- hence the nan problem!!! So I should initialize - ! a starting beta matrix where everywhere is 1.0 or something! - ! add minimum beta value in case water is negative? - !lhflx(:) = cpair / gamma * (esat - eref) / res * beta * rhoair ! [W/m2] = [J/kg/K] / [Pa/K] * [Pa] / [s/m] * [unitless] * [kg/m3] - !dlhflx(:) = cpair / gamma * desat / res * beta * rhoair ! [W/m2/K] - lhflx(:) = rhoair * lambda * (qsrf - qref) * beta / res ! [W/m2] = [kg/m3] * [J/kg] * [kg/kg] * [unitless] / [s/m] -> kg/m3 * J/kg * m/s = kg/kg J/s 1/m2 = W/m2 - dlhflx(:) = rhoair * lambda * dqsrf * beta / res ! [W/m2/K] = [kg/m3] * [J/kg] * [kg/kg/K] * [unitless] / [s/m] -> kg/m3 * J/kg * 1/K * m/s -> J/s /K /m2 = W/m2/K - ! got here doing unit analysis - make sure this is actually the right equation!!! - end where - - ! make sure beta isn't negative (if neg, set equal to 0) - where ( beta <= 0.0 ) - beta(:) = 0.0_r8 - end where - - where ( snow > 0 ) ! go where there is snow and overwrite the value of lhflx and dlhflx - !lhflx(:) = cpair / gamma * ( esat - eref ) / res * rhoair ! [W/m2] - !dlhflx(:) = cpair / gamma * desat / res * rhoair ! [W/m2] - lhflx(:) = rhoair * lambda * (qsrf - qref) / res ! [W/m2] = [kg/m3] * [J/kg] * [kg/kg] * [unitless] / [s/m] -> kg/m3 * J/kg * m/s = kg/kg J/s 1/m2 = W/m2 - dlhflx(:) = rhoair * lambda * dqsrf / res ! [W/m2/K] = [kg/m3] * [J/kg] * [kg/kg/K] * [unitless] / [s/m] -> kg/m3 * J/kg * 1/K * m/s -> J/s /K /m2 = W/m2/K - end where - - ! Check if we tried to evaporate more water than is available - ! ... probably isn't the sneakiest way to do this... what if dlhflx is <0? then we might - ! be okay - would have to check at end of time step... - where ( lhflx * dt / lambda > ( water + snow ) ) ! [W/m2] * [s] / [J/kg] -> W * [s/J] * kg/m2 = kg/m2 - !write(iulog,*)subname, 'MML tried to evaporate more water than there is in snow + water, adjusting accordingly' - !lhflx(:) = lambda / dt * ( water + snow ) * rhoair ! [W/m2] - !dlhflx(:) = 0._r8 ! [W/m2] - lhflx(:) = lambda / dt * ( water + snow ) ! [W/m2] = [J/kg] / [s] * [kg/m2] -> J/s * kg/kg/m2 = W/m2 - dlhflx(:) = 0._r8 ! [W/m2/K] - end where - - - - - - ! Net flux of energy into soil [W/m2] and temperature derivative [W/m2/K] from the - ! surface energy imbalance given other fluxes: - f0(:) = radforc - ( lwrad + lhflx + shflx ) ! [W/m2] - df0(:) = - ( dlwrad + dlhflx + dshflx ) ! [W/m2] - - ! lets temporarily save this value out as gsoi (not the real gsoi, but the right "family" - gsoi(:) = f0 ! [W/m2] - - - ! ------------------------------------------------------------- - ! Initial pass at soil temperatures - ! ------------------------------------------------------------- - - ! Initial change in soil temperatures = 0 - dtsoi(:,:) = 0.0_r8 ! see if this helps? - - ! ------------------------------------------------------------- - ! Set up tri-diagonal matrix - - ! surface - i = 1 - - aa(:,i) = 0.0_r8 - cc(:,i) = -soil_tkh(:,i) / ( soil_z(:,i) - soil_z(:,i+1) ) - bb(:,i) = soil_cv(:,i) * soil_dz(:,i) / dt - cc(:,i) - df0 - dd(:,i) = -soil_tkh(:,i) * ( tsoi(:,i) - tsoi(:,i+1) ) / ( soil_z(:,i) - soil_z(:,i+1) ) + f0 - - ! layers 2 to nsoi-1 - dummy = mml_nsoi - 1 - do i = 2, dummy - aa(:,i) = -soil_tkh(:,i-1) / ( soil_z(:,i-1) - soil_z(:,i) ) - cc(:,i) = -soil_tkh(:,i) / ( soil_z(:,i) - soil_z(:,i+1) ) - bb(:,i) = soil_cv(:,i) * soil_dz(:,i) / dt - aa(:,i) - cc(:,i) - dd(:,i) = soil_tkh(:,i-1) * ( tsoi(:,i-1) - tsoi(:,i) ) / (soil_z(:,i-1) - soil_z(:,i)) & - - soil_tkh(:,i) * (tsoi(:,i) - tsoi(:,i+1)) / (soil_z(:,i) - soil_z(:,i+1)) - end do - - ! Bottom soil layer - i = mml_nsoi - aa(:,i) = -soil_tkh(:,i-1) / (soil_z(:,i-1) - soil_z(:,i)) - cc(:,i) = 0.0_r8 - bb(:,i) = soil_cv(:,i) * soil_dz(:,i) / dt - aa(:,i) - dd(:,i) = soil_tkh(:,i-1) * (tsoi(:,i-1) - tsoi(:,i)) / (soil_z(:,i-1) - soil_z(:,i)) - - ! ---------------------------------------------------------- - ! Begin forward (upward) sweep of tridiagonal matrix from layer N to 1 - - ! Bottom soil layer - i = mml_nsoi - ee(:,i) = aa(:,i) / bb(:,i) - ff(:,i) = dd(:,i) / bb(:,i) - - ! Layers nsoi-1 to 2 - dummy = mml_nsoi-1 - do i = dummy, 2, -1 - den = bb(:,i) - cc(:,i)*ee(:,i+1) - ee(:,i) = aa(:,i) / den - ff(:,i) = (dd(:,i) - cc(:,i)*ff(:,i+1)) / den - end do - - ! Complete tridiagonal sol'n to get initial temperature guess for top soil layer - i = 1 - num = dd(:,i) - cc(:,i) * ff(:,i+1) - den = bb(:,i) - cc(:,i) * ee(:,i+1) - tsrf = tsoi0(:,i) + num/den - - - !write(iulog,*)subname, 'MML new tridiagonal solver IS being used' - - ! ------------------------------------------------------------- - ! Snow accounting: - ! if tsrf>freezing and there is snow on the ground, melt some snow! - ! ------------------------------------------------------------- - - !t_to_snow(:) = soil_cv(:,1) * soil_dz(:,1) / hfus ! factor to convert a change in temperature to snow melt - - ! how much snow can we melt given the temperature? - snow_melt = 0.0_r8 - !where ( snow > 0.0_r8 .and. tsrf > tfrz) snow_melt(:) = (tsrf(:) - tfrz) * den(:) * t_to_snow(:) - - ! Maximum snow melt RATE based on temperature above freezing: - ptl_snow_melt(:) = max(0.0 , (tsrf(:) - tfrz) * den(:) / hfus) - !where ( snow > 0.0_r8 .and. tsrf > tfrz) snow_melt(:) = (tsrf(:) - tfrz) * den(:) / hfus - - ! Maximum melt RATE is the rate it would take to melt all the snow that is currently present: - max_snow_melt(:) = snow / dt - - ! Set actual snow melt RATE to either the total the potential (if enough snow is present) or the total (if enoguh energy is present) - snow_melt(:) = min( max_snow_melt(:) , ptl_snow_melt(:) ) - - ! Energy flux associated with realized snow melt - gsnow(:) = snow_melt(:) * hfus ! [kg/m2/s]*[J/kg] = [J/s/m2] = [W/m2] - - ! Recalculate melt based off how much snow is actually present (can't melt more - ! than what is actually present) - ! If we have more energy than snow to melt, update surface temperature accordingly - !where ( snow > 0.0_r8 .and. snow_melt > 0.0_r8 .and. snow_melt <= snow ) tsrf(:) = tfrz ! where snow_melt < snow, temperature stays at freezing - !where ( snow > 0.0_r8 .and. snow_melt > 0.0_r8 .and. snow_melt > snow ) - ! snow_melt(:) = snow ! melt all available snow - ! tsrf(:) = tsoi(:,1) + (num(:) - snow_melt(:)/t_to_snow(:))/den(:) - !end where - - ! Update snow and water buckets accordingly -> convert to water units, not rates - snow(:) = snow - snow_melt*dt ! [kg/m2] = [kg/m2] - [kg/m2/s]*[s] - water(:) = water + snow_melt*dt - - ! Update surface temperature to reflect snow melt: - ! If there is no snow melt, tsoi(1) = tsrf as above, unmodified - ! While snow is actively melting, tsrf should be tfrz - ! If snow melt was less than the total energy, tsrf should be > trfz but less tahn tsrf above - tsoi(:,1) = tsoi(:,1) + (num - gsnow) / den; - dtsoi(:,1) = tsoi(:,1) - tsoi0(:,1) - - - ! ------------------------------------------------------------- - ! Complete the tri-diagonal solver for soil temperature given we now know the - ! surface temperature after snow melting - ! ------------------------------------------------------------- - - !dtsoi(:,1) = tsrf(:) - tsoi(:,1) ! save change in top soil layer - !tsoi(:,1) = tsrf(:) ! update top soil layer to be surface temperature - - !------ Complete tri-diagonal solver (downwards sweep) - do i = 2,mml_nsoi - dtsoi(:,i) = ff(:,i) - ee(:,i)*dtsoi(:,i-1) - tsoi(:,i) = tsoi(:,i) + dtsoi(:,i) - end do - - !dummy = mml_nsoi - 1 - !do i = 1, dummy - ! dtsoi(:,i+1) = dp(:,i) + cp(:,i)*dtsoi(:,i) ! ah, this hsould have been i+1 - ! tsoi(:,i+1) = tsoi(:,i+1) + dtsoi(:,i+1) ! old tsoi + dtsoi - !end do - - - ! ------------------------------------------------------------- - ! Update surface energy fluxes based on the change in surface temperature - ! ------------------------------------------------------------- - - lwrad(:) = lwrad + dlwrad * dtsoi(:,1) - lhflx(:) = lhflx + dlhflx * dtsoi(:,1) ! if lhflx = snow+water, dlhflx = 0 - shflx(:) = shflx + dshflx * dtsoi(:,1) - ! and the ground energy flux: - gsoi(:) = f0 + df0 * dtsoi(:,1) - - ! split energy flux into ground into flux into soil (gsoi) and snow (gsnow) - gsoi(:) = gsoi(:) - gsnow(:) - !gsoi(:) = gsoi - snow_melt / dt * hfus - !gsnow(:) = snow_melt / dt * hfus - - - ! Energy conservation check: - ! Sum change in energy (W/m2) - edif(:) = 0._r8 - do i = 1,mml_nsoi - edif(:) = edif(:) + soil_cv(:,i) * soil_dz(:,i) * ( tsoi(:,i) - tsoi0(:,i) ) / dt - end do - ! Energy conservation check: - err(:) = 0._r8 - err(:) = edif(:) - gsoi(:) - do g = begg,endg - if ( abs( err(g) ) > 1.0e-06 ) then - write(iulog,*)subname, 'MML ERROR: Soil temperature energy conservation error: pre-phase change' - call endrun(msg=errmsg(__FILE__, __LINE__)) - end if - end do - - ! Maybe should be checking lhflx HERE for if it is larger than water+snow - - - lwup(:) = lwup + lwrad ! reflected longwave (0 at the moment) plus sigma*T^4 - - - ! ------------------------------------------------------------- - ! TO DO: - ! If lhflx < 0 and the total amount of water the land tries to suck out of the atmosphere is - ! larger than the total water available in the lowest level of the atmosphere, cap the negative LHFLX - ! at the amount of water in the atm_bot and put the excess energy into SHFLX (cam has a check - ! that does this (qneg4.f90) - - ! check 1: if evap*dt > water + snow at this point, take excess and put into sensible heat flux? - do g = begg, endg - if ( lhflx(g) * dt / lambda(g) > (water(g) + snow(g)) ) then - !where ( lhflx * dt / lambda > (water + snow) ) - temp(g) = lhflx(g) - (water(g) + snow(g)) * lambda(g) / dt !excess energy that we don't have water for - lhflx(g) = lhflx(g) - temp(g) ! remove the excess from lh - shflx(g) = shflx(g) + temp(g) ! give it to shflx ... ask Gordon about a better way to do this... - write(iulog,*)subname, 'MML Warning: lhflx > available water; put excess in shflx' - !end where - end if ! put in an if loop just so I could get it to write the warning - end do - - - ! MML 2021.09.13: move update of evap (in water units) to AFTER the lh/sh check - otherwise lh and evap won't match (once put into proper units) + ! Initialize beta = 1.0 (no extra bucket resistance) everywhere. Overwrite with smaller values where appropriate. + beta(begg:endg) = 1.0_r8 + + ! similarly initialize mml_lnd_effective_res_grc and mml_lnd_res_grc to avoid nans + atm2lnd_inst%mml_lnd_effective_res_grc(begg:endg) = 1.0_r8 !9999.99_r8 + atm2lnd_inst%mml_lnd_res_grc(begg:endg) = 1.0_r8 ! 9999.99_r8 + + where ( snow(begg:endg) <= 0 ) + beta = min ( water / (0.75_r8 * bucket_cap) , 1.0_r8 ) ! scaling factor [unitless] + ! OH I bet the problem is that I only end up defining beta in places where snow<0 -- hence the nan problem!!! So I should initialize + ! a starting beta matrix where everywhere is 1.0 or something! + ! add minimum beta value in case water is negative? + !lhflx(:) = cpair / gamma * (esat - eref) / res * beta * rhoair ! [W/m2] = [J/kg/K] / [Pa/K] * [Pa] / [s/m] * [unitless] * [kg/m3] + !dlhflx(:) = cpair / gamma * desat / res * beta * rhoair ! [W/m2/K] + lhflx = rhoair * lambda * (qsrf - qref) * beta / res ! [W/m2] = [kg/m3] * [J/kg] * [kg/kg] * [unitless] / [s/m] -> kg/m3 * J/kg * m/s = kg/kg J/s 1/m2 = W/m2 + dlhflx = rhoair * lambda * dqsrf * beta / res ! [W/m2/K] = [kg/m3] * [J/kg] * [kg/kg/K] * [unitless] / [s/m] -> kg/m3 * J/kg * 1/K * m/s -> J/s /K /m2 = W/m2/K + ! got here doing unit analysis - make sure this is actually the right equation!!! + end where + + ! make sure beta isn't negative (if neg, set equal to 0) + where ( beta(begg:endg) <= 0.0_r8 ) + beta = 0.0_r8 + end where + + where ( snow(begg:endg) > 0 ) ! go where there is snow and overwrite the value of lhflx and dlhflx + !lhflx(:) = cpair / gamma * ( esat - eref ) / res * rhoair ! [W/m2] + !dlhflx(:) = cpair / gamma * desat / res * rhoair ! [W/m2] + lhflx = rhoair * lambda * (qsrf - qref) / res ! [W/m2] = [kg/m3] * [J/kg] * [kg/kg] * [unitless] / [s/m] -> kg/m3 * J/kg * m/s = kg/kg J/s 1/m2 = W/m2 + dlhflx = rhoair * lambda * dqsrf / res ! [W/m2/K] = [kg/m3] * [J/kg] * [kg/kg/K] * [unitless] / [s/m] -> kg/m3 * J/kg * 1/K * m/s -> J/s /K /m2 = W/m2/K + end where + + ! Check if we tried to evaporate more water than is available + ! ... probably isn't the sneakiest way to do this... what if dlhflx is <0? then we might + ! be okay - would have to check at end of time step... + where ( lhflx(begg:endg) * dt / lambda(begg:endg) > ( water(begg:endg) + snow(begg:endg) ) ) ! [W/m2] * [s] / [J/kg] -> W * [s/J] * kg/m2 = kg/m2 + !write(iulog,*)subname, 'MML tried to evaporate more water than there is in snow + water, adjusting accordingly' + !lhflx(:) = lambda / dt * ( water + snow ) * rhoair ! [W/m2] + !dlhflx(:) = 0._r8 ! [W/m2] + lhflx = lambda / dt * ( water + snow ) ! [W/m2] = [J/kg] / [s] * [kg/m2] -> J/s * kg/kg/m2 = W/m2 + dlhflx = 0._r8 ! [W/m2/K] + end where + + + begg_to_endg_1: do g = begg, endg + ! Net flux of energy into soil [W/m2] and temperature derivative [W/m2/K] from the + ! surface energy imbalance given other fluxes: + f0(g) = radforc(g) - ( lwrad(g) + lhflx(g) + shflx(g) ) ! [W/m2] + df0(g) = - ( dlwrad(g) + dlhflx(g) + dshflx(g) ) ! [W/m2] + + ! lets temporarily save this value out as gsoi (not the real gsoi, but the right "family" + gsoi(g) = f0(g) ! [W/m2] + + + ! ------------------------------------------------------------- + ! Initial pass at soil temperatures + ! ------------------------------------------------------------- + + ! Initial change in soil temperatures = 0 + dtsoi(g,:) = 0.0_r8 ! see if this helps? + + ! ------------------------------------------------------------- + ! Set up tri-diagonal matrix + + ! surface + i = 1 + + aa(g,i) = 0.0_r8 + cc(g,i) = -soil_tkh(g,i) / ( soil_z(g,i) - soil_z(g,i+1) ) + bb(g,i) = soil_cv(g,i) * soil_dz(g,i) / dt - cc(g,i) - df0(g) + dd(g,i) = -soil_tkh(g,i) * ( tsoi(g,i) - tsoi(g,i+1) ) / ( soil_z(g,i) - soil_z(g,i+1) ) + f0(g) + + ! layers 2 to nsoi-1 + dummy = mml_nsoi - 1 + do i = 2, dummy + aa(g,i) = -soil_tkh(g,i-1) / ( soil_z(g,i-1) - soil_z(g,i) ) + cc(g,i) = -soil_tkh(g,i) / ( soil_z(g,i) - soil_z(g,i+1) ) + bb(g,i) = soil_cv(g,i) * soil_dz(g,i) / dt - aa(g,i) - cc(g,i) + dd(g,i) = soil_tkh(g,i-1) * ( tsoi(g,i-1) - tsoi(g,i) ) / (soil_z(g,i-1) - soil_z(g,i)) & + - soil_tkh(g,i) * (tsoi(g,i) - tsoi(g,i+1)) / (soil_z(g,i) - soil_z(g,i+1)) + end do + + ! Bottom soil layer + i = mml_nsoi + aa(g,i) = -soil_tkh(g,i-1) / (soil_z(g,i-1) - soil_z(g,i)) + cc(g,i) = 0.0_r8 + bb(g,i) = soil_cv(g,i) * soil_dz(g,i) / dt - aa(g,i) + dd(g,i) = soil_tkh(g,i-1) * (tsoi(g,i-1) - tsoi(g,i)) / (soil_z(g,i-1) - soil_z(g,i)) + + ! ---------------------------------------------------------- + ! Begin forward (upward) sweep of tridiagonal matrix from layer N to 1 + + ! Bottom soil layer + i = mml_nsoi + ee(g,i) = aa(g,i) / bb(g,i) + ff(g,i) = dd(g,i) / bb(g,i) + + ! Layers nsoi-1 to 2 + dummy = mml_nsoi-1 + do i = dummy, 2, -1 + den = bb(g,i) - cc(g,i) * ee(g,i+1) + ee(g,i) = aa(g,i) / den(g) + ff(g,i) = (dd(g,i) - cc(g,i) * ff(g,i+1)) / den(g) + end do + + ! Complete tridiagonal sol'n to get initial temperature guess for top soil layer + i = 1 + num = dd(g,i) - cc(g,i) * ff(g,i+1) + den = bb(g,i) - cc(g,i) * ee(g,i+1) + tsrf(g) = tsoi0(g,i) + num(g) / den(g) + + !write(iulog,*)subname, 'MML new tridiagonal solver IS being used' + + ! ------------------------------------------------------------- + ! Snow accounting: + ! if tsrf>freezing and there is snow on the ground, melt some snow! + ! ------------------------------------------------------------- + + !t_to_snow(:) = soil_cv(:,1) * soil_dz(:,1) / hfus ! factor to convert a change in temperature to snow melt + + ! how much snow can we melt given the temperature? + snow_melt(g) = 0.0_r8 + !where ( snow > 0.0_r8 .and. tsrf > tfrz) snow_melt(:) = (tsrf(:) - tfrz) * den(:) * t_to_snow(:) + + ! Maximum snow melt RATE based on temperature above freezing: + ptl_snow_melt(g) = max(0.0 , (tsrf(g) - tfrz) * den(g) / hfus) + !where ( snow > 0.0_r8 .and. tsrf > tfrz) snow_melt(:) = (tsrf(:) - tfrz) * den(:) / hfus + + ! Maximum melt RATE is the rate it would take to melt all the snow that is currently present: + max_snow_melt(g) = snow(g) / dt + + ! Set actual snow melt RATE to either the total the potential (if enough snow is present) or the total (if enoguh energy is present) + snow_melt(g) = min( max_snow_melt(g) , ptl_snow_melt(g) ) + + ! Energy flux associated with realized snow melt + gsnow(g) = snow_melt(g) * hfus ! [kg/m2/s]*[J/kg] = [J/s/m2] = [W/m2] + + ! Recalculate melt based off how much snow is actually present (can't melt more + ! than what is actually present) + ! If we have more energy than snow to melt, update surface temperature accordingly + !where ( snow > 0.0_r8 .and. snow_melt > 0.0_r8 .and. snow_melt <= snow ) tsrf(:) = tfrz ! where snow_melt < snow, temperature stays at freezing + !where ( snow > 0.0_r8 .and. snow_melt > 0.0_r8 .and. snow_melt > snow ) + ! snow_melt(:) = snow ! melt all available snow + ! tsrf(:) = tsoi(:,1) + (num(:) - snow_melt(:)/t_to_snow(:))/den(:) + !end where - ! LHFLX in water units [kg/m2/s = mm/s] - ! update evap(g) - !evap(:) = lhflx * dt / lambda - evap(:) = lhflx / lambda ! kg/m2/s or mm/s, NOT times dt!!!! + ! Update snow and water buckets accordingly -> convert to water units, not rates + snow(g) = snow(g) - snow_melt(g) * dt ! [kg/m2] = [kg/m2] - [kg/m2/s]*[s] + water(g) = water(g) + snow_melt(g) * dt + + ! Update surface temperature to reflect snow melt: + ! If there is no snow melt, tsoi(1) = tsrf as above, unmodified + ! While snow is actively melting, tsrf should be tfrz + ! If snow melt was less than the total energy, tsrf should be > trfz but less tahn tsrf above + tsoi(g,1) = tsoi(g,1) + (num(g) - gsnow(g)) / den(g) + dtsoi(g,1) = tsoi(g,1) - tsoi0(g,1) + + ! ------------------------------------------------------------- + ! Complete the tri-diagonal solver for soil temperature given we now know the + ! surface temperature after snow melting + ! ------------------------------------------------------------- + + !dtsoi(:,1) = tsrf(:) - tsoi(:,1) ! save change in top soil layer + !tsoi(:,1) = tsrf(:) ! update top soil layer to be surface temperature + + !------ Complete tri-diagonal solver (downwards sweep) + do i = 2,mml_nsoi + dtsoi(g,i) = ff(g,i) - ee(g,i) * dtsoi(g,i-1) + tsoi(g,i) = tsoi(g,i) + dtsoi(g,i) + end do + + !dummy = mml_nsoi - 1 + !do i = 1, dummy + ! dtsoi(:,i+1) = dp(:,i) + cp(:,i)*dtsoi(:,i) ! ah, this should have been i+1 + ! tsoi(:,i+1) = tsoi(:,i+1) + dtsoi(:,i+1) ! old tsoi + dtsoi + !end do + + ! ------------------------------------------------------------- + ! Update surface energy fluxes based on the change in surface temperature + ! ------------------------------------------------------------- + + lwrad(g) = lwrad(g) + dlwrad(g) * dtsoi(g,1) + lhflx(g) = lhflx(g) + dlhflx(g) * dtsoi(g,1) ! if lhflx = snow+water, dlhflx = 0 + shflx(g) = shflx(g) + dshflx(g) * dtsoi(g,1) + ! and the ground energy flux: + gsoi(g) = f0(g) + df0(g) * dtsoi(g,1) + + ! split energy flux into ground into flux into soil (gsoi) and snow (gsnow) + gsoi(g) = gsoi(g) - gsnow(g) + !gsoi(g) = gsoi(g) - snow_melt(g) / dt * hfus + !gsnow(g) = snow_melt(g) / dt * hfus + + + ! Energy conservation check: + ! Sum change in energy (W/m2) + edif(g) = 0._r8 + do i = 1,mml_nsoi + edif(g) = edif(g) + soil_cv(g,i) * soil_dz(g,i) * ( tsoi(g,i) - tsoi0(g,i) ) / dt + end do + ! Energy conservation check: + err(g) = 0._r8 + err(g) = edif(g) - gsoi(g) + + if ( abs( err(g) ) > 1.0e-06 ) then + write(iulog,*)subname, 'MML ERROR: Soil temperature energy conservation error: pre-phase change' + call endrun(msg=errmsg(__FILE__, __LINE__)) + end if + ! Maybe should be checking lhflx HERE for if it is larger than water+snow + + lwup(g) = lwup(g) + lwrad(g) ! reflected longwave (0 at the moment) plus sigma*T^4 + + ! ------------------------------------------------------------- + ! TO DO: + ! If lhflx < 0 and the total amount of water the land tries to suck out of the atmosphere is + ! larger than the total water available in the lowest level of the atmosphere, cap the negative LHFLX + ! at the amount of water in the atm_bot and put the excess energy into SHFLX (cam has a check + ! that does this (qneg4.f90) + + ! check 1: if evap*dt > water + snow at this point, take excess and put into sensible heat flux? + if ( lhflx(g) * dt / lambda(g) > (water(g) + snow(g)) ) then + !where ( lhflx * dt / lambda > (water + snow) ) + temp(g) = lhflx(g) - (water(g) + snow(g)) * lambda(g) / dt !excess energy that we don't have water for + lhflx(g) = lhflx(g) - temp(g) ! remove the excess from lh + shflx(g) = shflx(g) + temp(g) ! give it to shflx ... ask Gordon about a better way to do this... + write(iulog,*)subname, 'MML Warning: lhflx > available water; put excess in shflx' + !end where + end if ! put in an if loop just so I could get it to write the warning + + ! MML 2021.09.13: move update of evap (in water units) to AFTER the lh/sh check - otherwise lh and evap won't match (once put into proper units) + + ! LHFLX in water units [kg/m2/s = mm/s] + ! update evap(g) + !evap(:) = lhflx * dt / lambda + evap(g) = lhflx(g) / lambda(g) ! kg/m2/s or mm/s, NOT times dt!!!! + +! ------------------------------------------------------------- +! Check that dew doesn't exceed water available in lowest atm level +! ------------------------------------------------------------- +! check 2: if evap*dt < 0 and requires more water than is available in the bottom of the atmosphere, +! that is bad... the atmosphere corrects for it, but I want the atm and land to be self-consistent... +! TODO STILL! +! GBB: CLM does not do this +! +! MML: implement a check for this (go back to CAM QNEG3 OR QNEG4 to check how CAM does it) +! Then limit the CLM LHFLX to whatever CAM is going to adjust it to. Also, print out how +! big that energy difference is and save it somewhere - it'll be big in the first couple +! of time steps, but I'm not sure how big/negligible it is after the model is sort of spun +! up. Gordon said there was O(1) W/m2 of energy that sort of gets lost in the coupled +! model - I'm curious if this contributes to that, or if this is totally negligible once +! the models spins up. +! (What CAM does is takes the excess energy that was in LHFLX (but there isn't enough water available +! in the lower level of the atmosphere for) and adds it to the SHFLX, so its still conserving ENERGY +! (ie shouldn't be a source of an energy leak), but its changing the PATHWAY the energy takes. - ! ------------------------------------------------------------- - ! Check that dew doesn't exceed water available in lowest atm level - ! ------------------------------------------------------------- - ! check 2: if evap*dt < 0 and requires more water than is available in the bottom of the atmosphere, - ! that is bad... the atmosphere corrects for it, but I want the atm and land to be self-consistent... - ! TODO STILL! - ! GBB: CLM does not do this - ! - ! MML: implement a check for this (go back to CAM QNEG3 OR QNEG4 to check how CAM does it) - ! Then limit the CLM LHFLX to whatever CAM is going to adjust it to. Also, print out how - ! big that energy difference is and save it somewhere - it'll be big in the first couple - ! of time steps, but I'm not sure how big/negligible it is after the model is sort of spun - ! up. Gordon said there was O(1) W/m2 of energy that sort of gets lost in the coupled - ! model - I'm curious if this contributes to that, or if this is totally negligible once - ! the models spins up. - ! (What CAM does is takes the excess energy that was in LHFLX (but there isn't enough water available - ! in the lower level of the atmosphere for) and adds it to the SHFLX, so its still conserving ENERGY - ! (ie shouldn't be a source of an energy leak), but its changing the PATHWAY the energy takes. - ! ! Method: ! ! Following that of the CAM routine qneg4.F90 in cam/src/physics ! ! @@ -1451,124 +1421,119 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! write(iulog,*)subname, 'MML Warning: initial shflx = ', shflx(endg) ! !call endrun(msg=errmsg(__FILE__, __LINE__)) ! end if - - - - ! ------------------------------------------------------------- - ! Update fsns and flns - fsns = fsds - fsr - ! compare to sw_abs, should be the same. Put in diag3_1d - !diag3_1d = sw_abs - - flns = lwdn - lwup - + ! ------------------------------------------------------------- + ! Update fsns and flns + fsns(g) = fsds(g) - fsr(g) + ! compare to sw_abs, should be the same. Put in diag3_1d + !diag3_1d = sw_abs + + flns(g) = lwdn(g) - lwup(g) + + ! ------------------------------------------------------------- + ! Adjust soil temperatures for phase change (freezing/thawing in soil) + ! ------------------------------------------------------------- + + ! have to translate that function first :p + ! returns new tsoi and epc, where epc is the energy used in phase change [W/m2] + epc(g) = 0.0 ! for now + end do begg_to_endg_1 + + call phase_change (begg, endg, tsoi, soil_cv, soil_dz, & + soil_maxice, soil_liq, soil_ice, & + mml_nsoi, dt, hfus, tfrz, epc & + !diag1_1d, diag1_2d, diag2_2d, diag3_2d & ! temporary diagnostics + ) + + begg_to_endg_2: do g = begg, endg + ! ------------------------------------------------------------- + ! Check soil temperature energy conservation + ! ------------------------------------------------------------- + edif(g) = 0.0 ! change in energy in each layer + do i = 1, mml_nsoi + edif(g) = edif(g) + soil_cv(g,i) * soil_dz(g,i) * (tsoi(g,i) - tsoi0(g,i)) / dt + end do + + err(g) = edif(g) - gsoi(g) - epc(g) ! not counting gsnow here, because it didn't heat/cool soil + + if ( abs(err(g)) .gt. 1.0e-06 ) then + write(iulog,*)subname, 'MML Soil Temperature Conservation Error :( at g = ', g, & + 'err(g) = ', err(g), ', edif(g) = ', edif(g),', gsoi(g) = ', gsoi(g) + call endrun(msg=errmsg(__FILE__, __LINE__)) + end if - ! ------------------------------------------------------------- - ! Adjust soil temperatures for phase change (freezing/thawing in soil) - ! ------------------------------------------------------------- - - ! have to translate that function first :p - ! returns new tsoi and epc, where epc is the energy used in phase change [W/m2] - epc(:) = 0.0 ! for now - - call phase_change (begg, endg, tsoi, soil_cv, soil_dz, & - soil_maxice, soil_liq, soil_ice, & - mml_nsoi, dt, hfus, tfrz, epc & - !diag1_1d, diag1_2d, diag2_2d, diag3_2d & ! temporary diagnostics - ) - - ! ------------------------------------------------------------- - ! Check soil temperature energy conservation - ! ------------------------------------------------------------- - edif(:) = 0.0 ! change in energy in each layer - do i = 1, mml_nsoi - edif(:) = edif(:) + soil_cv(:,i) * soil_dz(:,i) * (tsoi(:,i) - tsoi0(:,i)) / dt - end do - - err(:) = edif(:) - gsoi(:) - epc(:) ! not counting gsnow here, because it didn't heat/cool soil - - do g = begg, endg - if ( abs(err(g)) .gt. 1.0e-06 ) then - write(iulog,*)subname, 'MML Soil Temperature Conservation Error :( at g = ', g, & - 'err(g) = ', err(g), ', edif(g) = ', edif(g),', gsoi(g) = ', gsoi(g) - call endrun(msg=errmsg(__FILE__, __LINE__)) - end if - end do - - ! ------------------------------------------------------------- - ! Bucket hydrology! - ! Remove water that evaporated via LHFLX from ye-old water and snow buckets - ! Also add rain/snow falling in from the great-big-sometimes-blue sky - ! Then calculate runoff if the bucket overflowed - ! - ! Ask Gordon - should I be raining into the bucket at the start of the time step? - ! then let the bucket exceed capacity, do evaporation, and only if there is excess water - ! at the end of the time step send it to runoff? - ! (right now, I'm raining after LHFLX is calculated, so if it was dry then rains, - ! we have small lhflx, but it could catch up next time step... - ! ... probably doesn't matter much on the monthly mean scale, but if doing it one - ! way vs the other results in wibbly-wobbly surface fluxes from time step to time - ! step which can be avoided, should do it right... - ! - ! GBB: This is how I would do it (calculate latent heat flux on current soil - ! water) and then update the soil water. See what GFDL did. - ! ------------------------------------------------------------- - - !write(iulog,*)subname, 'MML welcome to bucket hydrology land!' - - ! If there is snow on the ground, sublimate that to get lhflx - ! If there isn't enough snow to accomodate evap(g) when there is snow, steal it from - ! the water bucket (without accounting for hvap or soil wetness or anything like that - - ! treating the snow like it has a magic straw into the soil pool) - ! If there isn't snow, take the water in evap(g) right from the soil water bucket - - - !------------------------------------ - ! Rain into buckets - - ! (should I do this at the start of the time step? would up the amount of lh possible...) - water = water + mms2kgm * prec_liq ! water in bucket [kg/m2] - snow = snow + mms2kgm * prec_frz ! snow in bucket [kg/m2] - - - ! ------------------------------------------------------------- - ! Evaporation - - ! shouldn't ever be in a case where evap > snow + water, it checks that when calculating lhflx - ! though its possible if lhflx was close to snow + water, that when we update with dTsrf, it goes negative... hmm... - ! (allow it for now?) - - ! Snow Evaporation: - snow0 = snow - water0 = water - - where (snow0 > 0 .and. evap*dt <= snow0) - ! where snow is enough to cover all evaporation, take lhflx out of snow bucket - snow(:) = snow0(:) - evap(:)*dt ! here I need to say evap*dt to get kg/m2 not kg/m2/s - ! NOTE: IF lhflx < 0, then evap < 0, so this will ADD snow to snow bucket (sucking water out of atm) + ! ------------------------------------------------------------- + ! Bucket hydrology! + ! Remove water that evaporated via LHFLX from ye-old water and snow buckets + ! Also add rain/snow falling in from the great-big-sometimes-blue sky + ! Then calculate runoff if the bucket overflowed + ! + ! Ask Gordon - should I be raining into the bucket at the start of the time step? + ! then let the bucket exceed capacity, do evaporation, and only if there is excess water + ! at the end of the time step send it to runoff? + ! (right now, I'm raining after LHFLX is calculated, so if it was dry then rains, + ! we have small lhflx, but it could catch up next time step... + ! ... probably doesn't matter much on the monthly mean scale, but if doing it one + ! way vs the other results in wibbly-wobbly surface fluxes from time step to time + ! step which can be avoided, should do it right... + ! + ! GBB: This is how I would do it (calculate latent heat flux on current soil + ! water) and then update the soil water. See what GFDL did. + ! ------------------------------------------------------------- + + !write(iulog,*)subname, 'MML welcome to bucket hydrology land!' + + ! If there is snow on the ground, sublimate that to get lhflx + ! If there isn't enough snow to accomodate evap(g) when there is snow, steal it from + ! the water bucket (without accounting for hvap or soil wetness or anything like that - + ! treating the snow like it has a magic straw into the soil pool) + ! If there isn't snow, take the water in evap(g) right from the soil water bucket + + !------------------------------------ + ! Rain into buckets + + ! (should I do this at the start of the time step? would up the amount of lh possible...) + water(g) = water(g) + mms2kgm * prec_liq(g) ! water in bucket [kg/m2] + snow(g) = snow(g) + mms2kgm * prec_frz(g) ! snow in bucket [kg/m2] + + ! ------------------------------------------------------------- + ! Evaporation + + ! shouldn't ever be in a case where evap > snow + water, it checks that when calculating lhflx + ! though its possible if lhflx was close to snow + water, that when we update with dTsrf, it goes negative... hmm... + ! (allow it for now?) + + ! Snow Evaporation: + snow0(g) = snow(g) + water0(g) = water(g) + end do begg_to_endg_2 + + where (snow0(begg:endg) > 0 .and. evap(begg:endg) * dt <= snow0(begg:endg)) + ! where snow is enough to cover all evaporation, take lhflx out of snow bucket + snow = snow0 - evap * dt ! here I need to say evap*dt to get kg/m2 not kg/m2/s + ! NOTE: IF lhflx < 0, then evap < 0, so this will ADD snow to snow bucket (sucking water out of atm) end where ! MML 2021.09.21: changed from using snow to using snow0 in the where statments, otherwise I'm going to evaproate twice, aren't I? - where (snow0 > 0 .and. evap*dt > snow0) - ! where snow isn't enough to cover all evaporation - - ! steal excess water we need from soil bucket - wat2snow(:) = evap*dt - snow0 - ! remove wat2snow from water bucket - water(:) = water0 - wat2snow ! POSSIBLE that this could go negative at one time step, but shouldn't blow up - ! give snow wat2snow and remove evap (should equal zero) - snow(:) = snow0 + wat2snow - evap*dt - - ! NOTE: IF lhflx < 0, then evap < 0, so this will ADD water to the bucket (sucking it out of the atmosphere) - ! ... shouldn't actually happen in this case b/c evap*dt < 0 shouldn't also be > snow + where (snow0(begg:endg) > 0 .and. evap(begg:endg) * dt > snow0(begg:endg)) + ! where snow isn't enough to cover all evaporation + + ! steal excess water we need from soil bucket + wat2snow = evap * dt - snow0 + ! remove wat2snow from water bucket + water = water0 - wat2snow ! POSSIBLE that this could go negative at one time step, but shouldn't blow up + ! give snow wat2snow and remove evap (should equal zero) + snow = snow0 + wat2snow - evap * dt + + ! NOTE: IF lhflx < 0, then evap < 0, so this will ADD water to the bucket (sucking it out of the atmosphere) + ! ... shouldn't actually happen in this case b/c evap*dt < 0 shouldn't also be > snow end where ! Snow-free Evaporation: - where (snow0 <= 0 ) - water(:) = water0 - evap*dt - ! NOTE: IF lhflx < 0, then evap < 0, so this will ADD water to the bucket (sucking it out of the atmosphere) + where (snow0(begg:endg) <= 0 ) + water = water0 - evap * dt + ! NOTE: IF lhflx < 0, then evap < 0, so this will ADD water to the bucket (sucking it out of the atmosphere) end where ! Check water and snow buckets @@ -1591,15 +1556,12 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst end if end do - - - !------------------------------------ ! Runoff: check if bucket overflowed - where (water > bucket_cap) - runoff = water - bucket_cap ! excess h20 - water = bucket_cap + where (water(begg:endg) > bucket_cap(begg:endg)) + runoff = water - bucket_cap ! excess h20 + water = bucket_cap end where ! Check we didn't let snow or water go negative @@ -1648,7 +1610,7 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! ------------------------------------------------------------- ! radforc = swabs + lwabs ! lwup = lw_reflected + lwrad - err = radforc - (lwup + lhflx + shflx + gsoi + gsnow) + err(begg:endg) = radforc(begg:endg) - (lwup(begg:endg) + lhflx(begg:endg) + shflx(begg:endg) + gsoi(begg:endg) + gsnow(begg:endg)) do g = begg, endg if( abs(err(g)) > 1.0e-06) then write(iulog,*)subname, 'MML ERROR: Not conserving energy (surface fluxes) \n', & @@ -1662,32 +1624,27 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst call endrun(msg=errmsg(__FILE__, __LINE__)) end if end do - - - - - ! ------------------------------------------------------------- ! Update qs (surface specific humidity - need it for next round's MO calculations) ! ------------------------------------------------------------- ! instead of direct calculation, re-evaluate QSat on the new surface temperature to get qsrf - qsrf(:) = qref + evap*dt * res / (dt * rhoair) + qsrf(begg:endg) = qref(begg:endg) + evap(begg:endg) * dt * res(begg:endg) / (dt * rhoair(begg:endg)) ! Gordon says leave it with the above equation (the below is the inversion to calculate it...) !do g = begg, endg - ! call QSat (tsrf(g), pref(g), esrf(g), desrf(g), qsrf(g), dqsrf(g)) + ! call QSatOld (tsrf(g), pref(g), esrf(g), desrf(g), qsrf(g), dqsrf(g)) !end do ! updates qsrf for next time step using current tsrf ! do I need to do this if I'm using qsrf for my lhflx now? probably... or move the call - ! to QSat to before the MO calculation... that sounds better... except I still want to + ! to QSatOld to before the MO calculation... that sounds better... except I still want to ! print out qsrf to the h0 file. Hmm. Well, they SHOULD be consistent, right? Actually no, ! because I calculate the first pass at qsrf using tsrf from last time step, and I want to ! get the updated version to pass up to the atm. - ! Go through after implementing the call to QSat instead of satvap and make sure I'm + ! Go through after implementing the call to QSatOld instead of satvap and make sure I'm ! being self-consistent within the module re: qsrf that I'm using / passing out / using on next time step. ! Trying to follow CLM 4.5 tech note, but there they're using uatm - us (u surface? not u star?) AND @@ -1699,8 +1656,8 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! but for taux and tauy you want to preserve the zonal and meridonal components ! taux = -rhoair * atm2lnd_inst%forc_u_grc(g) / ram ! tauy = -rhoair * atm2lnd_inst%forc_v_grc(g) / ram - taux = -rhoair * (atm2lnd_inst%forc_u_grc - 0._r8) / ram ! [kg/m/s2] = [kg/m3] * [m/s] / [s/m] - tauy = -rhoair * (atm2lnd_inst%forc_v_grc - 0._r8) / ram ! [kg/m/s2] = [kg/m3] * [m/s] / [s/m] + taux(begg:endg) = -rhoair(begg:endg) * (atm2lnd_inst%forc_u_grc(begg:endg) - 0._r8) / ram(begg:endg) ! [kg/m/s2] = [kg/m3] * [m/s] / [s/m] + tauy(begg:endg) = -rhoair(begg:endg) * (atm2lnd_inst%forc_v_grc(begg:endg) - 0._r8) / ram(begg:endg) ! [kg/m/s2] = [kg/m3] * [m/s] / [s/m] ! the - 0._r8 should be removed later, this is to remind myself I'm saying u_ref - u_srf, where u_srf = 0 by def'n @@ -1881,48 +1838,48 @@ subroutine mml_main (bounds, atm2lnd_inst, lnd2atm_inst) !lnd2atm_inst ! lnd -> atm - lnd2atm_inst%t_rad_grc = tsrf ! radiative temperature (Kelvin) - lnd2atm_inst%t_ref2m_grc = atm2lnd_inst%mml_out_tref2m_grc ! 2m surface air temperature (Kelvin) + lnd2atm_inst%t_rad_grc(begg:endg) = tsrf(begg:endg) ! radiative temperature (Kelvin) + lnd2atm_inst%t_ref2m_grc(begg:endg) = atm2lnd_inst%mml_out_tref2m_grc(begg:endg) ! 2m surface air temperature (Kelvin) !atm2lnd_inst%mml_lnd_ts_grc = tsrf ! dunno what its saving out now... !lnd2atm_inst%q_ref2m_grc = atm2lnd_inst%mml_out_qref2m_grc ! 2m surface specific humidity (kg/kg) !lnd2atm_inst%u_ref10m_grc = atm2lnd_inst%mml_out_uref10m_grc ! 10m surface wind speed (m/sec) - lnd2atm_inst%q_ref2m_grc = atm2lnd_inst%mml_out_qref2m_grc ! 2m surface specific humidity (kg/kg) - lnd2atm_inst%u_ref10m_grc = atm2lnd_inst%mml_out_uref10m_grc ! 10m surface wind speed (m/sec) + lnd2atm_inst%q_ref2m_grc(begg:endg) = atm2lnd_inst%mml_out_qref2m_grc(begg:endg) ! 2m surface specific humidity (kg/kg) + lnd2atm_inst%u_ref10m_grc(begg:endg) = atm2lnd_inst%mml_out_uref10m_grc(begg:endg) ! 10m surface wind speed (m/sec) ! note: mm h20 snow if using rhowat to convert should be the same as kg/m2 - lnd2atm_inst%h2osno_grc = snow / rhowat * 1000 ! [kg/m2] / [kg/m3] * 1000[mm/m]! snow water (mm H2O) + lnd2atm_inst%h2osno_grc(begg:endg) = snow(begg:endg) / rhowat * 1000 ! [kg/m2] / [kg/m3] * 1000[mm/m]! snow water (mm H2O) !lnd2atm_inst%h2osoi_vol_grc ! volumetric soil water (0~watsat, m3/m3, nlevgrnd) (for dust model) ! MML: albedo (:,:) -> albd is direct, albd(:,1) direct vis, albd(:,2) direct nir ! -> albi is diffuse, albi(:,1) diffuse vis, albi(:,2) diffuse nir (I THINK) ! GBB: yes - lnd2atm_inst%albd_grc(:,1) = alb_vis_dir ! (numrad=1, vis) surface albedo (direct) - lnd2atm_inst%albd_grc(:,2) = alb_nir_dir ! (numrad=2, nir) surface albedo (direct) - - lnd2atm_inst%albi_grc(:,1) = alb_vis_dif ! (numrad=1, vis) surface albedo (diffuse) - lnd2atm_inst%albi_grc(:,2) = alb_nir_dif ! (numrad=2, nir) surface albedo (diffuse) - - lnd2atm_inst%taux_grc = taux ! wind stress: e-w (kg/m/s**2) - lnd2atm_inst%tauy_grc = tauy ! wind stress: n-s (kg/m/s**2) - lnd2atm_inst%eflx_lh_tot_grc = lhflx ! total latent HF (W/m**2) [+ to atm] - lnd2atm_inst%eflx_sh_tot_grc = shflx ! total sensible HF (W/m**2) [+ to atm] + lnd2atm_inst%albd_grc(begg:endg,1) = alb_vis_dir(begg:endg) ! (numrad=1, vis) surface albedo (direct) + lnd2atm_inst%albd_grc(begg:endg,2) = alb_nir_dir(begg:endg) ! (numrad=2, nir) surface albedo (direct) + + lnd2atm_inst%albi_grc(begg:endg,1) = alb_vis_dif(begg:endg) ! (numrad=1, vis) surface albedo (diffuse) + lnd2atm_inst%albi_grc(begg:endg,2) = alb_nir_dif(begg:endg) ! (numrad=2, nir) surface albedo (diffuse) + + lnd2atm_inst%taux_grc(begg:endg) = taux(begg:endg) ! wind stress: e-w (kg/m/s**2) + lnd2atm_inst%tauy_grc(begg:endg) = tauy(begg:endg) ! wind stress: n-s (kg/m/s**2) + lnd2atm_inst%eflx_lh_tot_grc(begg:endg) = lhflx(begg:endg) ! total latent HF (W/m**2) [+ to atm] + lnd2atm_inst%eflx_sh_tot_grc(begg:endg) = shflx(begg:endg) ! total sensible HF (W/m**2) [+ to atm] ! lnd2atm_inst%eflx_sh_precip_conversion_grc ! sensible HF from precipitation conversion (W/m**2) [+ to atm] - ! Land group says (a) this is new (sh_precip_converstion) and I can set it to 0 since I don't have multiple levels on my (currently nonexistent) ice sheets - lnd2atm_inst%eflx_lwrad_out_grc = lwup ! IR (longwave) radiation (W/m**2) - lnd2atm_inst%qflx_evap_tot_grc = evap ! (mm H2O/s) ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg - lnd2atm_inst%fsa_grc = sw_abs ! solar rad absorbed (total) (W/m**2) + ! Land group says (a) this is new (sh_precip_converstion) and I can set it to 0 since I don't have multiple levels on my (currently nonexistent) ice sheets + lnd2atm_inst%eflx_lwrad_out_grc(begg:endg) = lwup(begg:endg) ! IR (longwave) radiation (W/m**2) + lnd2atm_inst%qflx_evap_tot_grc(begg:endg) = evap(begg:endg) ! (mm H2O/s) ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg + lnd2atm_inst%fsa_grc(begg:endg) = sw_abs(begg:endg) ! solar rad absorbed (total) (W/m**2) ! MML: not running interactive BGC, set CO2/Methane fluxes to 0 !lnd2atm_inst%net_carbon_exchange_grc = 0._r8 ! net CO2 flux (kg CO2/m**2/s) [+ to atm] - lnd2atm_inst%net_carbon_exchange_grc = 0._r8 - lnd2atm_inst%nem_grc = 0._r8 ! gridcell average net methane correction to CO2 flux (g C/m^2/s) - lnd2atm_inst%ram1_grc = ram ! aerodynamical resistance (s/m) + lnd2atm_inst%net_carbon_exchange_grc(begg:endg) = 0._r8 + lnd2atm_inst%nem_grc(begg:endg) = 0._r8 ! gridcell average net methane correction to CO2 flux (g C/m^2/s) + lnd2atm_inst%ram1_grc(begg:endg) = ram(begg:endg) ! aerodynamical resistance (s/m) ! MML: check if it is ram (vs res) that I should be exporting here !lnd2atm_inst%fv_grc = ! friction velocity (m/s) (for dust model) ! MML: should be able to calculate this from MO theory... is this ustar? ! Need to put the dust fluxes I read from the .nc file into the right size - lnd2atm_inst%flxdst_grc = dust ! dust flux (size bins) + lnd2atm_inst%flxdst_grc(begg:endg,:) = dust(begg:endg,:) ! dust flux (size bins) !lnd2atm_inst%flxdst_grc = 0._r8 ! (:,ndust) where ndust=4, so I need a 4th dust flux field! and I think the ones I had were wrong... ! MML: need some sort of forcing file - see what the aquaplanet people are using ! currently borrowing the value from CLM by running the whole CLM model first... @@ -2028,28 +1985,28 @@ subroutine nc_import (begg, endg, mml_nsoi, lfsurdat, mon, & ! !LOCAL VARIABLES: character(len=32) :: subname = 'nc_import_sub_mml' ! MML allocation variables to read from .nc file - real(r8), pointer :: nc_alb_gvd(:) => null() ! ground albedo read from .nc file - real(r8), pointer :: nc_alb_svd(:) => null() ! snow albedo read from .nc file - real(r8), pointer :: nc_alb_gnd(:) => null() ! - real(r8), pointer :: nc_alb_snd(:) => null() - real(r8), pointer :: nc_alb_gvf(:) => null() ! ground albedo read from .nc file - real(r8), pointer :: nc_alb_svf(:) => null() ! snow albedo read from .nc file - real(r8), pointer :: nc_alb_gnf(:) => null() ! - real(r8), pointer :: nc_alb_snf(:) => null() - real(r8), pointer :: nc_snowmask(:) => null() ! snow masking depth read from .nc file - real(r8), pointer :: nc_evaprs(:) => null() ! evap resistance from .nc file - real(r8), pointer :: nc_bucket(:) => null() ! soil bucket depth from .nc file - real(r8), pointer :: nc_ice(:,:) => null() ! freezeable water in each soil layer from .nc file - real(r8), pointer :: nc_z(:,:) => null() ! depth from surf to each soil layer from .nc file - real(r8), pointer :: nc_type(:) => null() ! soil type from .nc file - real(r8), pointer :: nc_rough(:) => null() ! roughness length from .nc file - real(r8), pointer :: nc_soil_tk(:) => null() ! soil thermal conductivity from .nc file - real(r8), pointer :: nc_glc_tk(:) => null() ! glacier thermal conductivity from .nc file - real(r8), pointer :: nc_soil_cv(:) => null() ! soil heat capacity from .nc file - real(r8), pointer :: nc_glc_cv(:) => null() ! glacier heat capacity from .nc file - real(r8), pointer :: nc_glc_mask(:) => null() ! glacier mask from .nc file - real(r8), pointer :: nc_emiss(:) => null() ! emissivity (for LW) from .nc file - real(r8), pointer :: nc_dust(:) => null() ! dust flux (clm5 climatology for now) from .nc file + real(r8), pointer :: nc_alb_gvd(:) => null() ! ground albedo read from .nc file + real(r8), pointer :: nc_alb_svd(:) => null() ! snow albedo read from .nc file + real(r8), pointer :: nc_alb_gnd(:) => null() ! + real(r8), pointer :: nc_alb_snd(:) => null() + real(r8), pointer :: nc_alb_gvf(:) => null() ! ground albedo read from .nc file + real(r8), pointer :: nc_alb_svf(:) => null() ! snow albedo read from .nc file + real(r8), pointer :: nc_alb_gnf(:) => null() ! + real(r8), pointer :: nc_alb_snf(:) => null() + real(r8), pointer :: nc_snowmask(:) => null() ! snow masking depth read from .nc file + real(r8), pointer :: nc_evaprs(:) => null() ! evap resistance from .nc file + real(r8), pointer :: nc_bucket(:) => null() ! soil bucket depth from .nc file + real(r8), pointer :: nc_ice(:,:) => null() ! freezeable water in each soil layer from .nc file + real(r8), pointer :: nc_z(:,:) => null() ! depth from surf to each soil layer from .nc file + real(r8), pointer :: nc_type(:) => null() ! soil type from .nc file + real(r8), pointer :: nc_rough(:) => null() ! roughness length from .nc file + real(r8), pointer :: nc_soil_tk(:) => null() ! soil thermal conductivity from .nc file + real(r8), pointer :: nc_glc_tk(:) => null() ! glacier thermal conductivity from .nc file + real(r8), pointer :: nc_soil_cv(:) => null() ! soil heat capacity from .nc file + real(r8), pointer :: nc_glc_cv(:) => null() ! glacier heat capacity from .nc file + real(r8), pointer :: nc_glc_mask(:) => null() ! glacier mask from .nc file + real(r8), pointer :: nc_emiss(:) => null() ! emissivity (for LW) from .nc file + real(r8), pointer :: nc_dust(:) => null() ! dust flux (clm5 climatology for now) from .nc file ! note: doing allocatable, pointer won't compile, says variable has already been ! assigned the allocatbale tribute ... so does being a pointer encompass being allocatable? ! same error if I do pointer, allocatable instead: @@ -2070,7 +2027,6 @@ subroutine nc_import (begg, endg, mml_nsoi, lfsurdat, mon, & ! 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) character(len=256) :: locfn ! local file name logical :: readvar ! true => variable is on dataset @@ -2086,28 +2042,28 @@ subroutine nc_import (begg, endg, mml_nsoi, lfsurdat, mon, & ival = 0.0_r8 - allocate( nc_alb_gvd (begg:endg) ) ; nc_alb_gvd(:) = ival - allocate( nc_alb_svd (begg:endg) ) ; nc_alb_svd(:) = ival - allocate( nc_alb_gnd (begg:endg) ) ; nc_alb_gnd(:) = ival - allocate( nc_alb_snd (begg:endg) ) ; nc_alb_snd(:) = ival - allocate( nc_alb_gvf (begg:endg) ) ; nc_alb_gvf(:) = ival - allocate( nc_alb_svf (begg:endg) ) ; nc_alb_svf(:) = ival - allocate( nc_alb_gnf (begg:endg) ) ; nc_alb_gnf(:) = ival - allocate( nc_alb_snf (begg:endg) ) ; nc_alb_snf(:) = ival - allocate( nc_snowmask (begg:endg) ) ; nc_snowmask(:) = ival - allocate( nc_evaprs (begg:endg) ) ; nc_evaprs(:) = ival - allocate( nc_bucket (begg:endg) ) ; nc_bucket(:) = ival - allocate( nc_ice (begg:endg,mml_nsoi) ) ; nc_ice(:,:) = ival - allocate( nc_z (begg:endg,mml_nsoi) ) ; nc_z(:,:) = ival - allocate( nc_type (begg:endg) ) ; nc_type(:) = ival - allocate( nc_rough (begg:endg) ) ; nc_rough(:) = ival - allocate( nc_soil_tk (begg:endg) ) ; nc_soil_tk(:) = ival - allocate( nc_glc_tk (begg:endg) ) ; nc_glc_tk(:) = ival - allocate( nc_soil_cv (begg:endg) ) ; nc_soil_cv(:) = ival - allocate( nc_glc_cv (begg:endg) ) ; nc_glc_cv(:) = ival - allocate( nc_glc_mask (begg:endg) ) ; nc_glc_mask(:) = ival - allocate( nc_emiss (begg:endg) ) ; nc_emiss(:) = ival - allocate( nc_dust (begg:endg) ) ; nc_dust(:) = ival ! keep overwriting this for each dust bin + allocate( nc_alb_gvd(begg:endg) ); nc_alb_gvd(begg:endg) = ival + allocate( nc_alb_svd(begg:endg) ); nc_alb_svd(begg:endg) = ival + allocate( nc_alb_gnd(begg:endg) ); nc_alb_gnd(begg:endg) = ival + allocate( nc_alb_snd(begg:endg) ); nc_alb_snd(begg:endg) = ival + allocate( nc_alb_gvf(begg:endg) ); nc_alb_gvf(begg:endg) = ival + allocate( nc_alb_svf(begg:endg) ); nc_alb_svf(begg:endg) = ival + allocate( nc_alb_gnf(begg:endg) ); nc_alb_gnf(begg:endg) = ival + allocate( nc_alb_snf(begg:endg) ); nc_alb_snf(begg:endg) = ival + allocate( nc_snowmask(begg:endg) ); nc_snowmask(begg:endg) = ival + allocate( nc_evaprs(begg:endg) ); nc_evaprs(begg:endg) = ival + allocate( nc_bucket(begg:endg) ); nc_bucket(begg:endg) = ival + allocate( nc_ice(begg:endg,mml_nsoi) ); nc_ice(begg:endg,:) = ival + allocate( nc_z(begg:endg,mml_nsoi) ); nc_z(begg:endg,:) = ival + allocate( nc_type(begg:endg) ); nc_type(begg:endg) = ival + allocate( nc_rough(begg:endg) ); nc_rough(begg:endg) = ival + allocate( nc_soil_tk(begg:endg) ); nc_soil_tk(begg:endg) = ival + allocate( nc_glc_tk(begg:endg) ); nc_glc_tk(begg:endg) = ival + allocate( nc_soil_cv(begg:endg) ); nc_soil_cv(begg:endg) = ival + allocate( nc_glc_cv(begg:endg) ); nc_glc_cv(begg:endg) = ival + allocate( nc_glc_mask(begg:endg) ); nc_glc_mask(begg:endg) = ival + allocate( nc_emiss(begg:endg) ); nc_emiss(begg:endg) = ival + allocate( nc_dust(begg:endg) ); nc_dust(begg:endg) = ival ! keep overwriting this for each dust bin ! if (ier /= 0) then @@ -2151,9 +2107,8 @@ subroutine nc_import (begg, endg, mml_nsoi, lfsurdat, mon, & if ( .NOT. readvar .and. masterproc) then write(iulog,*)subname, 'MML tried to read dust-1, failed ', readvar else - dust(begg:endg,1) = nc_dust - end if - + dust(begg:endg,1) = nc_dust(begg:endg) + end if ! second dust bin: call ncd_io(ncid=ncid, varname='l2xavg_Fall_flxdst2', flag='read', data=nc_dust, & @@ -2161,9 +2116,8 @@ subroutine nc_import (begg, endg, mml_nsoi, lfsurdat, mon, & if ( .NOT. readvar .and. masterproc) then write(iulog,*)subname, 'MML tried to read dust-2, failed ', readvar else - dust(begg:endg,2) = nc_dust - end if - + dust(begg:endg,2) = nc_dust(begg:endg) + end if ! third dust bin: call ncd_io(ncid=ncid, varname='l2xavg_Fall_flxdst3', flag='read', data=nc_dust, & @@ -2171,9 +2125,8 @@ subroutine nc_import (begg, endg, mml_nsoi, lfsurdat, mon, & if ( .NOT. readvar .and. masterproc) then write(iulog,*)subname, 'MML tried to read dust-3, failed ', readvar else - dust(begg:endg,3) = nc_dust - end if - + dust(begg:endg,3) = nc_dust(begg:endg) + end if ! fourth dust bin: call ncd_io(ncid=ncid, varname='l2xavg_Fall_flxdst4', flag='read', data=nc_dust, & @@ -2181,9 +2134,8 @@ subroutine nc_import (begg, endg, mml_nsoi, lfsurdat, mon, & if ( .NOT. readvar .and. masterproc) then write(iulog,*)subname, 'MML tried to read dust-4, failed ', readvar else - dust(begg:endg,4) = nc_dust - end if - + dust(begg:endg,4) = nc_dust(begg:endg) + end if ! Albedo Direct @@ -2376,10 +2328,10 @@ subroutine nc_import (begg, endg, mml_nsoi, lfsurdat, mon, & roughness(begg:endg) = nc_rough(begg:endg) emiss(begg:endg) = nc_emiss(begg:endg) glc_mask(begg:endg) = nc_glc_mask(begg:endg) - soil_tk_1d(begg:endg) = nc_soil_tk - soil_cv_1d(begg:endg) = nc_soil_cv - glc_tk_1d(begg:endg) = nc_glc_tk - glc_cv_1d(begg:endg) = nc_glc_cv + soil_tk_1d(begg:endg) = nc_soil_tk(begg:endg) + soil_cv_1d(begg:endg) = nc_soil_cv(begg:endg) + glc_tk_1d(begg:endg) = nc_glc_tk(begg:endg) + glc_cv_1d(begg:endg) = nc_glc_cv(begg:endg) !dust(begg:endg) = nc_dust(begg:endg) ! @@ -2431,11 +2383,11 @@ end subroutine nc_import !*********************************************** ! phase change !*********************************************** - subroutine phase_change (begg, endg, tsoi, soil_cv, soil_dz, & - soil_maxice, soil_liq, soil_ice, & - mml_nsoi, dt, hfus, tfrz, epc & - !diag1_1d, diag1_2d, diag2_2d, diag3_2d & ! temporary diagnostics - ) + subroutine phase_change (begg, endg, tsoi, soil_cv, soil_dz, & + soil_maxice, soil_liq, soil_ice, & + mml_nsoi, dt, hfus, tfrz, epc & + !diag1_1d, diag1_2d, diag2_2d, diag3_2d & ! temporary diagnostics + ) !% ------------------------------------------------------------------------- ! Given the initial soil temperature calculation, go check if we should be ! freezing/thawing any of the available freezeable water in that layer. @@ -2450,17 +2402,17 @@ subroutine phase_change (begg, endg, tsoi, soil_cv, soil_dz, & real(r8), intent(in) :: dt real(r8), intent(in) :: hfus real(r8), intent(in) :: tfrz - real(r8), intent(in) :: soil_cv(:,:) - real(r8), intent(in) :: soil_dz(:,:) - real(r8), intent(in) :: soil_maxice(:,:) ! Not using this right now, instead using presc. soil_liq and soil_ice vals + real(r8), intent(in) :: soil_cv(begg:endg,mml_nsoi) + real(r8), intent(in) :: soil_dz(begg:endg,mml_nsoi) + real(r8), intent(in) :: soil_maxice(begg:endg,mml_nsoi) ! Not using this right now, instead using presc. soil_liq and soil_ice vals ! ----- Output Variables -------- - real(r8), intent(inout) :: tsoi(:,:) + real(r8), intent(inout) :: tsoi(begg:endg,mml_nsoi) ! tsoi(begg:endg,:) ! try defining them this way instead, to avoid the dummy vars and keep the correct g indices - real(r8), intent(inout) :: soil_liq(:,:) ! - real(r8), intent(inout) :: soil_ice(:,:) ! + real(r8), intent(inout) :: soil_liq(begg:endg,mml_nsoi) ! + real(r8), intent(inout) :: soil_ice(begg:endg,mml_nsoi) ! - real(r8), intent(out) :: epc(:) ! (:,:) derivative of sat vapour pressure at ta [Pa/K] + real(r8), intent(out) :: epc(begg:endg) ! (begg:endg,:) derivative of sat vapour pressure at ta [Pa/K] ! real(r8), intent(out) :: diag1_1d(:) ! put alhf here ! real(r8), intent(out) :: diag1_2d(:,:) ! put rfm here @@ -2491,104 +2443,103 @@ subroutine phase_change (begg, endg, tsoi, soil_cv, soil_dz, & phase_tsoi(begg:endg,mml_nsoi) , & phase_liq(begg:endg,mml_nsoi) , & phase_ice(begg:endg,mml_nsoi) - - - phase_cv = soil_cv - phase_dz = soil_dz - phase_maxice = soil_maxice - phase_tsoi = tsoi - phase_liq = soil_liq - phase_ice = soil_ice - - !------------------------------------------------------ - - !----------------------------- - ! Initialization - wliq0 = phase_liq ! [kg/m2] per layer - wice0 = phase_ice - wmass0 = wliq0 + wice0 ! should equal 300/dz in all but top layer, where it should be 0 - tsoi0 = phase_tsoi - - !----------------------------- - ! Identify if layers should be melting or freezing - ! imelt = 0 -> no phase change - ! imelt = 1 -> melt - ! imelt = 2 -> freeze - imelt(:,:) = 0._r8 - - !do i = 1, mml_nsoi - do i = 1, mml_nsoi ! should be no freezeable water in top layer... ie phase_ice and phase_liq should both ==0 - - ! Melting: if there is ice and phase_tsoi > 0 - where (phase_ice(:,i) > 0._r8 .and. phase_tsoi(:,i) > tfrz) - imelt(:,i) = 1 - phase_tsoi(:,i) = tfrz - end where - - ! Freezing: if there is water and phase_tsoi < 0 - where (phase_liq(:,i) > 0._r8 .and. phase_tsoi(:,i) < tfrz) - imelt(:,i) = 2 - phase_tsoi(:,i) = tfrz - end where - - ! otherwise, leave phase_tsoi as is and don't put energy into phase change - - end do - - !----------------------------- - ! Energy available for freezing or melting comes from difference between phase_tsoi(:,i) and - ! tfreeze - ! - - do i = 1, mml_nsoi - - hfm(:,i) = 0._r8 ! all the palces imelt=0, no phase change - - ! Energy for freezing or melting [W/m2]; hfm > 0 freezing, hfm < 0 melting - where (imelt(:,i) > 0) - hfm(:,i) = ( phase_tsoi(:,i) - tsoi0(:,i) ) * phase_cv(:,i) * phase_dz(:,i) / dt - ! if I accounted for cv water/ice here, too, would that fix part of the problem? - - ! how much energy for freezing or melting based only off Delta T (if you've got excess, use for T change) - ! maybe I need to include water in cv to conserve energy? Hmm. Don't think gfdl does, though... - end where - - ! Melting: maximum energy available for freezing or melting [W/m2] - where (imelt(:,i) .eq. 1) ! Melting case - hfmx(:,i) = - phase_ice(:,i) * hfus / dt ! total meltable = depends how much ice you've got - end where - - ! Freezing: maximum energy available for freezing or melting [W/m2] - where (imelt(:,i) .eq. 2) ! freezing case - hfmx(:,i) = phase_liq(:,i) * hfus / dt ! total freezable = depends how much water you've got - end where - - end do - - - !----------------------------- - ! Calculate phase change - - epc(:) = 0._r8 - - do i = 1, mml_nsoi - - where( imelt(:,i) > 0 ) - - ! Freeze or melt ice - rfm(:,i) = hfm(:,i) / hfus ! change in ice (>0 freeze, <0 melt) [kg/m2/s] - phase_ice(:,i) = wice0(:,i) + rfm(:,i) * dt ! update ice [kg/m2] - phase_ice(:,i) = max( 0.0 , phase_ice(:,i) ) ! can't melt more ice than is present - phase_ice(:,i) = min( wmass0(:,i) , phase_ice(:,i) ) ! can't exceed total water than is present (300*dz, should be) - phase_liq(:,i) = max( 0.0 , ( wmass0(:,i) - phase_ice(:,i) ) ) ! update liquid water (kg/m2) - alhf(:) = hfus * (phase_ice(:,i) - wice0(:,i)) / dt ! actual heat flux from phase change [w/m2] - epc(:) = epc + alhf ! sum of heat flux from phase change over soil column [w/m2] - - ! If there is energy left over, use it to change soil layer temperature - phase_tsoi(:,i) = phase_tsoi(:,i) - (hfm(:,i) - alhf(:)) * dt / (phase_cv(:,i) * phase_dz(:,i)) - - end where + +phase_cv(begg:endg,:) = soil_cv(begg:endg,:) +phase_dz(begg:endg,:) = soil_dz(begg:endg,:) +phase_maxice(begg:endg,:) = soil_maxice(begg:endg,:) +phase_tsoi(begg:endg,:) = tsoi(begg:endg,:) +phase_liq(begg:endg,:) = soil_liq(begg:endg,:) +phase_ice(begg:endg,:) = soil_ice(begg:endg,:) + +!------------------------------------------------------ + +!----------------------------- +! Initialization +wliq0(begg:endg,:) = phase_liq(begg:endg,:) ! [kg/m2] per layer +wice0(begg:endg,:) = phase_ice(begg:endg,:) +wmass0(begg:endg,:) = wliq0(begg:endg,:) + wice0(begg:endg,:) ! should equal 300/dz in all but top layer, where it should be 0 +tsoi0(begg:endg,:) = phase_tsoi(begg:endg,:) + + !----------------------------- + ! Identify if layers should be melting or freezing + ! imelt = 0 -> no phase change + ! imelt = 1 -> melt + ! imelt = 2 -> freeze + imelt(begg:endg,:) = 0._r8 + + !do i = 1, mml_nsoi + do i = 1, mml_nsoi ! should be no freezeable water in top layer... ie phase_ice and phase_liq should both ==0 + + ! Melting: if there is ice and phase_tsoi > 0 + where (phase_ice(begg:endg,i) > 0._r8 .and. phase_tsoi(begg:endg,i) > tfrz) + imelt(:,i) = 1 + phase_tsoi(:,i) = tfrz + end where + + ! Freezing: if there is water and phase_tsoi < 0 + where (phase_liq(begg:endg,i) > 0._r8 .and. phase_tsoi(begg:endg,i) < tfrz) + imelt(:,i) = 2 + phase_tsoi(:,i) = tfrz + end where + + ! otherwise, leave phase_tsoi as is and don't put energy into phase change + + end do + + !----------------------------- + ! Energy available for freezing or melting comes from difference between phase_tsoi(:,i) and + ! tfreeze + ! + + do i = 1, mml_nsoi + + hfm(begg:endg,i) = 0._r8 ! all the palces imelt=0, no phase change + + ! Energy for freezing or melting [W/m2]; hfm > 0 freezing, hfm < 0 melting + where (imelt(begg:endg,i) > 0) + hfm(:,i) = ( phase_tsoi(:,i) - tsoi0(:,i) ) * phase_cv(:,i) * phase_dz(:,i) / dt + ! if I accounted for cv water/ice here, too, would that fix part of the problem? + + ! how much energy for freezing or melting based only off Delta T (if you've got excess, use for T change) + ! maybe I need to include water in cv to conserve energy? Hmm. Don't think gfdl does, though... + end where + + ! Melting: maximum energy available for freezing or melting [W/m2] + where (imelt(begg:endg,i) == 1) ! Melting case + hfmx(:,i) = - phase_ice(:,i) * hfus / dt ! total meltable = depends how much ice you've got + end where + + ! Freezing: maximum energy available for freezing or melting [W/m2] + where (imelt(begg:endg,i) == 2) ! freezing case + hfmx(:,i) = phase_liq(:,i) * hfus / dt ! total freezable = depends how much water you've got + end where + + end do + + + !----------------------------- + ! Calculate phase change + + epc(begg:endg) = 0._r8 + + do i = 1, mml_nsoi + + where( imelt(begg:endg,i) > 0 ) + + ! Freeze or melt ice + rfm(:,i) = hfm(:,i) / hfus ! change in ice (>0 freeze, <0 melt) [kg/m2/s] + phase_ice(:,i) = wice0(:,i) + rfm(:,i) * dt ! update ice [kg/m2] + phase_ice(:,i) = max( 0.0 , phase_ice(:,i) ) ! can't melt more ice than is present + phase_ice(:,i) = min( wmass0(:,i) , phase_ice(:,i) ) ! can't exceed total water than is present (300*dz, should be) + phase_liq(:,i) = max( 0.0 , ( wmass0(:,i) - phase_ice(:,i) ) ) ! update liquid water (kg/m2) + alhf = hfus * (phase_ice(:,i) - wice0(:,i)) / dt ! actual heat flux from phase change [w/m2] + epc = epc + alhf ! sum of heat flux from phase change over soil column [w/m2] + + ! If there is energy left over, use it to change soil layer temperature + phase_tsoi(:,i) = phase_tsoi(:,i) - (hfm(:,i) - alhf) * dt / (phase_cv(:,i) * phase_dz(:,i)) + + end where !--------------------- @@ -2659,13 +2610,11 @@ subroutine phase_change (begg, endg, tsoi, soil_cv, soil_dz, & !------------------------ end do - - ! update out vars - soil_liq = phase_liq - soil_ice = phase_ice - tsoi = phase_tsoi - + ! update out vars + soil_liq(begg:endg,:) = phase_liq(begg:endg,:) + soil_ice(begg:endg,:) = phase_ice(begg:endg,:) + tsoi(begg:endg,:) = phase_tsoi(begg:endg,:) end subroutine phase_change @@ -2692,27 +2641,27 @@ subroutine soil_thermal_properties ( begg, endg, glc_mask, & implicit none ! ----- Input Variables -------- - real(r8), intent(in) :: soil_type(:) ! silt/sand/clay identified from a table (in theory... not yet :p ) - real(r8), intent(in) :: soil_z(:,:) ! soil depth (mid point of soil layer) - real(r8), intent(in) :: soil_zh(:,:) ! soil depth (bottom interface of soil layer) - real(r8), intent(in) :: soil_dz(:,:) ! soil layer thickness - real(r8), intent(in) :: soil_liq(:,:) ! soil layer water content (kg/m2) - real(r8), intent(in) :: soil_ice(:,:) ! soil layer ice content (kg/m2) - - real(r8), intent(inout) :: soil_tk_1d(:) ! nc prescribed soil tk (for all layers) - real(r8), intent(inout) :: soil_cv_1d(:) ! nc prescribed soil cv (for all layers) - real(r8), intent(inout) :: glc_tk_1d(:) ! nc prescribed soil tk (for all layers) - real(r8), intent(inout) :: glc_cv_1d(:) ! nc prescribed soil cv (for all layers) - - - integer , intent(in) :: mml_nsoi - integer , intent(in) :: begg, endg ! spatial bounds - real(r8), intent(in) :: glc_mask(:) ! mask of glaciated cells, use ice properties here. + integer, intent(in) :: mml_nsoi + integer, intent(in) :: begg, endg ! spatial bounds + real(r8), intent(in) :: soil_type(begg:endg) ! silt/sand/clay identified from a table (in theory... not yet :p ) + real(r8), intent(in) :: soil_z(begg:endg,mml_nsoi) ! soil depth (mid point of soil layer) + real(r8), intent(in) :: soil_zh(begg:endg,mml_nsoi) ! soil depth (bottom interface of soil layer) + real(r8), intent(in) :: soil_dz(begg:endg,mml_nsoi) ! soil layer thickness + real(r8), intent(in) :: soil_liq(begg:endg,mml_nsoi) ! soil layer water content (kg/m2) + real(r8), intent(in) :: soil_ice(begg:endg,mml_nsoi) ! soil layer ice content (kg/m2) + + real(r8), intent(in) :: soil_tk_1d(begg:endg) ! nc prescribed soil tk (for all layers) + real(r8), intent(in) :: soil_cv_1d(begg:endg) ! nc prescribed soil cv (for all layers) + real(r8), intent(in) :: glc_tk_1d(begg:endg) ! nc prescribed soil tk (for all layers) + real(r8), intent(in) :: glc_cv_1d(begg:endg) ! nc prescribed soil cv (for all layers) + + + real(r8), intent(in) :: glc_mask(begg:endg) ! mask of glaciated cells, use ice properties here. ! ----- Output Variables -------- - real(r8), intent(out) :: soil_tk(:,:) ! soil thermal resistance at each layer - real(r8), intent(out) :: soil_cv(:,:) ! soil heat capacity at each layer - real(r8), intent(out) :: soil_tkh(:,:)! soil thermal resistance at the boundary (bottom) of each layer + real(r8), intent(out) :: soil_tk(begg:endg,mml_nsoi) ! soil thermal resistance at each layer + real(r8), intent(out) :: soil_cv(begg:endg,mml_nsoi) ! soil heat capacity at each layer + real(r8), intent(out) :: soil_tkh(begg:endg,mml_nsoi) ! soil thermal resistance at the boundary (bottom) of each layer ! ----- Local Variables -------- integer :: i ! indexing variable @@ -2744,70 +2693,65 @@ subroutine soil_thermal_properties ( begg, endg, glc_mask, & ! (consider using the table-implementation in Gordon's code and in the GFDL code) ! calculate the volumetric liquid / ice water content in each soil layer: - watliq = soil_liq / (rho_wat * soil_dz) ! [kg/m2] / ([kg/m3] * [m]) -> unitless? hmm... or m3/m3 I guess - watice = soil_ice / (rho_ice * soil_dz) ! m3/m3 ? + watliq(begg:endg,:) = soil_liq(begg:endg,:) / (rho_wat * soil_dz(begg:endg,:)) ! [kg/m2] / ([kg/m3] * [m]) -> unitless? hmm... or m3/m3 I guess + watice(begg:endg,:) = soil_ice(begg:endg,:) / (rho_ice * soil_dz(begg:endg,:)) ! m3/m3 ? ! I'm assuming matrix addition works as I expect in Fortran? ! ie I don't have to loop over g = begg,endg, do I? (I might if it goes spatially ! varying and the equations aren't the same have to check. But for now, implement like this) do i = 1, mml_nsoi - - ! For soil points (non-glaciated), use these values: - - !soil_tk(:,i) = 1.5_r8 ! [W/m/K] ! in the ballpark of that for various soils in LaD - soil_tk(:,i) = soil_tk_1d(:) - - !soil_cv(:,i) = 2.0e06_r8 ! [J/m3/K] ! that used for "medium" soil in LaD - soil_cv(:,i) = soil_cv_1d(:) - - ! If the point is a glacier (glc_mask=1), use these values instead: - where(glc_mask .eq. 1) ! really, I should make glc_mask a logical... - - ! Using heat capacity and thermal resistance of ice - !soil_tk(:,i) = tk_ice ! [W/m/K] - soil_tk(:,i) = glc_tk_1d(:) - - !2.3_r8 ! [W/m/K] - ! value somewhat arbitrarily taken from: - ! http://www.engineeringtoolbox.com/ice-thermal-properties-d_576.html - ! ... find a more supportable value to use in the end - - !soil_cv(:,i) = cv_ice ! [J/m3/K] - soil_cv(:,i) = glc_cv_1d(:) - - !1.8e06_r8 ! [J/m3/K] - ! value somewhat arbitrarily taken from: - ! http://www.engineeringtoolbox.com/ice-thermal-properties-d_576.html - ! ... find a more supportable value to use in the end - - end where - - - ! later: add water to thermal resistance? or no? - ! is this right? soil_cv = actual_soil_cv + water_cv + ice_cv ? - !soil_cv(:,i) = 1.926e06 + cv_wat*watliq(:,i) + cv_ice*watice(:,i) ! [J/m3/K] - - enddo ! loop over all soil layers and assign them the 1d value - - - soil_tkh(:,:) = 0.0_r8 ! for now, just so each entry has a value (it should really be size (:, mml_soi-1), not (:,mml_nsoi) - ! now find tkh - do i = 1, mml_nsoi-1 ! no heat diffusion through bottom layer - soil_tkh(:,i) = soil_tk(:,i) * soil_tk(:,i+1) * ( soil_z(:,i) - soil_z(:,i+1) ) / & - ( soil_tk(:,i) * (soil_zh(:,i) - soil_z(:,i+1)) + & - soil_tk(:,i+1) * (soil_z(:,i) - soil_zh(:,i)) ) - - ! This LOOKS the same as the matlab eq'n... add zh to - ! output and see if that looks okay... - - ! NOTE: tk and tkh not currently dependent on water/ice content of layer! - ! ... but I'll keep it like that, for now anyhow. More straightforward. - enddo - - - + ! For soil points (non-glaciated), use these values: + + !soil_tk(:,i) = 1.5_r8 ! [W/m/K] ! in the ballpark of that for various soils in LaD + soil_tk(begg:endg,i) = soil_tk_1d(begg:endg) + + !soil_cv(:,i) = 2.0e06_r8 ! [J/m3/K] ! that used for "medium" soil in LaD + soil_cv(begg:endg,i) = soil_cv_1d(begg:endg) + + ! If the point is a glacier (glc_mask=1), use these values instead: + where(glc_mask(begg:endg) == 1) ! really, I should make glc_mask a logical... + + ! Using heat capacity and thermal resistance of ice + !soil_tk(:,i) = tk_ice ! [W/m/K] + soil_tk(:,i) = glc_tk_1d + + !2.3_r8 ! [W/m/K] + ! value somewhat arbitrarily taken from: + ! http://www.engineeringtoolbox.com/ice-thermal-properties-d_576.html + ! ... find a more supportable value to use in the end + + !soil_cv(:,i) = cv_ice ! [J/m3/K] + soil_cv(:,i) = glc_cv_1d + + !1.8e06_r8 ! [J/m3/K] + ! value somewhat arbitrarily taken from: + ! http://www.engineeringtoolbox.com/ice-thermal-properties-d_576.html + ! ... find a more supportable value to use in the end + + end where + + ! later: add water to thermal resistance? or no? + ! is this right? soil_cv = actual_soil_cv + water_cv + ice_cv ? + !soil_cv(:,i) = 1.926e06 + cv_wat*watliq(:,i) + cv_ice*watice(:,i) ! [J/m3/K] + + end do ! loop over all soil layers and assign them the 1d value + + soil_tkh(begg:endg,:) = 0.0_r8 ! for now, just so each entry has a value (it should really be size (:, mml_soi-1), not (:,mml_nsoi) + ! now find tkh + do i = 1, mml_nsoi-1 ! no heat diffusion through bottom layer + soil_tkh(begg:endg,i) = soil_tk(begg:endg,i) * soil_tk(begg:endg,i+1) * ( soil_z(begg:endg,i) - soil_z(begg:endg,i+1) ) / & + ( soil_tk(begg:endg,i) * (soil_zh(begg:endg,i) - soil_z(begg:endg,i+1)) + & + soil_tk(begg:endg,i+1) * (soil_z(begg:endg,i) - soil_zh(begg:endg,i)) ) + + ! This LOOKS the same as the matlab eq'n... add zh to + ! output and see if that looks okay... + + ! NOTE: tk and tkh not currently dependent on water/ice content of layer! + ! ... but I'll keep it like that, for now anyhow. More straightforward. + enddo + end subroutine soil_thermal_properties diff --git a/src/cpl/clm_cpl_indices.F90 b/src/cpl/mct/clm_cpl_indices.F90 similarity index 75% rename from src/cpl/clm_cpl_indices.F90 rename to src/cpl/mct/clm_cpl_indices.F90 index 525b709c..129cb6a2 100644 --- a/src/cpl/clm_cpl_indices.F90 +++ b/src/cpl/mct/clm_cpl_indices.F90 @@ -18,16 +18,12 @@ module clm_cpl_indices ! ! !PUBLIC DATA MEMBERS: ! - integer , public :: glc_nec ! number of elevation classes for glacier_mec landunits - ! (from coupler) - must equal maxpatch_glcmec from namelist - ! lnd -> drv (required) integer, public ::index_l2x_Flrl_rofsur ! lnd->rtm input liquid surface fluxes integer, public ::index_l2x_Flrl_rofgwl ! lnd->rtm input liquid gwl fluxes integer, public ::index_l2x_Flrl_rofsub ! lnd->rtm input liquid subsurface fluxes integer, public ::index_l2x_Flrl_rofi ! lnd->rtm input frozen fluxes - integer, public ::index_l2x_Flrl_irrig ! irrigation withdrawal integer, public ::index_l2x_Sl_t ! temperature integer, public ::index_l2x_Sl_tref ! 2m reference temperature @@ -49,21 +45,11 @@ module clm_cpl_indices integer, public ::index_l2x_Fall_lwup ! upward longwave heat flux integer, public ::index_l2x_Fall_evap ! evaporation water flux integer, public ::index_l2x_Fall_swnet ! heat flux shortwave net - integer, public ::index_l2x_Fall_fco2_lnd ! co2 flux **For testing set to 0 integer, public ::index_l2x_Fall_flxdst1 ! dust flux size bin 1 integer, public ::index_l2x_Fall_flxdst2 ! dust flux size bin 2 integer, public ::index_l2x_Fall_flxdst3 ! dust flux size bin 3 integer, public ::index_l2x_Fall_flxdst4 ! dust flux size bin 4 - integer, public ::index_l2x_Fall_flxvoc ! MEGAN fluxes - integer, public ::index_l2x_Fall_flxfire ! Fire fluxes - integer, public ::index_l2x_Sl_ztopfire ! Top of fire emissions (m) - - ! In the following, index 0 is bare land, other indices are glc elevation classes - integer, allocatable, public ::index_l2x_Sl_tsrf(:) ! glc MEC temperature - integer, allocatable, public ::index_l2x_Sl_topo(:) ! glc MEC topo height - integer, allocatable, public ::index_l2x_Flgl_qice(:) ! glc MEC ice flux - integer, public ::index_x2l_Sa_methane integer, public ::index_l2x_Fall_methane integer, public :: nflds_l2x = 0 @@ -87,8 +73,6 @@ module clm_cpl_indices integer, public ::index_x2l_Faxa_swvdr ! sw: vis direct downward integer, public ::index_x2l_Faxa_swndf ! sw: nir diffuse downward integer, public ::index_x2l_Faxa_swvdf ! sw: vis diffuse downward - integer, public ::index_x2l_Sa_co2prog ! bottom atm level prognostic co2 - integer, public ::index_x2l_Sa_co2diag ! bottom atm level diagnostic co2 integer, public ::index_x2l_Faxa_bcphidry ! flux: Black Carbon hydrophilic dry deposition integer, public ::index_x2l_Faxa_bcphodry ! flux: Black Carbon hydrophobic dry deposition integer, public ::index_x2l_Faxa_bcphiwet ! flux: Black Carbon hydrophilic wet deposition @@ -104,13 +88,6 @@ module clm_cpl_indices integer, public ::index_x2l_Faxa_dstdry3 ! flux: Size 3 dust -- dry deposition integer, public ::index_x2l_Faxa_dstdry4 ! flux: Size 4 dust -- dry deposition - integer, public ::index_x2l_Faxa_nhx ! flux nhx from atm - integer, public ::index_x2l_Faxa_noy ! flux noy from atm - - integer, public ::index_x2l_Flrr_flood ! rtm->lnd rof flood flux - integer, public ::index_x2l_Flrr_volr ! rtm->lnd rof volr total volume - integer, public ::index_x2l_Flrr_volrmch ! rtm->lnd rof volr main channel volume - ! In the following, index 0 is bare land, other indices are glc elevation classes integer, allocatable, public ::index_x2l_Sg_ice_covered(:) ! Fraction of glacier from glc model integer, allocatable, public ::index_x2l_Sg_topo(:) ! Topo height from glc model @@ -136,10 +113,6 @@ subroutine clm_cpl_indices_set( ) use seq_flds_mod , only: seq_flds_x2l_fields, seq_flds_l2x_fields use mct_mod , only: mct_aVect, mct_aVect_init, mct_avect_indexra use mct_mod , only: mct_aVect_clean, mct_avect_nRattr - use seq_drydep_mod , only: drydep_fields_token, lnd_drydep - use shr_megan_mod , only: shr_megan_fields_token, shr_megan_mechcomps_n - use shr_fire_emis_mod,only: shr_fire_emis_fields_token, shr_fire_emis_ztop_token, shr_fire_emis_mechcomps_n - use clm_varctl , only: ndep_from_cpl use glc_elevclass_mod, only: glc_get_num_elevation_classes, glc_elevclass_as_string ! ! !ARGUMENTS: @@ -175,7 +148,6 @@ subroutine clm_cpl_indices_set( ) index_l2x_Flrl_rofgwl = mct_avect_indexra(l2x,'Flrl_rofgwl') index_l2x_Flrl_rofsub = mct_avect_indexra(l2x,'Flrl_rofsub') index_l2x_Flrl_rofi = mct_avect_indexra(l2x,'Flrl_rofi') - index_l2x_Flrl_irrig = mct_avect_indexra(l2x,'Flrl_irrig') index_l2x_Sl_t = mct_avect_indexra(l2x,'Sl_t') index_l2x_Sl_snowh = mct_avect_indexra(l2x,'Sl_snowh') @@ -190,12 +162,6 @@ subroutine clm_cpl_indices_set( ) index_l2x_Sl_fv = mct_avect_indexra(l2x,'Sl_fv') index_l2x_Sl_soilw = mct_avect_indexra(l2x,'Sl_soilw',perrwith='quiet') - if ( lnd_drydep )then - index_l2x_Sl_ddvel = mct_avect_indexra(l2x, trim(drydep_fields_token)) - else - index_l2x_Sl_ddvel = 0 - end if - index_l2x_Fall_taux = mct_avect_indexra(l2x,'Fall_taux') index_l2x_Fall_tauy = mct_avect_indexra(l2x,'Fall_tauy') index_l2x_Fall_lat = mct_avect_indexra(l2x,'Fall_lat') @@ -208,26 +174,8 @@ subroutine clm_cpl_indices_set( ) index_l2x_Fall_flxdst3 = mct_avect_indexra(l2x,'Fall_flxdst3') index_l2x_Fall_flxdst4 = mct_avect_indexra(l2x,'Fall_flxdst4') - index_l2x_Fall_fco2_lnd = mct_avect_indexra(l2x,'Fall_fco2_lnd',perrwith='quiet') - index_l2x_Fall_methane = mct_avect_indexra(l2x,'Fall_methane',perrWith='quiet') - ! MEGAN fluxes - if (shr_megan_mechcomps_n>0) then - index_l2x_Fall_flxvoc = mct_avect_indexra(l2x,trim(shr_megan_fields_token)) - else - index_l2x_Fall_flxvoc = 0 - endif - - ! Fire fluxes - if (shr_fire_emis_mechcomps_n>0) then - index_l2x_Fall_flxfire = mct_avect_indexra(l2x,trim(shr_fire_emis_fields_token)) - index_l2x_Sl_ztopfire = mct_avect_indexra(l2x,trim(shr_fire_emis_ztop_token)) - else - index_l2x_Fall_flxfire = 0 - index_l2x_Sl_ztopfire = 0 - endif - !------------------------------------------------------------- ! drv -> clm !------------------------------------------------------------- @@ -240,13 +188,6 @@ subroutine clm_cpl_indices_set( ) index_x2l_Sa_pbot = mct_avect_indexra(x2l,'Sa_pbot') index_x2l_Sa_tbot = mct_avect_indexra(x2l,'Sa_tbot') index_x2l_Sa_shum = mct_avect_indexra(x2l,'Sa_shum') - index_x2l_Sa_co2prog = mct_avect_indexra(x2l,'Sa_co2prog',perrwith='quiet') - index_x2l_Sa_co2diag = mct_avect_indexra(x2l,'Sa_co2diag',perrwith='quiet') - - index_x2l_Sa_methane = mct_avect_indexra(x2l,'Sa_methane',perrWith='quiet') - - index_x2l_Flrr_volr = mct_avect_indexra(x2l,'Flrr_volr') - index_x2l_Flrr_volrmch = mct_avect_indexra(x2l,'Flrr_volrmch') index_x2l_Faxa_lwdn = mct_avect_indexra(x2l,'Faxa_lwdn') index_x2l_Faxa_rainc = mct_avect_indexra(x2l,'Faxa_rainc') @@ -272,15 +213,6 @@ subroutine clm_cpl_indices_set( ) index_x2l_Faxa_dstwet3 = mct_avect_indexra(x2l,'Faxa_dstwet3') index_x2l_Faxa_dstwet4 = mct_avect_indexra(x2l,'Faxa_dstwet4') - index_x2l_Faxa_nhx = mct_avect_indexra(x2l,'Faxa_nhx', perrWith='quiet') - index_x2l_Faxa_noy = mct_avect_indexra(x2l,'Faxa_noy', perrWith='quiet') - - if (index_x2l_Faxa_nhx > 0 .and. index_x2l_Faxa_noy > 0) then - ndep_from_cpl = .true. - end if - - index_x2l_Flrr_flood = mct_avect_indexra(x2l,'Flrr_flood') - !------------------------------------------------------------- ! glc coupling !------------------------------------------------------------- @@ -288,21 +220,13 @@ subroutine clm_cpl_indices_set( ) index_x2l_Sg_icemask = mct_avect_indexra(x2l,'Sg_icemask') index_x2l_Sg_icemask_coupled_fluxes = mct_avect_indexra(x2l,'Sg_icemask_coupled_fluxes') - glc_nec = glc_get_num_elevation_classes() - if (glc_nec < 1) then - call shr_sys_abort('ERROR: In CLM4.5 and later, glc_nec must be at least 1.') - end if - ! Create coupling fields for all glc elevation classes (1:glc_nec) plus bare land ! (index 0). - allocate(index_l2x_Sl_tsrf(0:glc_nec)) - allocate(index_l2x_Sl_topo(0:glc_nec)) - allocate(index_l2x_Flgl_qice(0:glc_nec)) - allocate(index_x2l_Sg_ice_covered(0:glc_nec)) - allocate(index_x2l_Sg_topo(0:glc_nec)) - allocate(index_x2l_Flgg_hflx(0:glc_nec)) + allocate(index_x2l_Sg_ice_covered(0:10)) + allocate(index_x2l_Sg_topo(0:10)) + allocate(index_x2l_Flgg_hflx(0:10)) - do num = 0,glc_nec + do num = 0,10 nec_str = glc_elevclass_as_string(num) name = 'Sg_ice_covered' // nec_str @@ -311,13 +235,6 @@ subroutine clm_cpl_indices_set( ) index_x2l_Sg_topo(num) = mct_avect_indexra(x2l,trim(name)) name = 'Flgg_hflx' // nec_str index_x2l_Flgg_hflx(num) = mct_avect_indexra(x2l,trim(name)) - - name = 'Sl_tsrf' // nec_str - index_l2x_Sl_tsrf(num) = mct_avect_indexra(l2x,trim(name)) - name = 'Sl_topo' // nec_str - index_l2x_Sl_topo(num) = mct_avect_indexra(l2x,trim(name)) - name = 'Flgl_qice' // nec_str - index_l2x_Flgl_qice(num) = mct_avect_indexra(l2x,trim(name)) end do call mct_aVect_clean(x2l) diff --git a/src/cpl/lnd_comp_mct.F90 b/src/cpl/mct/lnd_comp_mct.F90 similarity index 94% rename from src/cpl/lnd_comp_mct.F90 rename to src/cpl/mct/lnd_comp_mct.F90 index 394ea63e..929651ec 100644 --- a/src/cpl/lnd_comp_mct.F90 +++ b/src/cpl/mct/lnd_comp_mct.F90 @@ -42,10 +42,9 @@ subroutine lnd_init_mct( EClock, cdata_l, x2l_l, l2x_l, NLFilename ) use shr_kind_mod , only : shr_kind_cl use abortutils , only : endrun use clm_time_manager , only : get_nstep, get_step_size, set_timemgr_init, set_nextsw_cday - use clm_initializeMod, only : initialize1, initialize2, lnd2atm_inst, lnd2glc_inst + use clm_initializeMod, only : initialize1, initialize2, lnd2atm_inst use clm_varctl , only : finidat,single_column, clm_varctl_set, iulog, noland use clm_varctl , only : inst_index, inst_suffix, inst_name - use clm_varorb , only : eccen, obliqr, lambm0, mvelpp use controlMod , only : control_setNL use decompMod , only : get_proc_bounds use domainMod , only : ldomain @@ -151,11 +150,6 @@ subroutine lnd_init_mct( EClock, cdata_l, x2l_l, l2x_l, NLFilename ) call shr_file_getLogLevel(shrloglev) call shr_file_setLogUnit (iulog) - ! Use infodata to set orbital values - - call seq_infodata_GetData( infodata, orb_eccen=eccen, orb_mvelpp=mvelpp, & - orb_lambm0=lambm0, orb_obliqr=obliqr ) - ! Consistency check on namelist filename call control_setNL("lnd_in"//trim(inst_suffix)) @@ -252,7 +246,7 @@ subroutine lnd_init_mct( EClock, cdata_l, x2l_l, l2x_l, NLFilename ) ! Create land export state - call lnd_export(bounds, lnd2atm_inst, lnd2glc_inst, l2x_l%rattr) + call lnd_export(bounds, lnd2atm_inst, l2x_l%rattr) !write(iulog,*)'MML back from lnd_export' ! Fill in infodata settings @@ -295,14 +289,13 @@ subroutine lnd_run_mct(EClock, cdata_l, x2l_l, l2x_l) ! ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_initializeMod, only : lnd2atm_inst, atm2lnd_inst, lnd2glc_inst, glc2lnd_inst + use clm_initializeMod, only : lnd2atm_inst, atm2lnd_inst use clm_driver , only : clm_drv use clm_time_manager, only : get_curr_date, get_nstep, get_curr_calday, get_step_size use clm_time_manager, only : advance_timestep, set_nextsw_cday,update_rad_dtime use decompMod , only : get_proc_bounds use abortutils , only : endrun use clm_varctl , only : iulog - use clm_varorb , only : eccen, obliqr, lambm0, mvelpp use shr_file_mod , only : shr_file_setLogUnit, shr_file_setLogLevel use shr_file_mod , only : shr_file_getLogUnit, shr_file_getLogLevel use seq_cdata_mod , only : seq_cdata, seq_cdata_setptrs @@ -340,16 +333,13 @@ subroutine lnd_run_mct(EClock, cdata_l, x2l_l, l2x_l) logical :: dosend ! true => send data back to driver logical :: doalb ! .true. ==> do albedo calculation on this time step logical :: rof_prognostic ! .true. => running with a prognostic ROF model - logical :: glc_present ! .true. => running with a non-stub GLC model real(r8) :: nextsw_cday ! calday from clock of next radiation computation real(r8) :: caldayp1 ! clm calday plus dtime offset integer :: shrlogunit,shrloglev ! old values for share log unit and log level integer :: lbnum ! input to memory diagnostic integer :: g,i,lsize ! counters - real(r8) :: calday ! calendar day for nstep real(r8) :: declin ! solar declination angle in radians for nstep real(r8) :: declinp1 ! solar declination angle in radians for nstep+1 - real(r8) :: eccf ! earth orbit eccentricity factor real(r8) :: recip ! reciprical logical,save :: first_call = .true. ! first call work type(seq_infodata_type),pointer :: infodata ! CESM information from the driver @@ -398,8 +388,7 @@ subroutine lnd_run_mct(EClock, cdata_l, x2l_l, l2x_l) ! their being set in initialization, so need to get them in the run method. call seq_infodata_GetData( infodata, & - rof_prognostic=rof_prognostic, & - glc_present=glc_present) + rof_prognostic=rof_prognostic) ! Map MCT to land data type ! Perform downscaling if appropriate @@ -411,18 +400,9 @@ subroutine lnd_run_mct(EClock, cdata_l, x2l_l, l2x_l) call t_startf ('lc_lnd_import') call lnd_import( bounds, & x2l = x2l_l%rattr, & - glc_present = glc_present, & - atm2lnd_inst = atm2lnd_inst, & - glc2lnd_inst = glc2lnd_inst) + atm2lnd_inst = atm2lnd_inst) call t_stopf ('lc_lnd_import') - !write(*,*)'MML just after lc_lnd_impoft' - - ! Use infodata to set orbital values if updated mid-run - - call seq_infodata_GetData( infodata, orb_eccen=eccen, orb_mvelpp=mvelpp, & - orb_lambm0=lambm0, orb_obliqr=obliqr ) - !write(*,*)'MML just after se_infodata_GetData' ! Loop over time steps in coupling interval dosend = .false. @@ -468,25 +448,20 @@ subroutine lnd_run_mct(EClock, cdata_l, x2l_l, l2x_l) call t_barrierf('sync_clm_run1', mpicom) call t_startf ('clm_run') - call t_startf ('shr_orb_decl') - calday = get_curr_calday() - call shr_orb_decl( calday , eccen, mvelpp, lambm0, obliqr, declin , eccf ) - call shr_orb_decl( nextsw_cday, eccen, mvelpp, lambm0, obliqr, declinp1, eccf ) - call t_stopf ('shr_orb_decl') call clm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate, rof_prognostic) call t_stopf ('clm_run') ! Create l2x_l export state - add river runoff input to l2x_l if appropriate !write(*,*)'MML export l2x_l' call t_startf ('lc_lnd_export') - call lnd_export(bounds, lnd2atm_inst, lnd2glc_inst, l2x_l%rattr) + call lnd_export(bounds, lnd2atm_inst, l2x_l%rattr) call t_stopf ('lc_lnd_export') ! Advance clm time step !write(*,*)'MML advance clm timestep' - call t_startf ('lc_clm2_adv_timestep') + call t_startf ('lc_slim_adv_timestep') call advance_timestep() - call t_stopf ('lc_clm2_adv_timestep') + call t_stopf ('lc_slim_adv_timestep') end do diff --git a/src/cpl/lnd_import_export.F90 b/src/cpl/mct/lnd_import_export.F90 similarity index 62% rename from src/cpl/lnd_import_export.F90 rename to src/cpl/mct/lnd_import_export.F90 index 0232c0aa..3352d167 100644 --- a/src/cpl/lnd_import_export.F90 +++ b/src/cpl/mct/lnd_import_export.F90 @@ -4,9 +4,7 @@ module lnd_import_export use abortutils , only: endrun use decompmod , only: bounds_type use lnd2atmType , only: lnd2atm_type - use lnd2glcMod , only: lnd2glc_type use atm2lndType , only: atm2lnd_type - use glc2lndMod , only: glc2lnd_type use clm_cpl_indices ! implicit none @@ -15,7 +13,7 @@ module lnd_import_export contains !=============================================================================== - subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) + subroutine lnd_import( bounds, x2l, atm2lnd_inst) !--------------------------------------------------------------------------- ! !DESCRIPTION: @@ -23,9 +21,8 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) ! ! !USES: use seq_flds_mod , only: seq_flds_x2l_fields - use clm_varctl , only: co2_type, co2_ppmv, iulog - use clm_varctl , only: ndep_from_cpl - use clm_varcon , only: rair, o2_molar_const, c13ratio + use clm_varctl , only: iulog + use clm_varcon , only: rair, o2_molar_const use shr_const_mod , only: SHR_CONST_TKFRZ use shr_string_mod , only: shr_string_listGetName use domainMod , only: ldomain @@ -34,9 +31,7 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds ! bounds real(r8) , intent(in) :: x2l(:,:) ! driver import state to land model - logical , intent(in) :: glc_present ! .true. => running with a non-stub GLC model type(atm2lnd_type) , intent(inout) :: atm2lnd_inst ! clm internal input data type - type(glc2lnd_type) , intent(inout) :: glc2lnd_inst ! clm internal input data type ! ! !LOCAL VARIABLES: integer :: g,i,k,nstep,ier ! indices, number of steps, and error code @@ -49,10 +44,6 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) real(r8) :: forc_rainl ! rainxy Atm flux mm/s real(r8) :: forc_snowc ! snowfxy Atm flux mm/s real(r8) :: forc_snowl ! snowfxl Atm flux mm/s - real(r8) :: co2_ppmv_diag ! temporary - real(r8) :: co2_ppmv_prog ! temporary - real(r8) :: co2_ppmv_val ! temporary - integer :: co2_type_idx ! integer flag for co2_type options real(r8) :: esatw ! saturation vapor pressure over water (Pa) real(r8) :: esati ! saturation vapor pressure over ice (Pa) real(r8) :: a0,a1,a2,a3,a4,a5,a6 ! coefficients for esat over water @@ -79,18 +70,6 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) esati(t) = 100._r8*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6)))))) !--------------------------------------------------------------------------- - co2_type_idx = 0 - if (co2_type == 'prognostic') then - co2_type_idx = 1 - else if (co2_type == 'diagnostic') then - co2_type_idx = 2 - end if - if (co2_type == 'prognostic' .and. index_x2l_Sa_co2prog == 0) then - call endrun( sub//' ERROR: must have nonzero index_x2l_Sa_co2prog for co2_type equal to prognostic' ) - else if (co2_type == 'diagnostic' .and. index_x2l_Sa_co2diag == 0) then - call endrun( sub//' ERROR: must have nonzero index_x2l_Sa_co2diag for co2_type equal to diagnostic' ) - end if - ! Note that the precipitation fluxes received from the coupler ! are in units of kg/s/m^2. To convert these precipitation rates ! in units of mm/sec, one must divide by 1000 kg/m^3 and multiply @@ -101,19 +80,9 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) do g = bounds%begg,bounds%endg i = 1 + (g - bounds%begg) - ! Determine flooding input, sign convention is positive downward and - ! hierarchy is atm/glc/lnd/rof/ice/ocn. so water sent from rof to land is negative, - ! change the sign to indicate addition of water to system. - - atm2lnd_inst%forc_flood_grc(g) = -x2l(index_x2l_Flrr_flood,i) - - atm2lnd_inst%volr_grc(g) = x2l(index_x2l_Flrr_volr,i) * (ldomain%area(g) * 1.e6_r8) - atm2lnd_inst%volrmch_grc(g)= x2l(index_x2l_Flrr_volrmch,i) * (ldomain%area(g) * 1.e6_r8) - ! Determine required receive fields atm2lnd_inst%forc_hgt_grc(g) = x2l(index_x2l_Sa_z,i) ! zgcmxy Atm state m - atm2lnd_inst%forc_topo_grc(g) = x2l(index_x2l_Sa_topo,i) ! Atm surface height (m) atm2lnd_inst%forc_u_grc(g) = x2l(index_x2l_Sa_u,i) ! forc_uxy Atm state m/s atm2lnd_inst%forc_v_grc(g) = x2l(index_x2l_Sa_v,i) ! forc_vxy Atm state m/s atm2lnd_inst%forc_solad_grc(g,2) = x2l(index_x2l_Faxa_swndr,i) ! forc_sollxy Atm flux W/m^2 @@ -121,7 +90,6 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) atm2lnd_inst%forc_solai_grc(g,2) = x2l(index_x2l_Faxa_swndf,i) ! forc_solldxy Atm flux W/m^2 atm2lnd_inst%forc_solai_grc(g,1) = x2l(index_x2l_Faxa_swvdf,i) ! forc_solsdxy Atm flux W/m^2 - atm2lnd_inst%forc_th_not_downscaled_grc(g) = x2l(index_x2l_Sa_ptem,i) ! forc_thxy Atm state K atm2lnd_inst%forc_q_not_downscaled_grc(g) = x2l(index_x2l_Sa_shum,i) ! forc_qxy Atm state kg/kg atm2lnd_inst%forc_pbot_not_downscaled_grc(g) = x2l(index_x2l_Sa_pbot,i) ! ptcmxy Atm state Pa atm2lnd_inst%forc_t_not_downscaled_grc(g) = x2l(index_x2l_Sa_tbot,i) ! forc_txy Atm state K @@ -132,40 +100,6 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) forc_snowc = x2l(index_x2l_Faxa_snowc,i) ! mm/s forc_snowl = x2l(index_x2l_Faxa_snowl,i) ! mm/s - ! atmosphere coupling, for prognostic/prescribed aerosols - atm2lnd_inst%forc_aer_grc(g,1) = x2l(index_x2l_Faxa_bcphidry,i) - atm2lnd_inst%forc_aer_grc(g,2) = x2l(index_x2l_Faxa_bcphodry,i) - atm2lnd_inst%forc_aer_grc(g,3) = x2l(index_x2l_Faxa_bcphiwet,i) - atm2lnd_inst%forc_aer_grc(g,4) = x2l(index_x2l_Faxa_ocphidry,i) - atm2lnd_inst%forc_aer_grc(g,5) = x2l(index_x2l_Faxa_ocphodry,i) - atm2lnd_inst%forc_aer_grc(g,6) = x2l(index_x2l_Faxa_ocphiwet,i) - atm2lnd_inst%forc_aer_grc(g,7) = x2l(index_x2l_Faxa_dstwet1,i) - atm2lnd_inst%forc_aer_grc(g,8) = x2l(index_x2l_Faxa_dstdry1,i) - atm2lnd_inst%forc_aer_grc(g,9) = x2l(index_x2l_Faxa_dstwet2,i) - atm2lnd_inst%forc_aer_grc(g,10) = x2l(index_x2l_Faxa_dstdry2,i) - atm2lnd_inst%forc_aer_grc(g,11) = x2l(index_x2l_Faxa_dstwet3,i) - atm2lnd_inst%forc_aer_grc(g,12) = x2l(index_x2l_Faxa_dstdry3,i) - atm2lnd_inst%forc_aer_grc(g,13) = x2l(index_x2l_Faxa_dstwet4,i) - atm2lnd_inst%forc_aer_grc(g,14) = x2l(index_x2l_Faxa_dstdry4,i) - - ! Determine optional receive fields - - if (index_x2l_Sa_co2prog /= 0) then - co2_ppmv_prog = x2l(index_x2l_Sa_co2prog,i) ! co2 atm state prognostic - else - co2_ppmv_prog = co2_ppmv - end if - - if (index_x2l_Sa_co2diag /= 0) then - co2_ppmv_diag = x2l(index_x2l_Sa_co2diag,i) ! co2 atm state diagnostic - else - co2_ppmv_diag = co2_ppmv - end if - - if (index_x2l_Sa_methane /= 0) then - atm2lnd_inst%forc_pch4_grc(g) = x2l(index_x2l_Sa_methane,i) - endif - ! Determine derived quantities for required fields forc_t = atm2lnd_inst%forc_t_not_downscaled_grc(g) @@ -178,7 +112,6 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) atm2lnd_inst%forc_vp_grc(g) = forc_q * forc_pbot / (0.622_r8 + 0.378_r8 * forc_q) atm2lnd_inst%forc_rho_not_downscaled_grc(g) = & (forc_pbot - 0.378_r8 * atm2lnd_inst%forc_vp_grc(g)) / (rair * forc_t) - atm2lnd_inst%forc_po2_grc(g) = o2_molar_const * forc_pbot atm2lnd_inst%forc_wind_grc(g) = sqrt(atm2lnd_inst%forc_u_grc(g)**2 + atm2lnd_inst%forc_v_grc(g)**2) atm2lnd_inst%forc_solar_grc(g) = atm2lnd_inst%forc_solad_grc(g,1) + atm2lnd_inst%forc_solai_grc(g,1) + & atm2lnd_inst%forc_solad_grc(g,2) + atm2lnd_inst%forc_solai_grc(g,2) @@ -202,8 +135,6 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) endif endif - atm2lnd_inst%forc_rh_grc(g) = 100.0_r8*(forc_q / qsat) - ! Check that solar, specific-humidity and LW downward aren't negative if ( atm2lnd_inst%forc_lwrad_not_downscaled_grc(g) <= 0.0_r8 )then call endrun( sub//' ERROR: Longwave down sent from the atmosphere model is negative or zero' ) @@ -232,50 +163,13 @@ subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst) '(Not a Number from a bad floating point calculation)' ) end if - ! Make sure relative humidity is properly bounded - ! atm2lnd_inst%forc_rh_grc(g) = min( 100.0_r8, atm2lnd_inst%forc_rh_grc(g) ) - ! atm2lnd_inst%forc_rh_grc(g) = max( 0.0_r8, atm2lnd_inst%forc_rh_grc(g) ) - - ! Determine derived quantities for optional fields - ! Note that the following does unit conversions from ppmv to partial pressures (Pa) - ! Note that forc_pbot is in Pa - - if (co2_type_idx == 1) then - co2_ppmv_val = co2_ppmv_prog - else if (co2_type_idx == 2) then - co2_ppmv_val = co2_ppmv_diag - else - co2_ppmv_val = co2_ppmv - end if - atm2lnd_inst%forc_pco2_grc(g) = co2_ppmv_val * 1.e-6_r8 * forc_pbot - - if (ndep_from_cpl) then - ! The coupler is sending ndep in units if kgN/m2/s - and clm uses units of gN/m2/sec - so the - ! following conversion needs to happen - atm2lnd_inst%forc_ndep_grc(g) = (x2l(index_x2l_Faxa_nhx, i) + x2l(index_x2l_faxa_noy, i))*1000._r8 - end if - end do - call glc2lnd_inst%set_glc2lnd_fields( & - bounds = bounds, & - glc_present = glc_present, & - ! NOTE(wjs, 2017-12-13) the x2l argument doesn't have the typical bounds - ! subsetting (bounds%begg:bounds%endg). This mirrors the lack of these bounds in - ! the call to lnd_import from lnd_run_mct. This is okay as long as this code is - ! outside a clump loop. - x2l = x2l, & - index_x2l_Sg_ice_covered = index_x2l_Sg_ice_covered, & - index_x2l_Sg_topo = index_x2l_Sg_topo, & - index_x2l_Flgg_hflx = index_x2l_Flgg_hflx, & - index_x2l_Sg_icemask = index_x2l_Sg_icemask, & - index_x2l_Sg_icemask_coupled_fluxes = index_x2l_Sg_icemask_coupled_fluxes) - end subroutine lnd_import !=============================================================================== - subroutine lnd_export( bounds, lnd2atm_inst, lnd2glc_inst, l2x) + subroutine lnd_export( bounds, lnd2atm_inst, l2x) !--------------------------------------------------------------------------- ! !DESCRIPTION: @@ -286,9 +180,6 @@ subroutine lnd_export( bounds, lnd2atm_inst, lnd2glc_inst, l2x) use seq_flds_mod , only : seq_flds_l2x_fields use clm_varctl , only : iulog use clm_time_manager , only : get_nstep, get_step_size - use seq_drydep_mod , only : n_drydep - use shr_megan_mod , only : shr_megan_mechcomps_n - use shr_fire_emis_mod , only : shr_fire_emis_mechcomps_n use domainMod , only : ldomain use shr_string_mod , only : shr_string_listGetName use shr_infnan_mod , only : isnan => shr_infnan_isnan @@ -297,7 +188,6 @@ subroutine lnd_export( bounds, lnd2atm_inst, lnd2glc_inst, l2x) implicit none type(bounds_type) , intent(in) :: bounds ! bounds type(lnd2atm_type), intent(inout) :: lnd2atm_inst ! clm land to atmosphere exchange data type - type(lnd2glc_type), intent(inout) :: lnd2glc_inst ! clm land to atmosphere exchange data type real(r8) , intent(out) :: l2x(:,:)! land to coupler export state on land grid ! ! !LOCAL VARIABLES: @@ -332,45 +222,17 @@ subroutine lnd_export( bounds, lnd2atm_inst, lnd2glc_inst, l2x) l2x(index_l2x_Fall_lwup,i) = -lnd2atm_inst%eflx_lwrad_out_grc(g) l2x(index_l2x_Fall_evap,i) = -lnd2atm_inst%qflx_evap_tot_grc(g) l2x(index_l2x_Fall_swnet,i) = lnd2atm_inst%fsa_grc(g) - if (index_l2x_Fall_fco2_lnd /= 0) then - l2x(index_l2x_Fall_fco2_lnd,i) = -lnd2atm_inst%net_carbon_exchange_grc(g) - end if - ! Additional fields for DUST, PROGSSLT, dry-deposition and VOC + ! Additional fields for DUST, PROGSSLT, dry-deposition ! These are now standard fields, but the check on the index makes sure the driver handles them if (index_l2x_Sl_ram1 /= 0 ) l2x(index_l2x_Sl_ram1,i) = lnd2atm_inst%ram1_grc(g) if (index_l2x_Sl_fv /= 0 ) l2x(index_l2x_Sl_fv,i) = lnd2atm_inst%fv_grc(g) - if (index_l2x_Sl_soilw /= 0 ) l2x(index_l2x_Sl_soilw,i) = lnd2atm_inst%h2osoi_vol_grc(g,1) + if (index_l2x_Sl_soilw /= 0 ) l2x(index_l2x_Sl_soilw,i) = 0.5_r8 if (index_l2x_Fall_flxdst1 /= 0 ) l2x(index_l2x_Fall_flxdst1,i)= -lnd2atm_inst%flxdst_grc(g,1) if (index_l2x_Fall_flxdst2 /= 0 ) l2x(index_l2x_Fall_flxdst2,i)= -lnd2atm_inst%flxdst_grc(g,2) if (index_l2x_Fall_flxdst3 /= 0 ) l2x(index_l2x_Fall_flxdst3,i)= -lnd2atm_inst%flxdst_grc(g,3) if (index_l2x_Fall_flxdst4 /= 0 ) l2x(index_l2x_Fall_flxdst4,i)= -lnd2atm_inst%flxdst_grc(g,4) - - ! for dry dep velocities - if (index_l2x_Sl_ddvel /= 0 ) then - l2x(index_l2x_Sl_ddvel:index_l2x_Sl_ddvel+n_drydep-1,i) = & - lnd2atm_inst%ddvel_grc(g,:n_drydep) - end if - - ! for MEGAN VOC emis fluxes - if (index_l2x_Fall_flxvoc /= 0 ) then - l2x(index_l2x_Fall_flxvoc:index_l2x_Fall_flxvoc+shr_megan_mechcomps_n-1,i) = & - -lnd2atm_inst%flxvoc_grc(g,:shr_megan_mechcomps_n) - end if - - - ! for fire emis fluxes - if (index_l2x_Fall_flxfire /= 0 ) then - l2x(index_l2x_Fall_flxfire:index_l2x_Fall_flxfire+shr_fire_emis_mechcomps_n-1,i) = & - -lnd2atm_inst%fireflx_grc(g,:shr_fire_emis_mechcomps_n) - l2x(index_l2x_Sl_ztopfire,i) = lnd2atm_inst%fireztop_grc(g) - end if - - if (index_l2x_Fall_methane /= 0) then - l2x(index_l2x_Fall_methane,i) = -lnd2atm_inst%flux_ch4_grc(g) - endif - ! sign convention is positive downward with ! hierarchy of atm/glc/lnd/rof/ice/ocn. ! I.e. water sent from land to rof is positive @@ -389,19 +251,6 @@ subroutine lnd_export( bounds, lnd2atm_inst, lnd2glc_inst, l2x) ! ice sent individually to coupler l2x(index_l2x_Flrl_rofi,i) = lnd2atm_inst%qflx_rofice_grc(g) - ! irrigation flux to be removed from main channel storage (negative) - l2x(index_l2x_Flrl_irrig,i) = - lnd2atm_inst%qirrig_grc(g) - - ! glc coupling - ! We could avoid setting these fields if glc_present is .false., if that would - ! help with performance. (The downside would be that we wouldn't have these fields - ! available for diagnostic purposes or to force a later T compset with dlnd.) - do num = 0,glc_nec - l2x(index_l2x_Sl_tsrf(num),i) = lnd2glc_inst%tsrf_grc(g,num) - l2x(index_l2x_Sl_topo(num),i) = lnd2glc_inst%topo_grc(g,num) - l2x(index_l2x_Flgl_qice(num),i) = lnd2glc_inst%qice_grc(g,num) - end do - ! Check if any output sent to the coupler is NaN if ( any(isnan(l2x(:,i))) )then write(iulog,*) '# of NaNs = ', count(isnan(l2x(:,i))) diff --git a/src/cpl/nuopc/lnd_comp_nuopc.F90 b/src/cpl/nuopc/lnd_comp_nuopc.F90 new file mode 100644 index 00000000..29ae75a7 --- /dev/null +++ b/src/cpl/nuopc/lnd_comp_nuopc.F90 @@ -0,0 +1,1102 @@ +module lnd_comp_nuopc + + !---------------------------------------------------------------------------- + ! This is the NUOPC cap for SLIM + !---------------------------------------------------------------------------- + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet, NUOPC_CompAttributeSet + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : SetVM + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_DataInitialize => label_DataInitialize + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : label_CheckImport + + use NUOPC_Model , only : NUOPC_ModelGet + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl + use shr_sys_mod , only : shr_sys_abort + use shr_file_mod , only : shr_file_getlogunit, shr_file_setlogunit + use shr_cal_mod , only : shr_cal_noleap, shr_cal_gregorian, shr_cal_ymd2date + use spmdMod , only : masterproc, mpicom, spmd_init + use controlMod , only : control_setNL, control_init, control_print, NLFilename + use clm_varctl , only : inst_index, inst_suffix, inst_name + use clm_varctl , only : single_column, clm_varctl_set, iulog + use clm_varctl , only : nsrStartup, nsrContinue, nsrBranch + use clm_time_manager , only : set_timemgr_init, advance_timestep + use clm_time_manager , only : get_nstep, get_step_size + use clm_time_manager , only : get_curr_date + use clm_initializeMod , only : initialize1, initialize2 + use nuopc_shr_methods , only : chkerr, state_setscalar, state_getscalar, state_diagnose, alarmInit + use nuopc_shr_methods , only : set_component_logging, get_component_instance, log_clock_advance + use lnd_import_export , only : advertise_fields, realize_fields, import_fields, export_fields + use lnd_comp_shr , only : mesh, model_meshfile, model_clock + use perf_mod , only : t_startf, t_stopf, t_barrierf + + implicit none + private ! except + + ! Module public routines + public :: SetServices ! Setup the pointers to the function calls for the different models phases (initialize, run, finalize) + public :: SetVM ! Set the virtual machine description of the paralell model (both MPI and OpenMP) + + ! Module private routines + private :: InitializeP0 ! Phase zero of initialization + private :: InitializeAdvertise ! Advertise the fields that can be passed + private :: InitializeRealize ! Realize the list of fields that will be exchanged + private :: ModelSetRunClock ! Set the run clock + private :: ModelAdvance ! Advance the model + private :: ModelFinalize ! Finalize the model + private :: CheckImport + + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + + logical :: glc_present + logical :: rof_prognostic + logical :: atm_prognostic + integer, parameter :: dbug = 0 + character(*),parameter :: modName = "(lnd_comp_nuopc)" + + logical :: scol_valid ! if single_column, does point have a mask of zero + + integer :: nthrds ! Number of threads per task in this component + + character(len=*) , parameter :: startup_run = 'startup' + character(len=*) , parameter :: continue_run = 'continue' + character(len=*) , parameter :: branch_run = 'branch' + + logical :: write_restart_at_endofrun = .false. + + character(len=*) , parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine SetServices(gcomp, rc) + ! Setup the pointers to the function calls for the different models phases (initialize, run, finalize) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=InitializeP0, phase=0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p1"/), userRoutine=InitializeAdvertise, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p3"/), userRoutine=InitializeRealize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & + specRoutine=ModelAdvance, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, & + specRoutine=CheckImport, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & + specRoutine=ModelSetRunClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & + specRoutine=ModelFinalize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) + + end subroutine SetServices + + !=============================================================================== + subroutine InitializeP0(gcomp, importState, exportState, clock, rc) + + ! Phase zero initialization + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Switch to IPDv01 by filtering all other phaseMap entries + call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, acceptStringList=(/"IPDv01p"/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine InitializeP0 + + !=============================================================================== + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! Advertise the fields that can be exchanged + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + integer :: lmpicom + integer :: ierr + integer :: n + integer :: localPet ! local PET (Persistent Execution Threads) (both MPI tasks and OpenMP threads) + integer :: compid ! component id + integer :: shrlogunit ! original log unit + character(len=CL) :: cvalue + character(len=CL) :: logmsg + character(len=CL) :: atm_model + character(len=CL) :: rof_model + character(len=CL) :: glc_model + character(len=*), parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + character(len=*), parameter :: format = "('("//trim(subname)//") :',A)" + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + !---------------------------------------------------------------------------- + ! generate local mpi comm + !---------------------------------------------------------------------------- + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, mpiCommunicator=lmpicom, localpet=localpet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---------------------------------------------------------------------------- + ! initialize SLIM MPI info + !---------------------------------------------------------------------------- + + call mpi_comm_dup(lmpicom, mpicom, ierr) + + !---------------------------------------------------------------------------- + ! reset shr logging to my log file + !---------------------------------------------------------------------------- + + call set_component_logging(gcomp, localPet==0, iulog, shrlogunit, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Note still need compid for those parts of the code that use the data model + ! functionality through subroutine calls + call NUOPC_CompAttributeGet(gcomp, name='MCTID', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) compid ! convert from string to integer + + call spmd_init(mpicom, compid) + + !---------------------------------------------------------------------------- + ! determine instance information + !---------------------------------------------------------------------------- + + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + inst_name = 'LND' + + !---------------------------------------------------------------------------- + ! advertise fields + !---------------------------------------------------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + flds_scalar_name = trim(cvalue) + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue, *) flds_scalar_num + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_scalar_index_nx + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_scalar_index_ny + call NUOPC_CompAttributeGet(gcomp, name='ROF_model', value=rof_model, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (trim(rof_model) /= 'srof' .and. trim(rof_model) == 'drof') then + call shr_sys_abort( subname//'ERROR:: SLIM can NOT currently be coupled to a prognostic ROF model' ) + end if + rof_prognostic = .false. ! Always assume a ROF model is NOT under SLIM + call NUOPC_CompAttributeGet(gcomp, name='ATM_model', value=atm_model, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (trim(atm_model) == 'satm' .or. trim(atm_model) == 'datm') then + atm_prognostic = .false. + else + atm_prognostic = .true. + end if + call NUOPC_CompAttributeGet(gcomp, name='GLC_model', value=glc_model, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (trim(glc_model) /= 'sglc') then + call shr_sys_abort( subname//'ERROR:: SLIM can NOT be coupled to a prognostic GLC model' ) + end if + glc_present = .false. ! Always assume a land-ice model is NOT present + + if (masterproc) then + write(iulog,'(a )')' atm component = '//trim(atm_model) + write(iulog,'(a,L2)')' atm_prognostic = ',atm_prognostic + write(iulog,'(a )')' flds_scalar_name = '//trim(flds_scalar_name) + write(iulog,'(a,i8)')' flds_scalar_num = ',flds_scalar_num + write(iulog,'(a,i8)')' flds_scalar_index_nx = ',flds_scalar_index_nx + write(iulog,'(a,i8)')' flds_scalar_index_ny = ',flds_scalar_index_ny + end if + + !---------------------- + ! Set the namelist filename + !---------------------- + call control_setNL("lnd_in"//trim(inst_suffix)) + + + call advertise_fields(gcomp, flds_scalar_name, atm_prognostic, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---------------------------------------------------------------------------- + ! reset shr logging to original values + !---------------------------------------------------------------------------- + + call shr_file_setLogUnit (shrlogunit) + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) + + end subroutine InitializeAdvertise + + !=============================================================================== + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + + ! Realize the list of fields that will be exchanged + use ESMF , only : ESMF_VM, ESMF_VMGet + use clm_instMod , only : lnd2atm_inst + use domainMod , only : ldomain + use decompMod , only : bounds_type, get_proc_bounds + use lnd_set_decomp_and_domain , only : lnd_set_decomp_and_domain_from_readmesh + use lnd_set_decomp_and_domain , only : lnd_set_mesh_for_single_column + use lnd_set_decomp_and_domain , only : lnd_set_decomp_and_domain_for_single_column + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm ! Virtual machine, description of parallel procesors being used (both MPI and OpenMP) + type(ESMF_Time) :: currTime ! Current time + type(ESMF_Time) :: startTime ! Start time + type(ESMF_Time) :: refTime ! Ref time + type(ESMF_TimeInterval) :: timeStep ! Model timestep + type(ESMF_CalKind_Flag) :: esmf_caltype ! esmf calendar type + integer :: ref_ymd ! reference date (YYYYMMDD) + integer :: ref_tod ! reference time of day (sec) + integer :: yy,mm,dd ! Temporaries for time query + integer :: start_ymd ! start date (YYYYMMDD) + integer :: start_tod ! start time of day (sec) + integer :: curr_ymd ! Start date (YYYYMMDD) + integer :: curr_tod ! Start time of day (sec) + integer :: dtime_sync ! coupling time-step from the input synchronization clock + integer :: localPet ! local PET (Persistent Execution Threads) (both MPI tasks and OpenMP threads) + integer :: localPeCount ! Number of local Processors + character(len=CL) :: starttype ! start-type (startup, continue, branch, hybrid) + character(len=CL) :: calendar ! calendar type name + logical :: brnch_retain_casename ! flag if should retain the case name on a branch start type + integer :: nsrest ! SLIM restart type + integer :: lbnum ! input to memory diagnostic + integer :: shrlogunit ! original log unit + integer :: n, ni, nj ! Indices + character(len=CL) :: cvalue ! config data + character(len=CL) :: meshfile_mask ! filename of mesh file with land mask + character(len=CL) :: ctitle ! case description title + character(len=CL) :: caseid ! case identifier name + real(r8) :: scol_lat ! single-column latitude + real(r8) :: scol_lon ! single-column longitude + real(r8) :: scol_area ! single-column area + real(r8) :: scol_frac ! single-column frac + integer :: scol_mask ! single-column mask + real(r8) :: scol_spval ! single-column special value to indicate it isn't set + character(len=CL) :: single_column_lnd_domainfile ! domain filename to use for single-column mode (i.e. SCAM) + type(bounds_type) :: bounds ! bounds + type(ESMF_Field) :: lfield ! Land field read in + character(CL) ,pointer :: lfieldnamelist(:) => null() ! Land field namelist item sent with land field + integer :: fieldCount ! Number of fields on export state + integer :: rank ! Rank of field (1D or 2D) + real(r8), pointer :: fldptr1d(:) ! 1D field pointer + real(r8), pointer :: fldptr2d(:,:) ! 2D field pointer + logical :: isPresent ! If attribute is present + logical :: isSet ! If attribute is present and also set + character(len=CL) :: model_version ! Model version + character(len=CL) :: hostname ! hostname of machine running on + character(len=CL) :: username ! user running the model + character(len=*),parameter :: subname=trim(modName)//':(InitializeRealize) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + !---------------------------------------------------------------------------- + ! Single column logic - if mask is zero for nearest neighbor search then + ! set all export state fields to zero and return + !---------------------------------------------------------------------------- + + ! If single_column is true - used single_column_domainfile to + ! obtain nearest neighbor values for scol_lon and scol_lat + ! If single_column is false and scol_lon and scol_lat are not equal to scol_spval then + ! use scol_lon and scol_lat directly + + call NUOPC_CompAttributeGet(gcomp, name='scol_lon', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_lon + call NUOPC_CompAttributeGet(gcomp, name='scol_lat', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_lat + call NUOPC_CompAttributeGet(gcomp, name='single_column_lnd_domainfile', value=single_column_lnd_domainfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! TODO: there is a problem retrieving scol_spval from the driver - for now + ! hard-wire scol_spval - this needs to be fixed + scol_spval = -999._r8 + ! call NUOPC_CompAttributeGet(gcomp, name='scol_spval', value=cvalue, rc=rc) + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! read(cvalue,*) scol_spval + scol_valid = .true. + if (scol_lon > scol_spval .and. scol_lat > scol_spval) then + single_column = (trim(single_column_lnd_domainfile) /= 'UNSET') + + call NUOPC_CompAttributeGet(gcomp, name='scol_lndmask', value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_mask + + call NUOPC_CompAttributeGet(gcomp, name='scol_lndfrac', value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_frac + + call lnd_set_mesh_for_single_column(scol_lon, scol_lat, mesh, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + scol_valid = (scol_mask == 1) + if (.not. scol_valid) then + write(iulog,'(a)')' single column mode point does not contain any land - will set all export data to 0' + ! if single column is not valid - set all export state fields to zero and return + call realize_fields(importState, exportState, mesh, flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + call ESMF_StateGet(exportState, itemNameList=lfieldnamelist, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1, fieldCount + if (trim(lfieldnamelist(n)) /= flds_scalar_name) then + call ESMF_StateGet(exportState, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, rank=rank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (rank == 2) then + call ESMF_FieldGet(lfield, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0._r8 + else + call ESMF_FieldGet(lfield, farrayPtr=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr1d(:) = 0._r8 + end if + end if + enddo + deallocate(lfieldnamelist) + ! ******************* + ! *** RETURN HERE *** + ! ******************* + RETURN + else + write(iulog,'(a,3(f10.5,2x))')' single column mode scol_lon/scol_lat/scol_frac is ',& + scol_lon,scol_lat,scol_frac + end if + else + single_column = .false. + end if + if ( single_column )then + call shr_sys_abort( subname//'ERROR:: single_column NOT setup for SLIM yet' ) + end if + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + + call shr_file_getLogUnit (shrlogunit) + call shr_file_setLogUnit (iulog) +#if (defined _MEMTRACE) + if (masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out','lnd_comp_nuopc_InitializeRealize:start::',lbnum) + endif +#endif + !---------------------------------------------------------------------------- + ! Initialize component threading + !---------------------------------------------------------------------------- + + call ESMF_GridCompGet(gcomp, vm=vm, localPet=localPet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if(localPeCount == 1) then + call NUOPC_CompAttributeGet(gcomp, "nthreads", value=cvalue, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + read(cvalue,*) nthrds + else + nthrds = localPeCount + endif + if ( nthrds > 1 )then + call shr_sys_abort( subname//'ERROR:: SLIM can NOT currently handle threading' ) + end if + + !---------------------- + ! Get properties from clock + !---------------------- + call ESMF_ClockGet( clock, currTime=currTime, startTime=startTime, refTime=RefTime, & + timeStep=timeStep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet( currTime, yy=yy, mm=mm, dd=dd, s=curr_tod, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call shr_cal_ymd2date(yy,mm,dd,curr_ymd) + call ESMF_TimeGet( startTime, yy=yy, mm=mm, dd=dd, s=start_tod, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call shr_cal_ymd2date(yy,mm,dd,start_ymd) + call ESMF_TimeGet( refTime, yy=yy, mm=mm, dd=dd, s=ref_tod, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call shr_cal_ymd2date(yy,mm,dd,ref_ymd) + call ESMF_TimeGet( currTime, calkindflag=esmf_caltype, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (esmf_caltype == ESMF_CALKIND_NOLEAP) then + calendar = shr_cal_noleap + else if (esmf_caltype == ESMF_CALKIND_GREGORIAN) then + calendar = shr_cal_gregorian + else + call shr_sys_abort( subname//'ERROR:: bad calendar for ESMF' ) + end if + call ESMF_TimeIntervalGet( timeStep, s=dtime_sync, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (masterproc) then + write(iulog,*)'dtime = ', dtime_sync + end if + + !---------------------- + ! Initialize SLIM time manager + !---------------------- + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) caseid + ctitle= trim(caseid) + call NUOPC_CompAttributeGet(gcomp, name='model_version', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) model_version + + ! Note that we assume that SLIM's internal dtime matches the coupling time step. + ! i.e., we currently do NOT allow sub-cycling within a coupling time step. + call set_timemgr_init( & + calendar_in=calendar, & + start_ymd_in=start_ymd, & + start_tod_in=start_tod, & + ref_ymd_in=ref_ymd, & + ref_tod_in=ref_tod, & + dtime_in=dtime_sync) + + ! Set model clock in lnd_comp_shr + model_clock = clock + + call NUOPC_CompAttributeGet(gcomp, name="write_restart_at_endofrun", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(cvalue) .eq. '.true.') write_restart_at_endofrun = .true. + end if + ! --------------------- + ! Initialize first phase of SLIM + ! --------------------- + call NUOPC_CompAttributeGet(gcomp, name='hostname', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hostname + call NUOPC_CompAttributeGet(gcomp, name='username', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) username + call NUOPC_CompAttributeGet(gcomp, name='brnch_retain_casename', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) brnch_retain_casename + call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) starttype + + if ( trim(starttype) == trim(startup_run)) then + nsrest = nsrStartup + else if (trim(starttype) == trim(continue_run)) then + nsrest = nsrContinue + else if (trim(starttype) == trim(branch_run)) then + nsrest = nsrBranch + else + call shr_sys_abort( subname//' ERROR: unknown starttype' ) + end if + + ! set default values for run control variables + call clm_varctl_set(& + caseid_in=caseid, ctitle_in=ctitle, & + brnch_retain_casename_in=brnch_retain_casename, & + single_column_in=single_column, scmlat_in=scol_lat, scmlon_in=scol_lon, & + nsrest_in=nsrest, & + version_in=model_version, & + hostname_in=hostname, & + username_in=username) + + call initialize1( ) + + ! --------------------- + ! Create SLIM decomp and domain info + ! --------------------- + if (scol_lon > scol_spval .and. scol_lat > scol_spval) then + call lnd_set_decomp_and_domain_for_single_column(scol_lon, scol_lat, scol_mask, scol_frac) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call NUOPC_CompAttributeGet(gcomp, name='mesh_lnd', value=model_meshfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name='mesh_mask', value=meshfile_mask, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call lnd_set_decomp_and_domain_from_readmesh(vm=vm, & + meshfile_lnd=model_meshfile, meshfile_mask=meshfile_mask, mesh_slim=mesh, ni=ni, nj=nj, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + ! --------------------- + ! Realize the actively coupled fields + ! --------------------- + call realize_fields(importState, exportState, mesh, flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! --------------------- + ! Finish initializing SLIM + ! --------------------- + call initialize2( ) + + !-------------------------------- + ! Create land export state + !-------------------------------- + call get_proc_bounds(bounds) + call export_fields(gcomp, bounds, lnd2atm_inst, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Set scalars in export state + call State_SetScalar(dble(ldomain%ni), flds_scalar_index_nx, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(ldomain%nj), flds_scalar_index_ny, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! diagnostics + !-------------------------------- + + if (dbug > 1) then + call State_diagnose(exportState, subname//':ExportState',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + call shr_file_setLogUnit (shrlogunit) + +#if (defined _MEMTRACE) + if(masterproc) then + write(iulog,*) TRIM(subname) // ':end::' + lbnum=1 + call memmon_dump_fort('memmon.out','lnd_comp_nuopc_InitializeRealize:end::',lbnum) + call memmon_reset_addr() + endif +#endif + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) + + end subroutine InitializeRealize + + !=============================================================================== + + subroutine ModelAdvance(gcomp, rc) + + !------------------------ + ! Run SLIM + !------------------------ + + use ESMF , only : ESMF_VM, ESMF_VMGet + use clm_instMod , only : atm2lnd_inst, lnd2atm_inst + use decompMod , only : bounds_type, get_proc_bounds + use clm_driver , only : clm_drv + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables: + type(ESMF_Clock) :: clock + type(ESMF_Alarm) :: alarm + type(ESMF_Time) :: currTime + type(ESMF_Time) :: nextTime + type(ESMF_State) :: importState, exportState + type(ESMF_VM) :: vm + character(ESMF_MAXSTR) :: cvalue + character(ESMF_MAXSTR) :: case_name ! case name + integer :: ymd ! SLIM current date (YYYYMMDD) + integer :: yr ! SLIM current year + integer :: mon ! SLIM current month + integer :: day ! SLIM current day + integer :: tod ! SLIM current time of day (sec) + integer :: ymd_sync ! Sync date (YYYYMMDD) + integer :: yr_sync ! Sync current year + integer :: mon_sync ! Sync current month + integer :: day_sync ! Sync current day + integer :: tod_sync ! Sync current time of day (sec) + integer :: dtime ! time step increment (sec) + integer :: nstep ! time step index + integer :: localPet ! local PET (Persistent Execution Threads) (both MPI tasks and OpenMP threads) + integer :: localPeCount ! Number of local Processors + logical :: rstwr ! .true. ==> write restart file before returning + logical :: nlend ! .true. ==> last time-step + logical :: dosend ! true => send data back to driver + integer :: lbnum ! input to memory diagnostic + integer :: g,i ! counters + type(bounds_type) :: bounds ! bounds + character(len=32) :: rdate ! date char string for restart file names + logical :: doalb + real(r8) :: nextsw_cday + real(r8) :: declinp1 + real(r8) :: declin + integer :: shrlogunit ! original log unit + character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + !-------------------------------- + ! Single column logic if nearest neighbor point has a mask of zero + !-------------------------------- + + if (single_column .and. .not. scol_valid) then + RETURN + end if + + !-------------------------------- + ! Reset share log units + !-------------------------------- + + call shr_file_getLogUnit (shrlogunit) + call shr_file_setLogUnit (iulog) + +#if (defined _MEMTRACE) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out','lnd_comp_nuopc_ModelAdvance:start::',lbnum) + endif +#endif + + !-------------------------------- + ! Query the Component for its clock, importState and exportState and vm + !-------------------------------- + + call NUOPC_ModelGet(gcomp, modelClock=clock, importState=importState, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Get proc bounds + call get_proc_bounds(bounds) + + !-------------------------------- + ! Unpack import state + !-------------------------------- + + call t_startf ('lc_lnd_import') + call import_fields( gcomp, bounds, atm2lnd_inst, rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf ('lc_lnd_import') + + !-------------------------------- + ! Run model + !-------------------------------- + + dtime = get_step_size() + dosend = .false. + do while(.not. dosend) + + ! TODO: This is currently hard-wired - is there a better way for nuopc? + ! Note that the model clock is updated at the end of the time step not at the beginning + nstep = get_nstep() + if (nstep > 0) then + dosend = .true. + end if + + !-------------------------------- + ! Determine if time to stop + !-------------------------------- + + call ESMF_ClockGetAlarm(clock, alarmname='alarm_stop', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + nlend = .true. + call ESMF_AlarmRingerOff( alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + nlend = .false. + endif + + !-------------------------------- + ! Determine if time to write restart + !-------------------------------- + rstwr = .false. + if (nlend .and. write_restart_at_endofrun) then + rstwr = .true. + else + call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_AlarmIsCreated(alarm, rc=rc)) then + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + rstwr = .true. + call ESMF_AlarmRingerOff( alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif + end if + + !-------------------------------- + ! Run SLIM + !-------------------------------- + + call t_startf ('slim_run') + ! Restart File - use nexttimestr rather than currtimestr here since that is the time at the end of + ! the timestep and is preferred for restart file names + call ESMF_ClockGetNextTime(clock, nextTime=nextTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(nexttime, yy=yr_sync, mm=mon_sync, dd=day_sync, s=tod_sync, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(rdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr_sync, mon_sync, day_sync, tod_sync + call clm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate, rof_prognostic) + call t_stopf ('slim_run') + + !-------------------------------- + ! Pack export state + !-------------------------------- + + call t_startf ('lc_lnd_export') + call export_fields(gcomp, bounds, lnd2atm_inst, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf ('lc_lnd_export') + + !-------------------------------- + ! Advance SLIM time step + !-------------------------------- + + call t_startf ('lc_slim2_adv_timestep') + call advance_timestep() + call t_stopf ('lc_slim2_adv_timestep') + + end do + + ! Check that internal clock is in sync with master clock + ! Note that the driver clock has not been updated yet - so at this point + ! SLIM is actually 1 coupling intervals ahead of the driver clock + + call get_curr_date( yr, mon, day, tod, offset=-2*dtime ) + ymd = yr*10000 + mon*100 + day + tod = tod + + call ESMF_ClockGet( clock, currTime=currTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet( currTime, yy=yr_sync, mm=mon_sync, dd=day_sync, s=tod_sync, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call shr_cal_ymd2date(yr_sync, mon_sync, day_sync, ymd_sync) + + if ( (ymd /= ymd_sync) .or. (tod /= tod_sync) ) then + write(iulog,*)'slim ymd=',ymd ,' slim tod= ',tod + write(iulog,*)'sync ymd=',ymd_sync,' sync tod= ',tod_sync + call ESMF_LogWrite(subname//" SLIM clock not in sync with Master Sync clock",ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + end if + + !-------------------------------- + ! diagnostics + !-------------------------------- + + if (dbug > 1) then + call State_diagnose(exportState,subname//':ES',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (masterproc) then + call log_clock_advance(clock, 'SLIM', iulog, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + + !-------------------------------- + ! Reset shr logging to my original values + !-------------------------------- + + call shr_file_setLogUnit (shrlogunit) + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) + +#if (defined _MEMTRACE) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out','lnd_comp_nuopc_ModelAdvance:end::',lbnum) + call memmon_reset_addr() + endif +#endif + + end subroutine ModelAdvance + + !=============================================================================== + subroutine ModelSetRunClock(gcomp, rc) + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: mclock, dclock + type(ESMF_Time) :: mcurrtime, dcurrtime + type(ESMF_Time) :: mstoptime + type(ESMF_TimeInterval) :: mtimestep, dtimestep + character(len=256) :: cvalue + character(len=256) :: restart_option ! Restart option units + integer :: restart_n ! Number until restart interval + integer :: restart_ymd ! Restart date (YYYYMMDD) + type(ESMF_ALARM) :: restart_alarm + character(len=256) :: stop_option ! Stop option units + integer :: stop_n ! Number until stop interval + integer :: stop_ymd ! Stop date (YYYYMMDD) + type(ESMF_ALARM) :: stop_alarm + character(len=128) :: name + integer :: alarmcount + character(len=*),parameter :: subname=trim(modName)//':(ModelSetRunClock) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + if (.not. scol_valid) return + + ! query the Component for its clocks + call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! force model clock currtime and timestep to match driver and set stoptime + !-------------------------------- + + mstoptime = mcurrtime + dtimestep + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! set restart and stop alarms + !-------------------------------- + + call ESMF_ClockGetAlarmList(mclock, alarmlistflag=ESMF_ALARMLIST_ALL, alarmCount=alarmCount, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (alarmCount == 0) then + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//'setting alarms for ' // trim(name), ESMF_LOGMSG_INFO) + + !---------------- + ! Restart alarm + !---------------- + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) restart_n + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) restart_ymd + + call alarmInit(mclock, restart_alarm, restart_option, & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'alarm_restart', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---------------- + ! Stop alarm + !---------------- + call NUOPC_CompAttributeGet(gcomp, name="stop_option", value=stop_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="stop_n", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) stop_n + + call NUOPC_CompAttributeGet(gcomp, name="stop_ymd", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) stop_ymd + + call alarmInit(mclock, stop_alarm, stop_option, & + opt_n = stop_n, & + opt_ymd = stop_ymd, & + RefTime = mcurrTime, & + alarmname = 'alarm_stop', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(stop_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end if + + !-------------------------------- + ! Advance model clock to trigger alarms then reset model clock back to currtime + !-------------------------------- + + call ESMF_ClockAdvance(mclock,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) + + end subroutine ModelSetRunClock + + !=============================================================================== + subroutine ModelFinalize(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + character(*), parameter :: F00 = "('(lnd_comp_nuopc) ',8a)" + character(*), parameter :: F91 = "('(lnd_comp_nuopc) ',73('-'))" + character(len=*),parameter :: subname=trim(modName)//':(ModelFinalize) ' + !------------------------------------------------------------------------------- + + !-------------------------------- + ! Finalize routine + !-------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + if (masterproc) then + write(iulog,F91) + write(iulog,F00) 'SLIM: end of main integration loop' + write(iulog,F91) + end if + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) + + end subroutine ModelFinalize + + subroutine CheckImport(gcomp, rc) + use NUOPC + use ESMF + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + character(len=*) , parameter :: subname = "("//__FILE__//":CheckImport)" + + ! This is the routine that enforces the explicit time dependence on the + ! import fields. This simply means that the timestamps on the Fields in the + ! importState are checked against the currentTime on the Component's + ! internalClock. Consequenty, this model starts out with forcing fields + ! at the current time as it does its forward step from currentTime to + ! currentTime + timeStep. + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_Time) :: time + type(ESMF_State) :: importState + logical :: allCurrent + type(ESMF_Field), allocatable :: fieldList(:) + integer :: i + character(ESMF_MAXSTR) :: fieldName + character(ESMF_MAXSTR) :: name + character(ESMF_MAXSTR) :: valueString + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + if (single_column .and. .not. scol_valid) then + RETURN + end if + ! The remander of this should be equivalent to the NUOPC internal routine + ! from NUOPC_ModeBase.F90 + + ! query the component for info + call NUOPC_CompGet(gcomp, name=name, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! query the Component for its clock and importState + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! get the current time out of the clock + call ESMF_ClockGet(clock, currTime=time, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! check that Fields in the importState show correct timestamp + allCurrent = NUOPC_IsAtTime(importState, time, fieldList=fieldList, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (.not.allCurrent) then + !TODO: introduce and use INCOMPATIBILITY return codes!!!! + do i=1, size(fieldList) + call ESMF_FieldGet(fieldList(i), name=fieldName, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_GetAttribute(fieldList(i), name="StandardName", & + value=valueString, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(trim(name)//": Field '"//trim(fieldName)//& + "' in the importState is not at the expected time. StandardName: "& + //trim(valueString), ESMF_LOGMSG_WARNING) + enddo + deallocate(fieldList) + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg="NUOPC INCOMPATIBILITY DETECTED: Import Fields not at current time", & + line=__LINE__, file=__FILE__, & + rcToReturn=rc) + return ! bail out + endif + + end subroutine CheckImport +end module lnd_comp_nuopc diff --git a/src/cpl/nuopc/lnd_comp_shr.F90 b/src/cpl/nuopc/lnd_comp_shr.F90 new file mode 100644 index 00000000..dd619c76 --- /dev/null +++ b/src/cpl/nuopc/lnd_comp_shr.F90 @@ -0,0 +1,15 @@ +module lnd_comp_shr + + ! Model mesh info is here in order to be leveraged by CDEPS in line calls + + use ESMF + use shr_kind_mod, only : r8 => shr_kind_r8, cl=>shr_kind_cl + + implicit none + public + + type(ESMF_Clock) :: model_clock ! model clock + type(ESMF_Mesh) :: mesh ! model_mesh + character(len=cl) :: model_meshfile ! model mesh file + +end module lnd_comp_shr diff --git a/src/cpl/nuopc/lnd_import_export.F90 b/src/cpl/nuopc/lnd_import_export.F90 new file mode 100644 index 00000000..a1008d90 --- /dev/null +++ b/src/cpl/nuopc/lnd_import_export.F90 @@ -0,0 +1,956 @@ +module lnd_import_export + ! CTSM import and export fields exchanged with the coupler + use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Mesh, ESMF_StateGet + use ESMF , only : ESMF_KIND_R8, ESMF_SUCCESS, ESMF_MAXSTR, ESMF_LOGMSG_INFO + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LogFoundError + use ESMF , only : ESMF_STATEITEM_NOTFOUND, ESMF_StateItem_Flag + use ESMF , only : operator(/=), operator(==) + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_IsConnected + use NUOPC_Model , only : NUOPC_ModelGet + use shr_kind_mod , only : r8 => shr_kind_r8, cx=>shr_kind_cx, cxx=>shr_kind_cxx, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use clm_varctl , only : iulog + use clm_time_manager , only : get_nstep + use decompmod , only : bounds_type, get_proc_bounds + use lnd2atmType , only : lnd2atm_type + use atm2lndType , only : atm2lnd_type + use domainMod , only : ldomain + use spmdMod , only : masterproc + use shr_drydep_mod , only : shr_drydep_readnl + use shr_megan_mod , only : shr_megan_readnl + use nuopc_shr_methods , only : chkerr + use lnd_import_export_utils , only : check_for_errors, check_for_nans + + implicit none + private ! except + + public :: advertise_fields ! Advertise the fields that can be sent/received + public :: realize_fields ! Realize which fields will be sent and received + public :: import_fields ! Import needed fields from mediator + public :: export_fields ! Export fields from CTSM to mediator + + private :: fldlist_add + private :: fldlist_realize + private :: state_getimport_1d + private :: state_getimport_2d + private :: state_setexport_1d + private :: state_setexport_2d + private :: state_getfldptr + private :: fldchk + private :: ReadCapNamelist ! Read in namelists governing import and export state + + type fld_list_type + character(len=128) :: stdname + integer :: ungridded_lbound = 0 + integer :: ungridded_ubound = 0 + end type fld_list_type + + integer, parameter :: fldsMax = 100 + integer :: fldsToLnd_num = 0 + integer :: fldsFrLnd_num = 0 + type (fld_list_type) :: fldsToLnd(fldsMax) + type (fld_list_type) :: fldsFrLnd(fldsMax) + + ! from lnd->atm + character(len=cx) :: carma_fields ! List of CARMA fields from lnd->atm + integer :: drydep_nflds ! number of dry deposition fields, ensure this is zero + integer :: megan_nflds ! number of MEGAN voc fields from, ensure this is zero + integer :: emis_nflds ! number of fire emission fields, ensure this is zero + + logical :: flds_co2a ! use case SLIM doesn't use CO2 so make sure isn't set + logical :: flds_co2b ! use case (same as above) + logical :: flds_co2c ! use case (same as above) + logical :: force_send_to_atm = .true. ! Force sending export data to atmosphere even if ATM is not prognostic + integer :: glc_nec ! number of glc elevation classes + integer, parameter :: debug = 0 ! internal debug level + + ! import fields + character(*), parameter :: Sa_z = 'Sa_z' + character(*), parameter :: Sa_topo = 'Sa_topo' + character(*), parameter :: Sa_u = 'Sa_u' + character(*), parameter :: Sa_v = 'Sa_v' + character(*), parameter :: Sa_ptem = 'Sa_ptem' + character(*), parameter :: Sa_shum = 'Sa_shum' + character(*), parameter :: Sa_pbot = 'Sa_pbot' + character(*), parameter :: Sa_tbot = 'Sa_tbot' + character(*), parameter :: Faxa_rainc = 'Faxa_rainc' + character(*), parameter :: Faxa_rainl = 'Faxa_rainl' + character(*), parameter :: Faxa_snowc = 'Faxa_snowc' + character(*), parameter :: Faxa_snowl = 'Faxa_snowl' + character(*), parameter :: Faxa_lwdn = 'Faxa_lwdn' + character(*), parameter :: Faxa_swvdr = 'Faxa_swvdr' + character(*), parameter :: Faxa_swndr = 'Faxa_swndr' + character(*), parameter :: Faxa_swvdf = 'Faxa_swvdf' + character(*), parameter :: Faxa_swndf = 'Faxa_swndf' + + ! export fields + character(*), parameter :: Sl_lfrin = 'Sl_lfrin' + character(*), parameter :: Sl_t = 'Sl_t' + character(*), parameter :: Sl_snowh = 'Sl_snowh' + character(*), parameter :: Sl_avsdr = 'Sl_avsdr' + character(*), parameter :: Sl_anidr = 'Sl_anidr' + character(*), parameter :: Sl_avsdf = 'Sl_avsdf' + character(*), parameter :: Sl_anidf = 'Sl_anidf' + character(*), parameter :: Sl_tref = 'Sl_tref' + character(*), parameter :: Sl_qref = 'Sl_qref' + character(*), parameter :: Fall_taux = 'Fall_taux' + character(*), parameter :: Fall_tauy = 'Fall_tauy' + character(*), parameter :: Fall_lat = 'Fall_lat' + character(*), parameter :: Fall_sen = 'Fall_sen' + character(*), parameter :: Fall_lwup = 'Fall_lwup' + character(*), parameter :: Fall_evap = 'Fall_evap' + character(*), parameter :: Fall_swnet = 'Fall_swnet' + character(*), parameter :: Fall_flxdst = 'Fall_flxdst' + character(*), parameter :: Sl_u10 = 'Sl_u10' + character(*), parameter :: Sl_ram1 = 'Sl_ram1' + character(*), parameter :: Sl_fv = 'Sl_fv' + character(*), parameter :: Sl_soilw = 'Sl_soilw' + + logical :: send_to_atm + + character(*),parameter :: F01 = "('(lnd_import_export) ',a,i5,2x,i5,2x,d21.14)" + character(*),parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine advertise_fields(gcomp, flds_scalar_name, atm_prognostic, rc) + + use shr_carma_mod , only : shr_carma_readnl + use shr_fire_emis_mod , only : shr_fire_emis_readnl + use controlMod , only : NLFilename + + ! input/output variables + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(in) :: flds_scalar_name + logical , intent(in) :: atm_prognostic + integer , intent(out) :: rc + + ! local variables + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + character(len=CS) :: cvalue + logical :: isPresent, isSet + integer :: n, num + + character(len=*), parameter :: subname='(lnd_import_export:advertise_fields)' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine number of elevation classes + call NUOPC_CompAttributeGet(gcomp, name='glc_nec', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) glc_nec + call ESMF_LogWrite('glc_nec = '// trim(cvalue), ESMF_LOGMSG_INFO) + if (glc_nec < 1) then + call shr_sys_abort('ERROR: In CLM4.5 and later, glc_nec must be at least 1.') + end if + + !-------------------------------- + ! Advertise export fields + !-------------------------------- + + call ReadCapNamelist( NLFilename ) + + ! Need to determine if there is no land for single column before the advertise call is done + + if (atm_prognostic .or. force_send_to_atm) then + send_to_atm = .true. + else + send_to_atm = .false. + end if + + if (send_to_atm) then + call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_co2a + call NUOPC_CompAttributeGet(gcomp, name='flds_co2b', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_co2b + call NUOPC_CompAttributeGet(gcomp, name='flds_co2c', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_co2c + if ( flds_co2a .or. flds_co2b .or. flds_co2c )then + call shr_sys_abort(trim(subname)//": ERROR: SLIM can NOT pass CO2 fields to atmosphere") + end if + end if + + ! The following namelist reads should always be called regardless of the send_to_atm value + + ! (For dry-deposition, fire-emissions, and MEGAN just ensure they are NOT turned on) + + ! Dry Deposition velocities from land + call shr_drydep_readnl("drv_flds_in", drydep_nflds) + if ( drydep_nflds > 0 )then + call shr_sys_abort(trim(subname)//": ERROR: dry deposition can NOT be turned on when running with SLIM") + end if + + ! Fire emissions fluxes from land + call shr_fire_emis_readnl('drv_flds_in', emis_nflds) + if ( emis_nflds > 0 )then + call shr_sys_abort(trim(subname)//": ERROR: fire emissions can NOT be turned on when running with SLIM") + end if + + ! MEGAN VOC emissions fluxes from land + call shr_megan_readnl('drv_flds_in', megan_nflds) + if ( megan_nflds > 0 )then + call shr_sys_abort(trim(subname)//": ERROR: MEGAN BVOC fields can NOT be turned on when running with SLIM") + end if + + ! CARMA volumetric soil water from land + ! TODO: is the following correct - the CARMA field exchange is very confusing in mct + call shr_carma_readnl('drv_flds_in', carma_fields) + + ! export to atm + call fldlist_add(fldsFrLnd_num, fldsFrlnd, trim(flds_scalar_name)) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, 'Sl_lfrin') + if (send_to_atm) then + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_t ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_tref ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_qref ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_avsdr ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_anidr ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_avsdf ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_anidf ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_snowh ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_u10 ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_fv ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_ram1 ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Fall_taux ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Fall_tauy ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Fall_lat ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Fall_sen ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Fall_lwup ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Fall_evap ) + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Fall_swnet ) + ! dust fluxes from land (4 sizes) + call fldlist_add(fldsFrLnd_num, fldsFrLnd, Fall_flxdst, ungridded_lbound=1, ungridded_ubound=4) + if (carma_fields /= ' ') then + call fldlist_add(fldsFrLnd_num, fldsFrlnd, Sl_soilw) ! optional for carma + end if + end if + + call NUOPC_CompAttributeGet(gcomp, name="histaux_l2x1yrg", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Now advertise above export fields + do n = 1,fldsFrLnd_num + call NUOPC_Advertise(exportState, standardName=fldsFrLnd(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + + !-------------------------------- + ! Advertise import fields + !-------------------------------- + + call fldlist_add(fldsToLnd_num, fldsToLnd, trim(flds_scalar_name)) + + ! from atm + call fldlist_add(fldsToLnd_num, fldsToLnd, Sa_z ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sa_topo ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sa_u ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sa_v ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sa_ptem ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sa_pbot ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sa_tbot ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Sa_shum ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_lwdn ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_rainc ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_rainl ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_snowc ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_snowl ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_swndr ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_swvdr ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_swndf ) + call fldlist_add(fldsToLnd_num, fldsToLnd, Faxa_swvdf ) + + ! Now advertise import fields + do n = 1,fldsToLnd_num + call NUOPC_Advertise(importState, standardName=fldsToLnd(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + + end subroutine advertise_fields + + !=============================================================================== + subroutine realize_fields(importState, exportState, Emesh, flds_scalar_name, flds_scalar_num, rc) + + ! input/output variables + type(ESMF_State) , intent(inout) :: importState + type(ESMF_State) , intent(inout) :: exportState + type(ESMF_Mesh) , intent(in) :: Emesh + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + integer , intent(out) :: rc + + ! local variables + character(len=*), parameter :: subname='(lnd_import_export:realize_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call fldlist_realize( & + state=ExportState, & + fldList=fldsFrLnd, & + numflds=fldsFrLnd_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':clmExport',& + mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call fldlist_realize( & + state=importState, & + fldList=fldsToLnd, & + numflds=fldsToLnd_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':clmImport',& + mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine realize_fields + + !=============================================================================== + subroutine import_fields( gcomp, bounds, & + atm2lnd_inst, rc) + + !--------------------------------------------------------------------------- + ! Convert the input data from the mediator to the land model + !--------------------------------------------------------------------------- + + use clm_varcon , only: rair, o2_molar_const, c13ratio + use shr_const_mod , only: SHR_CONST_TKFRZ + use QSatMod , only: QSat + use lnd_import_export_utils , only: derive_quantities, check_for_errors + + ! input/output variabes + type(ESMF_GridComp) :: gcomp + type(bounds_type) , intent(in) :: bounds ! bounds + type(atm2lnd_type) , intent(inout) :: atm2lnd_inst ! clm internal input data type + integer , intent(out) :: rc + + ! local variables + type(ESMF_State) :: importState + type(ESMF_StateItem_Flag) :: itemFlag + real(r8), pointer :: dataPtr(:) + real(r8), pointer :: fldPtr1d(:) + real(r8), pointer :: fldPtr2d(:,:) + character(len=CS) :: fldname + integer :: num + integer :: begg, endg ! bounds + integer :: g,i,k,n ! indices + real(r8) :: qsat_kg_kg ! saturation specific humidity (kg/kg) + real(r8) :: forc_pbot ! atmospheric pressure (Pa) + real(r8) :: forc_rainc(bounds%begg:bounds%endg) ! rainxy Atm flux mm/s + real(r8) :: forc_rainl(bounds%begg:bounds%endg) ! rainxy Atm flux mm/s + real(r8) :: forc_snowc(bounds%begg:bounds%endg) ! snowfxy Atm flux mm/s + real(r8) :: forc_snowl(bounds%begg:bounds%endg) ! snowfxl Atm flux mm/s + real(r8) :: forc_noy(bounds%begg:bounds%endg) + real(r8) :: forc_nhx(bounds%begg:bounds%endg) + real(r8) :: frac_grc(bounds%begg:bounds%endg, 0:glc_nec) + real(r8) :: topo_grc(bounds%begg:bounds%endg, 0:glc_nec) + real(r8) :: hflx_grc(bounds%begg:bounds%endg, 0:glc_nec) + real(r8) :: icemask_grc(bounds%begg:bounds%endg) + real(r8) :: icemask_coupled_fluxes_grc(bounds%begg:bounds%endg) + character(len=*), parameter :: subname='(lnd_import_export:import_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + ! Get import state + call NUOPC_ModelGet(gcomp, importState=importState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Set bounds + begg = bounds%begg; endg=bounds%endg + + ! Note: precipitation fluxes received from the coupler + ! are in units of kg/s/m^2. To convert these precipitation rates + ! in units of mm/sec, one must divide by 1000 kg/m^3 and multiply + ! by 1000 mm/m resulting in an overall factor of unity. + ! Below the units are therefore given in mm/s. + + ! Required atm input fields + call state_getimport_1d(importState, Sa_z , atm2lnd_inst%forc_hgt_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Sa_topo , atm2lnd_inst%forc_topo_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Sa_u , atm2lnd_inst%forc_u_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Sa_v , atm2lnd_inst%forc_v_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Sa_shum , atm2lnd_inst%forc_q_not_downscaled_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Sa_ptem , atm2lnd_inst%forc_th_not_downscaled_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Sa_pbot , atm2lnd_inst%forc_pbot_not_downscaled_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Sa_tbot , atm2lnd_inst%forc_t_not_downscaled_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_rainc, forc_rainc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_rainl, forc_rainl(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_snowc, forc_snowc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_snowl, forc_snowl(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_lwdn , atm2lnd_inst%forc_lwrad_not_downscaled_grc(begg:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_swvdr, atm2lnd_inst%forc_solad_grc(begg:,1), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_swndr, atm2lnd_inst%forc_solad_grc(begg:,2), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_swvdf, atm2lnd_inst%forc_solai_grc(begg:,1), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport_1d(importState, Faxa_swndf, atm2lnd_inst%forc_solai_grc(begg:,2), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------- + ! Derived quantities for required fields + ! and corresponding error checks + !-------------------------- + + call derive_quantities(bounds, atm2lnd_inst, forc_rainc, forc_rainl, forc_snowc, forc_snowl) + + call check_for_errors(bounds, atm2lnd_inst ) + + end subroutine import_fields + + !=============================================================================== + subroutine export_fields( gcomp, bounds, lnd2atm_inst, rc) + + !------------------------------- + ! Pack the export state + ! sign convention is positive downward with hierarchy of atm/glc/lnd/rof/ice/ocn. + ! i.e. water sent from land to rof is positive + !------------------------------- + + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(bounds_type) , intent(in) :: bounds + type(lnd2atm_type) , intent(inout) :: lnd2atm_inst ! land to atmosphere exchange data type + integer , intent(out) :: rc + + ! local variables + type(ESMF_State) :: exportState + real(r8), pointer :: fldPtr1d(:) + real(r8), pointer :: fldPtr2d(:,:) + character(len=CS) :: fldname + integer :: begg, endg + integer :: i, g, num + real(r8) :: data1d(bounds%begg:bounds%endg) + character(len=*), parameter :: subname='(lnd_import_export:export_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Get export state + call NUOPC_ModelGet(gcomp, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Set bounds + begg = bounds%begg + endg = bounds%endg + + ! ----------------------- + ! output to mediator + ! ----------------------- + + call state_setexport_1d(exportState, Sl_lfrin, ldomain%frac(begg:), init_spval=.false., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! ----------------------- + ! output to atm + ! ----------------------- + + if (send_to_atm) then + call state_setexport_1d(exportState, Sl_t , lnd2atm_inst%t_rad_grc(begg:), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_snowh , lnd2atm_inst%h2osno_grc(begg:), & + init_spval=.false., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_avsdr , lnd2atm_inst%albd_grc(begg:,1), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_anidr , lnd2atm_inst%albd_grc(begg:,2), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_avsdf , lnd2atm_inst%albi_grc(begg:,1), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_anidf , lnd2atm_inst%albi_grc(begg:,2), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_tref , lnd2atm_inst%t_ref2m_grc(begg:), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_qref , lnd2atm_inst%q_ref2m_grc(begg:), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Fall_taux , lnd2atm_inst%taux_grc(begg:), & + init_spval=.true., minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Fall_tauy , lnd2atm_inst%tauy_grc(begg:), & + init_spval=.true., minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Fall_lat , lnd2atm_inst%eflx_lh_tot_grc(begg:), & + init_spval=.true., minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Fall_sen , lnd2atm_inst%eflx_sh_tot_grc(begg:), & + init_spval=.true., minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Fall_lwup , lnd2atm_inst%eflx_lwrad_out_grc(begg:), & + init_spval=.true., minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Fall_evap , lnd2atm_inst%qflx_evap_tot_grc(begg:), & + init_spval=.true., minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Fall_swnet, lnd2atm_inst%fsa_grc(begg:), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! optional fields + call state_setexport_2d(exportState, Fall_flxdst, lnd2atm_inst%flxdst_grc(begg:,1:4), & + init_spval=.true., minus= .true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_u10, lnd2atm_inst%u_ref10m_grc(begg:), & + init_spval=.false., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_ram1, lnd2atm_inst%ram1_grc(begg:), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport_1d(exportState, Sl_fv, lnd2atm_inst%fv_grc(begg:), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (fldchk(exportState, Sl_soilw)) then + call state_setexport_1d(exportState, Sl_soilw, lnd2atm_inst%h2osoi_vol_grc(begg:,1), & + init_spval=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + endif + + end subroutine export_fields + + !=============================================================================== + subroutine fldlist_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound) + + ! input/output variables + integer, intent(inout) :: num + type(fld_list_type), intent(inout) :: fldlist(:) + character(len=*), intent(in) :: stdname + integer, optional, intent(in) :: ungridded_lbound + integer, optional, intent(in) :: ungridded_ubound + + ! local variables + integer :: rc + character(len=*), parameter :: subname='(lnd_import_export:fldlist_add)' + !------------------------------------------------------------------------------- + + ! Set up a list of field information + + num = num + 1 + if (num > fldsMax) then + call ESMF_LogWrite(trim(subname)//": ERROR num > fldsMax "//trim(stdname), & + ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) + call shr_sys_abort(trim(subname)//": ERROR: num > fldsMax") + endif + fldlist(num)%stdname = trim(stdname) + + if (present(ungridded_lbound) .and. present(ungridded_ubound)) then + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound + end if + + end subroutine fldlist_add + + !=============================================================================== + subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scalar_num, mesh, tag, rc) + + use NUOPC , only : NUOPC_IsConnected, NUOPC_Realize + use ESMF , only : ESMF_MeshLoc_Element, ESMF_FieldCreate, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_MAXSTR, ESMF_Field, ESMF_State, ESMF_Mesh, ESMF_StateRemove + use ESMF , only : ESMF_LogFoundError, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LOGERR_PASSTHRU + + ! input/output variables + type(ESMF_State) , intent(inout) :: state + type(fld_list_type) , intent(in) :: fldList(:) + integer , intent(in) :: numflds + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + character(len=*) , intent(in) :: tag + type(ESMF_Mesh) , intent(in) :: mesh + integer , intent(inout) :: rc + + ! local variables + integer :: n + type(ESMF_Field) :: field + character(len=80) :: stdname + character(len=*),parameter :: subname='(lnd_import_export:fldlist_realize)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + do n = 1, numflds + stdname = fldList(n)%stdname + if (NUOPC_IsConnected(state, fieldName=stdname)) then + if (stdname == trim(flds_scalar_name)) then + call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected on root pe", & + ESMF_LOGMSG_INFO) + ! Create the scalar field + call SetScalarField(field, flds_scalar_name, flds_scalar_num, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + ! Create the field + if (fldlist(n)%ungridded_lbound > 0 .and. fldlist(n)%ungridded_ubound > 0) then + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & + ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & + gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected using mesh", & + ESMF_LOGMSG_INFO) + endif + + ! NOW call NUOPC_Realize + call NUOPC_Realize(state, field=field, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + if (stdname /= trim(flds_scalar_name)) then + call ESMF_LogWrite(subname // trim(tag) // " Field = "// trim(stdname) // " is not connected.", & + ESMF_LOGMSG_INFO) + call ESMF_StateRemove(state, (/stdname/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + end do + + contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + subroutine SetScalarField(field, flds_scalar_name, flds_scalar_num, rc) + ! ---------------------------------------------- + ! create a field with scalar data on the root pe + ! ---------------------------------------------- + use ESMF, only : ESMF_Field, ESMF_DistGrid, ESMF_Grid + use ESMF, only : ESMF_DistGridCreate, ESMF_GridCreate, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU + use ESMF, only : ESMF_FieldCreate, ESMF_GridCreate, ESMF_TYPEKIND_R8 + + type(ESMF_Field) , intent(inout) :: field + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + integer , intent(inout) :: rc + + ! local variables + type(ESMF_Distgrid) :: distgrid + type(ESMF_Grid) :: grid + character(len=*), parameter :: subname='(lnd_import_export:SetScalarField)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + ! create a DistGrid with a single index space element, which gets mapped onto DE 0. + distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + grid = ESMF_GridCreate(distgrid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + field = ESMF_FieldCreate(name=trim(flds_scalar_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), ungriddedUBound=(/flds_scalar_num/), gridToFieldMap=(/2/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + end subroutine SetScalarField + + end subroutine fldlist_realize + + !=============================================================================== + subroutine state_getimport_1d(state, fldname, ctsmdata, rc) + + ! fill in ctsm import data for 1d field + + use ESMF, only : ESMF_LOGERR_PASSTHRU, ESMF_END_ABORT, ESMF_LogFoundError + use ESMF, only : ESMF_Finalize + + ! input/output variabes + type(ESMF_State) , intent(in) :: state + character(len=*) , intent(in) :: fldname + real(r8) , intent(inout) :: ctsmdata(:) + integer , intent(out) :: rc + + ! local variables + real(r8), pointer :: fldPtr1d(:) + integer :: g + character(len=*), parameter :: subname='(lnd_import_export:state_getimport_1d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call state_getfldptr(State, trim(fldname), fldptr1d=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do g = 1,size(ctsmdata) + ctsmdata(g) = fldptr1d(g) + end do + call check_for_nans(ctsmdata, trim(fldname), 1) + + end subroutine state_getimport_1d + + !=============================================================================== + subroutine state_getimport_2d(state, fldname, ctsmdata, rc) + + ! fill in ctsm import data for 2d field + + use ESMF, only : ESMF_LOGERR_PASSTHRU, ESMF_END_ABORT, ESMF_LogFoundError + use ESMF, only : ESMF_Finalize + + ! input/output variabes + type(ESMF_State) , intent(in) :: state + character(len=*) , intent(in) :: fldname + real(r8) , intent(inout) :: ctsmdata(:,:) + integer , intent(out) :: rc + + ! local variables + real(r8), pointer :: fldPtr2d(:,:) + integer :: g,n + character(len=CS) :: cnum + character(len=*), parameter :: subname='(lnd_import_export:state_getimport_1d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call state_getfldptr(state, trim(fldname), fldptr2d=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 1,size(ctsmdata, dim=2) + write(cnum,'(i0)') n + do g = 1,size(ctsmdata,dim=1) + ctsmdata(g,n) = fldptr2d(n,g) + end do + call check_for_nans(ctsmdata(:,n), trim(fldname)//trim(cnum), 1) + end do + + end subroutine state_getimport_2d + + !=============================================================================== + subroutine state_setexport_1d(state, fldname, ctsmdata, init_spval, minus, rc) + + ! fill in ctsm export data for 1d field + + use ESMF , only : ESMF_LOGERR_PASSTHRU, ESMF_END_ABORT, ESMF_LogFoundError + use ESMF , only : ESMF_Finalize + use shr_const_mod , only : shr_const_spval + + ! input/output variabes + type(ESMF_State) , intent(in) :: state + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: ctsmdata(:) + logical , intent(in) :: init_spval + logical, optional, intent(in) :: minus + integer , intent(out):: rc + + ! local variables + logical :: l_minus ! local version of minus + real(r8), pointer :: fldPtr1d(:) + integer :: g + character(len=*), parameter :: subname='(lnd_export_export:state_setexport_1d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + if (present(minus)) then + l_minus = minus + else + l_minus = .false. + end if + + call state_getfldptr(state, trim(fldname), fldptr1d=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (init_spval) then + fldptr1d(:) = shr_const_spval + else + fldptr1d(:) = 0._r8 + end if + if (l_minus) then + do g = 1,size(ctsmdata) + fldptr1d(g) = -ctsmdata(g) + end do + else + do g = 1,size(ctsmdata) + fldptr1d(g) = ctsmdata(g) + end do + end if + call check_for_nans(ctsmdata, trim(fldname), 1) + + end subroutine state_setexport_1d + + !=============================================================================== + subroutine state_setexport_2d(state, fldname, ctsmdata, init_spval, minus, rc) + + ! fill in ctsm export data for 2d field + + use ESMF , only : ESMF_LOGERR_PASSTHRU, ESMF_END_ABORT, ESMF_LogFoundError + use ESMF , only : ESMF_Finalize + use shr_const_mod , only : shr_const_spval + + ! input/output variabes + type(ESMF_State) , intent(in) :: state + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: ctsmdata(:,:) + logical, intent(in) :: init_spval + logical, optional, intent(in) :: minus + integer , intent(out):: rc + + ! local variables + logical :: l_minus ! local version of minus + real(r8), pointer :: fldPtr2d(:,:) + integer :: g, n + character(len=CS) :: cnum + character(len=*), parameter :: subname='(lnd_export_export:state_setexport_2d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + if (present(minus)) then + l_minus = minus + else + l_minus = .false. + end if + + call state_getfldptr(state, trim(fldname), fldptr2d=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (init_spval) then + fldptr2d(:,:) = shr_const_spval + else + fldptr2d(:,:) = 0._r8 + end if + do n = 1,size(ctsmdata, dim=2) + write(cnum,'(i0)') n + if (l_minus) then + do g = 1,size(ctsmdata, dim=1) + fldptr2d(n,g) = -ctsmdata(g,n) + end do + else + do g = 1,size(ctsmdata, dim=1) + fldptr2d(n,g) = ctsmdata(g,n) + end do + end if + call check_for_nans(ctsmdata(:,n), trim(fldname)//trim(cnum), 1) + end do + + end subroutine state_setexport_2d + + !=============================================================================== + subroutine state_getfldptr(State, fldname, fldptr1d, fldptr2d, rc) + + ! ---------------------------------------------- + ! Get pointer to a state field + ! ---------------------------------------------- + + use ESMF , only : ESMF_State, ESMF_Field, ESMF_Mesh, ESMF_FieldStatus_Flag + use ESMF , only : ESMF_StateGet, ESMF_FieldGet, ESMF_MeshGet + use ESMF , only : ESMF_FIELDSTATUS_COMPLETE, ESMF_FAILURE + + ! input/output variables + type(ESMF_State), intent(in) :: State + character(len=*), intent(in) :: fldname + real(R8), pointer, optional , intent(out) :: fldptr1d(:) + real(R8), pointer, optional , intent(out) :: fldptr2d(:,:) + integer, intent(out) :: rc + + ! local variables + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_Field) :: lfield + character(len=*), parameter :: subname='(lnd_import_export:state_getfldptr)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (present(fldptr1d)) then + call ESMF_FieldGet(lfield, farrayPtr=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else if (present(fldptr2d)) then + call ESMF_FieldGet(lfield, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort("either fldptr1d or fldptr2d must be an input argument") + end if + + end subroutine state_getfldptr + + !=============================================================================== + logical function fldchk(state, fldname) + ! ---------------------------------------------- + ! Determine if field with fldname is in the input state + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: fldname + + ! local variables + type(ESMF_StateItem_Flag) :: itemFlag + ! ---------------------------------------------- + call ESMF_StateGet(state, trim(fldname), itemFlag) + if (itemflag /= ESMF_STATEITEM_NOTFOUND) then + fldchk = .true. + else + fldchk = .false. + endif + end function fldchk + + !=============================================================================== + subroutine ReadCapNamelist( NLFilename ) + + ! ---------------------------------------------------- + ! Read in tne namelist for CTSM nuopc cap level items + ! ---------------------------------------------------- + use clm_nlUtilsMod , only : find_nlgroup_name + use shr_mpi_mod , only : shr_mpi_bcast + use spmdMod , only : mpicom + use abortutils , only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + ! !ARGUMENTS: + character(len=*), intent(IN) :: NLFilename ! Namelist filename + ! !LOCAL VARIABLES: + integer :: nu_nml ! unit for namelist file + integer :: nml_error ! namelist i/o error flag + character(*), parameter :: nml_name = "ctsm_nuopc_cap" ! MUST match with namelist name below + namelist /ctsm_nuopc_cap/ force_send_to_atm + + ! Read namelist + if (masterproc) then + open( newunit=nu_nml, file=trim(NLFilename), status='old', iostat=nml_error ) + call find_nlgroup_name(nu_nml, nml_name, status=nml_error) + if (nml_error == 0) then + read(nu_nml, nml=ctsm_nuopc_cap, iostat=nml_error) + if (nml_error /= 0) then + call endrun(msg='ERROR reading '//nml_name//' namelist'//errMsg(u_FILE_u, __LINE__)) + end if + end if + close(nu_nml) + endif + + ! Broadcast namelist to all processors + call shr_mpi_bcast(force_send_to_atm , mpicom) + + end subroutine ReadCapNamelist + +end module lnd_import_export diff --git a/src/cpl/nuopc/lnd_import_export_utils.F90 b/src/cpl/nuopc/lnd_import_export_utils.F90 new file mode 100644 index 00000000..b0d73f89 --- /dev/null +++ b/src/cpl/nuopc/lnd_import_export_utils.F90 @@ -0,0 +1,164 @@ +module lnd_import_export_utils + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : isnan => shr_infnan_isnan + use shr_sys_mod , only : shr_sys_abort + use clm_varctl , only : iulog + use decompmod , only : bounds_type + use atm2lndType , only : atm2lnd_type + + implicit none + private ! except + + public :: derive_quantities + public :: check_for_errors + public :: check_for_nans + +!============================================================================= +contains +!============================================================================= + + !=========================================================================== + + subroutine derive_quantities( bounds, atm2lnd_inst, forc_rainc, forc_rainl, forc_snowc, forc_snowl ) + + !------------------------------------------------------------------------- + ! Convert the input data from the mediator to the land model + !------------------------------------------------------------------------- + + use clm_varcon, only: rair, o2_molar_const + use QSatMod, only: QSat + + ! input/output variabes + type(bounds_type), intent(in) :: bounds ! bounds + type(atm2lnd_type), intent(inout) :: atm2lnd_inst ! SLIM internal input data type + real(r8), intent(in) :: forc_rainc(bounds%begg:bounds%endg) ! convective rain (mm/s) + real(r8), intent(in) :: forc_rainl(bounds%begg:bounds%endg) ! large scale rain (mm/s) + real(r8), intent(in) :: forc_snowc(bounds%begg:bounds%endg) ! convective snow (mm/s) + real(r8), intent(in) :: forc_snowl(bounds%begg:bounds%endg) ! large scale snow (mm/s) + + ! local variables + integer :: g ! indices + integer :: begg, endg ! bounds + real(r8) :: qsat_kg_kg ! saturation specific humidity (kg/kg) + real(r8) :: forc_t ! atmospheric temperature (Kelvin) + real(r8) :: forc_q ! atmospheric specific humidity (kg/kg) + real(r8) :: forc_pbot ! atmospheric pressure (Pa) + character(len=*), parameter :: subname='(cpl:utils:derive_quantities)' + + !------------------------------------------------------------------------- + + ! Set bounds + begg = bounds%begg; endg=bounds%endg + + !-------------------------- + ! Derived quantities + !-------------------------- + + do g = begg, endg + forc_t = atm2lnd_inst%forc_t_not_downscaled_grc(g) + forc_q = atm2lnd_inst%forc_q_not_downscaled_grc(g) + forc_pbot = atm2lnd_inst%forc_pbot_not_downscaled_grc(g) + + atm2lnd_inst%forc_hgt_u_grc(g) = atm2lnd_inst%forc_hgt_grc(g) !observational height of wind [m] + atm2lnd_inst%forc_hgt_t_grc(g) = atm2lnd_inst%forc_hgt_grc(g) !observational height of temperature [m] + atm2lnd_inst%forc_hgt_q_grc(g) = atm2lnd_inst%forc_hgt_grc(g) !observational height of humidity [m] + + atm2lnd_inst%forc_vp_grc(g) = forc_q * forc_pbot / (0.622_r8 + 0.378_r8 * forc_q) + + atm2lnd_inst%forc_rho_not_downscaled_grc(g) = & + (forc_pbot - 0.378_r8 * atm2lnd_inst%forc_vp_grc(g)) / (rair * forc_t) + + atm2lnd_inst%forc_po2_grc(g) = o2_molar_const * forc_pbot + + atm2lnd_inst%forc_wind_grc(g) = sqrt(atm2lnd_inst%forc_u_grc(g)**2 + atm2lnd_inst%forc_v_grc(g)**2) + + atm2lnd_inst%forc_solar_grc(g) = atm2lnd_inst%forc_solad_grc(g,1) + atm2lnd_inst%forc_solai_grc(g,1) + & + atm2lnd_inst%forc_solad_grc(g,2) + atm2lnd_inst%forc_solai_grc(g,2) + + atm2lnd_inst%forc_rain_not_downscaled_grc(g) = forc_rainc(g) + forc_rainl(g) + atm2lnd_inst%forc_snow_not_downscaled_grc(g) = forc_snowc(g) + forc_snowl(g) + + call QSat(forc_t, forc_pbot, qsat_kg_kg) + + atm2lnd_inst%forc_rh_grc(g) = 100.0_r8*(forc_q / qsat_kg_kg) + end do + + end subroutine derive_quantities + + !=========================================================================== + + subroutine check_for_errors( bounds, atm2lnd_inst ) + + ! input/output variabes + type(bounds_type), intent(in) :: bounds ! bounds + type(atm2lnd_type), intent(inout) :: atm2lnd_inst ! SLIM internal input data type + + ! local variables + integer :: g ! indices + integer :: begg, endg ! bounds + character(len=*), parameter :: subname='(cpl:utils:check_for_errors)' + + !------------------------------------------------------------------------- + + ! Set bounds + begg = bounds%begg; endg=bounds%endg + + !-------------------------- + ! Error checks + !-------------------------- + + ! Check that solar, specific-humidity, and LW downward aren't negative + do g = begg, endg + if ( atm2lnd_inst%forc_lwrad_not_downscaled_grc(g) <= 0.0_r8 ) then + call shr_sys_abort( subname//& + ' ERROR: Longwave down sent from the atmosphere model is negative or zero' ) + end if + if ( (atm2lnd_inst%forc_solad_grc(g,1) < 0.0_r8) .or. & + (atm2lnd_inst%forc_solad_grc(g,2) < 0.0_r8) .or. & + (atm2lnd_inst%forc_solai_grc(g,1) < 0.0_r8) .or. & + (atm2lnd_inst%forc_solai_grc(g,2) < 0.0_r8) ) then + call shr_sys_abort( subname//& + ' ERROR: One of the solar fields (indirect/diffuse, vis or near-IR)'// & + ' from the atmosphere model is negative or zero' ) + end if + if ( atm2lnd_inst%forc_q_not_downscaled_grc(g) < 0.0_r8 )then + call shr_sys_abort( subname//& + ' ERROR: Bottom layer specific humidty sent from the atmosphere model is less than zero' ) + end if + end do + + ! Make sure relative humidity is properly bounded + ! atm2lnd_inst%forc_rh_grc(g) = min( 100.0_r8, atm2lnd_inst%forc_rh_grc(g) ) + ! atm2lnd_inst%forc_rh_grc(g) = max( 0.0_r8, atm2lnd_inst%forc_rh_grc(g) ) + + end subroutine check_for_errors + + !============================================================================= + + subroutine check_for_nans(array, fname, begg) + + ! input/output variables + real(r8) , intent(in) :: array(:) + character(len=*) , intent(in) :: fname + integer , intent(in) :: begg + + ! local variables + integer :: i + !--------------------------------------------------------------------------- + + ! Check if any input from mediator or output to mediator is NaN + + if (any(isnan(array))) then + write(iulog,*) '# of NaNs = ', count(isnan(array)) + write(iulog,*) 'Which are NaNs = ', isnan(array) + do i = 1, size(array) + if (isnan(array(i))) then + write(iulog,*) "NaN found in field ", trim(fname), ' at gridcell index ',begg+i-1 + end if + end do + call shr_sys_abort(' ERROR: One or more of the output from SLIM to the coupler are NaN ' ) + end if + end subroutine check_for_nans + +end module lnd_import_export_utils diff --git a/src/cpl/nuopc/lnd_set_decomp_and_domain.F90 b/src/cpl/nuopc/lnd_set_decomp_and_domain.F90 new file mode 100644 index 00000000..0c1f6d0f --- /dev/null +++ b/src/cpl/nuopc/lnd_set_decomp_and_domain.F90 @@ -0,0 +1,927 @@ +module lnd_set_decomp_and_domain + + use ESMF , only : ESMF_VM, ESMF_Mesh, ESMF_DistGrid, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU + use ESMF , only : ESMF_Array, ESMF_ArrayCreate, ESMF_SUCCESS, ESMF_MeshCreate, ESMF_FILEFORMAT_ESMFMESH + use ESMF , only : ESMF_MeshGet, ESMF_DistGridGet, ESMF_Grid, ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate, ESMF_FieldDestroy + use ESMF , only : ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT, ESMF_VMAllReduce, ESMF_REDUCE_SUM + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : errMsg => shr_log_errMsg + use spmdMod , only : masterproc, mpicom + use clm_varctl , only : iulog, inst_suffix + use abortutils , only : endrun + + implicit none + private ! except + + ! Module public routines + public :: lnd_set_decomp_and_domain_from_readmesh + public :: lnd_set_mesh_for_single_column + public :: lnd_set_decomp_and_domain_for_single_column + + ! Module private routines + private :: lnd_get_global_dims + private :: lnd_set_lndmask_from_maskmesh + private :: lnd_set_lndmask_from_lndmesh + private :: lnd_set_lndmask_from_fatmlndfrc + private :: lnd_set_ldomain_gridinfo_from_mesh + private :: chkerr + private :: pio_check_err + + character(len=*) , parameter :: u_FILE_u = & + __FILE__ + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine lnd_set_decomp_and_domain_from_readmesh(vm, meshfile_lnd, meshfile_mask, mesh_slim, & + ni, nj, rc) + + use decompInitMod , only : decompInit_lnd + use domainMod , only : ldomain, domain_init + use decompMod , only : gindex_global, bounds_type, get_proc_bounds + use ESMF , only : ESMF_DistGridCreate + + ! input/output variables + type(ESMF_VM) , intent(in) :: vm + character(len=*) , intent(in) :: meshfile_lnd + character(len=*) , intent(in) :: meshfile_mask + type(ESMF_Mesh) , intent(out) :: mesh_slim + integer , intent(out) :: ni,nj ! global grid dimensions + integer , intent(out) :: rc + + ! local variables + type(ESMF_Mesh) :: mesh_maskinput + type(ESMF_Mesh) :: mesh_lndinput + type(ESMF_DistGrid) :: distgrid_slim + integer :: g,n ! indices + integer :: nlnd, nocn ! local size of arrays + integer :: gsize ! global size of grid + logical :: isgrid2d ! true => grid is 2d + type(bounds_type) :: bounds ! bounds + integer :: begg,endg ! local bounds + integer , pointer :: gindex_lnd(:) ! global index space for just land points + integer , pointer :: gindex_ocn(:) ! global index space for just ocean points + integer , pointer :: gindex_slim(:) ! global index space for land and ocean points + integer , pointer :: lndmask_glob(:) + real(r8) , pointer :: lndfrac_glob(:) + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Write diag info + if (masterproc) then + write(iulog,*) + write(iulog,'(a)')' Input land mesh file '//trim(meshfile_lnd) + write(iulog,'(a)')' Input mask mesh file '//trim(meshfile_mask) + if (trim(meshfile_mask) /= trim(meshfile_lnd)) then + write(iulog, '(a)') ' Obtaining land mask and fraction from mask file '//trim(meshfile_mask) + else + write(iulog, '(a)') ' Obtaining land mask and fraction from land mesh file '//trim(meshfile_lnd) + end if + write(iulog,*) + end if + + ! Determine global 2d sizes from read of dimensions of surface dataset and allocate global memory + call lnd_get_global_dims(ni, nj, gsize, isgrid2d) + allocate(lndmask_glob(gsize)); lndmask_glob(:) = 0 + allocate(lndfrac_glob(gsize)); lndfrac_glob(:) = 0._r8 + + ! Read in the land mesh from the file + mesh_lndinput = ESMF_MeshCreate(filename=trim(meshfile_lnd), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Read in mask meshfile if needed + if (trim(meshfile_mask) /= trim(meshfile_lnd)) then + mesh_maskinput = ESMF_MeshCreate(filename=trim(meshfile_mask), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + ! Determine lndmask_glob and lndfrac_glob + if (trim(meshfile_mask) /= trim(meshfile_lnd)) then + ! obain land mask and land fraction by mapping ocean mesh conservatively to land mesh + call lnd_set_lndmask_from_maskmesh(mesh_lndinput, mesh_maskinput, vm, gsize, lndmask_glob, lndfrac_glob, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + ! obtain land mask from land mesh file - assume that land frac is identical to land mask + call lnd_set_lndmask_from_lndmesh(mesh_lndinput, vm, gsize, lndmask_glob, lndfrac_glob, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + ! Determine lnd decomposition that will be used by slim from lndmask_glob + call decompInit_lnd(lni=ni, lnj=nj, amask=lndmask_glob) + + ! Determine ocn decomposition that will be used to create the full mesh + ! note that the memory for gindex_ocn will be allocated in the following call + ! but deallocated at the end of this routine + call decompInit_ocn(ni=ni, nj=nj, amask=lndmask_glob, gindex_ocn=gindex_ocn) + + ! Get JUST gridcell processor bounds + ! Remaining bounds (landunits, columns, patches) will be set after calling decompInit_glcp + ! so get_proc_bounds is called twice and the gridcell information is just filled in twice + call get_proc_bounds(bounds) + begg = bounds%begg + endg = bounds%endg + + ! Create slim gindex_lnd + nlnd = endg - begg + 1 + allocate(gindex_lnd(nlnd)) + do g = begg, endg + n = 1 + (g - begg) + gindex_lnd(n) = gindex_global(g-begg+1) + end do + + ! Initialize domain data structure + call domain_init(domain=ldomain, isgrid2d=isgrid2d, ni=ni, nj=nj, nbeg=begg, nend=endg) + + ! Determine ldomain%mask and ldomain%frac using slim decomposition + do g = begg, endg + n = 1 + (g - begg) + ldomain%mask(g) = lndmask_glob(gindex_lnd(n)) + ldomain%frac(g) = lndfrac_glob(gindex_lnd(n)) + end do + + ! Deallocate global pointer memory + deallocate(lndmask_glob) + deallocate(lndfrac_glob) + + ! Generate a slim global index that includes both land and ocean points + nocn = size(gindex_ocn) + allocate(gindex_slim(nlnd + nocn)) + do n = 1,nlnd+nocn + if (n <= nlnd) then + gindex_slim(n) = gindex_lnd(n) + else + gindex_slim(n) = gindex_ocn(n-nlnd) + end if + end do + + ! Generate a new mesh on the gindex decomposition + distGrid_slim = ESMF_DistGridCreate(arbSeqIndexList=gindex_slim, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + mesh_slim = ESMF_MeshCreate(mesh_lndinput, elementDistGrid=distgrid_slim, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Set ldomain%lonc, ldomain%latc and ldomain%area + call lnd_set_ldomain_gridinfo_from_mesh(mesh_slim, vm, gindex_slim, begg, endg, isgrid2d, ni, nj, ldomain, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Deallocate local pointer memory + deallocate(gindex_lnd) + deallocate(gindex_ocn) + deallocate(gindex_slim) + + end subroutine lnd_set_decomp_and_domain_from_readmesh + + !=============================================================================== + subroutine lnd_set_mesh_for_single_column(scol_lon, scol_lat, mesh, rc) + + ! Generate a mesh for single column + use clm_varcon, only : spval + use ESMF , only : ESMF_Grid, ESMF_GridCreateNoPeriDimUfrm, ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER + + ! input/output variables + real(r8) , intent(in) :: scol_lon + real(r8) , intent(in) :: scol_lat + type(ESMF_Mesh) , intent(out) :: mesh + integer , intent(out) :: rc + + ! local variables + type(ESMF_Grid) :: lgrid + integer :: maxIndex(2) + real(r8) :: mincornerCoord(2) + real(r8) :: maxcornerCoord(2) + character(len=*), parameter :: subname= ' (lnd_set_mesh_for_single_column) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Use center and come up with arbitrary area delta lon and lat = .1 degree + maxIndex(1) = 1 ! number of lons + maxIndex(2) = 1 ! number of lats + mincornerCoord(1) = scol_lon - .1_r8 ! min lon + mincornerCoord(2) = scol_lat - .1_r8 ! min lat + maxcornerCoord(1) = scol_lon + .1_r8 ! max lon + maxcornerCoord(2) = scol_lat + .1_r8 ! max lat + ! create the ESMF grid + lgrid = ESMF_GridCreateNoPeriDimUfrm (maxindex=maxindex, & + mincornercoord=mincornercoord, maxcornercoord= maxcornercoord, & + staggerloclist=(/ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! create the mesh from the lgrid + mesh = ESMF_MeshCreate(lgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine lnd_set_mesh_for_single_column + + !=============================================================================== + subroutine lnd_set_decomp_and_domain_for_single_column(scol_lon, scol_lat, scol_mask, scol_frac) + + use decompInitMod , only : decompInit_lnd + use decompMod , only : bounds_type, get_proc_bounds + use domainMod , only : ldomain, domain_init + use clm_varcon , only : spval + + ! input/output variables + real(r8) , intent(in) :: scol_lon + real(r8) , intent(in) :: scol_lat + integer , intent(in) :: scol_mask + real(r8) , intent(in) :: scol_frac + + ! local variables + type(bounds_type) :: bounds ! bounds + !------------------------------------------------------------------------------- + + ! Determine decomp and ldomain + call decompInit_lnd(lni=1, lnj=1, amask=(/1/)) + + ! Initialize processor bounds + call get_proc_bounds(bounds) + + ! Initialize domain data structure + call domain_init(domain=ldomain, isgrid2d=.false., ni=1, nj=1, nbeg=1, nend=1) + + ! Initialize ldomain attributes + ldomain%lonc(1) = scol_lon + ldomain%latc(1) = scol_lat + ldomain%area(1) = spval + ldomain%mask(1) = scol_mask + ldomain%frac(1) = scol_frac + + end subroutine lnd_set_decomp_and_domain_for_single_column + + !=============================================================================== + subroutine lnd_get_global_dims(ni, nj, gsize, isgrid2d) + + ! Determine global 2d sizes from read of dimensions of surface dataset + ! + ! Meshes do not indicate if the mesh can be represented as a logically rectangular + ! grid. However, SLIM needs this information in the history file generation via the + ! logical variable isgrid2d. + + use clm_varctl , only : fsurdat, single_column + use fileutils , only : getfil + use ncdio_pio , only : ncd_io, file_desc_t, ncd_pio_openfile, ncd_pio_closefile, ncd_inqdlen, ncd_inqdid + + ! input/output variables + integer, intent(out) :: ni + integer, intent(out) :: nj + integer, intent(out) :: gsize + logical, intent(out) :: isgrid2d + + ! local variables + character(len=CL) :: locfn + type(file_desc_t) :: ncid ! netcdf file id + integer :: dimid ! netCDF dimension id + logical :: readvar ! read variable in or not + logical :: dim_exists + logical :: dim_found = .false. + !------------------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) 'Attempting to read global dimensions from surface dataset' + if (fsurdat == ' ') then + write(iulog,*)'fsurdat must be specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + endif + call getfil(fsurdat, locfn, 0 ) + call ncd_pio_openfile (ncid, trim(locfn), 0) + dim_found = .false. + call ncd_inqdid(ncid, 'lsmlon', dimid, dim_exists) + if ( dim_exists ) then + dim_found = .true. + call ncd_inqdlen(ncid, dimid, ni, 'lsmlon') + call ncd_inqdlen(ncid, dimid, nj, 'lsmlat') + end if + if (.not. dim_found) then + call ncd_inqdid(ncid, 'gridcell', dimid, dim_exists) + if ( dim_exists ) then + dim_found = .true. + call ncd_inqdlen(ncid, dimid, ni, 'gridcell') + nj = 1 + end if + end if + if (.not. dim_found) then + call shr_sys_abort('ERROR: surface dataset does not contain dims of lsmlon,lsmlat or gridcell') + end if + call ncd_pio_closefile(ncid) + gsize = ni*nj + if (single_column) then + isgrid2d = .true. + else if (nj == 1) then + isgrid2d = .false. + else + isgrid2d = .true. + end if + if (masterproc) then + write(iulog,'(a,2(i8,2x))') 'global ni,nj = ',ni,nj + if (isgrid2d) then + write(iulog,'(a)') 'model grid is 2-dimensional' + else + write(iulog,'(a)') 'model grid is not 2-dimensional' + end if + end if + + end subroutine lnd_get_global_dims + + !=============================================================================== + subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask_glob, lndfrac_glob, rc) + + ! If the landfrac/landmask file does not exists then determine the + ! land fraction and land mask on the land grid by mapping the mask + ! from the mesh_mask to the mesh_lnd mesh. Then write out the + ! landfrac/landmesh file. If the landfrac/landmask file does + ! exist then simply read in the global land fraction and land mask + ! from the file + + ! Uses: + use ESMF , only : ESMF_RouteHandle, ESMF_FieldRegridStore, ESMF_FieldRegrid + use ESMF , only : ESMF_REGRIDMETHOD_CONSERVE, ESMF_NORMTYPE_DSTAREA, ESMF_UNMAPPEDACTION_IGNORE + use ESMF , only : ESMF_TERMORDER_SRCSEQ, ESMF_REGION_TOTAL + + + ! input/out variables + type(ESMF_Mesh) , intent(in) :: mesh_lnd + type(ESMF_Mesh) , intent(in) :: mesh_mask + type(ESMF_VM) , intent(in) :: vm + integer , intent(in) :: gsize + integer , pointer :: lndmask_glob(:) + real(r8) , pointer :: lndfrac_glob(:) + integer , intent(out) :: rc + + ! local variables: + type(ESMF_DistGrid) :: distgrid_lnd + type(ESMF_RouteHandle) :: rhandle_mask2lnd + type(ESMF_Field) :: field_lnd + type(ESMF_Field) :: field_mask + type(ESMF_DistGrid) :: distgrid_mask + integer , pointer :: gindex_input(:) ! global index space for land and ocean points + integer , pointer :: lndmask_loc(:) + integer , pointer :: itemp_glob(:) + real(r8) , pointer :: rtemp_glob(:) + real(r8) , pointer :: lndfrac_loc(:) + real(r8) , pointer :: maskmask_loc(:) ! on ocean mesh + real(r8) , pointer :: maskfrac_loc(:) ! on land mesh + real(r8) , pointer :: dataptr1d(:) + type(ESMF_Array) :: elemMaskArray + integer :: lsize_lnd + integer :: lsize_mask + integer :: n, spatialDim + integer :: srcMaskValue = 0 + integer :: dstMaskValue = -987987 ! spval for RH mask values + integer :: srcTermProcessing_Value = 0 + integer :: klen + real(r8) :: fminval = 0.001_r8 + real(r8) :: fmaxval = 1._r8 + logical :: lexist + logical :: checkflag = .false. + character(len=CL) :: flandfrac + character(len=CL) :: flandfrac_status + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + flandfrac = './init_generated_files/slim_landfrac'//trim(inst_suffix)//'.nc' + klen = len_trim(flandfrac) - 3 ! remove the .nc + flandfrac_status = flandfrac(1:klen)//'.status' + + ! Determine if lndfrac/lndmask file exists + inquire(file=trim(flandfrac), exist=lexist) + + if (lexist) then + + ! If file exists - read in lndmask and lndfrac + if (masterproc) then + write(iulog,*) + write(iulog,'(a)')' Reading in land fraction and land mask from '//trim(flandfrac) + end if + call lnd_set_read_write_landmask(trim(flandfrac), trim(flandfrac_status), .false., .true., & + lndmask_glob, lndfrac_glob, size(lndmask_glob)) + + else + + ! If file does not exist - compute lndmask and lndfrac and write to output file + if (masterproc) then + write(iulog,*) + write(iulog,'(a)')' Computing land fraction and land mask by mapping mask from mesh_mask file' + end if + call ESMF_MeshGet(mesh_lnd, spatialDim=spatialDim, numOwnedElements=lsize_lnd, & + elementDistGrid=distgrid_lnd, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(lndmask_loc(lsize_lnd)) + allocate(lndfrac_loc(lsize_lnd)) + + ! create fields on land and ocean meshes + field_lnd = ESMF_FieldCreate(mesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + field_mask = ESMF_FieldCreate(mesh_mask, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! create route handle to map ocean mask from mask mesh to land mesh + call ESMF_FieldRegridStore(field_mask, field_lnd, routehandle=rhandle_mask2lnd, & + srcMaskValues=(/srcMaskValue/), dstMaskValues=(/dstMaskValue/), & + regridmethod=ESMF_REGRIDMETHOD_CONSERVE, normType=ESMF_NORMTYPE_DSTAREA, & + srcTermProcessing=srcTermProcessing_Value, & + ignoreDegenerate=.true., unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! fill in values for field_mask with mask on mask mesh + call ESMF_MeshGet(mesh_mask, elementdistGrid=distgrid_mask, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_DistGridGet(distgrid_mask, localDe=0, elementCount=lsize_mask, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(maskmask_loc(lsize_mask)) + elemMaskArray = ESMF_ArrayCreate(distgrid_mask, maskmask_loc, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(mesh_mask, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field_mask, farrayptr=dataptr1d, rc=rc) + dataptr1d(:) = maskmask_loc(:) + + ! map mask mask to land mesh + call ESMF_FieldRegrid(field_mask, field_lnd, routehandle=rhandle_mask2lnd, & + termorderflag=ESMF_TERMORDER_SRCSEQ, checkflag=checkflag, zeroregion=ESMF_REGION_TOTAL, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MeshGet(mesh_lnd, spatialDim=spatialDim, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(maskfrac_loc(lsize_lnd)) + call ESMF_FieldGet(field_lnd, farrayptr=maskfrac_loc, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,lsize_lnd + lndfrac_loc(n) = 1._r8 - maskfrac_loc(n) + if (lndfrac_loc(n) > fmaxval) lndfrac_loc(n) = 1._r8 + if (lndfrac_loc(n) < fminval) lndfrac_loc(n) = 0._r8 + if (lndfrac_loc(n) /= 0._r8) then + lndmask_loc(n) = 1 + else + lndmask_loc(n) = 0 + end if + enddo + call ESMF_FieldDestroy(field_lnd) + call ESMF_FieldDestroy(field_mask) + + ! determine global landmask_glob - needed to determine the slim decomposition + ! land frac, lats, lons and areas will be done below + allocate(gindex_input(lsize_lnd)) + call ESMF_DistGridGet(distgrid_lnd, 0, seqIndexList=gindex_input, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,lsize_lnd + lndmask_glob(gindex_input(n)) = lndmask_loc(n) + end do + allocate(itemp_glob(gsize)) + call ESMF_VMAllReduce(vm, sendData=lndmask_glob, recvData=itemp_glob, count=gsize, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + lndmask_glob(:) = int(itemp_glob(:)) + deallocate(itemp_glob) + + ! Determine ldomain%frac using both input and slim decompositions + ! lndfrac_glob is filled using the input decomposition and + ! ldomin%frac is set using the slim decomposition + allocate(rtemp_glob(gsize)) + do n = 1,lsize_lnd + lndfrac_glob(gindex_input(n)) = lndfrac_loc(n) + end do + call ESMF_VMAllReduce(vm, sendData=lndfrac_glob, recvData=rtemp_glob, count=gsize, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + lndfrac_glob(:) = rtemp_glob(:) + deallocate(rtemp_glob) + + ! deallocate memory + deallocate(maskmask_loc) + deallocate(lndmask_loc) + deallocate(lndfrac_loc) + + call lnd_set_read_write_landmask(trim(flandfrac), trim(flandfrac_status), .true., .false., & + lndmask_glob, lndfrac_glob, size(lndmask_glob)) + + end if + + end subroutine lnd_set_lndmask_from_maskmesh + + !=============================================================================== + subroutine lnd_set_lndmask_from_lndmesh(mesh_lnd, vm, gsize, lndmask_glob, lndfrac_glob, rc) + + ! input/out variables + type(ESMF_Mesh) , intent(in) :: mesh_lnd + type(ESMF_VM) , intent(in) :: vm + integer , intent(in) :: gsize + integer , pointer :: lndmask_glob(:) + real(r8) , pointer :: lndfrac_glob(:) + integer , intent(out) :: rc + + ! local variables: + integer :: n + integer :: lsize + integer , pointer :: gindex(:) + integer , pointer :: lndmask_loc(:) + integer , pointer :: itemp_glob(:) + type(ESMF_DistGrid) :: distgrid + type(ESMF_Array) :: elemMaskArray + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Determine lsize and distgrid_lnd + call ESMF_MeshGet(mesh_lnd, elementdistGrid=distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_DistGridGet(distgrid, localDe=0, elementCount=lsize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine lndmask_loc + ! The call to ESMF_MeshGet fills in the values of lndmask_loc + allocate(lndmask_loc(lsize)) + elemMaskArray = ESMF_ArrayCreate(distgrid, lndmask_loc, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(mesh_lnd, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine global landmask_glob - needed to determine the slim decomposition + ! land frac, lats, lons and areas will be done below + allocate(gindex(lsize)) + allocate(itemp_glob(gsize)) + call ESMF_DistGridGet(distgrid, 0, seqIndexList=gindex, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,lsize + lndmask_glob(gindex(n)) = lndmask_loc(n) + end do + call ESMF_VMAllReduce(vm, sendData=lndmask_glob, recvData=itemp_glob, count=gsize, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + lndmask_glob(:) = int(itemp_glob(:)) + deallocate(itemp_glob) + deallocate(gindex) + deallocate(lndmask_loc) + + ! ASSUME that land fraction is identical to land mask in this case + lndfrac_glob(:) = lndmask_glob(:) + + end subroutine lnd_set_lndmask_from_lndmesh + + !=============================================================================== + subroutine lnd_set_lndmask_from_fatmlndfrc(mask, frac, ni, nj) + + ! Read the surface dataset grid related information + ! This is used to set the domain decomposition - so global data is read here + + use clm_varctl , only : fatmlndfrc + use fileutils , only : getfil + use ncdio_pio , only : ncd_io, ncd_pio_openfile, ncd_pio_closefile, ncd_inqfdims, file_desc_t + + ! input/output variables + integer , pointer :: mask(:) ! grid mask + real(r8) , pointer :: frac(:) ! grid fraction + integer , intent(out) :: ni, nj ! global grid sizes + + ! local variables + logical :: isgrid2d + integer :: dimid,varid ! netCDF id's + integer :: ns ! size of grid on file + integer :: n,i,j ! index + integer :: ier ! error status + type(file_desc_t) :: ncid ! netcdf id + character(len=256) :: varname ! variable name + character(len=256) :: locfn ! local file name + logical :: readvar ! read variable in or not + integer , allocatable :: idata2d(:,:) + real(r8), allocatable :: rdata2d(:,:) + integer :: unitn + character(len=32) :: subname = 'lnd_set_mask_from_fatmlndfrc' ! subroutine name + !----------------------------------------------------------------------- + + ! Open file + call getfil( fatmlndfrc, locfn, 0 ) + call ncd_pio_openfile (ncid, trim(locfn), 0) + + ! Determine dimensions and if grid file is 2d or 1d + call ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) + if (masterproc) then + write(iulog,*)'lat/lon grid flag (isgrid2d) is ',isgrid2d + end if + + if (isgrid2d) then + ! Grid is 2d + allocate(idata2d(ni,nj)) + idata2d(:,:) = 1 + call ncd_io(ncid=ncid, varname='mask', data=idata2d, flag='read', readvar=readvar) + if (readvar) then + do j = 1,nj + do i = 1,ni + n = (j-1)*ni + i + mask(n) = idata2d(i,j) + enddo + enddo + else + call endrun( msg=' ERROR: mask not on fatmlndfrc file'//errMsg(sourcefile, __LINE__)) + end if + deallocate(idata2d) + allocate(rdata2d(ni,nj)) + rdata2d(:,:) = 1._r8 + call ncd_io(ncid=ncid, varname='frac', data=rdata2d, flag='read', readvar=readvar) + if (readvar) then + do j = 1,nj + do i = 1,ni + n = (j-1)*ni + i + frac(n) = rdata2d(i,j) + enddo + enddo + else + call endrun( msg=' ERROR: mask not on fatmlndfrc file'//errMsg(sourcefile, __LINE__)) + end if + deallocate(rdata2d) + else + ! Grid is not 2d + call ncd_io(ncid=ncid, varname='mask', data=mask, flag='read', readvar=readvar) + if (.not. readvar) then + call endrun( msg=' ERROR: mask not on fatmlndfrc file'//errMsg(sourcefile, __LINE__)) + end if + call ncd_io(ncid=ncid, varname='frac', data=frac, flag='read', readvar=readvar) + if (.not. readvar) then + call endrun( msg=' ERROR: frac not on fatmlndfrc file'//errMsg(sourcefile, __LINE__)) + end if + end if + + ! Close file + call ncd_pio_closefile(ncid) + + end subroutine lnd_set_lndmask_from_fatmlndfrc + + !=============================================================================== + subroutine lnd_set_ldomain_gridinfo_from_mesh(mesh, vm, gindex, begg, endg, isgrid2d, ni, nj, ldomain, rc) + + use domainMod , only : domain_type, lon1d, lat1d + use clm_varcon , only : re + + use clm_varcon , only : grlnd + use fileutils , only : getfil + use ncdio_pio , only : ncd_io, file_desc_t, ncd_pio_openfile, ncd_pio_closefile + use ESMF , only : ESMF_FieldRegridGetArea + + ! input/output variables + type(ESMF_Mesh) , intent(in) :: mesh + type(ESMF_VM) , intent(in) :: vm + integer , intent(in) :: gindex(:) + integer , intent(in) :: begg,endg + logical , intent(in) :: isgrid2d + integer , intent(in) :: ni, nj + type(domain_type) , intent(inout) :: ldomain + integer , intent(out) :: rc + + ! local variables + integer :: g,n + integer :: gsize + integer :: numownedelements + real(r8) , pointer :: ownedElemCoords(:) + integer :: spatialDim + real(r8) , pointer :: dataptr1d(:) + real(r8) , pointer :: lndlats_glob(:) + real(r8) , pointer :: lndlons_glob(:) + real(r8) , pointer :: rtemp_glob(:) + type(ESMF_Field) :: areaField + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Determine ldoman%latc and ldomain%lonc + call ESMF_MeshGet(mesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(ownedElemCoords(spatialDim*numownedelements)) + call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do g = begg,endg + n = g - begg + 1 + ldomain%lonc(g) = ownedElemCoords(2*n-1) + if (ldomain%lonc(g) == 360._r8) ldomain%lonc(g) = 0._r8 ! TODO: why the difference? + ldomain%latc(g) = ownedElemCoords(2*n) + end do + + ! Create ldomain%area by querying the mesh on the slim decomposition + areaField = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridGetArea(areaField, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(areaField, farrayPtr=dataptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do g = begg, endg + ldomain%area(g) = dataptr1d(g-begg+1) * (re*re) + end do + call ESMF_FieldDestroy(areaField) + + ! If grid is 2d, determine lon1d and lat1d from mesh + if (isgrid2d) then + gsize = ni*nj + allocate(rtemp_glob(gsize)) + + ! Determine lon1d + allocate(lndlons_glob(gsize)) + lndlons_glob(:) = 0._r8 + do n = 1,numownedelements + if (ownedElemCoords(2*n-1) == 360._r8) then ! TODO: why is this needed? + lndlons_glob(gindex(n)) = 0._r8 + else + lndlons_glob(gindex(n)) = ownedElemCoords(2*n-1) + end if + end do + call ESMF_VMAllReduce(vm, sendData=lndlons_glob, recvData=rtemp_glob, count=gsize, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + deallocate(lndlons_glob) + allocate(lon1d(ni)) + do n = 1,ni + lon1d(n) = rtemp_glob(n) + end do + + ! Determine lat1d + allocate(lndlats_glob(gsize)) + lndlats_glob(:) = 0._r8 + do n = 1,numownedelements + lndlats_glob(gindex(n)) = ownedElemCoords(2*n) + end do + call ESMF_VMAllReduce(vm, sendData=lndlats_glob, recvData=rtemp_glob, count=gsize, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + deallocate(lndlats_glob) + allocate(lat1d(nj)) + do n = 1,nj + lat1d(n) = rtemp_glob((n-1)*ni + 1) + end do + deallocate(rtemp_glob) + end if + + end subroutine lnd_set_ldomain_gridinfo_from_mesh + + !=============================================================================== + subroutine pio_check_err(ierror, description) + use pio, only : PIO_NOERR + integer , intent(in) :: ierror + character(*), intent(in) :: description + if (ierror /= PIO_NOERR) then + write (*,'(6a)') 'ERROR ', trim(description) + call shr_sys_abort() + endif + end subroutine pio_check_err + + !=============================================================================== + logical function chkerr(rc, line, file) + integer , intent(in) :: rc + integer , intent(in) :: line + character(len=*) , intent(in) :: file + + integer :: lrc + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif + end function chkerr + + !=============================================================================== + subroutine lnd_set_read_write_landmask(flandfrac, flandfrac_status, write_file, read_file, & + lndmask_glob, lndfrac_glob, gsize) + + ! Write or read landfrac and landmask to file so that mapping does not have to be done each time + ! mapping the ocean mask to the land grid, it's possible that landfrac will be + + use ncdio_pio , only : ncd_io, file_desc_t, ncd_pio_openfile, ncd_pio_closefile + use ncdio_pio , only : ncd_defdim, ncd_defvar, ncd_enddef, ncd_inqdlen + use ncdio_pio , only : ncd_int, ncd_double, ncd_pio_createfile + + ! input/output variables + character(len=*) , intent(in) :: flandfrac + character(len=*) , intent(in) :: flandfrac_status + logical , intent(in) :: write_file + logical , intent(in) :: read_file + integer , pointer :: lndmask_glob(:) + real(r8) , pointer :: lndfrac_glob(:) + integer , intent(in) :: gsize + + ! local variables + type(file_desc_t) :: pioid ! netcdf file id + integer :: dimid + integer :: iun + integer :: ioe + integer :: ier + logical :: lexists + !------------------------------------------------------------------------------- + + if (write_file) then + + if (masterproc) then + write(iulog,*) + write(iulog,'(a)') 'lnd_set_decomp_and_domain: writing landmask and landfrac data to landfrac.nc' + write(iulog,*) + + ! Remove file if it exists + inquire(file=trim(flandfrac), exist=lexists) + if (lexists) then + open(unit=9876, file=flandfrac, status='old', iostat=ioe) + if (ioe == 0) then + close(9876, status='delete') + end if + end if + end if + call mpi_barrier(mpicom,ier) + + call ncd_pio_createfile(pioid, trim(flandfrac)) + call ncd_defdim (pioid, 'gridcell', gsize, dimid) + call ncd_defvar(ncid=pioid, varname='landmask', xtype=ncd_int , dim1name='gridcell') + call ncd_defvar(ncid=pioid, varname='landfrac', xtype=ncd_double, dim1name='gridcell') + call ncd_enddef(pioid) + call ncd_io(ncid=pioid, varname='landmask', data=lndmask_glob, flag='write') + call ncd_io(ncid=pioid, varname='landfrac', data=lndfrac_glob, flag='write') + call ncd_pio_closefile(pioid) + + call mpi_barrier(mpicom,ier) + if (masterproc) then + open (newunit=iun, file=flandfrac_status, status='unknown', iostat=ioe) + if (ioe /= 0) then + call endrun(msg='ERROR failed to open file '//trim(flandfrac_status)//errMsg(sourcefile, __LINE__)) + end if + write(iun,'(a)')'Successfully wrote out '//trim(flandfrac_status) + close(iun) + write(iulog,'(a)')' Successfully wrote land fraction/mask status file '//trim(flandfrac_status) + end if + + else if (read_file) then + + if (masterproc) then + write(iulog,*) + write(iulog,'(a)') 'lnd_set_decomp_and_domain: reading landmask and landfrac data from landfrac.nc' + write(iulog,*) + end if + inquire(file=trim(flandfrac_status), exist=lexists) + if (.not. lexists) then + ! To read the file first check that the status file exists + if (masterproc) then + write(iulog,'(a)')' failed to find file '//trim(flandfrac_status) + write(iulog,'(a)')' this indicates a problem in creating '//trim(flandfrac_status) + write(iulog,'(a)')' remove '//trim(flandfrac)//' and try again' + end if + call endrun() + else + call ncd_pio_openfile (pioid, trim(flandfrac), 0) + call ncd_io(ncid=pioid, varname='landmask', data=lndmask_glob, flag='read') + call ncd_io(ncid=pioid, varname='landfrac', data=lndfrac_glob, flag='read') + call ncd_pio_closefile(pioid) + end if + + end if + + end subroutine lnd_set_read_write_landmask + + !=============================================================================== + subroutine decompInit_ocn(ni, nj, amask, gindex_ocn) + + ! !DESCRIPTION: + ! calculate a decomposition of only ocn points (needed for the nuopc interface) + + ! !USES: + use spmdMod , only : npes, iam + + ! !ARGUMENTS: + integer , intent(in) :: amask(:) + integer , intent(in) :: ni,nj ! domain global size + integer , pointer, intent(out) :: gindex_ocn(:) ! this variable is allocated here, and is assumed to start unallocated + + ! !LOCAL VARIABLES: + integer :: n,i,j,nocn + integer :: nlnd_global + integer :: nocn_global + integer :: nocn_local + integer :: my_ocn_start, my_ocn_end + !------------------------------------------------------------------------------ + + ! count total land and ocean gridcells + nlnd_global = 0 + nocn_global = 0 + do n = 1,ni*nj + if (amask(n) == 1) then + nlnd_global = nlnd_global + 1 + else + nocn_global = nocn_global + 1 + endif + enddo + + ! create the a global index array for ocean points + nocn_local = nocn_global / npes + + my_ocn_start = nocn_local*iam + min(iam, mod(nocn_global, npes)) + 1 + if (iam < mod(nocn_global, npes)) then + nocn_local = nocn_local + 1 + end if + my_ocn_end = my_ocn_start + nocn_local - 1 + + allocate(gindex_ocn(nocn_local)) + nocn = 0 + do n = 1,ni*nj + if (amask(n) == 0) then + nocn = nocn + 1 + if (nocn >= my_ocn_start .and. nocn <= my_ocn_end) then + gindex_ocn(nocn - my_ocn_start + 1) = n + end if + end if + end do + end subroutine decompInit_ocn + +end module lnd_set_decomp_and_domain diff --git a/src/init_interp/initInterp.F90 b/src/init_interp/initInterp.F90 index e15b7303..e9264493 100644 --- a/src/init_interp/initInterp.F90 +++ b/src/init_interp/initInterp.F90 @@ -7,7 +7,7 @@ module initInterpMod #include "shr_assert.h" use initInterpBounds, only : interp_bounds_type - use initInterpMindist, only: set_mindist, subgrid_type, subgrid_special_indices_type + use initInterpMindist, only: set_mindist, subgrid_type use initInterp1dData, only : interp_1d_data use initInterp2dvar, only: interp_2dvar_type use initInterpMultilevelBase, only : interp_multilevel_type @@ -31,7 +31,6 @@ module initInterpMod ! Public methods - public :: initInterp_readnl ! Read namelist public :: initInterp ! Private methods @@ -44,16 +43,9 @@ module initInterpMod private :: interp_1d_double private :: interp_1d_int private :: interp_2d_double - private :: limit_snlsno ! Private data - character(len=8) :: created_glacier_mec_landunits - - ! If true, fill missing types with closest natural veg column (using bare soil for - ! patch-level variables) - logical :: init_interp_fill_missing_with_natveg - character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -61,62 +53,6 @@ module initInterpMod !======================================================================= - !----------------------------------------------------------------------- - subroutine initInterp_readnl(NLFilename) - ! - ! !DESCRIPTION: - ! Read the namelist for initInterp - ! - ! !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 = 'initInterp_readnl' - !----------------------------------------------------------------------- - - namelist /clm_initinterp_inparm/ & - init_interp_fill_missing_with_natveg - - ! Initialize options to default values, in case they are not specified in the namelist - init_interp_fill_missing_with_natveg = .false. - - if (masterproc) then - unitn = getavu() - write(iulog,*) 'Read in clm_initinterp_inparm namelist' - call opnfil (NLFilename, unitn, 'F') - call shr_nl_find_group_name(unitn, 'clm_initinterp_inparm', status=ierr) - if (ierr == 0) then - read(unitn, clm_initinterp_inparm, iostat=ierr) - if (ierr /= 0) then - call endrun(msg="ERROR reading clm_initinterp_inparm namelist"//errmsg(sourcefile, __LINE__)) - end if - else - call endrun(msg='ERROR Could not find clm_initinterp_inparm namelist'//errmsg(sourcefile, __LINE__)) - end if - call relavu( unitn ) - end if - - call shr_mpi_bcast (init_interp_fill_missing_with_natveg, mpicom) - - if (masterproc) then - write(iulog,*) ' ' - write(iulog,*) 'initInterp settings:' - write(iulog,nml=clm_initinterp_inparm) - write(iulog,*) ' ' - end if - - end subroutine initInterp_readnl - - subroutine initInterp (filei, fileo, bounds) !----------------------------------------------------------------------- @@ -156,18 +92,11 @@ subroutine initInterp (filei, fileo, bounds) integer :: ivalue integer :: spinup_state_i, spinup_state_o integer :: decomp_cascade_state_i, decomp_cascade_state_o - integer :: npftsi, ncolsi, nlunsi, ngrcsi - integer :: npftso, ncolso, nlunso, ngrcso - integer , pointer :: pftindx(:) - integer , pointer :: colindx(:) - integer , pointer :: lunindx(:) + integer :: ngrcsi + integer :: ngrcso integer , pointer :: grcindx(:) - logical , pointer :: pft_activei(:), pft_activeo(:) - logical , pointer :: col_activei(:), col_activeo(:) - logical , pointer :: lun_activei(:), lun_activeo(:) logical , pointer :: grc_activei(:), grc_activeo(:) integer , pointer :: sgridindex(:) - type(subgrid_special_indices_type) :: subgrid_special_indices type(interp_multilevel_container_type) :: interp_multilevel_container type(interp_2dvar_type) :: var2d_i, var2d_o ! holds metadata for 2-d variables !-------------------------------------------------------------------- @@ -188,16 +117,10 @@ subroutine initInterp (filei, fileo, bounds) ! Determine dimensions and error checks on dimensions ! -------------------------------------------- - call check_dim_subgrid(ncidi, ncido, dimname ='pft' , dimleni=npftsi, dimleno=npftso) - call check_dim_subgrid(ncidi, ncido, dimname ='column' , dimleni=ncolsi, dimleno=ncolso) - call check_dim_subgrid(ncidi, ncido, dimname ='landunit', dimleni=nlunsi, dimleno=nlunso) call check_dim_subgrid(ncidi, ncido, dimname ='gridcell', dimleni=ngrcsi, dimleno=ngrcso) if (masterproc) then write (iulog,*) 'input gridcells = ',ngrcsi,' output gridcells = ',ngrcso - write (iulog,*) 'input landuntis = ',nlunsi,' output landunits = ',nlunso - write (iulog,*) 'input columns = ',ncolsi,' output columns = ',ncolso - write (iulog,*) 'input pfts = ',npftsi,' output pfts = ',npftso end if ! NOTE(wjs, 2015-10-31) The inclusion of must_be_same in these checks essentially @@ -206,113 +129,23 @@ subroutine initInterp (filei, fileo, bounds) ! ensure that the dimension sizes match. So we may want to remove the must_be_same ! argument, and make check_dim_level purely informational, in order to remove this ! maintenance problem - or maybe even remove check_dim_level entirely. - call check_dim_level(ncidi, ncido, dimname='levsno' , must_be_same=.false.) - call check_dim_level(ncidi, ncido, dimname='levsno1', must_be_same=.false.) - call check_dim_level(ncidi, ncido, dimname='levcan' , must_be_same=.true.) - call check_dim_level(ncidi, ncido, dimname='levlak' , must_be_same=.true.) - call check_dim_level(ncidi, ncido, dimname='levtot' , must_be_same=.false.) call check_dim_level(ncidi, ncido, dimname='levgrnd', must_be_same=.false.) call check_dim_level(ncidi, ncido, dimname='numrad' , must_be_same=.true.) ! -------------------------------------------- - ! Determine input file global attributes that are needed + ! Find closest values for gridcells ! -------------------------------------------- - status = pio_get_att(ncidi, pio_global, & - 'ipft_not_vegetated', & - subgrid_special_indices%ipft_not_vegetated) - status = pio_get_att(ncidi, pio_global, & - 'icol_vegetated_or_bare_soil', & - subgrid_special_indices%icol_vegetated_or_bare_soil) - status = pio_get_att(ncidi, pio_global, & - 'ilun_vegetated_or_bare_soil', & - subgrid_special_indices%ilun_vegetated_or_bare_soil) - status = pio_get_att(ncidi, pio_global, & - 'ilun_crop', & - subgrid_special_indices%ilun_crop) - status = pio_get_att(ncidi, pio_global, & - 'ilun_landice_multiple_elevation_classes', & - subgrid_special_indices%ilun_landice_multiple_elevation_classes) - status = pio_get_att(ncidi, pio_global, & - 'created_glacier_mec_landunits', & - created_glacier_mec_landunits) - - if (masterproc) then - write(iulog,*)'ipft_not_vegetated = ' , & - subgrid_special_indices%ipft_not_vegetated - write(iulog,*)'icol_vegetated_or_bare_soil = ' , & - subgrid_special_indices%icol_vegetated_or_bare_soil - write(iulog,*)'ilun_vegetated_or_bare_soil = ' , & - subgrid_special_indices%ilun_vegetated_or_bare_soil - write(iulog,*)'ilun_crop = ' , & - subgrid_special_indices%ilun_crop - write(iulog,*)'ilun_landice_multiple_elevation_classes = ' , & - subgrid_special_indices%ilun_landice_multiple_elevation_classes - write(iulog,*)'create_glacier_mec_landunits = ', & - trim(created_glacier_mec_landunits) - end if + bounds_i = interp_bounds_type(begg = 1, endg = ngrcsi) - ! -------------------------------------------- - ! Find closest values for pfts, cols, landunits, gridcells - ! -------------------------------------------- + bounds_o = interp_bounds_type(begg = bounds%begg, endg = bounds%endg) - bounds_i = interp_bounds_type( & - begp = 1, endp = npftsi, & - begc = 1, endc = ncolsi, & - begl = 1, endl = nlunsi, & - begg = 1, endg = ngrcsi) - - bounds_o = interp_bounds_type( & - 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(pft_activei(bounds_i%get_begp():bounds_i%get_endp())) - allocate(col_activei(bounds_i%get_begc():bounds_i%get_endc())) - allocate(lun_activei(bounds_i%get_begl():bounds_i%get_endl())) allocate(grc_activei(bounds_i%get_begg():bounds_i%get_endg())) - allocate(pft_activeo(bounds_o%get_begp():bounds_o%get_endp())) - allocate(col_activeo(bounds_o%get_begc():bounds_o%get_endc())) - allocate(lun_activeo(bounds_o%get_begl():bounds_o%get_endl())) allocate(grc_activeo(bounds_o%get_begg():bounds_o%get_endg())) - allocate(pftindx(bounds_o%get_begp():bounds_o%get_endp())) - allocate(colindx(bounds_o%get_begc():bounds_o%get_endc())) - allocate(lunindx(bounds_o%get_begl():bounds_o%get_endl())) allocate(grcindx(bounds_o%get_begg():bounds_o%get_endg())) - ! For each output pft, find the input pft, pftindx, that is closest - - if (masterproc) then - write(iulog,*)'finding minimum distance for pfts' - end if - vec_dimname = 'pft' - call findMinDist(vec_dimname, bounds_i%get_begp(), bounds_i%get_endp(), & - bounds_o%get_begp(), bounds_o%get_endp(), ncidi, ncido, & - subgrid_special_indices, pft_activei, pft_activeo, pftindx ) - - ! For each output column, find the input column, colindx, that is closest - - if (masterproc) then - write(iulog,*)'finding minimum distance for columns' - end if - vec_dimname = 'column' - call findMinDist(vec_dimname, bounds_i%get_begc(), bounds_i%get_endc(), & - bounds_o%get_begc(), bounds_o%get_endc(), ncidi, ncido, & - subgrid_special_indices, col_activei, col_activeo, colindx ) - - ! For each output landunit, find the input landunit, lunindx, that is closest - - if (masterproc) then - write(iulog,*)'finding minimum distance for landunits' - end if - vec_dimname = 'landunit' - call findMinDist(vec_dimname, bounds_i%get_begl(), bounds_i%get_endl(), & - bounds_o%get_begl(), bounds_o%get_endl(), ncidi, ncido, & - subgrid_special_indices, lun_activei, lun_activeo, lunindx ) - ! For each output gridcell, find the input gridcell, grcindx, that is closest if (masterproc) then @@ -321,19 +154,18 @@ subroutine initInterp (filei, fileo, bounds) vec_dimname = 'gridcell' call findMinDist(vec_dimname, bounds_i%get_begg(), bounds_i%get_endg(), & bounds_o%get_begg(), bounds_o%get_endg(), ncidi, ncido, & - subgrid_special_indices, grc_activei, grc_activeo, grcindx) + grc_activei, grc_activeo, grcindx) ! ------------------------------------------------------------------------ ! Set up interpolators for multi-level variables ! ------------------------------------------------------------------------ - if (masterproc) then - write(iulog,*)'setting up interpolators for multi-level variables' - end if - interp_multilevel_container = interp_multilevel_container_type( & - ncid_source = ncidi, ncid_dest = ncido, & - bounds_source = bounds_i, bounds_dest = bounds_o, & - pftindex = pftindx, colindex = colindx) +! if (masterproc) then +! write(iulog,*)'setting up interpolators for multi-level variables' +! end if +! interp_multilevel_container = interp_multilevel_container_type( & +! ncid_source = ncidi, ncid_dest = ncido, & +! bounds_source = bounds_i, bounds_dest = bounds_o) !------------------------------------------------------------------------ ! Read input initial data and write output initial data @@ -502,13 +334,7 @@ subroutine initInterp (filei, fileo, bounds) endi = bounds_i%get_end(vec_dimname) bego = bounds_o%get_beg(vec_dimname) endo = bounds_o%get_end(vec_dimname) - if ( vec_dimname == 'pft' )then - sgridindex => pftindx - else if ( vec_dimname == 'column' )then - sgridindex => colindx - else if ( vec_dimname == 'landunit' )then - sgridindex => lunindx - else if ( vec_dimname == 'gridcell' )then + if ( vec_dimname == 'gridcell' )then sgridindex => grcindx else call endrun(msg='ERROR interpinic: 1D variable '//trim(varname)//& @@ -555,13 +381,7 @@ subroutine initInterp (filei, fileo, bounds) endi = bounds_i%get_end(vec_dimname) bego = bounds_o%get_beg(vec_dimname) endo = bounds_o%get_end(vec_dimname) - if ( vec_dimname == 'pft' )then - sgridindex => pftindx - else if ( vec_dimname == 'column' )then - sgridindex => colindx - else if ( vec_dimname == 'landunit' )then - sgridindex => lunindx - else if ( vec_dimname == 'gridcell' )then + if ( vec_dimname == 'gridcell' )then sgridindex => grcindx else call endrun(msg='ERROR interpinic: 2D variable with unknown subgrid dimension: '//& @@ -609,9 +429,6 @@ subroutine initInterp (filei, fileo, bounds) write(iulog,*) 'Cleaning up / adjusting variables' end if - call limit_snlsno(ncido, bounds_o) - - ! Close output file call pio_closefile(ncido) @@ -625,7 +442,7 @@ end subroutine initInterp !======================================================================= subroutine findMinDist( dimname, begi, endi, bego, endo, ncidi, ncido, & - subgrid_special_indices, activei, activeo, minindx) + activei, activeo, minindx) ! -------------------------------------------------------------------- ! @@ -637,7 +454,6 @@ subroutine findMinDist( dimname, begi, endi, bego, endo, ncidi, ncido, & integer , intent(in) :: bego, endo type(file_desc_t) , intent(inout) :: ncidi type(file_desc_t) , intent(inout) :: ncido - type(subgrid_special_indices_type), intent(in) :: subgrid_special_indices logical , intent(out) :: activei(begi:endi) logical , intent(out) :: activeo(bego:endo) integer , intent(out) :: minindx(bego:endo) @@ -663,7 +479,7 @@ subroutine findMinDist( dimname, begi, endi, bego, endo, ncidi, ncido, & write(iulog,*)'calling set_mindist for ',trim(dimname) end if call set_mindist(begi, endi, bego, endo, activei, activeo, subgridi, subgrido, & - subgrid_special_indices, init_interp_fill_missing_with_natveg, minindx) + minindx) deallocate(subgridi%lat, subgridi%lon, subgridi%coslat) deallocate(subgrido%lat, subgrido%lon, subgrido%coslat) @@ -693,53 +509,6 @@ subroutine set_subgrid_info(beg, end, dimname, use_glob, ncid, active, subgrid) allocate(itemp(beg:end)) allocate(subgrid%lat(beg:end), subgrid%lon(beg:end), subgrid%coslat(beg:end)) - if (dimname == 'pft') then - allocate(subgrid%ptype(beg:end), subgrid%ctype(beg:end), subgrid%ltype(beg:end)) - else if (dimname == 'column') then - allocate(subgrid%ctype(beg:end), subgrid%ltype(beg:end)) - else if (dimname == 'landunit') then - allocate(subgrid%ltype(beg:end)) - end if - - ! determine if is_glcmec from global attributes - if (trim(created_glacier_mec_landunits) == 'true') then - if (dimname == 'pft' .or. dimname == 'column') then - allocate(subgrid%topoglc(beg:end)) - end if - end if - - if (dimname == 'pft') then - call read_var_double(ncid=ncid, varname='pfts1d_lon' , data=subgrid%lon , dim1name='pft', use_glob=use_glob) - call read_var_double(ncid=ncid, varname='pfts1d_lat' , data=subgrid%lat , dim1name='pft', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='pfts1d_itypveg', data=subgrid%ptype, dim1name='pft', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='pfts1d_itypcol', data=subgrid%ctype, dim1name='pft', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='pfts1d_ityplun', data=subgrid%ltype, dim1name='pft', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='pfts1d_active' , data=itemp , dim1name='pft', use_glob=use_glob) - if (associated(subgrid%topoglc)) then - call read_var_double(ncid=ncid, varname='pfts1d_topoglc', data=subgrid%topoglc, dim1name='pft', use_glob=use_glob) - end if - else if (dimname == 'column') then - call read_var_double(ncid=ncid, varname='cols1d_lon' , data=subgrid%lon , dim1name='column', use_glob=use_glob) - call read_var_double(ncid=ncid, varname='cols1d_lat' , data=subgrid%lat , dim1name='column', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='cols1d_ityp' , data=subgrid%ctype, dim1name='column', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='cols1d_ityplun', data=subgrid%ltype, dim1name='column', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='cols1d_active' , data=itemp , dim1name='column', use_glob=use_glob) - if (associated(subgrid%topoglc)) then - call read_var_double(ncid=ncid, varname='cols1d_topoglc', data=subgrid%topoglc, dim1name='column', use_glob=use_glob) - end if - else if (dimname == 'landunit') then - call read_var_double(ncid=ncid, varname='land1d_lon' , data=subgrid%lon , dim1name='landunit', use_glob=use_glob) - call read_var_double(ncid=ncid, varname='land1d_lat' , data=subgrid%lat , dim1name='landunit', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='land1d_ityplun', data=subgrid%ltype, dim1name='landunit', use_glob=use_glob) - call read_var_int(ncid=ncid, varname='land1d_active' , data=itemp , dim1name='landunit', use_glob=use_glob) - else if (dimname == 'gridcell') then - call read_var_double(ncid=ncid, varname='grid1d_lon' , data=subgrid%lon , dim1name='gridcell', use_glob=use_glob) - call read_var_double(ncid=ncid, varname='grid1d_lat' , data=subgrid%lat , dim1name='gridcell', use_glob=use_glob) - - ! All gridcells in the restart file are active - itemp(beg:end) = 1 - end if - do n = beg,end if (itemp(n) > 0) then active(n) = .true. @@ -1067,66 +836,4 @@ subroutine check_dim_level(ncidi, ncido, dimname, must_be_same) end subroutine check_dim_level - !----------------------------------------------------------------------- - subroutine limit_snlsno(ncido, bounds_o) - ! - ! !DESCRIPTION: - ! Apply a limit to SNLSNO in the output file so that it doesn't exceed the number of - ! snow layers. - ! - ! This is needed if the output file has fewer snow layers than the input file. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(file_desc_t) , intent(inout) :: ncido - type(interp_bounds_type), intent(in) :: bounds_o - ! - ! !LOCAL VARIABLES: - character(len=16) :: vec_dimname - integer :: bego, endo - integer, pointer :: snlsno(:) - integer :: snlsno_dids(1) ! dimension ID - integer :: levsno_dimid - integer :: levsno - integer :: i - integer :: err_code - - character(len=*), parameter :: levsno_dimname = 'levsno' - character(len=*), parameter :: snlsno_varname = 'SNLSNO' - - character(len=*), parameter :: subname = 'limit_snlsno' - !----------------------------------------------------------------------- - - ! Determine levsno size - call ncd_inqdlen(ncid=ncido, dimid=levsno_dimid, len=levsno, name=levsno_dimname) - - ! Read SNLSNO - ! - ! TODO(wjs, 2015-11-01) This is a lot of code for simply reading in a 1-d variable. - ! It would be nice if there was a routine that did all of this for you, similarly to - ! what initInterp2dvar does for 2-d variables. - call ncd_inqvdname(ncid=ncido, varname=snlsno_varname, dimnum=1, dname=vec_dimname, & - err_code=err_code) - if (err_code /= 0) then - call endrun(subname//' ERROR getting vec_dimname') - end if - bego = bounds_o%get_beg(vec_dimname) - endo = bounds_o%get_end(vec_dimname) - allocate(snlsno(bego:endo)) - call ncd_io(ncid=ncido, varname=snlsno_varname, flag='read', data=snlsno, & - dim1name=trim(vec_dimname)) - - ! Limit SNLSNO - do i = bego, endo - ! Note that snlsno is negative - snlsno(i) = max(snlsno(i), -1*levsno) - end do - - ! Write out limited SNLSNO - call ncd_io(ncid=ncido, varname=snlsno_varname, flag='write', data=snlsno, & - dim1name=trim(vec_dimname)) - deallocate(snlsno) - end subroutine limit_snlsno - end module initInterpMod diff --git a/src/init_interp/initInterpBounds.F90 b/src/init_interp/initInterpBounds.F90 index ff3704e4..d48280be 100644 --- a/src/init_interp/initInterpBounds.F90 +++ b/src/init_interp/initInterpBounds.F90 @@ -18,21 +18,9 @@ module initInterpBounds type :: interp_bounds_type private - integer :: begp ! beginning patch-level index - integer :: endp ! ending patch-level index - integer :: begc ! beginning col-level index - integer :: endc ! ending col-level index - integer :: begl ! beginning landunit-level index - integer :: endl ! ending landunit-level index integer :: begg ! beginning gridcell-level index integer :: endg ! ending gridcell-level index contains - procedure :: get_begp - procedure :: get_endp - procedure :: get_begc - procedure :: get_endc - procedure :: get_begl - procedure :: get_endl procedure :: get_begg procedure :: get_endg procedure :: get_beg ! get beginning index for a given subgrid level @@ -53,7 +41,7 @@ module initInterpBounds ! ======================================================================== !----------------------------------------------------------------------- - function constructor(begp, endp, begc, endc, begl, endl, begg, endg) result(this) + function constructor(begg, endg) result(this) ! ! !DESCRIPTION: ! Create an interp_bounds_type instance @@ -62,9 +50,6 @@ function constructor(begp, endp, begc, endc, begl, endl, begg, endg) result(this ! ! !ARGUMENTS: type(interp_bounds_type) :: this ! function result - integer, intent(in) :: begp, endp - integer, intent(in) :: begc, endc - integer, intent(in) :: begl, endl integer, intent(in) :: begg, endg ! ! !LOCAL VARIABLES: @@ -72,12 +57,6 @@ function constructor(begp, endp, begc, endc, begl, endl, begg, endg) result(this character(len=*), parameter :: subname = 'constructor' !----------------------------------------------------------------------- - this%begp = begp - this%endp = endp - this%begc = begc - this%endc = endc - this%begl = begl - this%endl = endl this%begg = begg this%endg = endg @@ -87,36 +66,6 @@ end function constructor ! Public methods ! ======================================================================== - integer function get_begp(this) - class(interp_bounds_type), intent(in) :: this - get_begp = this%begp - end function get_begp - - integer function get_endp(this) - class(interp_bounds_type), intent(in) :: this - get_endp = this%endp - end function get_endp - - integer function get_begc(this) - class(interp_bounds_type), intent(in) :: this - get_begc = this%begc - end function get_begc - - integer function get_endc(this) - class(interp_bounds_type), intent(in) :: this - get_endc = this%endc - end function get_endc - - integer function get_begl(this) - class(interp_bounds_type), intent(in) :: this - get_begl = this%begl - end function get_begl - - integer function get_endl(this) - class(interp_bounds_type), intent(in) :: this - get_endl = this%endl - end function get_endl - integer function get_begg(this) class(interp_bounds_type), intent(in) :: this get_begg = this%begg @@ -138,7 +87,7 @@ function get_beg(this, subgrid_level) result(beg_index) ! !ARGUMENTS: integer :: beg_index ! function result class(interp_bounds_type), intent(in) :: this - character(len=*), intent(in) :: subgrid_level ! 'pft', 'column', 'landunit' or 'gridcell' + character(len=*), intent(in) :: subgrid_level ! 'gridcell' ! ! !LOCAL VARIABLES: @@ -146,12 +95,6 @@ function get_beg(this, subgrid_level) result(beg_index) !----------------------------------------------------------------------- select case (subgrid_level) - case('pft') - beg_index = this%begp - case('column') - beg_index = this%begc - case('landunit') - beg_index = this%begl case('gridcell') beg_index = this%begg case default @@ -172,7 +115,7 @@ function get_end(this, subgrid_level) result(end_index) ! !ARGUMENTS: integer :: end_index ! function result class(interp_bounds_type), intent(in) :: this - character(len=*), intent(in) :: subgrid_level ! 'pft', 'column', 'landunit' or 'gridcell' + character(len=*), intent(in) :: subgrid_level ! 'gridcell' ! ! !LOCAL VARIABLES: @@ -180,12 +123,6 @@ function get_end(this, subgrid_level) result(end_index) !----------------------------------------------------------------------- select case (subgrid_level) - case('pft') - end_index = this%endp - case('column') - end_index = this%endc - case('landunit') - end_index = this%endl case('gridcell') end_index = this%endg case default diff --git a/src/init_interp/initInterpMindist.F90 b/src/init_interp/initInterpMindist.F90 index 8e345a6a..663cd243 100644 --- a/src/init_interp/initInterpMindist.F90 +++ b/src/init_interp/initInterpMindist.F90 @@ -26,77 +26,25 @@ module initInterpMindist ! Public types - type, public :: subgrid_special_indices_type - integer :: ipft_not_vegetated - integer :: icol_vegetated_or_bare_soil - integer :: ilun_vegetated_or_bare_soil - integer :: ilun_crop - integer :: ilun_landice_multiple_elevation_classes - contains - procedure :: is_vegetated_landunit ! returns true if the given landunit type is natural veg or crop - end type subgrid_special_indices_type - type, public :: subgrid_type - character(len=16) :: name ! pft, column, landunit, gridcell - integer , pointer :: ptype(:) => null() ! used for patch type - integer , pointer :: ctype(:) => null() ! used for patch or col type - integer , pointer :: ltype(:) => null() ! used for pft, col or lun type + character(len=16) :: name ! gridcell real(r8), pointer :: topoglc(:) => null() real(r8), pointer :: lat(:) real(r8), pointer :: lon(:) real(r8), pointer :: coslat(:) - contains - procedure :: print_point ! print info about one point end type subgrid_type ! Private methods - private :: do_fill_missing_with_natveg private :: is_sametype - private :: is_baresoil character(len=*), parameter, private :: sourcefile = & __FILE__ contains - !----------------------------------------------------------------------- - subroutine print_point(this, index, unit) - ! - ! !DESCRIPTION: - ! Print info about one point in a subgrid_type object - ! - ! !USES: - ! - ! !ARGUMENTS: - class(subgrid_type), intent(in) :: this - integer , intent(in) :: index - integer , intent(in) :: unit ! unit to which we should write the info - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'print_point' - !----------------------------------------------------------------------- - - write(unit,*) 'subgrid level, index = ',& - this%name, index - if (associated(this%ltype)) then - write(unit,*) 'ltype: ', this%ltype(index) - end if - if (associated(this%ctype)) then - write(unit,*) 'ctype: ', this%ctype(index) - end if - if (associated(this%ptype)) then - write(unit,*) 'ptype: ', this%ptype(index) - end if - - end subroutine print_point - - - !======================================================================= - subroutine set_mindist(begi, endi, bego, endo, activei, activeo, subgridi, subgrido, & - subgrid_special_indices, fill_missing_with_natveg, mindist_index) + mindist_index) ! -------------------------------------------------------------------- ! arguments @@ -106,7 +54,6 @@ subroutine set_mindist(begi, endi, bego, endo, activei, activeo, subgridi, subgr logical , intent(in) :: activeo(bego:endo) type(subgrid_type) , intent(in) :: subgridi type(subgrid_type) , intent(in) :: subgrido - type(subgrid_special_indices_type), intent(in) :: subgrid_special_indices ! If false: if an output type cannot be found in the input, code aborts ! If true: if an output type cannot be found in the input, fill with closest natural @@ -115,7 +62,6 @@ subroutine set_mindist(begi, endi, bego, endo, activei, activeo, subgridi, subgr ! NOTE: always treated as true for natural veg and crop landunits/columns/patches in ! the output - e.g., if we can't find the right column type to fill crop, we always ! use the closest natural veg column, regardless of the value of this flag. - logical , intent(in) :: fill_missing_with_natveg integer , intent(out) :: mindist_index(bego:endo) ! @@ -146,7 +92,7 @@ subroutine set_mindist(begi, endi, bego, endo, activei, activeo, subgridi, subgr hgtdiffmin = spval do ni = begi,endi if (activei(ni)) then - if (is_sametype(ni, no, subgridi, subgrido, subgrid_special_indices)) then + if (is_sametype(ni, no, subgridi, subgrido)) then dy = abs(subgrido%lat(no)-subgridi%lat(ni))*re dx = abs(subgrido%lon(no)-subgridi%lon(ni))*re * & 0.5_r8*(subgrido%coslat(no)+subgridi%coslat(ni)) @@ -184,42 +130,6 @@ subroutine set_mindist(begi, endi, bego, endo, activei, activeo, subgridi, subgr end if end do - ! If output type is not contained in input dataset, then use closest bare soil, - ! if this point is one for which we fill missing with natveg. - if ( distmin == spval .and. & - do_fill_missing_with_natveg( & - fill_missing_with_natveg, no, subgrido, subgrid_special_indices)) then - do ni = begi, endi - if (activei(ni)) then - if ( is_baresoil(ni, subgridi, subgrid_special_indices)) then - dy = abs(subgrido%lat(no)-subgridi%lat(ni))*re - dx = abs(subgrido%lon(no)-subgridi%lon(ni))*re * & - 0.5_r8*(subgrido%coslat(no)+subgridi%coslat(ni)) - dist = dx*dx + dy*dy - if ( dist < distmin )then - distmin = dist - nmin = ni - end if - end if - end if - end do - end if - - ! Error conditions - if ( distmin == spval )then - write(iulog,*) 'ERROR initInterp set_mindist: & - &Cannot find any input points matching output point:' - call subgrido%print_point(no, iulog) - write(iulog,*) ' ' - write(iulog,*) 'Consider rerunning with the following in user_nl_clm:' - write(iulog,*) 'init_interp_fill_missing_with_natveg = .true.' - write(iulog,*) 'However, note that this will fill all missing types in the output' - write(iulog,*) 'with the closest natural veg column in the input' - write(iulog,*) '(using bare soil for patch-level variables).' - write(iulog,*) 'So, you should consider whether that is what you want.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - mindist_index(no) = nmin end if ! end if activeo block @@ -228,51 +138,9 @@ subroutine set_mindist(begi, endi, bego, endo, activei, activeo, subgridi, subgr end subroutine set_mindist - !----------------------------------------------------------------------- - function do_fill_missing_with_natveg(fill_missing_with_natveg, & - no, subgrido, subgrid_special_indices) - ! - ! !DESCRIPTION: - ! Returns true if the given output point, if missing, should be filled with the - ! closest natural veg point. - ! - ! !ARGUMENTS: - logical :: do_fill_missing_with_natveg ! function result - - ! whether we should fill ALL missing points with natveg - logical, intent(in) :: fill_missing_with_natveg - - integer , intent(in) :: no - type(subgrid_type), intent(in) :: subgrido - type(subgrid_special_indices_type), intent(in) :: subgrid_special_indices - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'do_fill_missing_with_natveg' - !----------------------------------------------------------------------- - - if (subgrido%name == 'gridcell') then - ! It makes no sense to try to fill missing with natveg for gridcell-level values - do_fill_missing_with_natveg = .false. - else if (fill_missing_with_natveg) then - ! User has asked for all missing points to be filled with natveg - do_fill_missing_with_natveg = .true. - else if (subgrid_special_indices%is_vegetated_landunit(subgrido%ltype(no))) then - ! Even if user hasn't asked for it, we fill missing vegetated points (natural veg - ! and crop) with the closest natveg point. This is mainly to support the common - ! use case of interpolating non-crop to crop, but also supports adding a new PFT - ! type. - do_fill_missing_with_natveg = .true. - else - do_fill_missing_with_natveg = .false. - end if - - end function do_fill_missing_with_natveg - - !======================================================================= - logical function is_sametype (ni, no, subgridi, subgrido, subgrid_special_indices) + logical function is_sametype (ni, no, subgridi, subgrido) ! -------------------------------------------------------------------- ! arguments @@ -280,49 +148,11 @@ logical function is_sametype (ni, no, subgridi, subgrido, subgrid_special_indice integer , intent(in) :: no type(subgrid_type), intent(in) :: subgridi type(subgrid_type), intent(in) :: subgrido - type(subgrid_special_indices_type), intent(in) :: subgrid_special_indices ! -------------------------------------------------------------------- is_sametype = .false. - if (trim(subgridi%name) == 'pft' .and. trim(subgrido%name) == 'pft') then - if ( subgridi%ltype(ni) == subgrid_special_indices%ilun_landice_multiple_elevation_classes .and. & - subgrido%ltype(no) == subgrid_special_indices%ilun_landice_multiple_elevation_classes) then - is_sametype = .true. - else if (subgrid_special_indices%is_vegetated_landunit(subgrido%ltype(no))) then - ! If the output type is natural veg or crop, then just look for the correct PFT, - ! without regard for what column or landunit it's on (as long as it's on either - ! the natural veg or crop landunit). This is needed to handle the generic crop - ! properly when interpolating from non-crop to crop, or vice versa. - ! - ! TODO(wjs, 2015-09-15) If we ever allow the same PFT to appear on multiple - ! columns within a given grid cell, then this logic will need to be made - ! somewhat more complex: e.g., preferably take something from the same column - ! type, but if we can't find anything from the same column type, then ignore - ! column type. - - if (subgrid_special_indices%is_vegetated_landunit(subgridi%ltype(ni)) .and. & - subgridi%ptype(ni) == subgrido%ptype(no)) then - is_sametype = .true. - end if - else if (subgridi%ptype(ni) == subgrido%ptype(no) .and. & - subgridi%ctype(ni) == subgrido%ctype(no) .and. & - subgridi%ltype(ni) == subgrido%ltype(no)) then - is_sametype = .true. - end if - else if (trim(subgridi%name) == 'column' .and. trim(subgrido%name) == 'column') then - if ( subgridi%ltype(ni) == subgrid_special_indices%ilun_landice_multiple_elevation_classes .and. & - subgrido%ltype(no) == subgrid_special_indices%ilun_landice_multiple_elevation_classes ) then - is_sametype = .true. - else if (subgridi%ctype(ni) == subgrido%ctype(no) .and. & - subgridi%ltype(ni) == subgrido%ltype(no)) then - is_sametype = .true. - end if - else if (trim(subgridi%name) == 'landunit' .and. trim(subgrido%name) == 'landunit') then - if (subgridi%ltype(ni) == subgrido%ltype(no)) then - is_sametype = .true. - end if - else if (trim(subgridi%name) == 'gridcell' .and. trim(subgrido%name) == 'gridcell') then + if (trim(subgridi%name) == 'gridcell' .and. trim(subgrido%name) == 'gridcell') then is_sametype = .true. else if (masterproc) then @@ -335,69 +165,4 @@ logical function is_sametype (ni, no, subgridi, subgrido, subgrid_special_indice end function is_sametype - !======================================================================= - - logical function is_baresoil (n, subgrid, subgrid_special_indices) - - ! -------------------------------------------------------------------- - ! arguments - integer , intent(in) :: n - type(subgrid_type), intent(in) :: subgrid - type(subgrid_special_indices_type), intent(in) :: subgrid_special_indices - ! -------------------------------------------------------------------- - - is_baresoil = .false. - - if (subgrid%name == 'pft') then - if (subgrid%ptype(n) == subgrid_special_indices%ipft_not_vegetated .and. & - subgrid%ctype(n) == subgrid_special_indices%icol_vegetated_or_bare_soil .and. & - subgrid%ltype(n) == subgrid_special_indices%ilun_vegetated_or_bare_soil) then - is_baresoil = .true. - end if - else if (subgrid%name == 'column') then - if (subgrid%ctype(n) == subgrid_special_indices%icol_vegetated_or_bare_soil .and. & - subgrid%ltype(n) == subgrid_special_indices%ilun_vegetated_or_bare_soil) then - is_baresoil = .true. - end if - else if (subgrid%name == 'landunit') then - if (subgrid%ltype(n) == subgrid_special_indices%ilun_vegetated_or_bare_soil) then - is_baresoil = .true. - end if - else - if (masterproc) then - write(iulog,*)'ERROR interpinic: is_baresoil subgrid type ',subgrid%name,' not supported' - end if - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end function is_baresoil - - !----------------------------------------------------------------------- - function is_vegetated_landunit(this, ltype) - ! - ! !DESCRIPTION: - ! Returns true if the given landunit type is vegetated: either natural veg or crop - ! - ! !USES: - ! - ! !ARGUMENTS: - logical :: is_vegetated_landunit ! function result - class(subgrid_special_indices_type), intent(in) :: this - integer, intent(in) :: ltype ! landunit type of interest - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'is_vegetated_landunit' - !----------------------------------------------------------------------- - - if (ltype == this%ilun_vegetated_or_bare_soil .or. & - ltype == this%ilun_crop) then - is_vegetated_landunit = .true. - else - is_vegetated_landunit = .false. - end if - - end function is_vegetated_landunit - - end module initInterpMindist diff --git a/src/init_interp/initInterpMultilevelContainer.F90 b/src/init_interp/initInterpMultilevelContainer.F90 index 1c165181..765141bf 100644 --- a/src/init_interp/initInterpMultilevelContainer.F90 +++ b/src/init_interp/initInterpMultilevelContainer.F90 @@ -45,11 +45,6 @@ module initInterpMultilevelContainer ! pointers would be to require all instances of this derived type to have the target ! attribute.) type(interp_multilevel_copy_type), pointer :: interp_multilevel_copy - type(interp_multilevel_interp_type), pointer :: interp_multilevel_levgrnd_col - type(interp_multilevel_interp_type), pointer :: interp_multilevel_levgrnd_pft - type(interp_multilevel_snow_type), pointer :: interp_multilevel_levsno - type(interp_multilevel_snow_type), pointer :: interp_multilevel_levsno1 - type(interp_multilevel_split_type), pointer :: interp_multilevel_levtot_col contains procedure :: find_interpolator end type interp_multilevel_container_type @@ -58,12 +53,6 @@ module initInterpMultilevelContainer module procedure constructor end interface interp_multilevel_container_type - ! Private routines - - private :: create_interp_multilevel_levgrnd - private :: interp_levgrnd_check_source_file - private :: create_snow_interpolators - character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -94,7 +83,7 @@ function constructor(ncid_source, ncid_dest, bounds_source, bounds_dest, & ! e.g., colindex(i) gives source col corresponding to dest col i. integer, intent(in) :: pftindex(:) integer, intent(in) :: colindex(:) - ! + ! !LOCAL VARIABLES: character(len=*), parameter :: subname = 'constructor' @@ -103,44 +92,6 @@ function constructor(ncid_source, ncid_dest, bounds_source, bounds_dest, & allocate(this%interp_multilevel_copy) this%interp_multilevel_copy = interp_multilevel_copy_type() - allocate(this%interp_multilevel_levgrnd_col) - this%interp_multilevel_levgrnd_col = create_interp_multilevel_levgrnd( & - ncid_source = ncid_source, & - ncid_dest = ncid_dest, & - bounds_source = bounds_source, & - bounds_dest = bounds_dest, & - coord_varname = 'COL_Z', & - level_class_varname = 'LEVGRND_CLASS', & - sgridindex = colindex) - - allocate(this%interp_multilevel_levgrnd_pft) - this%interp_multilevel_levgrnd_pft = create_interp_multilevel_levgrnd( & - ncid_source = ncid_source, & - ncid_dest = ncid_dest, & - bounds_source = bounds_source, & - bounds_dest = bounds_dest, & - coord_varname = 'COL_Z_p', & - level_class_varname = 'LEVGRND_CLASS_p', & - sgridindex = pftindex) - - allocate(this%interp_multilevel_levsno) - allocate(this%interp_multilevel_levsno1) - call create_snow_interpolators( & - interp_multilevel_levsno = this%interp_multilevel_levsno, & - interp_multilevel_levsno1 = this%interp_multilevel_levsno1, & - ncid_source = ncid_source, & - bounds_source = bounds_source, & - bounds_dest = bounds_dest, & - colindex = colindex) - - ! levtot is two sets of levels: first snow, then levgrnd - allocate(this%interp_multilevel_levtot_col) - this%interp_multilevel_levtot_col = create_interp_multilevel_split_type( & - interpolator_first_levels = this%find_interpolator('levsno', 'column'), & - interpolator_second_levels = this%interp_multilevel_levgrnd_col, & - num_second_levels_source = this%interp_multilevel_levgrnd_col%get_nlev_source(), & - num_second_levels_dest = this%interp_multilevel_levgrnd_col%get_nlev_dest()) - end function constructor ! ======================================================================== @@ -171,24 +122,9 @@ function find_interpolator(this, lev_dimname, vec_dimname) result(interpolator) select case (lev_dimname) case ('levgrnd') select case (vec_dimname) - case ('column') - interpolator => this%interp_multilevel_levgrnd_col - case ('pft') - interpolator => this%interp_multilevel_levgrnd_pft - case default - call error_not_found(subname, lev_dimname, vec_dimname) - end select - case ('levtot') - select case (vec_dimname) - case ('column') - interpolator => this%interp_multilevel_levtot_col case default call error_not_found(subname, lev_dimname, vec_dimname) end select - case ('levsno') - interpolator => this%interp_multilevel_levsno - case ('levsno1') - interpolator => this%interp_multilevel_levsno1 case default interpolator => this%interp_multilevel_copy end select @@ -208,287 +144,4 @@ end subroutine error_not_found end function find_interpolator - ! ======================================================================== - ! Private methods and routines - ! ======================================================================== - - !----------------------------------------------------------------------- - function create_interp_multilevel_levgrnd(ncid_source, ncid_dest, & - bounds_source, bounds_dest, & - coord_varname, level_class_varname, & - sgridindex) & - result(interpolator) - ! - ! !DESCRIPTION: - ! Create the interpolator used to interpolate variables dimensioned by levgrnd - ! - ! !USES: - ! - ! !ARGUMENTS: - type(interp_multilevel_interp_type) :: interpolator ! function result - type(file_desc_t), target, intent(inout) :: ncid_source - type(file_desc_t), target, intent(inout) :: ncid_dest - type(interp_bounds_type), intent(in) :: bounds_source - type(interp_bounds_type), intent(in) :: bounds_dest - character(len=*), intent(in) :: coord_varname - character(len=*), intent(in) :: level_class_varname - integer, intent(in) :: sgridindex(:) ! mappings from source to dest points for the appropriate subgrid level (e.g., column-level mappings if this interpolator is for column-level data) - ! - ! !LOCAL VARIABLES: - type(interp_2dvar_type) :: coord_source - type(interp_2dvar_type) :: coord_dest - type(interp_2dvar_type) :: level_class_source - type(interp_2dvar_type) :: level_class_dest - real(r8), pointer :: coord_data_source_sgrid_1d(:) ! [vec] On the source grid - real(r8), allocatable :: coord_data_source(:,:) ! [vec, lev] Interpolated to the dest grid, but source vertical grid - real(r8), pointer :: coord_data_dest(:,:) ! [vec, lev] Dest horiz & vertical grid - integer , pointer :: level_class_data_source_sgrid_1d(:) ! [vec] On the source grid - integer , allocatable :: level_class_data_source(:,:) ! [vec, lev] Interpolated to the dest grid, but source vertical grid - integer , pointer :: level_class_data_dest(:,:) ! [vec, lev] Dest horiz & vertical grid - real(r8), allocatable :: coord_data_source_transpose(:,:) ! [lev, vec] - real(r8), allocatable :: coord_data_dest_transpose(:,:) ! [lev, vec] - integer , allocatable :: level_class_data_source_transpose(:,:) ! [lev, vec] - integer , allocatable :: level_class_data_dest_transpose(:,:) ! [lev, vec] - - integer :: beg_dest - integer :: end_dest - integer :: beg_source - integer :: end_source - - integer :: level - integer :: nlev_source - - character(len=*), parameter :: subname = 'create_interp_multilevel_levgrnd' - !----------------------------------------------------------------------- - - ! Set coord_data_dest - coord_dest = interp_2dvar_type( & - varname = coord_varname, & - ncid = ncid_dest, & - file_is_dest = .true., & - bounds = bounds_dest) - ! COMPILER_BUG(wjs, 2015-11-25, cray8.4.0) The cray compiler has trouble - ! resolving the generic reference here, giving the message: 'No specific - ! match can be found for the generic subprogram call "READVAR"'. So we - ! explicitly call the specific routine, rather than calling readvar. - call coord_dest%readvar_double(coord_data_dest) - beg_dest = coord_dest%get_vec_beg() - end_dest = coord_dest%get_vec_end() - - ! Set level_class_data_dest - level_class_dest = interp_2dvar_type( & - varname = level_class_varname, & - ncid = ncid_dest, & - file_is_dest = .true., & - bounds = bounds_dest) - ! COMPILER_BUG(wjs, 2015-11-25, cray8.4.0) The cray compiler has trouble - ! resolving the generic reference here, giving the message: 'No specific - ! match can be found for the generic subprogram call "READVAR"'. So we - ! explicitly call the specific routine, rather than calling readvar. - call level_class_dest%readvar_int(level_class_data_dest) - SHR_ASSERT(level_class_dest%get_vec_beg() == beg_dest, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(level_class_dest%get_vec_end() == end_dest, errMsg(sourcefile, __LINE__)) - - ! NOTE(wjs, 2015-10-18) The following check is helpful while we still have old initial - ! conditions files that do not have the necessary metadata. Once these old initial - ! conditions files have been phased out, we can remove this check. (Without this - ! check, the run will still abort if it can't find the necessary variables - it just - ! won't have a very helpful error message.) - call interp_levgrnd_check_source_file(ncid_source, coord_varname, level_class_varname) - - ! Set coord_data_source - coord_source = interp_2dvar_type( & - varname = coord_varname, & - ncid = ncid_source, & - file_is_dest = .false., & - bounds = bounds_source) - nlev_source = coord_source%get_nlev() - beg_source = coord_source%get_vec_beg() - end_source = coord_source%get_vec_end() - allocate(coord_data_source(beg_dest:end_dest, nlev_source)) - allocate(coord_data_source_sgrid_1d(beg_source:end_source)) - do level = 1, nlev_source - ! COMPILER_BUG(wjs, 2015-11-25, cray8.4.0) The cray compiler has trouble - ! resolving the generic reference here, giving the message: 'No specific - ! match can be found for the generic subprogram call "READLEVEL"'. So we - ! explicitly call the specific routine, rather than calling readlevel. - call coord_source%readlevel_double(coord_data_source_sgrid_1d, level) - call interp_1d_data( & - begi = beg_source, endi = end_source, & - bego = beg_dest, endo = end_dest, & - sgridindex = sgridindex, & - keep_existing = .false., & - data_in = coord_data_source_sgrid_1d, & - data_out = coord_data_source(:,level)) - end do - deallocate(coord_data_source_sgrid_1d) - - ! Set level_class_data_source - level_class_source = interp_2dvar_type( & - varname = level_class_varname, & - ncid = ncid_source, & - file_is_dest = .false., & - bounds = bounds_source) - SHR_ASSERT(level_class_source%get_nlev() == nlev_source, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(level_class_source%get_vec_beg() == beg_source, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(level_class_source%get_vec_end() == end_source, errMsg(sourcefile, __LINE__)) - allocate(level_class_data_source(beg_dest:end_dest, nlev_source)) - allocate(level_class_data_source_sgrid_1d(beg_source:end_source)) - do level = 1, nlev_source - ! COMPILER_BUG(wjs, 2015-11-25, cray8.4.0) The cray compiler has trouble - ! resolving the generic reference here, giving the message: 'No specific - ! match can be found for the generic subprogram call "READLEVEL"'. So we - ! explicitly call the specific routine, rather than calling readlevel. - call level_class_source%readlevel_int(level_class_data_source_sgrid_1d, level) - call interp_1d_data( & - begi = beg_source, endi = end_source, & - bego = beg_dest, endo = end_dest, & - sgridindex = sgridindex, & - keep_existing = .false., & - data_in = level_class_data_source_sgrid_1d, & - data_out = level_class_data_source(:,level)) - end do - deallocate(level_class_data_source_sgrid_1d) - - ! Create interpolator - call transpose_wrapper(coord_data_source_transpose, coord_data_source) - call transpose_wrapper(coord_data_dest_transpose, coord_data_dest) - call transpose_wrapper(level_class_data_source_transpose, level_class_data_source) - call transpose_wrapper(level_class_data_dest_transpose, level_class_data_dest) - interpolator = interp_multilevel_interp_type( & - coordinates_source = coord_data_source_transpose, & - coordinates_dest = coord_data_dest_transpose, & - level_classes_source = level_class_data_source_transpose, & - level_classes_dest = level_class_data_dest_transpose, & - coord_varname = coord_varname) - - ! Deallocate pointers (allocatables are automatically deallocated) - deallocate(coord_data_dest) - deallocate(level_class_data_dest) - - end function create_interp_multilevel_levgrnd - - !----------------------------------------------------------------------- - subroutine interp_levgrnd_check_source_file(ncid_source, coord_varname, level_class_varname) - ! - ! !DESCRIPTION: - ! Ensure that the necessary variables are present on the source file for the levgrnd - ! interpolator. - ! - ! Aborts the run with a useful error message if either variable is missing - ! - ! !USES: - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: ncid_source - character(len=*) , intent(in) :: coord_varname - character(len=*) , intent(in) :: level_class_varname - ! - ! !LOCAL VARIABLES: - logical :: coord_on_source - logical :: level_class_on_source - type(var_desc_t) :: coord_source_vardesc ! unused, but needed for check_var interface - type(var_desc_t) :: level_class_source_vardesc ! unused, but needed for check_var interface - character(len=:), allocatable :: variables_missing - - character(len=*), parameter :: subname = 'interp_levgrnd_check_source_file' - !----------------------------------------------------------------------- - - variables_missing = ' ' - call check_var(ncid_source, coord_varname, coord_source_vardesc, coord_on_source) - if (.not. coord_on_source) then - variables_missing = variables_missing // coord_varname // ' ' - end if - call check_var(ncid_source, level_class_varname, level_class_source_vardesc, level_class_on_source) - if (.not. level_class_on_source) then - variables_missing = variables_missing // level_class_varname // ' ' - end if - if (variables_missing /= ' ') then - if (masterproc) then - write(iulog,*) subname//& - ' ERROR: source file for init_interp is missing the necessary variable(s):' - write(iulog,*) variables_missing - write(iulog,*) 'To solve this problem, run the model for a short time using this tag,' - write(iulog,*) 'with a configuration that matches the source file, using the source' - write(iulog,*) 'file as finidat (with use_init_interp = .false.), in order to' - write(iulog,*) 'produce a new restart file with the necessary metadata.' - write(iulog,*) 'Then use that new file as the finidat file for init_interp.' - write(iulog,*) ' ' - write(iulog,*) 'If that is not possible, then an alternative is to run the model for' - write(iulog,*) 'a short time using this tag, with cold start initial conditions' - write(iulog,*) '(finidat = " "). Then use a tool like ncks to copy the misssing fields' - write(iulog,*) 'onto the original source finidat file. Then use that patched file' - write(iulog,*) 'as the finidat file for init_interp.' - end if - - call endrun(subname//' ERROR: source file for init_interp is missing '// & - variables_missing) - end if - - end subroutine interp_levgrnd_check_source_file - - !----------------------------------------------------------------------- - subroutine create_snow_interpolators(interp_multilevel_levsno, interp_multilevel_levsno1, & - ncid_source, bounds_source, bounds_dest, colindex) - ! - ! !DESCRIPTION: - ! Create multi-level interpolators for snow variables - ! - ! !USES: - ! - ! !ARGUMENTS: - type(interp_multilevel_snow_type), intent(out) :: interp_multilevel_levsno - type(interp_multilevel_snow_type), intent(out) :: interp_multilevel_levsno1 - type(file_desc_t), intent(inout) :: ncid_source ! netcdf ID for source file - type(interp_bounds_type), intent(in) :: bounds_source - type(interp_bounds_type), intent(in) :: bounds_dest - integer, intent(in) :: colindex(:) ! mappings from source to dest for column-level arrays - ! - ! !LOCAL VARIABLES: - ! snlsno_source needs to be a pointer to satisfy the interface of ncd_io - integer, pointer :: snlsno_source_sgrid(:) ! snlsno in source, on source grid - integer, allocatable :: snlsno_source(:) ! snlsno_source interpolated to dest - integer, allocatable :: snlsno_source_plus_1(:) ! snlsno_source+1 interpolated to dest - - character(len=*), parameter :: subname = 'create_snow_interpolators' - !----------------------------------------------------------------------- - - ! Read snlsno_source_sgrid - allocate(snlsno_source_sgrid(bounds_source%get_begc() : bounds_source%get_endc())) - call ncd_io(ncid=ncid_source, varname='SNLSNO', flag='read', & - data=snlsno_source_sgrid) - snlsno_source_sgrid(:) = abs(snlsno_source_sgrid(:)) - - ! Interpolate to dest - allocate(snlsno_source(bounds_dest%get_begc() : bounds_dest%get_endc())) - call interp_1d_data( & - begi = bounds_source%get_begc(), endi = bounds_source%get_endc(), & - bego = bounds_dest%get_begc(), endo = bounds_dest%get_endc(), & - sgridindex = colindex, & - keep_existing = .false., & - data_in = snlsno_source_sgrid, data_out = snlsno_source) - deallocate(snlsno_source_sgrid) - - ! Set up interp_multilevel_levsno - interp_multilevel_levsno = interp_multilevel_snow_type( & - num_snow_layers_source = snlsno_source, & - num_layers_name = 'SNLSNO') - - ! Set up interp_multilevel_levsno1 - ! - ! For variables dimensioned (levsno+1), we assume they have (snlsno+1) active layers. - ! Thus, if there are 0 active layers in the source, the bottom layer's value will - ! still get copied for these (levsno+1) variables. - allocate(snlsno_source_plus_1(bounds_dest%get_begc() : bounds_dest%get_endc())) - snlsno_source_plus_1(:) = snlsno_source(:) + 1 - interp_multilevel_levsno1 = interp_multilevel_snow_type( & - num_snow_layers_source = snlsno_source_plus_1, & - num_layers_name = 'SNLSNO+1') - - deallocate(snlsno_source) - deallocate(snlsno_source_plus_1) - - end subroutine create_snow_interpolators - - end module initInterpMultilevelContainer diff --git a/src/main/ColumnType.F90 b/src/main/ColumnType.F90 deleted file mode 100644 index 7043bfa1..00000000 --- a/src/main/ColumnType.F90 +++ /dev/null @@ -1,209 +0,0 @@ -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 - 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) - 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 :: n_melt (:) ! SCA shape parameter - 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 - - ! 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%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 - this%snl (:) = 0 ! Explicitly set the number of snow laters to zero as they are unused - allocate(this%dz (begc:endc,-nlevsno+1:nlevgrnd)) ; this%dz (:,:) = nan - allocate(this%z (begc:endc,-nlevsno+1:nlevgrnd)) ; this%z (:,:) = nan - allocate(this%zi (begc:endc,-nlevsno+0:nlevgrnd)) ; 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,nlevgrnd)) ; this%levgrnd_class(:,:) = ispval - allocate(this%micro_sigma (begc:endc)) ; this%micro_sigma (:) = nan - allocate(this%n_melt (begc:endc)) ; this%n_melt (:) = 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. - - 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%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%n_melt ) - deallocate(this%topo_slope ) - deallocate(this%topo_std ) - deallocate(this%nbedrock ) - deallocate(this%levgrnd_class) - deallocate(this%hydrologically_active) - - 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. - ! - ! !ARGUMENTS: - class(column_type), intent(inout) :: this - integer, intent(in) :: c - integer, intent(in) :: itype - ! - ! !LOCAL VARIABLES: - integer :: l - - character(len=*), parameter :: subname = 'update_itype' - !----------------------------------------------------------------------- - - l = col%landunit(c) - - if (col%type_is_dynamic(c)) then - col%itype(c) = itype - col%hydrologically_active(c) = is_hydrologically_active( & - col_itype = itype, & - lun_itype = lun%itype(l)) - 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/src/main/FuncPedotransferMod.F90 b/src/main/FuncPedotransferMod.F90 deleted file mode 100644 index 41e75134..00000000 --- a/src/main/FuncPedotransferMod.F90 +++ /dev/null @@ -1,141 +0,0 @@ -module FuncPedotransferMod -! -!DESCRIPTIONS: -!module contains different pedotransfer functions to -!compute the mineral soil hydraulic properties. -!currenty, only the Clapp-Hornberg formulation is used. -!HISTORY: -!created by Jinyun Tang, Mar.1st, 2014 -implicit none - private - public :: pedotransf - public :: get_ipedof - public :: init_pedof - - integer, parameter :: cosby_1984_table5 = 0 !by default uses this form - integer, parameter :: cosby_1984_table4 = 1 - integer, parameter :: noilhan_lacarrere_1995 = 2 - integer :: ipedof0 -contains - - subroutine init_pedof() - ! - !DESCRIPTIONS - !initialize the default pedotransfer function - implicit none - - - ipedof0 = cosby_1984_table5 !the default pedotransfer function - end subroutine init_pedof - - subroutine pedotransf(ipedof, sand, clay, watsat, bsw, sucsat, xksat) - !pedotransfer function to compute hydraulic properties of mineral soil - !based on input soil texture - - use shr_kind_mod , only : r8 => shr_kind_r8 - use abortutils , only : endrun - implicit none - integer, intent(in) :: ipedof !type of pedotransfer function, use the default pedotransfer function - real(r8), intent(in) :: sand !% sand - real(r8), intent(in) :: clay !% clay - real(r8), intent(out):: watsat !v/v saturate moisture - real(r8), intent(out):: bsw !b shape parameter - real(r8), intent(out):: sucsat !mm, soil matric potential - real(r8), intent(out):: xksat !mm/s, saturated hydraulic conductivity - - character(len=32) :: subname = 'pedotransf' ! subroutine name - select case (ipedof) - case (cosby_1984_table4) - call pedotransf_cosby1984_table4(sand, clay, watsat, bsw, sucsat, xksat) - case (noilhan_lacarrere_1995) - call pedotransf_noilhan_lacarrere1995(sand, clay, watsat, bsw, sucsat, xksat) - case (cosby_1984_table5) - call pedotransf_cosby1984_table5(sand, clay, watsat, bsw, sucsat, xksat) - case default - call endrun(subname // ':: a pedotransfer function must be specified!') - end select - - end subroutine pedotransf - -!------------------------------------------------------------------------------------------ - subroutine pedotransf_cosby1984_table4(sand, clay, watsat, bsw, sucsat, xksat) - ! - !DESCRIPTIONS - !compute hydraulic properties based on functions derived from Table 4 in cosby et al, 1984 - use shr_kind_mod , only : r8 => shr_kind_r8 - implicit none - real(r8), intent(in) :: sand !% sand - real(r8), intent(in) :: clay !% clay - real(r8), intent(out):: watsat !v/v saturate moisture - real(r8), intent(out):: bsw !b shape parameter - real(r8), intent(out):: sucsat !mm, soil matric potential - real(r8), intent(out):: xksat !mm/s, saturated hydraulic conductivity - - !Cosby et al. Table 4 - watsat = 0.505_r8-0.00142_r8*sand-0.00037*clay - bsw = 3.10+0.157*clay-0.003*sand - sucsat = 10._r8 * ( 10._r8**(1.54_r8-0.0095_r8*sand+0.0063*(100._r8-sand-clay))) - xksat = 0.0070556 *(10.**(-0.60+0.0126*sand-0.0064*clay) ) !mm/s now use table 4. - - end subroutine pedotransf_cosby1984_table4 - -!------------------------------------------------------------------------------------------ - subroutine pedotransf_cosby1984_table5(sand, clay, watsat, bsw, sucsat, xksat) - ! - !DESCRIPTIONS - !compute hydraulic properties based on functions derived from Table 5 in cosby et al, 1984 - - use shr_kind_mod , only : r8 => shr_kind_r8 - implicit none - real(r8), intent(in) :: sand !% sand - real(r8), intent(in) :: clay !% clay - real(r8), intent(out):: watsat !v/v saturate moisture - real(r8), intent(out):: bsw !b shape parameter - real(r8), intent(out):: sucsat !mm, soil matric potential - real(r8), intent(out):: xksat !mm/s, saturated hydraulic conductivity - - !Cosby et al. Table 5 - watsat = 0.489_r8 - 0.00126_r8*sand - bsw = 2.91 + 0.159*clay - sucsat = 10._r8 * ( 10._r8**(1.88_r8-0.0131_r8*sand) ) - xksat = 0.0070556 *( 10.**(-0.884+0.0153*sand) ) ! mm/s, from table 5 - - end subroutine pedotransf_cosby1984_table5 - -!------------------------------------------------------------------------------------------ - subroutine pedotransf_noilhan_lacarrere1995(sand, clay, watsat, bsw, sucsat, xksat) - ! - !DESCRIPTIONS - !compute hydraulic properties based on functions derived from Noilhan and Lacarrere, 1995 - - use shr_kind_mod , only : r8 => shr_kind_r8 - implicit none - real(r8), intent(in) :: sand !% sand - real(r8), intent(in) :: clay !% clay - real(r8), intent(out):: watsat !v/v saturate moisture - real(r8), intent(out):: bsw !b shape parameter - real(r8), intent(out):: sucsat !mm, soil matric potential - real(r8), intent(out):: xksat !mm/s, saturated hydraulic conductivity - - !Noilhan and Lacarrere, 1995 - watsat = -0.00108*sand+0.494305 - bsw = 0.137*clay + 3.501 - sucsat = 10._r8**(-0.0088*sand+2.85) - xksat = 10._r8**(-0.0582*clay-0.00091*sand+0.000529*clay**2._r8-0.0001203*sand**2._r8-1.38) - end subroutine pedotransf_noilhan_lacarrere1995 -!------------------------------------------------------------------------------------------ - function get_ipedof(soil_order)result(ipedof) - ! - ! DESCRIPTION - ! select the pedotransfer function to be used - implicit none - integer, intent(in) :: soil_order - - integer :: ipedof - - if(soil_order==0)then - ipedof=ipedof0 - endif - - end function get_ipedof -end module FuncpedotransferMod diff --git a/src/main/GetGlobalValuesMod.F90 b/src/main/GetGlobalValuesMod.F90 index 3cd1f9a3..1f43f27f 100644 --- a/src/main/GetGlobalValuesMod.F90 +++ b/src/main/GetGlobalValuesMod.F90 @@ -28,7 +28,7 @@ integer function GetGlobalIndex(decomp_index, clmlevel) use shr_log_mod, only: errMsg => shr_log_errMsg use decompMod , only: bounds_type, get_clmlevel_gsmap, get_proc_bounds use spmdMod , only: iam - use clm_varcon , only: nameg, namel, namec, namep + use clm_varcon , only: nameg use clm_varctl , only: iulog use mct_mod , only: mct_gsMap, mct_gsMap_orderedPoints use shr_sys_mod, only: shr_sys_abort @@ -48,12 +48,6 @@ integer function GetGlobalIndex(decomp_index, clmlevel) if (trim(clmlevel) == nameg) then beg_index = bounds_proc%begg - else if (trim(clmlevel) == namel) then - beg_index = bounds_proc%begl - else if (trim(clmlevel) == namec) then - beg_index = bounds_proc%begc - else if (trim(clmlevel) == namep) then - beg_index = bounds_proc%begp else call shr_sys_abort('clmlevel of '//trim(clmlevel)//' not supported' // & errmsg(sourcefile, __LINE__)) @@ -77,18 +71,15 @@ subroutine GetGlobalWrite(decomp_index, clmlevel) use shr_sys_mod , only : shr_sys_abort use shr_log_mod , only : errMsg => shr_log_errMsg use clm_varctl , only : iulog - use clm_varcon , only : nameg, namel, namec, namep + use clm_varcon , only : nameg use GridcellType , only : grc - use LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch ! ! Arguments: integer , intent(in) :: decomp_index character(len=*) , intent(in) :: clmlevel ! ! Local Variables: - integer :: igrc, ilun, icol, ipft + integer :: igrc !----------------------------------------------------------------------- if (trim(clmlevel) == nameg) then @@ -99,48 +90,6 @@ subroutine GetGlobalWrite(decomp_index, clmlevel) write(iulog,*)'gridcell longitude = ',grc%londeg(igrc) write(iulog,*)'gridcell latitude = ',grc%latdeg(igrc) - else if (trim(clmlevel) == namel) then - - ilun = decomp_index - igrc = lun%gridcell(ilun) - write(iulog,*)'local landunit index = ',ilun - write(iulog,*)'global landunit index = ',GetGlobalIndex(decomp_index=ilun, clmlevel=namel) - write(iulog,*)'global gridcell index = ',GetGlobalIndex(decomp_index=igrc, clmlevel=nameg) - write(iulog,*)'gridcell longitude = ',grc%londeg(igrc) - write(iulog,*)'gridcell latitude = ',grc%latdeg(igrc) - write(iulog,*)'landunit type = ',lun%itype(decomp_index) - - else if (trim(clmlevel) == namec) then - - icol = decomp_index - ilun = col%landunit(icol) - igrc = col%gridcell(icol) - write(iulog,*)'local column index = ',icol - write(iulog,*)'global column index = ',GetGlobalIndex(decomp_index=icol, clmlevel=namec) - write(iulog,*)'global landunit index = ',GetGlobalIndex(decomp_index=ilun, clmlevel=namel) - write(iulog,*)'global gridcell index = ',GetGlobalIndex(decomp_index=igrc, clmlevel=nameg) - write(iulog,*)'gridcell longitude = ',grc%londeg(igrc) - write(iulog,*)'gridcell latitude = ',grc%latdeg(igrc) - write(iulog,*)'column type = ',col%itype(icol) - write(iulog,*)'landunit type = ',lun%itype(ilun) - - else if (trim(clmlevel) == namep) then - - ipft = decomp_index - icol = patch%column(ipft) - ilun = patch%landunit(ipft) - igrc = patch%gridcell(ipft) - write(iulog,*)'local patch index = ',ipft - write(iulog,*)'global patch index = ',GetGlobalIndex(decomp_index=ipft, clmlevel=namep) - write(iulog,*)'global column index = ',GetGlobalIndex(decomp_index=icol, clmlevel=namec) - write(iulog,*)'global landunit index = ',GetGlobalIndex(decomp_index=ilun, clmlevel=namel) - write(iulog,*)'global gridcell index = ',GetGlobalIndex(decomp_index=igrc, clmlevel=nameg) - write(iulog,*)'gridcell longitude = ',grc%londeg(igrc) - write(iulog,*)'gridcell latitude = ',grc%latdeg(igrc) - write(iulog,*)'pft type = ',patch%itype(ipft) - write(iulog,*)'column type = ',col%itype(icol) - write(iulog,*)'landunit type = ',lun%itype(ilun) - else call shr_sys_abort('clmlevel '//trim(clmlevel)//'not supported '//errmsg(sourcefile, __LINE__)) diff --git a/src/main/GridcellType.F90 b/src/main/GridcellType.F90 index 30fe988e..580b2bd3 100644 --- a/src/main/GridcellType.F90 +++ b/src/main/GridcellType.F90 @@ -10,7 +10,6 @@ module GridcellType ! 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: @@ -29,20 +28,11 @@ module GridcellType 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 @@ -70,15 +60,12 @@ subroutine Init(this, begg, endg) 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 !------------------------------------------------------------------------ @@ -95,11 +82,9 @@ subroutine Clean(this) 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 diff --git a/src/main/LandunitType.F90 b/src/main/LandunitType.F90 deleted file mode 100644 index 2236ca27..00000000 --- a/src/main/LandunitType.F90 +++ /dev/null @@ -1,140 +0,0 @@ -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/src/main/PatchType.F90 b/src/main/PatchType.F90 deleted file mode 100644 index d00f5588..00000000 --- a/src/main/PatchType.F90 +++ /dev/null @@ -1,207 +0,0 @@ -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/src/main/TopoMod.F90 b/src/main/TopoMod.F90 deleted file mode 100644 index 9841f59b..00000000 --- a/src/main/TopoMod.F90 +++ /dev/null @@ -1,314 +0,0 @@ -module TopoMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Handles topographic height of each column - ! - ! !USES: - 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 PatchType , only : patch - use ColumnType , only : col - use LandunitType , only : lun - use glc2lndMod , only : glc2lnd_type - use glcBehaviorMod , only : glc_behavior_type - use landunit_varcon, only : istice_mec - use filterColMod , only : filter_col_type, col_filter_from_logical_array_active_only - ! - ! !PUBLIC TYPES: - implicit none - save - private - - type, public :: topo_type - private - - ! Public member data - - real(r8), pointer, public :: topo_col(:) ! surface elevation (m) - - ! Private member data - - logical, pointer :: needs_downscaling_col(:) ! whether a column needs to be downscaled - contains - procedure, public :: Init - procedure, public :: Restart - procedure, public :: Clean - procedure, public :: UpdateTopo ! Update topographic height each time step - procedure, public :: DownscaleFilterc ! Returns column-level filter: which columns need downscaling - - procedure, private :: InitAllocate - procedure, private :: InitHistory - procedure, private :: InitCold - end type topo_type - -contains - - !----------------------------------------------------------------------- - subroutine Init(this, bounds) - ! !ARGUMENTS: - class(topo_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(topo_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%topo_col(begc:endc)) - this%topo_col(:) = nan - - allocate(this%needs_downscaling_col(begc:endc)) - this%needs_downscaling_col(:) = .false. - - end subroutine InitAllocate - - !----------------------------------------------------------------------- - subroutine InitHistory(this, bounds) - ! !USES: - use histFileMod , only : hist_addfld1d - ! - ! !ARGUMENTS: - class(topo_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'InitHistory' - !----------------------------------------------------------------------- - - call hist_addfld1d(fname='TOPO_COL', units='m', & - avgflag='A', long_name='column-level topographic height', & - ptr_col=this%topo_col, default='inactive') - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine InitCold(this, bounds) - ! !USES: - use column_varcon , only: col_itype_to_icemec_class - use clm_instur, only : topo_glc_mec - ! !ARGUMENTS: - class(topo_type), intent(inout) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: c, l, g - integer :: icemec_class ! current icemec class (1..maxpatch_glcmec) - - character(len=*), parameter :: subname = 'InitCold' - !----------------------------------------------------------------------- - - do c = bounds%begc, bounds%endc - l = col%landunit(c) - g = col%gridcell(c) - - if (lun%itype(l) == istice_mec) then - ! For ice_mec landunits, initialize topo_col based on surface dataset; this - ! will get overwritten in the run loop by values sent from CISM - icemec_class = col_itype_to_icemec_class(col%itype(c)) - this%topo_col(c) = topo_glc_mec(g, icemec_class) - this%needs_downscaling_col(c) = .true. - else - ! For other landunits, arbitrarily initialize topo_col to 0 m; for landunits - ! where this matters, this will get overwritten in the run loop by values sent - ! from CISM - this%topo_col(c) = 0._r8 - this%needs_downscaling_col(c) = .false. - 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(topo_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' - ! - ! !LOCAL VARIABLES: - integer :: p, c - real(r8), pointer :: rparr(:) - logical :: readvar - - character(len=*), parameter :: subname = 'Restart' - !----------------------------------------------------------------------- - - allocate(rparr(bounds%begp:bounds%endp)) - - ! TODO(wjs, 2016-04-05) Rename these restart variables to get rid of 'glc' in their - ! names. However, this will require some changes to init_interp, too. - - call restartvar(ncid=ncid, flag=flag, varname='cols1d_topoglc', xtype=ncd_double, & - dim1name='column', & - long_name='mean elevation on glacier elevation classes', units='m', & - interpinic_flag='skip', readvar=readvar, data=this%topo_col) - - if (flag /= 'read') then - do p=bounds%begp,bounds%endp - c = patch%column(p) - rparr(p) = this%topo_col(c) - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_topoglc', xtype=ncd_double, & - dim1name='pft', & - long_name='mean elevation on glacier elevation classes', units='m', & - interpinic_flag='skip', readvar=readvar, data=rparr) - end if - - deallocate(rparr) - - end subroutine Restart - - - !----------------------------------------------------------------------- - subroutine UpdateTopo(this, bounds, num_icemecc, filter_icemecc, & - glc2lnd_inst, glc_behavior, atm_topo) - ! - ! !DESCRIPTION: - ! Update topographic heights - ! - ! Should be called each time step. - ! - ! Should be called after glc2lndMod:update_glc2lnd_fracs, and before - ! atm2lndMod:downscale_forcings - ! - ! !ARGUMENTS: - class(topo_type) , intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_icemecc ! number of points in filter_icemecc - integer , intent(in) :: filter_icemecc(:) ! col filter for ice_mec - type(glc2lnd_type) , intent(in) :: glc2lnd_inst - type(glc_behavior_type) , intent(in) :: glc_behavior - real(r8) , intent(in) :: atm_topo( bounds%begg: ) ! atmosphere topographic height [m] - ! - ! !LOCAL VARIABLES: - integer :: begc, endc - integer :: c, g - - character(len=*), parameter :: subname = 'UpdateTopo' - !----------------------------------------------------------------------- - - begc = bounds%begc - endc = bounds%endc - - ! Reset needs_downscaling_col each time step, because this is potentially - ! time-varying for some columns. It's simplest just to reset it everywhere, rather - ! than trying to figure out where it does and does not need to be reset. - this%needs_downscaling_col(begc:endc) = .false. - - call glc_behavior%icemec_cols_need_downscaling(bounds, num_icemecc, filter_icemecc, & - this%needs_downscaling_col(begc:endc)) - - ! In addition to updating topo_col, this also sets some additional elements of - ! needs_downscaling_col to .true. (but leaves the already-.true. values as is.) - call glc2lnd_inst%update_glc2lnd_topo(bounds, & - this%topo_col(begc:endc), & - this%needs_downscaling_col(begc:endc)) - - ! For any point that isn't downscaled, set its topo value to the atmosphere's - ! topographic height. This shouldn't matter, but is useful if topo_col is written to - ! the history file. - ! - ! This could operate over a filter like 'allc' in order to just operate over active - ! points, but I'm not sure that would speed things up much, and would require passing - ! in this additional filter. - do c = bounds%begc, bounds%endc - if (.not. this%needs_downscaling_col(c)) then - g = col%gridcell(c) - this%topo_col(c) = atm_topo(g) - end if - end do - - call glc_behavior%update_glc_classes(bounds, this%topo_col(begc:endc)) - - end subroutine UpdateTopo - - !----------------------------------------------------------------------- - function DownscaleFilterc(this, bounds) result(filter) - ! - ! !DESCRIPTION: - ! Returns a column-level filter: which columns need downscaling. - ! - ! This filter only contains active points. - ! - ! The main reason it's important to have this filter (as opposed to just doing the - ! downscaling for all columns) is because of downscaled fields that are normalized - ! (like longwave radiation): Consider a gridcell with a glc_mec column and a - ! vegetated column (outside of the icemask, so the vegetated column doesn't have its - ! topographic height explicitly set). If we called the downscaling code for all - ! columns, the longwave radiation would get adjusted over the vegetated column. This - ! is undesirable, because it means that adding a downscaled column in a gridcell can - ! change answers for all other columns in that gridcell. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(filter_col_type) :: filter ! function result - class(topo_type), intent(in) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'DownscaleFilterc' - !----------------------------------------------------------------------- - - ! Currently this creates the filter on the fly, recreating it every time this function - ! is called. In principle, we should be able to compute and save this filter when - ! UpdateTopo is called, returning the already-computed filter when this function is - ! called. However, the problem with that is the need to have a different filter for - ! each clump (and potentially another filter for calls from outside a clump - ! loop). This will become easier to handle if we rework CLM's threading so that there - ! is a separate instance of each object for each clump: in that case, we'll have - ! multiple instances of topo_type, each corresponding to one clump, each with its own - ! filter. - - filter = col_filter_from_logical_array_active_only(bounds, & - this%needs_downscaling_col(bounds%begc:bounds%endc)) - - end function DownscaleFilterc - - - !----------------------------------------------------------------------- - subroutine Clean(this) - ! !ARGUMENTS: - class(topo_type), intent(inout) :: this - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'Clean' - !----------------------------------------------------------------------- - - deallocate(this%topo_col) - deallocate(this%needs_downscaling_col) - - end subroutine Clean - -end module TopoMod diff --git a/src/main/abortutils.F90 b/src/main/abortutils.F90 index cd91e53a..c6e8309d 100644 --- a/src/main/abortutils.F90 +++ b/src/main/abortutils.F90 @@ -62,7 +62,7 @@ subroutine endrun_globalindex(decomp_index, clmlevel, msg) character(len=*) , intent(in), optional :: msg ! string to be printed ! ! Local Variables: - integer :: igrc, ilun, icol + integer :: igrc !----------------------------------------------------------------------- write(6,*)'calling getglobalwrite with decomp_index= ',decomp_index,' and clmlevel= ',trim(clmlevel) diff --git a/src/main/accumulMod.F90 b/src/main/accumulMod.F90 index 29a52ceb..a8925fee 100644 --- a/src/main/accumulMod.F90 +++ b/src/main/accumulMod.F90 @@ -26,9 +26,6 @@ module accumulMod use abortutils , only: endrun use clm_varctl , only: iulog, nsrest, nsrStartup use clm_varcon , only: spval, ispval - use PatchType , only : patch - use ColumnType , only : col - use LandunitType, only : lun use GridcellType, only : grc ! ! !PUBLIC TYPES: @@ -160,7 +157,7 @@ subroutine init_accum_field (name, units, desc, & character(len=*), intent(in) :: desc !field description character(len=*), intent(in) :: accum_type !field type: timeavg, runmean, runaccum integer , intent(in) :: accum_period !field accumulation period - character(len=*), intent(in) :: subgrid_type !["gridcell","landunit","column" or "patch"] + character(len=*), intent(in) :: subgrid_type !["gridcell"] integer , intent(in) :: numlev !number of vertical levels real(r8), intent(in) :: init_value !field initial or reset value character(len=*), intent(in), optional :: type2d !level type (optional) - needed if numlev > 1 @@ -168,17 +165,12 @@ subroutine init_accum_field (name, units, desc, & ! !LOCAL VARIABLES: integer :: nf ! field index integer :: beg1d,end1d ! beggining and end subgrid indices - integer :: begp, endp ! per-proc beginning and ending patch 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 :: begCohort, endCohort ! per-proc beg end cohort indices !------------------------------------------------------------------------ ! Determine necessary indices - call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp, & - begCohort, endCohort ) + call get_proc_bounds(begg, endg) ! update field index ! Consistency check that number of accumulated does not exceed maximum. @@ -226,18 +218,6 @@ subroutine init_accum_field (name, units, desc, & beg1d = begg end1d = endg accum(nf)%active => grc%active - case ('landunit') - beg1d = begl - end1d = endl - accum(nf)%active => lun%active - case ('column') - beg1d = begc - end1d = endc - accum(nf)%active => col%active - case ('pft') - beg1d = begp - end1d = endp - accum(nf)%active => patch%active case default write(iulog,*)'init_accum_field: unknown subgrid type ',subgrid_type call shr_sys_abort () diff --git a/src/main/atm2lndMod.F90 b/src/main/atm2lndMod.F90 deleted file mode 100644 index bfa868b2..00000000 --- a/src/main/atm2lndMod.F90 +++ /dev/null @@ -1,682 +0,0 @@ -module atm2lndMod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Handle atm2lnd forcing - ! - ! !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, denh2o, spval - use clm_varcon , only : wv_to_dair_weight_ratio - use clm_varctl , only : iulog, use_cn, iulog - use abortutils , only : endrun - use decompMod , only : bounds_type - use atm2lndType , only : atm2lnd_type - use TopoMod , only : topo_type - use filterColMod , only : filter_col_type - use LandunitType , only : lun - use ColumnType , only : col - use landunit_varcon, only : istice_mec - ! - ! !PUBLIC TYPES: - implicit none - private - save - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: downscale_forcings ! Downscale atm forcing fields from gridcell to column - - ! The following routines are public for the sake of unit testing; they should not be - ! called by production code outside this module - public :: partition_precip ! Partition precipitation into rain/snow - public :: sens_heat_from_precip_conversion ! Compute sensible heat flux needed to compensate for rain-snow conversion - ! - ! !PRIVATE MEMBER FUNCTIONS: - private :: rhos ! calculate atmospheric density - private :: repartition_rain_snow_one_col ! Re-partition precipitation for a single column - private :: downscale_longwave ! Downscale longwave radiation from gridcell to column - private :: build_normalization ! Compute normalization factors so that downscaled fields are conservative - private :: check_downscale_consistency ! Check consistency of downscaling - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine downscale_forcings(bounds, & - topo_inst, atm2lnd_inst, eflx_sh_precip_conversion) - ! - ! !DESCRIPTION: - ! Downscale atmospheric forcing fields from gridcell to column. - ! - ! Downscaling is done based on the difference between each CLM column's elevation and - ! the atmosphere's surface elevation (which is the elevation at which the atmospheric - ! forcings are valid). - ! - ! Note that the downscaling procedure can result in changes in grid cell mean values - ! compared to what was provided by the atmosphere. We conserve fluxes of mass and - ! energy, but allow states such as temperature to differ. - ! - ! For most variables, downscaling is done over columns defined by - ! topo_inst%DownscaleFilterc. But we also do direct copies of gridcell-level forcings - ! into column-level forcings over all other active columns. In addition, precipitation - ! (rain vs. snow partitioning) is adjusted everywhere. - ! - ! !USES: - use clm_varcon , only : rair, cpair, grav - use QsatMod , only : Qsat - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - class(topo_type) , intent(in) :: topo_inst - type(atm2lnd_type) , intent(inout) :: atm2lnd_inst - real(r8) , intent(out) :: eflx_sh_precip_conversion(bounds%begc:) ! sensible heat flux from precipitation conversion (W/m**2) [+ to atm] - ! - ! !LOCAL VARIABLES: - integer :: g, l, c, fc ! indices - integer :: clo, cc - type(filter_col_type) :: downscale_filter_c - - ! temporaries for topo downscaling - real(r8) :: hsurf_g,hsurf_c - real(r8) :: Hbot, zbot - real(r8) :: tbot_g, pbot_g, thbot_g, qbot_g, qs_g, es_g, rhos_g - real(r8) :: tbot_c, pbot_c, thbot_c, qbot_c, qs_c, es_c, rhos_c - real(r8) :: rhos_c_estimate, rhos_g_estimate - real(r8) :: dum1, dum2 - - character(len=*), parameter :: subname = 'downscale_forcings' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(eflx_sh_precip_conversion) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - associate(& - ! Parameters: - lapse_rate => atm2lnd_inst%params%lapse_rate , & ! Input: [real(r8)] Surface temperature lapse rate (K m-1) - - ! Gridcell-level metadata: - forc_topo_g => atm2lnd_inst%forc_topo_grc , & ! Input: [real(r8) (:)] atmospheric surface height (m) - - ! Column-level metadata: - topo_c => topo_inst%topo_col , & ! Input: [real(r8) (:)] column surface height (m) - - ! Gridcell-level non-downscaled fields: - forc_t_g => atm2lnd_inst%forc_t_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric temperature (Kelvin) - forc_th_g => atm2lnd_inst%forc_th_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric potential temperature (Kelvin) - forc_q_g => atm2lnd_inst%forc_q_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric specific humidity (kg/kg) - forc_pbot_g => atm2lnd_inst%forc_pbot_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric pressure (Pa) - forc_rho_g => atm2lnd_inst%forc_rho_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric density (kg/m**3) - - ! Column-level downscaled fields: - forc_t_c => atm2lnd_inst%forc_t_downscaled_col , & ! Output: [real(r8) (:)] atmospheric temperature (Kelvin) - forc_th_c => atm2lnd_inst%forc_th_downscaled_col , & ! Output: [real(r8) (:)] atmospheric potential temperature (Kelvin) - forc_q_c => atm2lnd_inst%forc_q_downscaled_col , & ! Output: [real(r8) (:)] atmospheric specific humidity (kg/kg) - forc_pbot_c => atm2lnd_inst%forc_pbot_downscaled_col , & ! Output: [real(r8) (:)] atmospheric pressure (Pa) - forc_rho_c => atm2lnd_inst%forc_rho_downscaled_col & ! Output: [real(r8) (:)] atmospheric density (kg/m**3) - ) - - ! Initialize column forcing (needs to be done for ALL active columns) - do c = bounds%begc,bounds%endc - if (col%active(c)) then - g = col%gridcell(c) - - forc_t_c(c) = forc_t_g(g) - forc_th_c(c) = forc_th_g(g) - forc_q_c(c) = forc_q_g(g) - forc_pbot_c(c) = forc_pbot_g(g) - forc_rho_c(c) = forc_rho_g(g) - end if - end do - - downscale_filter_c = topo_inst%DownscaleFilterc(bounds) - - ! Downscale forc_t, forc_th, forc_q, forc_pbot, and forc_rho to columns. - ! For glacier_mec columns the downscaling is based on surface elevation. - ! For other columns the downscaling is a simple copy (above). - do fc = 1, downscale_filter_c%num - c = downscale_filter_c%indices(fc) - l = col%landunit(c) - g = col%gridcell(c) - - ! This is a simple downscaling procedure - ! Note that forc_hgt, forc_u, and forc_v are not downscaled. - - hsurf_g = forc_topo_g(g) ! gridcell sfc elevation - hsurf_c = topo_c(c) ! column sfc elevation - tbot_g = forc_t_g(g) ! atm sfc temp - thbot_g = forc_th_g(g) ! atm sfc pot temp - qbot_g = forc_q_g(g) ! atm sfc spec humid - pbot_g = forc_pbot_g(g) ! atm sfc pressure - rhos_g = forc_rho_g(g) ! atm density - zbot = atm2lnd_inst%forc_hgt_grc(g) ! atm ref height - tbot_c = tbot_g-lapse_rate*(hsurf_c-hsurf_g) ! sfc temp for column - Hbot = rair*0.5_r8*(tbot_g+tbot_c)/grav ! scale ht at avg temp - pbot_c = pbot_g*exp(-(hsurf_c-hsurf_g)/Hbot) ! column sfc press - - ! Derivation of potential temperature calculation: - ! - ! The textbook definition would be: - ! thbot_c = tbot_c * (p0/pbot_c)^(rair/cpair) - ! - ! Note that pressure is related to scale height as: - ! pbot_c = p0 * exp(-zbot/H) - ! - ! Using Hbot in place of H, we get: - ! pbot_c = p0 * exp(-zbot/Hbot) - ! - ! Plugging this in to the textbook definition, then manipulating, we get: - ! thbot_c = tbot_c * (p0/(p0*exp(-zbot/Hbot)))^(rair/cpair) - ! = tbot_c * (1/exp(-zbot/Hbot))^(rair/cpair) - ! = tbot_c * (exp(zbot/Hbot))^(rair/cpair) - ! = tbot_c * exp((zbot/Hbot) * (rair/cpair)) - ! - ! But we want everything expressed in delta form, resulting in: - ! thbot_c = thbot_g + (tbot_c - tbot_g)*exp((zbot/Hbot)*(rair/cpair)) - - thbot_c= thbot_g + (tbot_c - tbot_g)*exp((zbot/Hbot)*(rair/cpair)) ! pot temp calc - - call Qsat(tbot_g,pbot_g,es_g,dum1,qs_g,dum2) - call Qsat(tbot_c,pbot_c,es_c,dum1,qs_c,dum2) - - qbot_c = qbot_g*(qs_c/qs_g) - - ! For forc_rho_c: We could simply set: - ! - ! rhos_c = rhos(pbot_c, egcm_c, tbot_c) - ! - ! However, we want forc_rho_c to be identical to forc_rho_g when topo_c equals - ! forc_topo_g. So we compute our own version of forc_rho_g using the rhos - ! function, and then multiply forc_rho_g by the ratio of (computed column-level - ! rho) to (computed gridcell-level rho). - rhos_c_estimate = rhos(qbot=qbot_c, pbot=pbot_c, tbot=tbot_c) - rhos_g_estimate = rhos(qbot=qbot_g, pbot=pbot_g, tbot=tbot_g) - rhos_c = rhos_g * (rhos_c_estimate / rhos_g_estimate) - - forc_t_c(c) = tbot_c - forc_th_c(c) = thbot_c - forc_q_c(c) = qbot_c - forc_pbot_c(c) = pbot_c - forc_rho_c(c) = rhos_c - - end do - - call partition_precip(bounds, atm2lnd_inst, & - eflx_sh_precip_conversion(bounds%begc:bounds%endc)) - - call downscale_longwave(bounds, downscale_filter_c, topo_inst, atm2lnd_inst) - - call check_downscale_consistency(bounds, atm2lnd_inst) - - end associate - - end subroutine downscale_forcings - - !----------------------------------------------------------------------- - pure function rhos(qbot, pbot, tbot) - ! - ! !DESCRIPTION: - ! Compute atmospheric density (kg/m**3) - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8) :: rhos ! function result: atmospheric density (kg/m**3) - real(r8), intent(in) :: qbot ! atmospheric specific humidity (kg/kg) - real(r8), intent(in) :: pbot ! atmospheric pressure (Pa) - real(r8), intent(in) :: tbot ! atmospheric temperature (K) - ! - ! !LOCAL VARIABLES: - real(r8) :: egcm - - character(len=*), parameter :: subname = 'rhos' - !----------------------------------------------------------------------- - - egcm = qbot*pbot / & - (wv_to_dair_weight_ratio + (1._r8 - wv_to_dair_weight_ratio)*qbot) - rhos = (pbot - (1._r8 - wv_to_dair_weight_ratio)*egcm) / (rair*tbot) - - end function rhos - - !----------------------------------------------------------------------- - subroutine partition_precip(bounds, atm2lnd_inst, eflx_sh_precip_conversion) - ! - ! !DESCRIPTION: - ! Partition precipitation into rain/snow based on temperature. - ! - ! Note that, unlike the other downscalings done here, this is currently applied over - ! all points - not just those within the downscale filter. - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - type(atm2lnd_type) , intent(inout) :: atm2lnd_inst - real(r8), intent(inout) :: eflx_sh_precip_conversion(bounds%begc:) ! sensible heat flux from precipitation conversion (W/m**2) [+ to atm] - ! - ! !LOCAL VARIABLES: - integer :: c,l,g ! indices - real(r8) :: rain_old ! rain before conversion - real(r8) :: snow_old ! snow before conversion - real(r8) :: all_snow_t ! temperature at which all precip falls as snow (K) - real(r8) :: frac_rain_slope ! slope of the frac_rain vs. temperature relationship - - character(len=*), parameter :: subname = 'partition_precip' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(eflx_sh_precip_conversion) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - associate(& - ! Gridcell-level non-downscaled fields: - forc_rain_g => atm2lnd_inst%forc_rain_not_downscaled_grc , & ! Input: [real(r8) (:)] rain rate [mm/s] - forc_snow_g => atm2lnd_inst%forc_snow_not_downscaled_grc , & ! Input: [real(r8) (:)] snow rate [mm/s] - - ! Column-level downscaled fields: - forc_t_c => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:)] atmospheric temperature (Kelvin) - forc_rain_c => atm2lnd_inst%forc_rain_downscaled_col , & ! Output: [real(r8) (:)] rain rate [mm/s] - forc_snow_c => atm2lnd_inst%forc_snow_downscaled_col & ! Output: [real(r8) (:)] snow rate [mm/s] - ) - - ! Initialize column forcing - do c = bounds%begc,bounds%endc - if (col%active(c)) then - g = col%gridcell(c) - forc_rain_c(c) = forc_rain_g(g) - forc_snow_c(c) = forc_snow_g(g) - eflx_sh_precip_conversion(c) = 0._r8 - end if - end do - - ! Optionally, convert rain to snow or vice versa based on forc_t_c - if (atm2lnd_inst%params%repartition_rain_snow) then - do c = bounds%begc, bounds%endc - if (col%active(c)) then - l = col%landunit(c) - rain_old = forc_rain_c(c) - snow_old = forc_snow_c(c) - if (lun%itype(l) == istice_mec) then - all_snow_t = atm2lnd_inst%params%precip_repartition_glc_all_snow_t - frac_rain_slope = atm2lnd_inst%params%precip_repartition_glc_frac_rain_slope - else - all_snow_t = atm2lnd_inst%params%precip_repartition_nonglc_all_snow_t - frac_rain_slope = atm2lnd_inst%params%precip_repartition_nonglc_frac_rain_slope - end if - call repartition_rain_snow_one_col(& - temperature = forc_t_c(c), & - all_snow_t = all_snow_t, & - frac_rain_slope = frac_rain_slope, & - rain = forc_rain_c(c), & - snow = forc_snow_c(c)) - call sens_heat_from_precip_conversion(& - rain_old = rain_old, & - snow_old = snow_old, & - rain_new = forc_rain_c(c), & - snow_new = forc_snow_c(c), & - sens_heat_flux = eflx_sh_precip_conversion(c)) - end if - end do - end if - - end associate - - end subroutine partition_precip - - !----------------------------------------------------------------------- - subroutine repartition_rain_snow_one_col(temperature, all_snow_t, frac_rain_slope, & - rain, snow) - ! - ! !DESCRIPTION: - ! Re-partition precipitation into rain/snow for a single column. - ! - ! Rain and snow variables should be set initially, and are updated here - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: temperature ! near-surface temperature (K) - real(r8) , intent(in) :: all_snow_t ! temperature at which precip falls entirely as snow (K) - real(r8) , intent(in) :: frac_rain_slope ! slope of the frac_rain vs. T relationship - real(r8) , intent(inout) :: rain ! atm rain rate [mm/s] - real(r8) , intent(inout) :: snow ! atm snow rate [(mm water equivalent)/s] - ! - ! !LOCAL VARIABLES: - real(r8) :: frac_rain ! fraction of precipitation that should become rain - real(r8) :: total_precip - - character(len=*), parameter :: subname = 'repartition_rain_snow_one_col' - !----------------------------------------------------------------------- - - frac_rain = (temperature - all_snow_t) * frac_rain_slope - - ! bound in [0,1] - frac_rain = min(1.0_r8,max(0.0_r8,frac_rain)) - - total_precip = rain + snow - rain = total_precip * frac_rain - snow = total_precip - rain - - end subroutine repartition_rain_snow_one_col - - !----------------------------------------------------------------------- - subroutine sens_heat_from_precip_conversion(rain_old, snow_old, rain_new, snow_new, & - sens_heat_flux) - ! - ! !DESCRIPTION: - ! Given old and new rain and snow amounts, compute the sensible heat flux needed to - ! compensate for the rain-snow conversion. - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: rain_old ! [mm/s] - real(r8), intent(in) :: snow_old ! [(mm water equivalent)/s] - real(r8), intent(in) :: rain_new ! [mm/s] - real(r8), intent(in) :: snow_new ! [(mm water equivalent)/s] - real(r8), intent(out) :: sens_heat_flux ! [W/m^2] - ! - ! !LOCAL VARIABLES: - real(r8) :: total_old - real(r8) :: total_new - real(r8) :: rain_to_snow ! net conversion of rain to snow - - real(r8), parameter :: mm_to_m = 1.e-3_r8 ! multiply by this to convert from mm to m - real(r8), parameter :: tol = 1.e-13_r8 ! relative tolerance for error checks - - character(len=*), parameter :: subname = 'sens_heat_from_precip_conversion' - !----------------------------------------------------------------------- - - total_old = rain_old + snow_old - total_new = rain_new + snow_new - SHR_ASSERT(abs(total_new - total_old) <= (tol * total_old), subname//' ERROR: mismatch between old and new totals') - - ! rain to snow releases energy, so results in a positive heat flux to atm - rain_to_snow = snow_new - snow_old - sens_heat_flux = rain_to_snow * mm_to_m * denh2o * hfus - - end subroutine sens_heat_from_precip_conversion - - - !----------------------------------------------------------------------- - subroutine downscale_longwave(bounds, downscale_filter_c, & - topo_inst, atm2lnd_inst) - ! - ! !DESCRIPTION: - ! Downscale longwave radiation from gridcell to column - ! Must be done AFTER temperature downscaling - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - type(filter_col_type) , intent(in) :: downscale_filter_c - class(topo_type) , intent(in) :: topo_inst - type(atm2lnd_type) , intent(inout) :: atm2lnd_inst - ! - ! !LOCAL VARIABLES: - integer :: c,l,g,fc ! indices - real(r8) :: hsurf_c ! column-level elevation (m) - real(r8) :: hsurf_g ! gridcell-level elevation (m) - - real(r8), dimension(bounds%begg : bounds%endg) :: sum_lwrad_g ! weighted sum of column-level lwrad - real(r8), dimension(bounds%begg : bounds%endg) :: sum_wts_g ! sum of weights that contribute to sum_lwrad_g - real(r8), dimension(bounds%begg : bounds%endg) :: lwrad_norm_g ! normalization factors - real(r8), dimension(bounds%begg : bounds%endg) :: newsum_lwrad_g ! weighted sum of column-level lwrad after normalization - - character(len=*), parameter :: subname = 'downscale_longwave' - !----------------------------------------------------------------------- - - associate(& - ! Parameters: - lapse_rate_longwave => atm2lnd_inst%params%lapse_rate_longwave , & ! Input: [real(r8)] longwave radiation lapse rate (W m-2 m-1) - longwave_downscaling_limit => atm2lnd_inst%params%longwave_downscaling_limit, & ! Input: [real(r8)] Relative limit for how much longwave downscaling can be done (unitless) - - ! Gridcell-level metadata: - forc_topo_g => atm2lnd_inst%forc_topo_grc , & ! Input: [real(r8) (:)] atmospheric surface height (m) - - ! Column-level metadata: - topo_c => topo_inst%topo_col , & ! Input: [real(r8) (:)] column surface height (m) - - ! Gridcell-level fields: - forc_lwrad_g => atm2lnd_inst%forc_lwrad_not_downscaled_grc, & ! Input: [real(r8) (:)] downward longwave (W/m**2) - - ! Column-level (downscaled) fields: - forc_lwrad_c => atm2lnd_inst%forc_lwrad_downscaled_col & ! Output: [real(r8) (:)] downward longwave (W/m**2) - ) - - ! Initialize column forcing (needs to be done for ALL active columns) - do c = bounds%begc, bounds%endc - if (col%active(c)) then - g = col%gridcell(c) - forc_lwrad_c(c) = forc_lwrad_g(g) - end if - end do - - ! Optionally, downscale the longwave radiation, conserving energy - if (atm2lnd_inst%params%glcmec_downscale_longwave) then - - ! Initialize variables related to normalization - do g = bounds%begg, bounds%endg - sum_lwrad_g(g) = 0._r8 - sum_wts_g(g) = 0._r8 - newsum_lwrad_g(g) = 0._r8 - end do - - ! Do the downscaling - do fc = 1, downscale_filter_c%num - c = downscale_filter_c%indices(fc) - l = col%landunit(c) - g = col%gridcell(c) - - hsurf_g = forc_topo_g(g) - hsurf_c = topo_c(c) - - ! Assume a linear decrease in downwelling longwave radiation with increasing - ! elevation, based on Van Tricht et al. (2016, TC) Figure 6, - ! doi:10.5194/tc-10-2379-2016 - forc_lwrad_c(c) = forc_lwrad_g(g) - lapse_rate_longwave * (hsurf_c-hsurf_g) - ! But ensure that we don't depart too far from the atmospheric forcing value: - ! negative values of lwrad are certainly bad, but small positive values might - ! also be bad. We can especially run into trouble due to the normalization: a - ! small lwrad value in one column can lead to a big normalization factor, - ! leading to huge lwrad values in other columns. - forc_lwrad_c(c) = min(forc_lwrad_c(c), & - forc_lwrad_g(g) * (1._r8 + longwave_downscaling_limit)) - forc_lwrad_c(c) = max(forc_lwrad_c(c), & - forc_lwrad_g(g) * (1._r8 - longwave_downscaling_limit)) - - ! Keep track of the gridcell-level weighted sum for later normalization. - ! - ! This gridcell-level weighted sum just includes points for which we do the - ! downscaling (e.g., glc_mec points). Thus the contributing weights - ! generally do not add to 1. So to do the normalization properly, we also - ! need to keep track of the weights that have contributed to this sum. - sum_lwrad_g(g) = sum_lwrad_g(g) + col%wtgcell(c)*forc_lwrad_c(c) - sum_wts_g(g) = sum_wts_g(g) + col%wtgcell(c) - end do - - - ! Normalize forc_lwrad_c(c) to conserve energy - - call build_normalization(orig_field=forc_lwrad_g(bounds%begg:bounds%endg), & - sum_field=sum_lwrad_g(bounds%begg:bounds%endg), & - sum_wts=sum_wts_g(bounds%begg:bounds%endg), & - norms=lwrad_norm_g(bounds%begg:bounds%endg)) - - do fc = 1, downscale_filter_c%num - c = downscale_filter_c%indices(fc) - l = col%landunit(c) - g = col%gridcell(c) - - forc_lwrad_c(c) = forc_lwrad_c(c) * lwrad_norm_g(g) - newsum_lwrad_g(g) = newsum_lwrad_g(g) + col%wtgcell(c)*forc_lwrad_c(c) - end do - - - ! Make sure that, after normalization, the grid cell mean is conserved - - do g = bounds%begg, bounds%endg - if (sum_wts_g(g) > 0._r8) then - if (abs((newsum_lwrad_g(g) / sum_wts_g(g)) - forc_lwrad_g(g)) > 1.e-8_r8) then - write(iulog,*) 'g, newsum_lwrad_g, sum_wts_g, forc_lwrad_g: ', & - g, newsum_lwrad_g(g), sum_wts_g(g), forc_lwrad_g(g) - call endrun(msg=' ERROR: Energy conservation error downscaling longwave'//& - errMsg(sourcefile, __LINE__)) - end if - end if - end do - - end if ! glcmec_downscale_longwave - - end associate - - end subroutine downscale_longwave - - !----------------------------------------------------------------------- - subroutine build_normalization(orig_field, sum_field, sum_wts, norms) - ! - ! !DESCRIPTION: - ! Build an array of normalization factors that can be applied to a downscaled forcing - ! field, in order to force the mean of the new field to be the same as the mean of - ! the old field (for conservation). - ! - ! This allows for the possibility that only a subset of columns are downscaled. Only - ! the columns that are adjusted should be included in the weighted sum, sum_field; - ! sum_wts gives the sum of contributing weights on the grid cell level. - - ! For example, if a grid cell has an original forcing value of 1.0, and contains 4 - ! columns with the following weights on the gridcell, and the following values after - ! normalization: - ! - ! col #: 1 2 3 4 - ! weight: 0.1 0.2 0.3 0.4 - ! downscaled?: yes yes no no - ! value: 0.9 1.1 1.0 1.0 - ! - ! Then we would have: - ! orig_field(g) = 1.0 - ! sum_field(g) = 0.1*0.9 + 0.2*1.1 = 0.31 - ! sum_wts(g) = 0.1 + 0.2 = 0.3 - ! norms(g) = 1.0 / (0.31 / 0.3) = 0.9677 - ! - ! The field can then be normalized as: - ! forc_lwrad_c(c) = forc_lwrad_c(c) * lwrad_norm_g(g) - ! where lwrad_norm_g is the array of norms computed by this routine - - ! - ! !ARGUMENTS: - real(r8), intent(in) :: orig_field(:) ! the original field, at the grid cell level - real(r8), intent(in) :: sum_field(:) ! the new weighted sum across columns (dimensioned by grid cell) - real(r8), intent(in) :: sum_wts(:) ! sum of the weights used to create sum_field (dimensioned by grid cell) - real(r8), intent(out) :: norms(:) ! computed normalization factors - !----------------------------------------------------------------------- - - SHR_ASSERT((size(orig_field) == size(norms)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT((size(sum_field) == size(norms)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT((size(sum_wts) == size(norms)), errMsg(sourcefile, __LINE__)) - - where (sum_wts == 0._r8) - ! Avoid divide by zero; if sum_wts is 0, then the normalization doesn't matter, - ! because the adjusted values won't affect the grid cell mean. - norms = 1.0_r8 - - elsewhere (sum_field == 0._r8) - ! Avoid divide by zero. If this is because both sum_field and orig_field are 0, - ! then the normalization doesn't matter. If sum_field == 0 while orig_field /= 0, - ! then we have a problem: no normalization will allow us to recover the original - ! gridcell mean. We should probably catch this and abort, but for now we're - ! relying on error checking in the caller (checking for conservation) to catch - ! this potential problem. - norms = 1.0_r8 - - elsewhere - ! The standard case - norms = orig_field / (sum_field / sum_wts) - - end where - - end subroutine build_normalization - - - !----------------------------------------------------------------------- - subroutine check_downscale_consistency(bounds, atm2lnd_inst) - ! - ! !DESCRIPTION: - ! Check consistency of downscaling - ! - ! Note that this operates over more than just the filter used for the downscaling, - ! because it checks some things outside that filter. - ! - ! !ARGUMENTS: - implicit none - type(bounds_type) , intent(in) :: bounds - type(atm2lnd_type), intent(in) :: atm2lnd_inst - ! - ! !LOCAL VARIABLES: - integer :: g, l, c ! indices - character(len=*), parameter :: subname = 'check_downscale_consistency' - !----------------------------------------------------------------------- - - associate(& - ! Gridcell-level fields: - forc_t_g => atm2lnd_inst%forc_t_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric temperature (Kelvin) - forc_th_g => atm2lnd_inst%forc_th_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric potential temperature (Kelvin) - forc_q_g => atm2lnd_inst%forc_q_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric specific humidity (kg/kg) - forc_pbot_g => atm2lnd_inst%forc_pbot_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric pressure (Pa) - forc_rho_g => atm2lnd_inst%forc_rho_not_downscaled_grc , & ! Input: [real(r8) (:)] atmospheric density (kg/m**3) - forc_rain_g => atm2lnd_inst%forc_rain_not_downscaled_grc , & ! Input: [real(r8) (:)] rain rate [mm/s] - forc_snow_g => atm2lnd_inst%forc_snow_not_downscaled_grc , & ! Input: [real(r8) (:)] snow rate [mm/s] - forc_lwrad_g => atm2lnd_inst%forc_lwrad_not_downscaled_grc , & ! Input: [real(r8) (:)] downward longwave (W/m**2) - - ! Column-level (downscaled) fields: - forc_t_c => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:)] atmospheric temperature (Kelvin) - forc_th_c => atm2lnd_inst%forc_th_downscaled_col , & ! Input: [real(r8) (:)] atmospheric potential temperature (Kelvin) - forc_q_c => atm2lnd_inst%forc_q_downscaled_col , & ! Input: [real(r8) (:)] atmospheric specific humidity (kg/kg) - forc_pbot_c => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:)] atmospheric pressure (Pa) - forc_rho_c => atm2lnd_inst%forc_rho_downscaled_col , & ! Input: [real(r8) (:)] atmospheric density (kg/m**3) - forc_rain_c => atm2lnd_inst%forc_rain_downscaled_col , & ! Input: [real(r8) (:)] rain rate [mm/s] - forc_snow_c => atm2lnd_inst%forc_snow_downscaled_col , & ! Input: [real(r8) (:)] snow rate [mm/s] - forc_lwrad_c => atm2lnd_inst%forc_lwrad_downscaled_col & ! Input: [real(r8) (:)] downward longwave (W/m**2) - ) - - ! BUG(wjs, 2016-11-15, bugz 2377) - ! - ! Make sure that, for urban points, the column-level forcing fields are identical to - ! the gridcell-level forcing fields. This is needed because the urban-specific code - ! sometimes uses the gridcell-level forcing fields (and it would take a large - ! refactor to change this to use column-level fields). - ! - ! However, do NOT check rain & snow: these ARE downscaled for urban points (as for - ! all other points), and the urban code does not refer to the gridcell-level versions - ! of these fields. - - do c = bounds%begc, bounds%endc - if (col%active(c)) then - l = col%landunit(c) - g = col%gridcell(c) - - if (lun%urbpoi(l)) then - if (forc_t_c(c) /= forc_t_g(g) .or. & - forc_th_c(c) /= forc_th_g(g) .or. & - forc_q_c(c) /= forc_q_g(g) .or. & - forc_pbot_c(c) /= forc_pbot_g(g) .or. & - forc_rho_c(c) /= forc_rho_g(g) .or. & - forc_lwrad_c(c) /= forc_lwrad_g(g)) then - write(iulog,*) subname//' ERROR: column-level forcing differs from gridcell-level forcing for urban point' - write(iulog,*) 'c, g = ', c, g - write(iulog,*) 'forc_t_c, forc_t_g = ', forc_t_c(c), forc_t_g(g) - write(iulog,*) 'forc_th_c, forc_th_g = ', forc_th_c(c), forc_th_g(g) - write(iulog,*) 'forc_q_c, forc_q_g = ', forc_q_c(c), forc_q_g(g) - write(iulog,*) 'forc_pbot_c, forc_pbot_g = ', forc_pbot_c(c), forc_pbot_g(g) - write(iulog,*) 'forc_rho_c, forc_rho_g = ', forc_rho_c(c), forc_rho_g(g) - write(iulog,*) 'forc_lwrad_c, forc_lwrad_g = ', forc_lwrad_c(c), forc_lwrad_g(g) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if ! inequal - end if ! urbpoi - end if ! active - end do - - end associate - - end subroutine check_downscale_consistency - -end module atm2lndMod diff --git a/src/main/atm2lndType.F90 b/src/main/atm2lndType.F90 index 8b2d72e0..cf065145 100644 --- a/src/main/atm2lndType.F90 +++ b/src/main/atm2lndType.F90 @@ -8,12 +8,12 @@ module atm2lndType 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. ! MML: numrad = 2, 1=vis, 2=nir - use clm_varcon , only : rair, grav, cpair, hfus, tfrz, spval - use clm_varctl , only : iulog, use_cn, use_cndv, use_fates, use_luna + use clm_varpar , only : numrad ! MML: numrad = 2, 1=vis, 2=nir + use clm_varcon , only : spval + use clm_varctl , only : iulog use decompMod , only : bounds_type use abortutils , only : endrun - use PatchType , only : patch +! use PatchType , only : patch ! ! !PUBLIC TYPES: implicit none @@ -21,38 +21,6 @@ module atm2lndType 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 ! @@ -68,39 +36,26 @@ module atm2lndType ! MML: I don't think this applies to me... I'm working at the grc level, not the col level... !---------------------------------------------------- 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) ! mml maybe use these real(r8), pointer :: forc_vp_grc (:) => null() ! atmospheric vapor pressure (Pa) - real(r8), pointer :: forc_rh_grc (:) => null() ! atmospheric relative humidity (%) real(r8), pointer :: forc_psrf_grc (:) => null() ! surface 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_q_not_downscaled_grc (:) => null() ! not downscaled atm specific humidity (kg/kg) ! MML: I think this is the q I need to check if the negative LH is too big. 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_rain_not_downscaled_grc (:) => null() ! not downscaled atm rain rate [mm/s] real(r8), pointer :: forc_snow_not_downscaled_grc (:) => null() ! not downscaled atm snow rate [mm/s] @@ -183,7 +138,6 @@ module atm2lndType real(r8), pointer :: mml_atm_rhomol_grc (:) => null() ! molar density of air at ref height [mol/m3] real(r8), pointer :: mml_atm_rhoair_grc (:) => null() ! density of air at ref height [kg/m3] real(r8), pointer :: mml_atm_cp_grc (:) => null() ! specific heat of air at const pressure + ref height [J/kg/K] - real(r8), pointer :: mml_atm_pco2 (:) => null() ! partial pressure of co2 ! Hydrology: real(r8), pointer :: mml_atm_prec_liq_grc (:) => null() ! liquid precipitation (rain) [mm/s] ! MML 20180615 - bug: used to say m/s, changing to mm/s real(r8), pointer :: mml_atm_prec_frz_grc (:) => null() ! frozen precipitation (snow) [mm/s] @@ -276,224 +230,37 @@ module atm2lndType ! ------------------------------------------------------------------------------------ - - - ! 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_q_downscaled_col (:) => null() ! downscaled atm specific humidity (kg/kg) - 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_rain_downscaled_col (:) => null() ! downscaled atm rain rate [mm/s] - real(r8), pointer :: forc_snow_downscaled_col (:) => null() ! downscaled atm snow rate [mm/s] - real(r8), pointer :: forc_lwrad_downscaled_col (:) => null() ! downscaled atm downwrd IR longwave radiation (W/m**2) - - ! rof->lnd - real(r8), pointer :: forc_flood_grc (:) => null() ! rof flood (mm/s) - real(r8), pointer :: volr_grc (:) => null() ! rof volr total volume (m3) - real(r8), pointer :: volrmch_grc (:) => null() ! rof volr main channel (m3) - - ! anomaly forcing - real(r8), pointer :: af_precip_grc (:) => null() ! anomaly forcing - real(r8), pointer :: af_uwind_grc (:) => null() ! anomaly forcing - real(r8), pointer :: af_vwind_grc (:) => null() ! anomaly forcing - real(r8), pointer :: af_tbot_grc (:) => null() ! anomaly forcing - real(r8), pointer :: af_pbot_grc (:) => null() ! anomaly forcing - real(r8), pointer :: af_shum_grc (:) => null() ! anomaly forcing - real(r8), pointer :: af_swdn_grc (:) => null() ! anomaly forcing - real(r8), pointer :: af_lwdn_grc (:) => null() ! anomaly forcing - real(r8), pointer :: bc_precip_grc (:) => null() ! anomaly forcing - add bias correction ! 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 :: prec365_col (:) => null() ! 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 (:) => null() ! patch 60-day running mean of tot. precipitation (mm/s) - real(r8) , pointer :: prec10_patch (:) => null() ! patch 10-day running mean of tot. precipitation (mm/s) - real(r8) , pointer :: rh30_patch (:) => null() ! patch 30-day running mean of relative humidity - real(r8) , pointer :: prec24_patch (:) => null() ! patch 24-hour running mean of tot. precipitation (mm/s) - real(r8) , pointer :: rh24_patch (:) => null() ! patch 24-hour running mean of relative humidity - 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) +! real(r8) , pointer :: fsd240_patch (:) => null() ! patch 240hr average of direct beam radiation contains procedure, public :: Init - procedure, public :: InitForTesting ! version of Init meant for unit testing - procedure, private :: ReadNamelist procedure, private :: InitAllocate procedure, private :: InitHistory procedure, private :: InitCold ! MML 2016.01.15 adding InitCold to give accumulating variables a starting point - procedure, public :: InitAccBuffer - procedure, public :: InitAccVars - procedure, public :: UpdateAccVars +! 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) + subroutine Init(this, bounds) 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) ! MML 2016.01.15 adding call to InitCold (make sure it doesn't keep using the @@ -502,156 +269,6 @@ subroutine Init(this, bounds, NLFilename) 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 - write(iulog,*) "could NOT find "//nmlname//"namelist" - 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) ! @@ -665,46 +282,28 @@ subroutine InitAllocate(this, 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_rh_grc (begg:endg)) ; this%forc_rh_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_psrf_grc (begg:endg)) ; this%forc_psrf_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_q_not_downscaled_grc (begg:endg)) ; this%forc_q_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 allocate(this%forc_rain_not_downscaled_grc (begg:endg)) ; this%forc_rain_not_downscaled_grc (:) = ival @@ -757,7 +356,6 @@ subroutine InitAllocate(this, bounds) allocate(this%mml_atm_rhomol_grc (begg:endg)) ; this%mml_atm_rhomol_grc (:) = ival allocate(this%mml_atm_rhoair_grc (begg:endg)) ; this%mml_atm_rhoair_grc (:) = ival allocate(this%mml_atm_cp_grc (begg:endg)) ; this%mml_atm_cp_grc (:) = ival - allocate(this%mml_atm_pco2 (begg:endg)) ; this%mml_atm_pco2 (:) = ival allocate(this%mml_atm_prec_liq_grc (begg:endg)) ; this%mml_atm_prec_liq_grc (:) = ival allocate(this%mml_atm_prec_frz_grc (begg:endg)) ; this%mml_atm_prec_frz_grc (:) = ival @@ -847,48 +445,7 @@ subroutine InitAllocate(this, bounds) ! --------------------------------------- - - ! atm->lnd downscaled - allocate(this%forc_t_downscaled_col (begc:endc)) ; this%forc_t_downscaled_col (:) = ival - allocate(this%forc_q_downscaled_col (begc:endc)) ; this%forc_q_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%forc_rain_downscaled_col (begc:endc)) ; this%forc_rain_downscaled_col (:) = ival - allocate(this%forc_snow_downscaled_col (begc:endc)) ; this%forc_snow_downscaled_col (:) = ival - - ! rof->lnd - allocate(this%forc_flood_grc (begg:endg)) ; this%forc_flood_grc (:) = ival - allocate(this%volr_grc (begg:endg)) ; this%volr_grc (:) = ival - allocate(this%volrmch_grc (begg:endg)) ; this%volrmch_grc (:) = ival - - ! anomaly forcing - allocate(this%bc_precip_grc (begg:endg)) ; this%bc_precip_grc (:) = ival - allocate(this%af_precip_grc (begg:endg)) ; this%af_precip_grc (:) = ival - allocate(this%af_uwind_grc (begg:endg)) ; this%af_uwind_grc (:) = ival - allocate(this%af_vwind_grc (begg:endg)) ; this%af_vwind_grc (:) = ival - allocate(this%af_tbot_grc (begg:endg)) ; this%af_tbot_grc (:) = ival - allocate(this%af_pbot_grc (begg:endg)) ; this%af_pbot_grc (:) = ival - allocate(this%af_shum_grc (begg:endg)) ; this%af_shum_grc (:) = ival - allocate(this%af_swdn_grc (begg:endg)) ; this%af_swdn_grc (:) = ival - allocate(this%af_lwdn_grc (begg:endg)) ; this%af_lwdn_grc (:) = 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 - allocate(this%prec10_patch (begp:endp)) ; this%prec10_patch (:) = nan - allocate(this%prec60_patch (begp:endp)) ; this%prec60_patch (:) = nan - allocate(this%rh30_patch (begp:endp)) ; this%rh30_patch (:) = nan - allocate(this%prec365_col (begc:endc)) ; this%prec365_col (:) = 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 - 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 +! allocate(this%fsd240_patch (begp:endp)) ; this%fsd240_patch (:) = nan end subroutine InitAllocate @@ -898,7 +455,7 @@ subroutine InitHistory(this, bounds) ! !USES: ! use histFileMod, only : hist_addfld1d ! MML: - use histFileMod, only : hist_addfld1d, hist_addfld2d, hist_addfld_decomp + use histFileMod, only : hist_addfld1d, hist_addfld2d ! ! !ARGUMENTS: class(atm2lnd_type) :: this @@ -906,8 +463,6 @@ subroutine InitHistory(this, bounds) ! ! !LOCAL VARIABLES: integer :: begg, endg - integer :: begc, endc - integer :: begp, endp integer :: mml_nsoi ! number of soil levels !--------------------------------------------------------------------- @@ -915,94 +470,29 @@ subroutine InitHistory(this, bounds) mml_nsoi = 10 begg = bounds%begg; endg= bounds%endg - begc = bounds%begc; endc= bounds%endc - begp = bounds%begp; endp= bounds%endp !write(iulog,*) 'MML trying write h0 - start' - this%forc_flood_grc(begg:endg) = spval - call hist_addfld1d (fname='QFLOOD', units='mm/s', & - avgflag='A', long_name='runoff from river flooding', & - ptr_lnd=this%forc_flood_grc) - - this%volr_grc(begg:endg) = spval - call hist_addfld1d (fname='VOLR', units='m3', & - avgflag='A', long_name='river channel total water storage', & - ptr_lnd=this%volr_grc) - - this%volrmch_grc(begg:endg) = spval - call hist_addfld1d (fname='VOLRMCH', units='m3', & - avgflag='A', long_name='river channel main channel water storage', & - ptr_lnd=this%volrmch_grc) - 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') - - this%forc_rh_grc(begg:endg) = spval - call hist_addfld1d (fname='RH', units='%', & - avgflag='A', long_name='atmospheric relative humidity', & - ptr_gcell=this%forc_rh_grc, default='inactive') - 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') - this%forc_rain_not_downscaled_grc(begg:endg) = spval call hist_addfld1d (fname='RAIN_FROM_ATM', units='mm/s', & avgflag='A', long_name='atmospheric rain received from atmosphere (pre-repartitioning)', & @@ -1013,41 +503,6 @@ subroutine InitHistory(this, bounds) avgflag='A', long_name='atmospheric snow received from atmosphere (pre-repartitioning)', & ptr_lnd=this%forc_snow_not_downscaled_grc) - this%forc_rain_downscaled_col(begc:endc) = spval - call hist_addfld1d (fname='RAIN', units='mm/s', & - avgflag='A', long_name='atmospheric rain, after rain/snow repartitioning based on temperature', & - ptr_col=this%forc_rain_downscaled_col) - call hist_addfld1d (fname='Rainf', units='mm/s', & - avgflag='A', long_name='atmospheric rain, after rain/snow repartitioning based on temperature', & - ptr_col=this%forc_rain_downscaled_col, default='inactive') - - this%forc_snow_downscaled_col(begc:endc) = spval - call hist_addfld1d (fname='SNOW', units='mm/s', & - avgflag='A', long_name='atmospheric snow, after rain/snow repartitioning based on temperature', & - ptr_col=this%forc_snow_downscaled_col) - - 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) - -! ! MML: 2016.01.14 Try and add a new history field variable equal to 2TBOT -! ! (just to see if it will print) -! this%forc_2t_not_downscaled_grc(begg:endg) = spval -! call hist_addfld1d (fname='T2BOT', units='K', & -! avgflag='A', long_name='2x atmospheric air temperature MML Test', & -! ptr_lnd=this%forc_2t_not_downscaled_grc) - - this%forc_q_downscaled_col(begc:endc) = spval - call hist_addfld1d (fname='QBOT', units='kg/kg', & - avgflag='A', long_name='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='Qair', units='kg/kg', & - avgflag='A', long_name='atmospheric specific humidity (downscaled to columns in glacier regions)', & - ptr_col=this%forc_q_downscaled_col, default='inactive') - - !----------------------------------------------------------------------- ! MML: 2016.01.14 Simple Land Energy and Hydrology variables (gridscale) @@ -1057,57 +512,57 @@ subroutine InitHistory(this, bounds) ! (don't typically print these - waste of space. But for now, could be useful... ! Skipping because I'm lazy; add later ! this%mml_nc_alb_grc(begg:endg) = spval -! call hist_addfld1d (fname='MML_albdeo', units='unitless', & -! avgflag='A', long_name='MML prescribed snow-free surface albedo', & +! call hist_addfld1d (fname='albedo', units='unitless', & +! avgflag='A', long_name='prescribed snow-free surface albedo', & ! ptr_lnd=this%mml_nc_alb_grc) ! ! this%mml_nc_snoalb_grc(begg:endg) = spval -! call hist_addfld1d (fname='MML_snow_albdeo', units='unitless', & -! avgflag='A', long_name='MML prescribed deep-snow albedo', & +! call hist_addfld1d (fname='snow_albedo', units='unitless', & +! avgflag='A', long_name='prescribed deep-snow albedo', & ! ptr_lnd=this%mml_nc_snoalb_grc) this%mml_nc_snowmask_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_snowmaskdepth', units='kg/m2', & - avgflag='A', long_name='MML snow required to toggle deep snow albedo', & + call hist_addfld1d (fname='snowmaskdepth', units='kg/m2', & + avgflag='A', long_name='snow required to toggle deep snow albedo', & ptr_lnd=this%mml_nc_snowmask_grc) this%mml_nc_evaprs_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_evap_rs', units='s/m', & - avgflag='A', long_name='MML like stomatal resistance of soil', & + call hist_addfld1d (fname='evap_rs', units='s/m', & + avgflag='A', long_name='like stomatal resistance of soil', & ptr_lnd=this%mml_nc_evaprs_grc) this%mml_nc_bucket_cap_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_bucket_cap', units='kg/m2', & - avgflag='A', long_name='MML soil water bucket capacity (maximum water soil can hold)', & + call hist_addfld1d (fname='bucket_cap', units='kg/m2', & + avgflag='A', long_name='soil water bucket capacity (maximum water soil can hold)', & ptr_lnd=this%mml_nc_bucket_cap_grc) !this%mml_nc_soil_maxice_grc(begg:endg,:) = spval - !call hist_addfld1d (fname='MML_maxice', units='kg/m3', & - ! avgflag='A', long_name='MML maximum freezable water in each soil layer; for thermal calculations', & + !call hist_addfld1d (fname='maxice', units='kg/m3', & + ! avgflag='A', long_name='maximum freezable water in each soil layer; for thermal calculations', & ! ptr_lnd=this%mml_nc_soil_maxice_grc) !data2dptr => this%mml_nc_soil_maxice_grc(begg:endg,:) - !fieldname = 'MML_maxice' - !longname = 'MML maximum freezable water in each soil layer; for thermal calculations' + !fieldname = 'maxice' + !longname = 'maximum freezable water in each soil layer; for thermal calculations' this%mml_nc_soil_type_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_soiltype', units='unitless', & - avgflag='A', long_name='MML Soil type (sand/clay), of 11 possible types; for thermal calculations', & + call hist_addfld1d (fname='soiltype', units='unitless', & + avgflag='A', long_name='Soil type (sand/clay), of 11 possible types; for thermal calculations', & ptr_lnd=this%mml_nc_soil_type_grc) this%mml_nc_roughness_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_roughness', units='m', & - avgflag='A', long_name='MML surface roughness length (e.g. canopy height) ', & + call hist_addfld1d (fname='roughness', units='m', & + avgflag='A', long_name='surface roughness length (e.g. canopy height) ', & ptr_lnd=this%mml_nc_roughness_grc) this%mml_nc_emiss_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_emiss', units='unitless', & - avgflag='A', long_name='MML surface emissivity ', & + call hist_addfld1d (fname='emiss', units='unitless', & + avgflag='A', long_name='surface emissivity ', & ptr_lnd=this%mml_nc_emiss_grc) this%mml_nc_glcmask_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_glcmask', units='unitless', & - avgflag='A', long_name='MML logical mask saying which cells should be treated as glaciers', & + call hist_addfld1d (fname='glcmask', units='unitless', & + avgflag='A', long_name='logical mask saying which cells should be treated as glaciers', & ptr_lnd=this%mml_nc_glcmask_grc) @@ -1115,356 +570,346 @@ subroutine InitHistory(this, bounds) ! Carried from atmosphere: ! write(iulog,*) 'MML write to h0: atm vars ' - this%mml_atm_fsds_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsds', units='W/m2', & - avgflag='A', long_name='MML incoming shortwave radiation', & - ptr_lnd=this%mml_atm_fsds_grc) + this%forc_solar_grc(begg:endg) = spval + call hist_addfld1d (fname='fsds', units='W/m2', & + avgflag='A', long_name='incoming shortwave radiation', & + ptr_lnd=this%forc_solar_grc) this%mml_atm_fsdsnd_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsdsnd', units='W/m2', & - avgflag='A', long_name='MML incoming shortwave nir direct radiation', & + call hist_addfld1d (fname='fsdsnd', units='W/m2', & + avgflag='A', long_name='incoming shortwave nir direct radiation', & ptr_lnd=this%mml_atm_fsdsnd_grc) - - this%mml_atm_fsdsvd_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsdsvd', units='W/m2', & - avgflag='A', long_name='MML incoming shortwave visible direct radiation', & + + this%mml_atm_fsdsvd_grc(begg:endg) = spval + call hist_addfld1d (fname='fsdsvd', units='W/m2', & + avgflag='A', long_name='incoming shortwave visible direct radiation', & ptr_lnd=this%mml_atm_fsdsvd_grc) this%mml_atm_fsdsni_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsdsni', units='W/m2', & - avgflag='A', long_name='MML incoming shortwave nir diffuse radiation', & + call hist_addfld1d (fname='fsdsni', units='W/m2', & + avgflag='A', long_name='incoming shortwave nir diffuse radiation', & ptr_lnd=this%mml_atm_fsdsni_grc) this%mml_atm_fsdsvi_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsdsvi', units='W/m2', & - avgflag='A', long_name='MML incoming shortwave visible diffuse radiation', & + call hist_addfld1d (fname='fsdsvi', units='W/m2', & + avgflag='A', long_name='incoming shortwave visible diffuse radiation', & ptr_lnd=this%mml_atm_fsdsvi_grc) - this%mml_atm_lwdn_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_lwdn', units='W/m2', & - avgflag='A', long_name='MML incoming longwave radiation', & - ptr_lnd=this%mml_atm_lwdn_grc) + this%forc_lwrad_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname='lwdn', units='W/m2', & + avgflag='A', long_name='incoming longwave radiation', & + ptr_lnd=this%forc_lwrad_not_downscaled_grc) - this%mml_atm_zref_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_zref', units='m', & - avgflag='A', long_name='MML height of atm reference level', & - ptr_lnd=this%mml_atm_zref_grc) + this%forc_hgt_grc(begg:endg) = spval + call hist_addfld1d (fname='zref', units='m', & + avgflag='A', long_name='height of atm reference level', & + ptr_lnd=this%forc_hgt_grc) this%mml_atm_tbot_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_tbot', units='K', & - avgflag='A', long_name='MML temperature midpoint of lowest atm layer', & + call hist_addfld1d (fname='tbot', units='K', & + avgflag='A', long_name='temperature midpoint of lowest atm layer', & ptr_lnd=this%mml_atm_tbot_grc) this%mml_atm_thref_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_thref', units='K', & - avgflag='A', long_name='MML potential temperature theta at reference height', & + call hist_addfld1d (fname='thref', units='K', & + avgflag='A', long_name='potential temperature theta at reference height', & ptr_lnd=this%mml_atm_thref_grc) - this%mml_atm_qbot_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_qbot', units='kg/kg', & - avgflag='A', long_name='MML specific humidity midpoint of lowest atm layer', & - ptr_lnd=this%mml_atm_qbot_grc) + this%forc_q_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname='qbot', units='kg/kg', & + avgflag='A', long_name='specific humidity midpoint of lowest atm layer', & + ptr_lnd=this%forc_q_not_downscaled_grc) - this%mml_atm_uref_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_uref', units='m/s', & - avgflag='A', long_name='MML wind speed at reference height', & - ptr_lnd=this%mml_atm_uref_grc) + this%forc_wind_grc(begg:endg) = spval + call hist_addfld1d (fname='uref', units='m/s', & + avgflag='A', long_name='wind speed at reference height', & + ptr_lnd=this%forc_wind_grc) - this%mml_atm_eref_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_eref', units='Pa', & - avgflag='A', long_name='MML vapor pressure at reference height', & - ptr_lnd=this%mml_atm_eref_grc) + this%forc_vp_grc(begg:endg) = spval + call hist_addfld1d (fname='eref', units='Pa', & + avgflag='A', long_name='vapor pressure at reference height', & + ptr_lnd=this%forc_vp_grc) - this%mml_atm_pbot_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_pbot', units='Pa', & - avgflag='A', long_name='MML atmospheric pressure midpoint of lowest atm layer', & - ptr_lnd=this%mml_atm_pbot_grc) + this%forc_pbot_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname='pbot', units='Pa', & + avgflag='A', long_name='atmospheric pressure midpoint of lowest atm layer', & + ptr_lnd=this%forc_pbot_not_downscaled_grc) this%mml_atm_psrf_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_psrf', units='Pa', & - avgflag='A', long_name='MML atmospheric pressure surface', & + call hist_addfld1d (fname='psrf', units='Pa', & + avgflag='A', long_name='atmospheric pressure surface', & ptr_lnd=this%mml_atm_psrf_grc) this%mml_atm_rhomol_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_rhomol', units='mol/m3', & - avgflag='A', long_name='MML molar density of air at reference height', & + call hist_addfld1d (fname='rhomol', units='mol/m3', & + avgflag='A', long_name='molar density of air at reference height', & ptr_lnd=this%mml_atm_rhomol_grc) - this%mml_atm_rhoair_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_rhoair', units='kg/m3', & - avgflag='A', long_name='MML mass density of air at reference height', & - ptr_lnd=this%mml_atm_rhoair_grc) + this%forc_rho_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname='rhoair', units='kg/m3', & + avgflag='A', long_name='mass density of air at reference height', & + ptr_lnd=this%forc_rho_not_downscaled_grc) this%mml_atm_cp_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_cpair', units='J/kg/K', & - avgflag='A', long_name='MML specific heat of air at constant pressure at ref height', & + call hist_addfld1d (fname='cpair', units='J/kg/K', & + avgflag='A', long_name='specific heat of air at constant pressure at ref height', & ptr_lnd=this%mml_atm_cp_grc) - this%mml_atm_pco2(begg:endg) = spval - call hist_addfld1d (fname='MML_pco2', units='Pa', & - avgflag='A', long_name='MML partial pressure of co2', & - ptr_lnd=this%mml_atm_pco2) - - this%mml_atm_prec_liq_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_prec_liq', units='mm/s', & ! or mm/s? - avgflag='A', long_name='MML rate of liquid precipitation (rain)', & - ptr_lnd=this%mml_atm_prec_liq_grc) + this%forc_rain_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname='prec_liq', units='mm/s', & ! or mm/s? + avgflag='A', long_name='rate of liquid precipitation (rain)', & + ptr_lnd=this%forc_rain_not_downscaled_grc) - this%mml_atm_prec_frz_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_prec_frz', units='mm/s', & - avgflag='A', long_name='MML rate of frozen precipitation (snow)', & - ptr_lnd=this%mml_atm_prec_frz_grc) + this%forc_snow_not_downscaled_grc(begg:endg) = spval + call hist_addfld1d (fname='prec_frz', units='mm/s', & + avgflag='A', long_name='rate of frozen precipitation (snow)', & + ptr_lnd=this%forc_snow_not_downscaled_grc) ! Land calculated surface variables !write(iulog,*) 'MML write to h0: 1d land vars ' this%mml_lnd_ts_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_ts', units='K', & - avgflag='A', long_name='MML surface skin temperature', & + call hist_addfld1d (fname='ts', units='K', & + avgflag='A', long_name='surface skin temperature', & ptr_lnd=this%mml_lnd_ts_grc) this%mml_lnd_qs_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_qs', units='kg/kg', & + call hist_addfld1d (fname='qs', units='kg/kg', & avgflag='A', long_name='surface specific humidity [kg/kg] or [mol/mol]', & ptr_lnd=this%mml_lnd_qs_grc) this%mml_lnd_qa_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_qa', units='W/m2', & - avgflag='A', long_name='MML radiative forcing (SWin*albedo + LWin)', & + call hist_addfld1d (fname='qa', units='W/m2', & + avgflag='A', long_name='radiative forcing (SWin*albedo + LWin)', & ptr_lnd=this%mml_lnd_qa_grc) this%mml_lnd_swabs_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_swabs', units='W/m2', & - avgflag='A', long_name='MML absorbed shortwave radiation', & + call hist_addfld1d (fname='swabs', units='W/m2', & + avgflag='A', long_name='absorbed shortwave radiation', & ptr_lnd=this%mml_lnd_swabs_grc) this%mml_lnd_fsr_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsr', units='W/m2', & - avgflag='A', long_name='MML reflected shortwave radation', & + call hist_addfld1d (fname='fsr', units='W/m2', & + avgflag='A', long_name='reflected shortwave radation', & ptr_lnd=this%mml_lnd_fsr_grc) this%mml_lnd_fsrnd_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsrnd', units='W/m2', & - avgflag='A', long_name='MML reflected shortwave nir direct radation', & + call hist_addfld1d (fname='fsrnd', units='W/m2', & + avgflag='A', long_name='reflected shortwave nir direct radation', & ptr_lnd=this%mml_lnd_fsrnd_grc) this%mml_lnd_fsrni_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsrni', units='W/m2', & - avgflag='A', long_name='MML reflected shortwave nir diffuse radation', & + call hist_addfld1d (fname='fsrni', units='W/m2', & + avgflag='A', long_name='reflected shortwave nir diffuse radation', & ptr_lnd=this%mml_lnd_fsrni_grc) this%mml_lnd_fsrvd_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsrvd', units='W/m2', & - avgflag='A', long_name='MML reflected shortwave visible direct radation', & + call hist_addfld1d (fname='fsrvd', units='W/m2', & + avgflag='A', long_name='reflected shortwave visible direct radation', & ptr_lnd=this%mml_lnd_fsrvd_grc) this%mml_lnd_fsrvi_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsrvi', units='W/m2', & - avgflag='A', long_name='MML reflected shortwave visible diffuse radation', & + call hist_addfld1d (fname='fsrvi', units='W/m2', & + avgflag='A', long_name='reflected shortwave visible diffuse radation', & ptr_lnd=this%mml_lnd_fsrvi_grc) this%mml_lnd_lwup_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_lwup', units='W/m2', & - avgflag='A', long_name='MML emitted longwave radiation', & + call hist_addfld1d (fname='lwup', units='W/m2', & + avgflag='A', long_name='emitted longwave radiation', & ptr_lnd=this%mml_lnd_lwup_grc) this%mml_lnd_shflx_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_shflx', units='W/m2', & - avgflag='A', long_name='MML sensible heat flux', & + call hist_addfld1d (fname='shflx', units='W/m2', & + avgflag='A', long_name='sensible heat flux', & ptr_lnd=this%mml_lnd_shflx_grc) this%mml_lnd_lhflx_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_lhflx', units='W/m2', & - avgflag='A', long_name='MML latent heat flux', & + call hist_addfld1d (fname='lhflx', units='W/m2', & + avgflag='A', long_name='latent heat flux', & ptr_lnd=this%mml_lnd_lhflx_grc) this%mml_lnd_gsoi_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_gsoi', units='W/m2', & - avgflag='A', long_name='MML flux of energy into the soil', & + call hist_addfld1d (fname='gsoi', units='W/m2', & + avgflag='A', long_name='flux of energy into the soil', & ptr_lnd=this%mml_lnd_gsoi_grc) this%mml_lnd_gsnow_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_gsnow', units='W/m2', & - avgflag='A', long_name='MML flux of energy into snowmelt', & + call hist_addfld1d (fname='gsnow', units='W/m2', & + avgflag='A', long_name='flux of energy into snowmelt', & ptr_lnd=this%mml_lnd_gsnow_grc) this%mml_lnd_evap_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_evap', units='kg H20 / m2 / s = mm/s', & - avgflag='A', long_name='MML evapotranspiration (in kg water over whole time step)', & + call hist_addfld1d (fname='evap', units='kg H20 / m2 / s = mm/s', & + avgflag='A', long_name='evapotranspiration (in kg water over whole time step)', & ptr_lnd=this%mml_lnd_evap_grc) this%mml_lnd_ustar_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_ustar', units='m/s', & - avgflag='A', long_name='MML friction velocity from MO theory', & + call hist_addfld1d (fname='ustar', units='m/s', & + avgflag='A', long_name='friction velocity from MO theory', & ptr_lnd=this%mml_lnd_ustar_grc) this%mml_lnd_tstar_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_tstar', units='K', & - avgflag='A', long_name='MML temperature scale from MO theory', & + call hist_addfld1d (fname='tstar', units='K', & + avgflag='A', long_name='temperature scale from MO theory', & ptr_lnd=this%mml_lnd_tstar_grc) this%mml_lnd_qstar_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_qstar', units='kg/kg', & - avgflag='A', long_name='MML humidity scale (?) from MO theory', & + call hist_addfld1d (fname='qstar', units='kg/kg', & + avgflag='A', long_name='humidity scale (?) from MO theory', & ptr_lnd=this%mml_lnd_qstar_grc) this%mml_lnd_tvstar_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_tvstar', units='K', & - avgflag='A', long_name='MML virtual potential temperature scale from MO theory', & + call hist_addfld1d (fname='tvstar', units='K', & + avgflag='A', long_name='virtual potential temperature scale from MO theory', & ptr_lnd=this%mml_lnd_tvstar_grc) this%mml_lnd_obu_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_obu', units='m', & - avgflag='A', long_name='MML Obukhov length from MO theory', & + call hist_addfld1d (fname='obu', units='m', & + avgflag='A', long_name='Obukhov length from MO theory', & ptr_lnd=this%mml_lnd_obu_grc) this%mml_lnd_ram_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_ram', units='s/m', & - avgflag='A', long_name='MML aerodynamic resistance for momentum (and moisture; from MO theory)', & + call hist_addfld1d (fname='ram', units='s/m', & + avgflag='A', long_name='aerodynamic resistance for momentum (and moisture; from MO theory)', & ptr_lnd=this%mml_lnd_ram_grc) this%mml_lnd_rah_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_rah', units='s/m', & - avgflag='A', long_name='MML aerodynamic resistance for heat', & + call hist_addfld1d (fname='rah', units='s/m', & + avgflag='A', long_name='aerodynamic resistance for heat', & ptr_lnd=this%mml_lnd_rah_grc) this%mml_lnd_res_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_res_tot', units='s/m', & - avgflag='A', long_name='MML lid resistance + aerodynamic resistance for heat (MML_evap_rs + MML_rah)', & + call hist_addfld1d (fname='res_tot', units='s/m', & + avgflag='A', long_name='lid resistance + aerodynamic resistance for heat (evap_rs + rah)', & ptr_lnd=this%mml_lnd_res_grc) this%mml_lnd_effective_res_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_res_effective', units='s/m', & - avgflag='A', long_name='MML effective surface resistance = 1/beta * (MML_evap_rs + MML_rah)', & + call hist_addfld1d (fname='res_effective', units='s/m', & + avgflag='A', long_name='effective surface resistance = 1/beta * (evap_rs + rah)', & ptr_lnd=this%mml_lnd_effective_res_grc) this%mml_lnd_beta_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_beta', units='unitless', & - avgflag='A', long_name='MML beta factor for resistance due to bucket emptiness (between 0 and 1)', & + call hist_addfld1d (fname='beta', units='unitless', & + avgflag='A', long_name='beta factor for resistance due to bucket emptiness (between 0 and 1)', & ptr_lnd=this%mml_lnd_beta_grc) this%mml_lnd_z0m_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_z0m', units='m', & - avgflag='A', long_name='MML roughness length for momentum', & + call hist_addfld1d (fname='z0m', units='m', & + avgflag='A', long_name='roughness length for momentum', & ptr_lnd=this%mml_lnd_z0m_grc) this%mml_lnd_z0h_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_z0h', units='m', & - avgflag='A', long_name='MML roughness length for heat', & + call hist_addfld1d (fname='z0h', units='m', & + avgflag='A', long_name='roughness length for heat', & ptr_lnd=this%mml_lnd_z0h_grc) this%mml_lnd_alb_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_alb', units='unitless', & - avgflag='A', long_name='MML actual albedo (accounting for snow) used', & + call hist_addfld1d (fname='alb', units='unitless', & + avgflag='A', long_name='actual albedo (accounting for snow) used', & ptr_lnd=this%mml_lnd_alb_grc) this%mml_lnd_fsns_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_fsns', units='W/m2', & - avgflag='A', long_name='MML net flux of shortwave at surface (in - out), pos into land', & + call hist_addfld1d (fname='fsns', units='W/m2', & + avgflag='A', long_name='net flux of shortwave at surface (in - out), pos into land', & ptr_lnd=this%mml_lnd_fsns_grc) this%mml_lnd_flns_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_flns', units='W/m2', & - avgflag='A', long_name='MML net flux of longwave at surface (out-in), pos out of land', & + call hist_addfld1d (fname='flns', units='W/m2', & + avgflag='A', long_name='net flux of longwave at surface (out-in), pos out of land', & ptr_lnd=this%mml_lnd_flns_grc) this%mml_lnd_snowmelt(begg:endg) = spval - call hist_addfld1d (fname='MML_snowmelt', units='kg/m2', & - avgflag='A', long_name='MML snow that melted into water bucket', & + call hist_addfld1d (fname='snowmelt', units='kg/m2', & + avgflag='A', long_name='snow that melted into water bucket', & ptr_lnd=this%mml_lnd_snowmelt) ! Soil variables ! start 2d - ! 2d example from SoilBiogeochemCarbonStateType.F90 - !call hist_addfld2d (fname=fieldname, units='gC/m^3', type2d='levdcmp', & - ! avgflag='A', long_name=longname, & - ! ptr_col=data2dptr) - ! I wanted to add an mml case to the type2d, but for now change it back, since its crashing !write(iulog,*) 'MML write to h0: 2d soil vars ' this%mml_nc_dust_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_dust_2atm', units='unknown', type2d='mml_dust', & - avgflag='A', long_name='MML surface dust flux to atmosphere ', & + call hist_addfld2d (fname='dust_2atm', units='unknown', type2d='mml_dust', & + avgflag='A', long_name='surface dust flux to atmosphere ', & ptr_lnd=this%mml_nc_dust_grc) this%mml_nc_soil_maxice_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_maxice', units='kg/m3', type2d='mml_lev', & - avgflag='A', long_name='MML maximum freezable water in each soil layer; for thermal calculations', & + call hist_addfld2d (fname='maxice', units='kg/m3', type2d='mml_lev', & + avgflag='A', long_name='maximum freezable water in each soil layer; for thermal calculations', & ptr_lnd=this%mml_nc_soil_maxice_grc) this%mml_nc_soil_levels_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_soilz', units='m', type2d='mml_lev', & - avgflag='A', long_name='MML depth (negative) from surface of midpoint of each soil layer', & + call hist_addfld2d (fname='soilz', units='m', type2d='mml_lev', & + avgflag='A', long_name='depth (negative) from surface of midpoint of each soil layer', & ptr_lnd=this%mml_nc_soil_levels_grc, mml_dim=mml_nsoi) this%mml_soil_t_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_soil_t', units='K', type2d='mml_lev', & - avgflag='A', long_name='MML soil temperature at each layer', & + call hist_addfld2d (fname='soil_t', units='K', type2d='mml_lev', & + avgflag='A', long_name='soil temperature at each layer', & ptr_lnd=this%mml_soil_t_grc, mml_dim=mml_nsoi) this%mml_soil_liq_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_soil_liq', units='kg/m2', type2d='mml_lev', & - avgflag='A', long_name='MML kg of liquid water in each soil layer (Thermodynamic ONLY)', & + call hist_addfld2d (fname='soil_liq', units='kg/m2', type2d='mml_lev', & + avgflag='A', long_name='kg of liquid water in each soil layer (Thermodynamic ONLY)', & ptr_lnd=this%mml_soil_liq_grc, mml_dim=mml_nsoi) this%mml_soil_ice_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_soil_ice', units='kg/m2', type2d='mml_lev', & - avgflag='A', long_name='MML kg of frozen water in each soil layer (Thermodynamic ONLY)', & + call hist_addfld2d (fname='soil_ice', units='kg/m2', type2d='mml_lev', & + avgflag='A', long_name='kg of frozen water in each soil layer (Thermodynamic ONLY)', & ptr_lnd=this%mml_soil_ice_grc, mml_dim=mml_nsoi) this%mml_soil_dz_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_dz', units='m', type2d='mml_lev', & - avgflag='A', long_name='MML thickness of each soil layer', & + call hist_addfld2d (fname='dz', units='m', type2d='mml_lev', & + avgflag='A', long_name='thickness of each soil layer', & ptr_lnd=this%mml_soil_dz_grc, mml_dim=mml_nsoi) this%mml_soil_zh_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_zh', units='m', type2d='mml_lev', & - avgflag='A', long_name='MML soil depth at interface between each soil layer', & + call hist_addfld2d (fname='zh', units='m', type2d='mml_lev', & + avgflag='A', long_name='soil depth at interface between each soil layer', & ptr_lnd=this%mml_soil_zh_grc, mml_dim=mml_nsoi) this%mml_soil_tk_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_tk', units='W/m/K', type2d='mml_lev', & - avgflag='A', long_name='MML thermal conductivity of each soil layer', & + call hist_addfld2d (fname='tk', units='W/m/K', type2d='mml_lev', & + avgflag='A', long_name='thermal conductivity of each soil layer', & ptr_lnd=this%mml_soil_tk_grc, mml_dim=mml_nsoi) this%mml_soil_tk_1d_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_tk_1d', units='W/m/K', & - avgflag='A', long_name='MML thermal resistance of every soil layer', & + call hist_addfld1d (fname='tk_1d', units='W/m/K', & + avgflag='A', long_name='thermal resistance of every soil layer', & ptr_lnd=this%mml_soil_tk_1d_grc) this%mml_soil_tkh_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_tkh', units='W/m/K', type2d='mml_lev', & - avgflag='A', long_name='MML thermal conductivity at bottom boundary of each soil layer', & + call hist_addfld2d (fname='tkh', units='W/m/K', type2d='mml_lev', & + avgflag='A', long_name='thermal conductivity at bottom boundary of each soil layer', & ptr_lnd=this%mml_soil_tkh_grc, mml_dim=mml_nsoi) this%mml_soil_dtsoi_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_dtsoi', units='K', type2d='mml_lev', & - avgflag='A', long_name='MML temperature tendency in each soil layer', & + call hist_addfld2d (fname='dtsoi', units='K', type2d='mml_lev', & + avgflag='A', long_name='temperature tendency in each soil layer', & ptr_lnd=this%mml_soil_dtsoi_grc, mml_dim=mml_nsoi) this%mml_soil_cv_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_cv', units='J/m3/K', type2d='mml_lev', & - avgflag='A', long_name='MML heat capacity of each soil layer (depends on soil type)', & + call hist_addfld2d (fname='cv', units='J/m3/K', type2d='mml_lev', & + avgflag='A', long_name='heat capacity of each soil layer (depends on soil type)', & ptr_lnd=this%mml_soil_cv_grc, mml_dim=mml_nsoi) this%mml_soil_cv_1d_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_cv_1d', units='J/m3/K', & - avgflag='A', long_name='MML heat capacity of every soil layer', & + call hist_addfld1d (fname='cv_1d', units='J/m3/K', & + avgflag='A', long_name='heat capacity of every soil layer', & ptr_lnd=this%mml_soil_cv_1d_grc) this%mml_glc_tk_1d_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_glc_tk_1d', units='W/m/K', & - avgflag='A', long_name='MML thermal resistance of every ice layer where glaciated', & + call hist_addfld1d (fname='glc_tk_1d', units='W/m/K', & + avgflag='A', long_name='thermal resistance of every ice layer where glaciated', & ptr_lnd=this%mml_glc_tk_1d_grc) this%mml_glc_cv_1d_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_glc_cv_1d', units='J/m3/K', & - avgflag='A', long_name='MML heat capacity of every ice layer where glaciated', & + call hist_addfld1d (fname='glc_cv_1d', units='J/m3/K', & + avgflag='A', long_name='heat capacity of every ice layer where glaciated', & ptr_lnd=this%mml_glc_cv_1d_grc) ! end 2d @@ -1472,126 +917,126 @@ subroutine InitHistory(this, bounds) !write(iulog,*) 'MML write to h0: 1d soil vars ' this%mml_soil_water_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_water', units='kg/m2', & - avgflag='A', long_name='MML total amount of liquid water in soil bucket (hydrology)', & + call hist_addfld1d (fname='water', units='kg/m2', & + avgflag='A', long_name='total amount of liquid water in soil bucket (hydrology)', & ptr_lnd=this%mml_soil_water_grc) this%mml_soil_snow_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_snow', units='kg/m2', & - avgflag='A', long_name='MML total amount of snow in snow bucket (hydrology)', & + call hist_addfld1d (fname='snow', units='kg/m2', & + avgflag='A', long_name='total amount of snow in snow bucket (hydrology)', & ptr_lnd=this%mml_soil_snow_grc) this%mml_soil_runoff_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_runoff', units='kg/m2', & - avgflag='A', long_name='MML water in excess of bucket capacity (runoff, but it disappears)', & + call hist_addfld1d (fname='runoff', units='kg/m2', & + avgflag='A', long_name='water in excess of bucket capacity (runoff, but it disappears)', & ptr_lnd=this%mml_soil_runoff_grc) ! lnd2atm MML vars this%mml_out_tref2m_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_l2a_tref2m', units='K', & - avgflag='A', long_name='MML 2m ref height temperature calculated from tsrf and tstar', & + call hist_addfld1d (fname='l2a_tref2m', units='K', & + avgflag='A', long_name='2m ref height temperature calculated from tsrf and tstar', & ptr_lnd=this%mml_out_tref2m_grc) this%mml_out_qref2m_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_l2a_qref2m', units='kg/kg', & - avgflag='A', long_name='MML 2m ref height humidity calculated from qsrf and qstar', & + call hist_addfld1d (fname='l2a_qref2m', units='kg/kg', & + avgflag='A', long_name='2m ref height humidity calculated from qsrf and qstar', & ptr_lnd=this%mml_out_qref2m_grc) this%mml_out_uref10m_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_l2a_uref10m', units='m/s', & - avgflag='A', long_name='MML 10m ref wind calculated from ustar', & + call hist_addfld1d (fname='l2a_uref10m', units='m/s', & + avgflag='A', long_name='10m ref wind calculated from ustar', & ptr_lnd=this%mml_out_uref10m_grc) this%mml_out_taux(begg:endg) = spval - call hist_addfld1d (fname='MML_l2a_taux', units='m/s', & - avgflag='A', long_name='MML zonal surface stress ', & + call hist_addfld1d (fname='l2a_taux', units='m/s', & + avgflag='A', long_name='zonal surface stress ', & ptr_lnd=this%mml_out_taux) this%mml_out_tauy(begg:endg) = spval - call hist_addfld1d (fname='MML_l2a_tauy', units='m/s', & - avgflag='A', long_name='MML meridional surface stress ', & + call hist_addfld1d (fname='l2a_tauy', units='m/s', & + avgflag='A', long_name='meridional surface stress ', & ptr_lnd=this%mml_out_tauy) ! MML check if latent heat flux is larger than atm can support (giant dew) this%mml_q_excess(begg:endg) = spval - call hist_addfld1d (fname='MML_q_excess', units='kg/m2/s', & - avgflag='A', long_name='MML over-demand of dew (positive downwards) by land from atmosphere', & + call hist_addfld1d (fname='q_excess', units='kg/m2/s', & + avgflag='A', long_name='over-demand of dew (positive downwards) by land from atmosphere', & ptr_lnd=this%mml_q_excess) this%mml_lh_excess(begg:endg) = spval - call hist_addfld1d (fname='MML_lh_excess', units='W/m2', & - avgflag='A', long_name='MML over-demand of latent heat flux (dew; positive downwards) by land from atmosphere', & + call hist_addfld1d (fname='lh_excess', units='W/m2', & + avgflag='A', long_name='over-demand of latent heat flux (dew; positive downwards) by land from atmosphere', & ptr_lnd=this%mml_lh_excess) this%mml_q_demand(begg:endg) = spval - call hist_addfld1d (fname='MML_q_demand', units='kg/m2/s', & - avgflag='A', long_name='MML initial demand of water flux by land from atmosphere (before correction for excess dew)', & + call hist_addfld1d (fname='q_demand', units='kg/m2/s', & + avgflag='A', long_name='initial demand of water flux by land from atmosphere (before correction for excess dew)', & ptr_lnd=this%mml_q_demand) this%mml_lh_demand(begg:endg) = spval - call hist_addfld1d (fname='MML_lh_demand', units='W/m2', & - avgflag='A', long_name='MML initial demand of latent heat flux by land from atmosphere (before correction for excess dew)', & + call hist_addfld1d (fname='lh_demand', units='W/m2', & + avgflag='A', long_name='initial demand of latent heat flux by land from atmosphere (before correction for excess dew)', & ptr_lnd=this%mml_lh_demand) ! mml diagnostic vars (temproary) this%mml_diag1_1d_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_diag1_1d', units='n/a', & - avgflag='A', long_name='MML temporary 1d diagnostic var 1', & + call hist_addfld1d (fname='diag1_1d', units='n/a', & + avgflag='A', long_name='temporary 1d diagnostic var 1', & ptr_lnd=this%mml_diag1_1d_grc) this%mml_diag2_1d_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_diag2_1d', units='n/a', & - avgflag='A', long_name='MML temporary 1d diagnostic var 2', & + call hist_addfld1d (fname='diag2_1d', units='n/a', & + avgflag='A', long_name='temporary 1d diagnostic var 2', & ptr_lnd=this%mml_diag2_1d_grc) this%mml_diag3_1d_grc(begg:endg) = spval - call hist_addfld1d (fname='MML_diag3_1d', units='n/a', & - avgflag='A', long_name='MML temporary 1d diagnostic var 3', & + call hist_addfld1d (fname='diag3_1d', units='n/a', & + avgflag='A', long_name='temporary 1d diagnostic var 3', & ptr_lnd=this%mml_diag3_1d_grc) this%mml_diag1_2d_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_diag1_2d', units='n/a', type2d='mml_lev', & - avgflag='A', long_name='MML temporary 2d diagnostic var 1', & + call hist_addfld2d (fname='diag1_2d', units='n/a', type2d='mml_lev', & + avgflag='A', long_name='temporary 2d diagnostic var 1', & ptr_lnd=this%mml_diag1_2d_grc, mml_dim=mml_nsoi) this%mml_diag2_2d_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_diag2_2d', units='n/a', type2d='mml_lev', & - avgflag='A', long_name='MML temporary 2d diagnostic var 2', & + call hist_addfld2d (fname='diag2_2d', units='n/a', type2d='mml_lev', & + avgflag='A', long_name='temporary 2d diagnostic var 2', & ptr_lnd=this%mml_diag2_2d_grc, mml_dim=mml_nsoi) this%mml_diag3_2d_grc(begg:endg,:) = spval - call hist_addfld2d (fname='MML_diag3_2d', units='n/a', type2d='mml_lev', & - avgflag='A', long_name='MML temporary 2d diagnostic var 3', & + call hist_addfld2d (fname='diag3_2d', units='n/a', type2d='mml_lev', & + avgflag='A', long_name='temporary 2d diagnostic var 3', & ptr_lnd=this%mml_diag3_2d_grc, mml_dim=mml_nsoi) ! mml error flux/balance vars this%mml_err_h2o(begg:endg) = spval - call hist_addfld1d (fname='mml_err_h2o', units='n/a', & - avgflag='A', long_name='MML total water conservation error', & + call hist_addfld1d (fname='err_h2o', units='n/a', & + avgflag='A', long_name='total water conservation error', & ptr_lnd=this%mml_err_h2o) this%mml_err_h2osno(begg:endg) = spval - call hist_addfld1d (fname='mml_err_h2osno', units='n/a', & - avgflag='A', long_name='MML imbalance in snow depth (liquid water)', & + call hist_addfld1d (fname='err_h2osno', units='n/a', & + avgflag='A', long_name='imbalance in snow depth (liquid water)', & ptr_lnd=this%mml_err_h2osno) this%mml_err_seb(begg:endg) = spval - call hist_addfld1d (fname='mml_err_seb', units='n/a', & - avgflag='A', long_name='MML surface energy conservation error', & + call hist_addfld1d (fname='err_seb', units='n/a', & + avgflag='A', long_name='surface energy conservation error', & ptr_lnd=this%mml_err_seb) this%mml_err_soi(begg:endg) = spval - call hist_addfld1d (fname='mml_err_soi', units='n/a', & - avgflag='A', long_name='MML soil/lake energy conservation error', & + call hist_addfld1d (fname='err_soi', units='n/a', & + avgflag='A', long_name='soil/lake energy conservation error', & ptr_lnd=this%mml_err_soi) this%mml_err_sol(begg:endg) = spval - call hist_addfld1d (fname='mml_err_sol', units='n/a', & - avgflag='A', long_name='MML solar radiation conservation error', & + call hist_addfld1d (fname='err_sol', units='n/a', & + avgflag='A', long_name='solar radiation conservation error', & ptr_lnd=this%mml_err_sol) @@ -1601,66 +1046,6 @@ subroutine InitHistory(this, bounds) ! End MML simple land model added variables !----------------------------------------------------------------------- - - ! 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_cn) then - this%rh30_patch(begp:endp) = spval - call hist_addfld1d (fname='RH30', units='%', & - avgflag='A', long_name='30-day running mean of relative humidity', & - ptr_patch=this%rh30_patch, default='inactive') - - this%prec10_patch(begp:endp) = spval - call hist_addfld1d (fname='PREC10', units='MM H2O/S', & - avgflag='A', long_name='10-day running mean of PREC', & - ptr_patch=this%prec10_patch, default='inactive') - - this%prec60_patch(begp:endp) = spval - call hist_addfld1d (fname='PREC60', units='MM H2O/S', & - avgflag='A', long_name='60-day running mean of PREC', & - ptr_patch=this%prec60_patch, default='inactive') - end if - - 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 !----------------------------------------------------------------------- @@ -1853,368 +1238,114 @@ end subroutine InitCold ! MML: InitAccBuffer sounds like what I actually want... unless it only initializes a ! value with the necessity of having a r0 file overwrite it. !----------------------------------------------------------------------- - 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_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) - - 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_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) - - 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 ('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) - - 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) - - ! 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) - - ! 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 - 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_wind_grc(g) - end do - call update_accum_field ('WIND24', rbufslp, nstep) - call extract_accum_field ('WIND24', this%wind24_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_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 - - 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 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%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) + +! 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 :: 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="InitAccVars allocation error for rbufslp"//& +! errMsg(sourcefile, __LINE__)) +! endif + +! ! Determine time step +! nstep = get_nstep() + +! call extract_accum_field ('FSD240', rbufslp, nstep) +! this%fsd240_patch(begp:endp) = rbufslp(begp:endp) + +! 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(atm2lnd_type) :: 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 +! 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,*)'UpdateAccVars allocation error for rbufslp' +! 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) + +! deallocate(rbufslp) + +! end subroutine UpdateAccVars !------------------------------------------------------------------------ subroutine Restart(this, bounds, ncid, flag) @@ -2233,165 +1364,61 @@ subroutine Restart(this, bounds, ncid, flag) logical :: readvar !------------------------------------------------------------------------ - call restartvar(ncid=ncid, flag=flag, varname='qflx_floodg', xtype=ncd_double, & - dim1name='gridcell', & - long_name='flood water flux', units='mm/s', & - interpinic_flag='skip', readvar=readvar, data=this%forc_flood_grc) - if (flag == 'read' .and. .not. readvar) then - ! initial run, readvar=readvar, not restart: initialize flood to zero - this%forc_flood_grc = 0._r8 - endif - - 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 - ! ----------------------------------------------------------------------- ! Start MML simple land model restart variables section ! MML 2016.01.15 write(iulog,*) ' MML trying to write r 1d restart vars ' ! MML: surface - call restartvar(ncid=ncid, flag=flag, varname='mml_lnd_ts_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='lnd_ts_grc', xtype=ncd_double, & dim1name='gridcell', & long_name='Surface Temperature for MO', units='K', & interpinic_flag='skip', readvar=readvar, data=this%mml_lnd_ts_grc) - call restartvar(ncid=ncid, flag=flag, varname='mml_lnd_qs_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='lnd_qs_grc', xtype=ncd_double, & dim1name='gridcell', & long_name='surface specific humidity for MO', units='kg/kg', & interpinic_flag='skip', readvar=readvar, data=this%mml_lnd_qs_grc) ! MML soil: ! MML Hydrology variables: - call restartvar(ncid=ncid, flag=flag, varname='mml_soil_water_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='soil_water_grc', xtype=ncd_double, & dim1name='gridcell', & long_name='soil bucket water content', units='kg', & interpinic_flag='skip', readvar=readvar, data=this%mml_soil_water_grc) - call restartvar(ncid=ncid, flag=flag, varname='mml_soil_snow_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='soil_snow_grc', xtype=ncd_double, & dim1name='gridcell', & long_name='snow bucket snow content', units='kg', & interpinic_flag='skip', readvar=readvar, data=this%mml_soil_snow_grc) - call restartvar(ncid=ncid, flag=flag, varname='mml_soil_runoff_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='soil_runoff_grc', xtype=ncd_double, & dim1name='gridcell', & long_name='water runoff', units='kg', & interpinic_flag='skip', readvar=readvar, data=this%mml_soil_runoff_grc) ! write(iulog,*) 'MML trying to write r 2d restart vars ' ! MML Thermodynamic vars for each soil level (3d) - call restartvar(ncid=ncid, flag=flag, varname='mml_soil_liq_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='soil_liq_grc', xtype=ncd_double, & dim1name='gridcell', dim2name='mml_lev', switchdim=.true., & ! dim2 mml_lev? long_name='amount of liquid water in each soil layer', units='kg', & interpinic_flag='skip', readvar=readvar, data=this%mml_soil_liq_grc) - call restartvar(ncid=ncid, flag=flag, varname='mml_soil_ice_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='soil_ice_grc', xtype=ncd_double, & dim1name='gridcell', dim2name='mml_lev', switchdim=.true., & long_name='amount of frozen water in each soil layer', units='kg', & interpinic_flag='skip', readvar=readvar, data=this%mml_soil_ice_grc) - call restartvar(ncid=ncid, flag=flag, varname='mml_soil_t_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='soil_t_grc', xtype=ncd_double, & dim1name='gridcell', dim2name='mml_lev', switchdim=.true., & - long_name='MML soil temperature at each layer', units='K', & + long_name='soil temperature at each layer', units='K', & interpinic_flag='skip', readvar=readvar, data=this%mml_soil_t_grc) - call restartvar(ncid=ncid, flag=flag, varname='mml_soil_dtsoi_grc', xtype=ncd_double, & + call restartvar(ncid=ncid, flag=flag, varname='soil_dtsoi_grc', xtype=ncd_double, & dim1name='gridcell', dim2name='mml_lev', switchdim=.true., & - long_name='MML temperature tendency in each soil layer', units='K', & + long_name='temperature tendency in each soil layer', units='K', & interpinic_flag='skip', readvar=readvar, data=this%mml_soil_dtsoi_grc) - - ! MML nc vars, so if I stop mid-month / mid-day I can still know what that month's nc params are - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_alb_gvd_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Ground visible direct albedo (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_alb_gvd_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_alb_svd_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Snow visible direct albedo (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_alb_svd_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_alb_gnd_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Ground NIR direct albedo (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_alb_gnd_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_alb_snd_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Snow NIR direct albedo (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_alb_snd_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_alb_gvf_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Ground visible diffuse albedo (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_alb_gvf_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_alb_svf_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='snow visible diffuse albedo (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_alb_svf_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_alb_gnf_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Ground NIR diffuse albedo (from netcdf file)', units='K', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_alb_gnf_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_alb_snf_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Snow NIR diffuse albedo (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_alb_snf_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_snowmask_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Amount of snow required to fully mask ground albedo (from netcdf file)', units='kg/m2', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_snowmask_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_evaprs_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Evaporative resistance (from netcdf file)', units='s/m', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_evaprs_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_bucket_cap_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Bucket Capacity (from netcdf file)', units='kg/m2', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_bucket_cap_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_roughness_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Surface roughness (vegetation height) (from netcdf file)', units='m', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_roughness_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_emiss_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Surface emissivity (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_emiss_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_glcmask_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Mask of glaciated points (from netcdf file)', units='none', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_glcmask_grc) - - call restartvar(ncid=ncid, flag=flag, varname='mml_nc_dust_grc', xtype=ncd_double, & - dim1name='gridcell', & - long_name='Dust flux to atm (from netcdf file)', units='unknown', & - interpinic_flag='skip', readvar=readvar, data=this%mml_nc_dust_grc) - write(iulog,*) ' MML end of 1d restart vars ' ! 3d restart var example (soilbiogeochem carbon mod): @@ -2400,8 +1427,8 @@ subroutine Restart(this, bounds, ncid, flag) ! long_name='', units='', fill_value=spval, & ! interpinic_flag='interp', readvar=readvar, data=ptr2d) - ! End MML simple land model added variables - !----------------------------------------------------------------------- + ! End MML simple land model added variables + !----------------------------------------------------------------------- end subroutine Restart @@ -2425,74 +1452,26 @@ subroutine Clean(this) deallocate(this%forc_u_grc) deallocate(this%forc_v_grc) deallocate(this%forc_wind_grc) - deallocate(this%forc_rh_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_psrf_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_q_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) deallocate(this%forc_rain_not_downscaled_grc) deallocate(this%forc_snow_not_downscaled_grc) - ! atm->lnd downscaled - deallocate(this%forc_t_downscaled_col) - deallocate(this%forc_q_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%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%bc_precip_grc) - deallocate(this%af_precip_grc) - deallocate(this%af_uwind_grc) - deallocate(this%af_vwind_grc) - deallocate(this%af_tbot_grc) - deallocate(this%af_pbot_grc) - deallocate(this%af_shum_grc) - deallocate(this%af_swdn_grc) - deallocate(this%af_lwdn_grc) - - deallocate(this%fsd24_patch) - deallocate(this%fsd240_patch) - deallocate(this%fsi24_patch) - deallocate(this%fsi240_patch) - deallocate(this%prec10_patch) - deallocate(this%prec60_patch) - deallocate(this%prec365_col) - if (use_fates) then - deallocate(this%prec24_patch) - deallocate(this%rh24_patch) - deallocate(this%wind24_patch) - end if - deallocate(this%t_mo_patch) - deallocate(this%t_mo_min_patch) +! deallocate(this%fsd240_patch) ! MML: deallocate mml vars: @@ -2535,7 +1514,6 @@ subroutine Clean(this) deallocate(this%mml_atm_rhomol_grc ) deallocate(this%mml_atm_rhoair_grc ) deallocate(this%mml_atm_cp_grc ) - deallocate(this%mml_atm_pco2 ) deallocate(this%mml_atm_prec_liq_grc ) deallocate(this%mml_atm_prec_frz_grc ) diff --git a/src/main/clm_driver.F90 b/src/main/clm_driver.F90 index 5a36c237..c4465322 100644 --- a/src/main/clm_driver.F90 +++ b/src/main/clm_driver.F90 @@ -10,25 +10,17 @@ module clm_driver ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 use clm_varctl , only : wrtdia, iulog - use clm_varctl , only : use_cn, use_noio + use clm_varctl , only : use_noio use clm_time_manager , only : get_nstep use spmdMod , only : masterproc, mpicom use decompMod , only : get_proc_clumps, get_clump_bounds, get_proc_bounds, bounds_type - use filterMod , only : filter_inactive_and_active use histFileMod , only : hist_update_hbuf, hist_htapes_wrapup use restFileMod , only : restFile_write, restFile_filename use abortutils , only : endrun ! - use SoilBiogeochemVerticalProfileMod , only : SoilBiogeochemVerticalProfile - use ActiveLayerMod , only : alt_calc - ! use perf_mod ! MML: this is where t_startf and t_stopf are ! - use clm_instMod , only : temperature_inst, canopystate_inst - use clm_instMod , only : soilstate_inst, soilbiogeochem_state_inst - use clm_instMod , only : bgc_vegetation_inst use clm_instMod , only : atm2lnd_inst, lnd2atm_inst - use clm_instMod , only : soilstate_inst ! MML: add use simple land model module use mml_mainMod , only : mml_main ! MML if I don't say "only", it'll be fine, yes? @@ -84,13 +76,8 @@ subroutine clm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate, ro integer :: nclumps ! number of clumps on this processor character(len=256) :: filer ! restart file name integer :: ier ! error code - type(bounds_type) :: bounds_clump type(bounds_type) :: bounds_proc - ! COMPILER_BUG(wjs, 2014-11-29, pgi 14.7) Workaround for internal compiler error with - ! pgi 14.7 ('normalize_forall_array: non-conformable'), which appears in the call to - ! CalcIrrigationNeeded. Simply declaring this variable makes the ICE go away. - real(r8), allocatable :: dummy1_to_make_pgi_happy(:) !----------------------------------------------------------------------- ! Determine processor bounds and clumps for this processor @@ -98,35 +85,6 @@ subroutine clm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate, ro call get_proc_bounds(bounds_proc) nclumps = get_proc_clumps() -! MML: I think I need this bit - !$OMP PARALLEL DO PRIVATE (nc,bounds_clump) - do nc = 1,nclumps - call get_clump_bounds(nc, bounds_clump) - - ! BUG(wjs, 2014-12-15, bugz 2107) Because of the placement of the following - ! routines (alt_calc and SoilBiogeochemVerticalProfile) in the driver sequence - - ! they are called very early in each timestep, before weights are adjusted and - ! filters are updated - it may be necessary for these routines 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. - - call t_startf("decomp_vert") - call alt_calc(filter_inactive_and_active(nc)%num_soilc, filter_inactive_and_active(nc)%soilc, & - temperature_inst, canopystate_inst) - - if (use_cn) then - call SoilBiogeochemVerticalProfile(bounds_clump , & - filter_inactive_and_active(nc)%num_soilc, filter_inactive_and_active(nc)%soilc , & - filter_inactive_and_active(nc)%num_soilp, filter_inactive_and_active(nc)%soilp , & - canopystate_inst, soilstate_inst, soilbiogeochem_state_inst) - end if - - call t_stopf("decomp_vert") - end do - !$OMP END PARALLEL DO - ! ============================================================================ ! MML: Simple Land Model Override ! ============================================================================ @@ -140,9 +98,9 @@ subroutine clm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate, ro ! I give it everything it needs. I think lnd2atm (but check!) actually hands the data ! off to the coupler, so if thats the case I need to make my changes before hand. - call t_startf('mml_main') - call mml_main(bounds_clump, atm2lnd_inst, lnd2atm_inst) - call t_stopf('mml_main') + call t_startf('mml_main') + call mml_main(bounds_proc, atm2lnd_inst, lnd2atm_inst) + call t_stopf('mml_main') !write(iulog,*) 'MML: done with simple model, back at clm_driver' @@ -177,56 +135,22 @@ subroutine clm_drv(doalb, nextsw_cday, declinp1, declin, rstwr, nlend, rdate, ro ! Create history and write history tapes if appropriate call t_startf('clm_drv_io_htapes') - !write(iulog,*)'MML: about to call htapes_wrapup, prepare to die, my name is inigio montoya... also wtf does it want the soilstate for? ' - - ! MML workaround to try and avoid the soilstate leading to crashing - this is CLM's soil state, not SLIM's, so the values shouldn't be meaningful anyhow - !soilstate_inst%watsat_col(bounds_proc%begc:bounds_proc%endc, :) = 0.0_r8 - !soilstate_inst%sucsat_col(bounds_proc%begc:bounds_proc%endc, :) = 0.0_r8 - !soilstate_inst%bsw_col(bounds_proc%begc:bounds_proc%endc, :) = 0.0_r8 - !soilstate_inst%hksat_col(bounds_proc%begc:bounds_proc%endc, :) = 0.0_r8 - - !write(iulog,*)'MML: clobbered the soilstate_inst values, call hist_htapes_wrapup now' - - !write(iulog,*)'MML: rstwr = ',rstwr,', nlend = ',nlend - - call hist_htapes_wrapup( rstwr, nlend, bounds_proc, & - soilstate_inst%watsat_col(bounds_proc%begc:bounds_proc%endc, 1:), & - soilstate_inst%sucsat_col(bounds_proc%begc:bounds_proc%endc, 1:), & - soilstate_inst%bsw_col(bounds_proc%begc:bounds_proc%endc, 1:), & - soilstate_inst%hksat_col(bounds_proc%begc:bounds_proc%endc, 1:)) - - !write(iulog,*)'MML: back from wrapup, yet we are still running' + call hist_htapes_wrapup( rstwr, nlend, bounds_proc ) call t_stopf('clm_drv_io_htapes') - if (use_cn) then - call bgc_vegetation_inst%WriteHistory(bounds_proc) - end if - ! Write restart/initial files if appropriate if (rstwr) then - !write(iulog,*)'MML: write restart file' call t_startf('clm_drv_io_wrest') filer = restFile_filename(rdate=rdate) call restFile_write( bounds_proc, filer, rdate=rdate ) call t_stopf('clm_drv_io_wrest') - - ! MML: - ! write(iulog,*) 'MML: end of restart if statment ' - end if call t_stopf('clm_drv_io') - - ! MML: - !write(iulog,*) 'MML: after restart call ' - end if - ! MML: - !write(iulog,*) 'MML: end clm_drv routine ' - end subroutine clm_drv !------------------------------------------------------------------------ diff --git a/src/main/clm_initializeMod.F90 b/src/main/clm_initializeMod.F90 index 03b41227..ad29d447 100644 --- a/src/main/clm_initializeMod.F90 +++ b/src/main/clm_initializeMod.F90 @@ -12,17 +12,9 @@ module clm_initializeMod use clm_varctl , only : nsrest, nsrStartup, nsrContinue, nsrBranch use clm_varctl , only : is_cold_start, is_interpolated_start use clm_varctl , only : iulog - use clm_varctl , only : use_cn, use_cndv - use clm_instur , only : wt_lunit, urban_valid, wt_nat_patch, wt_cft, fert_cft, wt_glc_mec, topo_glc_mec use perf_mod , only : t_startf, t_stopf - use readParamsMod , only : readParameters use ncdio_pio , only : file_desc_t use GridcellType , only : grc ! instance - use LandunitType , only : lun ! instance - use ColumnType , only : col ! instance - use PatchType , only : patch ! instance - use reweightMod , only : reweight_wrapup - use filterMod , only : allocFilters, filter use clm_instMod ! @@ -42,18 +34,14 @@ subroutine initialize1( ) ! CLM initialization first phase ! ! !USES: - use clm_varpar , only: clm_varpar_init, natpft_lb, natpft_ub, cft_lb, cft_ub, maxpatch_glcmec + use clm_varpar , only: clm_varpar_init use clm_varcon , only: clm_varcon_init - use landunit_varcon , only: landunit_varcon_init, max_lunit - use clm_varctl , only: fsurdat, fatmlndfrc, noland, version, mml_surdat - use pftconMod , only: pftcon + use clm_varctl , only: fatmlndfrc, noland, version, mml_surdat use decompInitMod , only: decompInit_lnd, decompInit_clumps, decompInit_glcp use domainMod , only: domain_check, ldomain, domain_init - use surfrdMod , only: surfrd_get_globmask, surfrd_get_grid, surfrd_get_data + use surfrdMod , only: surfrd_get_globmask, surfrd_get_grid use controlMod , only: control_init, control_print, NLFilename, control_readNL_Physics, control_readNL_Perf use ncdio_pio , only: ncd_pio_init - use initGridCellsMod , only: initGridCells - use UrbanParamsType , only: UrbanInput, IsSimpleBuildTemp use mml_MainMod , only: readnml_datasets ! ! !LOCAL VARIABLES: @@ -89,8 +77,7 @@ subroutine initialize1( ) call control_readNL_Perf() call control_init() call clm_varpar_init() - call clm_varcon_init( IsSimpleBuildTemp() ) - call landunit_varcon_init() + call clm_varcon_init() call ncd_pio_init() if (masterproc) call control_print() @@ -105,6 +92,9 @@ subroutine initialize1( ) write(iulog,*) 'Attempting to read global land mask from ',trim(fatmlndfrc) call shr_sys_flush(iulog) endif + ! TODO Currently reading domain file, although this is done in surfrd. + ! In NUOPC version we will be reading ESMF mesh file. Until SLIM gets + ! updated to NUOPC, we are leaving the calls to surfrd unchanged. call surfrd_get_globmask(filename=fatmlndfrc, mask=amask, ni=ni, nj=nj) ! Exit early if no valid land points @@ -136,86 +126,34 @@ subroutine initialize1( ) write(iulog,*) 'Attempting to read ldomain from ',trim(fatmlndfrc) call shr_sys_flush(iulog) endif + ! TODO Currently reading domain file, although this is done in surfrd. + ! In NUOPC version we will be reading ESMF mesh file. Until SLIM gets + ! updated to NUOPC, we are leaving the calls to surfrd unchanged. call surfrd_get_grid(begg, endg, ldomain, fatmlndfrc) if (masterproc) then call domain_check(ldomain) endif ldomain%mask = 1 !!! TODO - is this needed? - ! Initialize glc behavior - call glc_behavior%Init(begg, endg, NLFilename) - - ! Initialize urban model input (initialize urbinp data structure) - ! This needs to be called BEFORE the call to surfrd_get_data since - ! that will call surfrd_get_special which in turn calls check_urban - - call UrbanInput(begg, endg, mode='initialize') - - ! Allocate surface grid dynamic memory (just gridcell bounds dependent) - - allocate (wt_lunit (begg:endg, max_lunit )) - allocate (urban_valid (begg:endg )) - allocate (wt_nat_patch (begg:endg, natpft_lb:natpft_ub )) - allocate (wt_cft (begg:endg, cft_lb:cft_ub )) - allocate (fert_cft (begg:endg, cft_lb:cft_ub )) - allocate (wt_glc_mec (begg:endg, maxpatch_glcmec)) - allocate (topo_glc_mec(begg:endg, maxpatch_glcmec)) - - ! Read list of Patches and their corresponding parameter values - ! Independent of model resolution, Needs to stay before surfrd_get_data - - call pftcon%Init() - - ! Read surface dataset and set up subgrid weight arrays - - call surfrd_get_data(begg, endg, ldomain, fsurdat) - ! ------------------------------------------------------------------------ ! Determine decomposition of subgrid scale landunits, columns, patches ! ------------------------------------------------------------------------ - call decompInit_clumps(ns, ni, nj, glc_behavior) + call decompInit_clumps(ns, ni, nj) ! *** Get ALL processor bounds - for gridcells, landunit, columns and patches *** call get_proc_bounds(bounds_proc) ! Allocate memory for subgrid data structures - ! This is needed here BEFORE the following call to initGridcells ! Note that the assumption is made that none of the subgrid initialization ! can depend on other elements of the subgrid in the calls below call grc%Init (bounds_proc%begg, bounds_proc%endg) - call lun%Init (bounds_proc%begl, bounds_proc%endl) - call col%Init (bounds_proc%begc, bounds_proc%endc) - call patch%Init(bounds_proc%begp, bounds_proc%endp) - - ! Build hierarchy and topological info for derived types - ! This is needed here for the following call to decompInit_glcp - call initGridCells(glc_behavior) + ! Set global seg maps for gridcells - ! Set global seg maps for gridcells, landlunits, columns and patches - - call decompInit_glcp(ns, ni, nj, glc_behavior) - - ! Set filters - - call allocFilters() - - nclumps = get_proc_clumps() - !$OMP PARALLEL DO PRIVATE (nc, bounds_clump) - do nc = 1, nclumps - call get_clump_bounds(nc, bounds_clump) - call reweight_wrapup(bounds_clump, glc_behavior) - end do - !$OMP END PARALLEL DO - - ! Deallocate surface grid dynamic memory for variables that aren't needed elsewhere. - ! Some things are kept until the end of initialize2; urban_valid is kept through the - ! end of the run for error checking. - - deallocate (wt_lunit, wt_cft, wt_glc_mec) + call decompInit_glcp(ns, ni, nj) call t_stopf('clm_init1') @@ -229,33 +167,19 @@ subroutine initialize2( ) ! CLM initialization - second phase ! ! !USES: - use shr_orb_mod , only : shr_orb_decl use shr_scam_mod , only : shr_scam_getCloseLatLon - use seq_drydep_mod , only : n_drydep, drydep_method, DD_XLND - use accumulMod , only : print_accum_fields - use clm_varpar , only : nlevsno use clm_varcon , only : spval - use clm_varctl , only : finidat, finidat_interp_source, finidat_interp_dest, fsurdat, mml_surdat - use clm_varctl , only : use_century_decomp, single_column, scmlat, scmlon, use_cn - use clm_varorb , only : eccen, mvelpp, lambm0, obliqr - use clm_time_manager , only : get_step_size, get_curr_calday + use clm_varctl , only : finidat, finidat_interp_source, finidat_interp_dest, mml_surdat + use clm_varctl , only : single_column, scmlat, scmlon use clm_time_manager , only : get_curr_date, get_nstep, advance_timestep use clm_time_manager , only : timemgr_init, timemgr_restart_io, timemgr_restart - !use DaylengthMod , only : InitDaylength, daylength -! use dynSubgridDriverMod , only : dynSubgrid_init use fileutils , only : getfil use initInterpMod , only : initInterp - use subgridWeightsMod , only : init_subgrid_weights_mod use histFileMod , only : hist_readNML use histFileMod , only : hist_htapes_build, htapes_fieldlist, hist_printflds - use histFileMod , only : hist_addfld1d, hist_addfld2d, no_snow_normal + use histFileMod , only : hist_addfld1d, hist_addfld2d use restFileMod , only : restFile_getfile, restFile_open, restFile_close use restFileMod , only : restFile_read, restFile_write - !use ndepStreamMod , only : ndep_init, ndep_interp - use LakeCon , only : LakeConInit - use SatellitePhenologyMod , only : SatellitePhenologyInit, readAnnualVegetation, interpMonthlyVeg - use SnowSnicarMod , only : SnowAge_init, SnowOptics_init - use lnd2atmMod , only : lnd2atm_minimal use controlMod , only : NLFilename ! ! !ARGUMENTS @@ -272,22 +196,12 @@ subroutine initialize2( ) character(len=256) :: pnamer ! full pathname of netcdf restart file character(len=256) :: locfn ! local file name type(file_desc_t) :: ncid ! netcdf id - real(r8) :: dtime ! time step increment (sec) integer :: nstep ! model time step - real(r8) :: calday ! calendar day for nstep - real(r8) :: caldaym1 ! calendar day for nstep-1 - real(r8) :: declin ! solar declination angle in radians for nstep - real(r8) :: declinm1 ! solar declination angle in radians for nstep-1 - real(r8) :: eccf ! earth orbit eccentricity factor type(bounds_type) :: bounds_proc ! processor bounds type(bounds_type) :: bounds_clump ! clump bounds logical :: lexist integer :: closelatidx,closelonidx real(r8) :: closelat,closelon - real(r8) :: max_decl ! temporary, for calculation of max_dayl - integer :: begp, endp - integer :: begc, endc - integer :: begl, endl real(r8), pointer :: data2dptr(:,:) ! temp. pointers for slicing larger arrays character(len=32) :: subname = 'initialize2' !---------------------------------------------------------------------- @@ -301,13 +215,6 @@ subroutine initialize2( ) call get_proc_bounds(bounds_proc) nclumps = get_proc_clumps() - ! ------------------------------------------------------------------------ - ! Read in parameters files - ! ------------------------------------------------------------------------ - - call clm_instReadNML( NLFilename ) - call readParameters(photosyns_inst) - ! ------------------------------------------------------------------------ ! Initialize time manager ! ------------------------------------------------------------------------ @@ -325,44 +232,6 @@ subroutine initialize2( ) ! History namelist read call hist_readNML( NLFilename ) - ! ------------------------------------------------------------------------ - ! Initialize daylength from the previous time step (needed so prev_dayl can be set correctly) - ! ------------------------------------------------------------------------ - - call t_startf('init_orbd') - - calday = get_curr_calday() - call shr_orb_decl( calday, eccen, mvelpp, lambm0, obliqr, declin, eccf ) - - dtime = get_step_size() - caldaym1 = get_curr_calday(offset=-int(dtime)) - call shr_orb_decl( caldaym1, eccen, mvelpp, lambm0, obliqr, declinm1, eccf ) - - call t_stopf('init_orbd') - - !call InitDaylength(bounds_proc, declin=declin, declinm1=declinm1) - - ! Initialize maximum daylength, based on latitude and maximum declination - ! given by the obliquity use negative value for S. Hem - - do g = bounds_proc%begg,bounds_proc%endg - max_decl = obliqr - if (grc%lat(g) < 0._r8) max_decl = -max_decl - !grc%max_dayl(g) = daylength(grc%lat(g), max_decl) - end do - - ! History file variables - - if (use_cn) then - !call hist_addfld1d (fname='DAYL', units='s', & - !avgflag='A', long_name='daylength', & - !ptr_gcell=grc%dayl, default='inactive') - - !call hist_addfld1d (fname='PREV_DAYL', units='s', & - !avgflag='A', long_name='daylength from previous timestep', & - !ptr_gcell=grc%prev_dayl, default='inactive') - end if - ! ------------------------------------------------------------------------ ! Initialize component data structures ! ------------------------------------------------------------------------ @@ -373,26 +242,10 @@ subroutine initialize2( ) ! First put in history calls for subgrid data structures - these cannot appear in the ! module for the subgrid data definition due to circular dependencies that are introduced - data2dptr => col%dz(:,-nlevsno+1:0) - col%dz(bounds_proc%begc:bounds_proc%endc,:) = spval - call hist_addfld2d (fname='SNO_Z', units='m', type2d='levsno', & - avgflag='A', long_name='Snow layer thicknesses', & - ptr_col=data2dptr, no_snow_behavior=no_snow_normal, default='inactive') - - call hist_addfld2d (fname='SNO_Z_ICE', units='m', type2d='levsno', & - avgflag='A', long_name='Snow layer thicknesses (ice landunits only)', & - ptr_col=data2dptr, no_snow_behavior=no_snow_normal, & - l2g_scale_type='ice', default='inactive') - - col%zii(bounds_proc%begc:bounds_proc%endc) = spval - call hist_addfld1d (fname='ZII', units='m', & - avgflag='A', long_name='convective boundary height', & - ptr_col=col%zii, default='inactive') - ! If single-column determine closest latitude and longitude if (single_column) then - call getfil (fsurdat, locfn, 0) + call getfil (mml_surdat, locfn, 0) call shr_scam_getCloseLatLon(locfn, scmlat, scmlon, & closelat, closelon, closelatidx, closelonidx) end if @@ -401,46 +254,12 @@ subroutine initialize2( ) call clm_instInit(bounds_proc) - ! Initialize SNICAR optical and aging parameters - - call SnowOptics_init( ) ! SNICAR optical parameters: - call SnowAge_init( ) ! SNICAR aging parameters: - call hist_printflds() - ! ------------------------------------------------------------------------ - ! Initializate dynamic subgrid weights (for prescribed transient Patches, CNDV - ! and/or dynamic landunits); note that these will be overwritten in a - ! restart run - ! ------------------------------------------------------------------------ - - call t_startf('init_subgrid_weights') - call init_subgrid_weights_mod(bounds_proc) - call t_stopf('init_subgrid_weights') - ! ------------------------------------------------------------------------ ! Initialize modules (after time-manager initialization in most cases) ! ------------------------------------------------------------------------ - if (use_cn) then - call bgc_vegetation_inst%Init2(bounds_proc, NLFilename) - - ! NOTE(wjs, 2016-02-23) Maybe the rest of the body of this conditional should also - ! be moved into bgc_vegetation_inst%Init2 - - if (n_drydep > 0 .and. drydep_method == DD_XLND) then - ! Must do this also when drydeposition is used so that estimates of monthly - ! differences in LAI can be computed - call SatellitePhenologyInit(bounds_proc) - end if - - else - call SatellitePhenologyInit(bounds_proc) - end if - - - - ! ------------------------------------------------------------------------ ! On restart only - process the history namelist. ! ------------------------------------------------------------------------ @@ -478,7 +297,7 @@ subroutine initialize2( ) write(iulog,*)'Reading initial conditions from ',trim(finidat) end if call getfil( finidat, fnamer, 0 ) - call restFile_read(bounds_proc, fnamer, glc_behavior) + call restFile_read(bounds_proc, fnamer) end if else if ((nsrest == nsrContinue) .or. (nsrest == nsrBranch)) then @@ -486,7 +305,7 @@ subroutine initialize2( ) if (masterproc) then write(iulog,*)'Reading restart file ',trim(fnamer) end if - call restFile_read(bounds_proc, fnamer, glc_behavior) + call restFile_read(bounds_proc, fnamer) end if @@ -512,7 +331,7 @@ subroutine initialize2( ) call initInterp(filei=fnamer, fileo=finidat_interp_dest, bounds=bounds_proc) ! Read new interpolated conditions file back in - call restFile_read(bounds_proc, finidat_interp_dest, glc_behavior) + call restFile_read(bounds_proc, finidat_interp_dest) ! Reset finidat to now be finidat_interp_dest ! (to be compatible with routines still using finidat) @@ -533,79 +352,14 @@ subroutine initialize2( ) call hist_htapes_build() end if - ! ------------------------------------------------------------------------ - ! Initialize variables that are associated with accumulated fields. - ! ------------------------------------------------------------------------ - - ! The following is called for both initial and restart runs and must - ! must be called after the restart file is read - - call atm2lnd_inst%initAccVars(bounds_proc) - call temperature_inst%initAccVars(bounds_proc) - call waterflux_inst%initAccVars(bounds_proc) - call energyflux_inst%initAccVars(bounds_proc) - call canopystate_inst%initAccVars(bounds_proc) - - call bgc_vegetation_inst%initAccVars(bounds_proc) - - !------------------------------------------------------------ - ! Read monthly vegetation - !------------------------------------------------------------ - - ! Even if CN is on, and dry-deposition is active, read CLMSP annual vegetation - ! to get estimates of monthly LAI - - if ( n_drydep > 0 .and. drydep_method == DD_XLND )then - call readAnnualVegetation(bounds_proc, canopystate_inst) - if (nsrest == nsrStartup .and. finidat /= ' ') then - ! Call interpMonthlyVeg for dry-deposition so that mlaidiff will be calculated - ! This needs to be done even if CN or CNDV is on! - call interpMonthlyVeg(bounds_proc, canopystate_inst) - end if - end if - - !------------------------------------------------------------ - ! Determine gridcell averaged properties to send to atm - !------------------------------------------------------------ - - if (nsrest == nsrStartup) then - call t_startf('init_map2gc') - call lnd2atm_minimal(bounds_proc, & - waterstate_inst, surfalb_inst, energyflux_inst, lnd2atm_inst) - call t_stopf('init_map2gc') - end if - - !------------------------------------------------------------ - ! Initialize sno export state to send to glc - !------------------------------------------------------------ - - !$OMP PARALLEL DO PRIVATE (nc, bounds_clump) - do nc = 1,nclumps - call get_clump_bounds(nc, bounds_clump) - - call t_startf('init_lnd2glc') - call lnd2glc_inst%update_lnd2glc(bounds_clump, & - filter(nc)%num_do_smb_c, filter(nc)%do_smb_c, & - temperature_inst, glacier_smb_inst, topo_inst, & - init=.true.) - call t_stopf('init_lnd2glc') - end do - !$OMP END PARALLEL DO - - !------------------------------------------------------------ - ! Deallocate wt_nat_patch - !------------------------------------------------------------ - - ! wt_nat_patch was allocated in initialize1, but needed to be kept around through - ! initialize2 for some consistency checking; now it can be deallocated - - deallocate(wt_nat_patch) - - ! topo_glc_mec was allocated in initialize1, but needed to be kept around through - ! initialize2 because it is used to initialize other variables; now it can be - ! deallocated +! TODO SLIM: slevis keeping an example of an accumulated field as template +! ! ------------------------------------------------------------------------ +! ! Initialize variables that are associated with accumulated fields. +! ! ------------------------------------------------------------------------ - deallocate(topo_glc_mec, fert_cft) +! ! The following is called for both initial and restart runs and must +! ! must be called after the restart file is read +! call atm2lnd_inst%initAccVars(bounds_proc) !------------------------------------------------------------ ! Write log output for end of initialization diff --git a/src/main/clm_instMod.F90 b/src/main/clm_instMod.F90 index 6be25eb4..d3306698 100644 --- a/src/main/clm_instMod.F90 +++ b/src/main/clm_instMod.F90 @@ -7,73 +7,21 @@ module clm_instMod ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 use decompMod , only : bounds_type - use clm_varpar , only : ndecomp_pools, nlevdecomp_full - use clm_varctl , only : use_cn, use_cndv - use clm_varctl , only : use_century_decomp, use_crop - use clm_varcon , only : bdsno, c13ratio, c14ratio - use landunit_varcon , only : istice_mec, istsoil + use clm_varcon , only : bdsno + use clm_varctl , only : iulog use perf_mod , only : t_startf, t_stopf - use controlMod , only : NLFilename !----------------------------------------- ! Constants !----------------------------------------- - use UrbanParamsType , only : urbanparams_type ! Constants - use UrbanParamsType , only : IsSimpleBuildTemp, IsProgBuildTemp - use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con - !use CNDVType , only : dgv_ecophyscon ! Constants - !----------------------------------------- ! Definition of component types !----------------------------------------- - use AerosolMod , only : aerosol_type - use CanopyStateType , only : canopystate_type - use ch4Mod , only : ch4_type - use CNVegetationFacade , only : cn_vegetation_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 CropType , only : crop_type - use DryDepVelocity , only : drydepvel_type - use DUSTMod , only : dust_type - use EnergyFluxType , only : energyflux_type - use FrictionVelocityMod , only : frictionvel_type - use GlacierSurfaceMassBalanceMod , only : glacier_smb_type - use LakeStateType , only : lakestate_type - use OzoneBaseMod , only : ozone_base_type - use OzoneFactoryMod , only : create_and_init_ozone_type - use PhotosynthesisMod , only : photosyns_type - use SoilHydrologyType , only : soilhydrology_type - use SoilStateType , only : soilstate_type - use SolarAbsorbedType , only : solarabs_type - use SurfaceRadiationMod , only : surfrad_type - use SurfaceAlbedoType , only : surfalb_type - use TemperatureType , only : temperature_type - use WaterFluxType , only : waterflux_type - use WaterStateType , only : waterstate_type - use UrbanParamsType , only : urbanparams_type - use VOCEmissionMod , only : vocemis_type use atm2lndType , only : atm2lnd_type use lnd2atmType , only : lnd2atm_type - use lnd2glcMod , only : lnd2glc_type - use glc2lndMod , only : glc2lnd_type - use glcBehaviorMod , only : glc_behavior_type - use TopoMod , only : topo_type use GridcellType , only : grc - use LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch - use SoilWaterRetentionCurveMod , only : soil_water_retention_curve_type - ! - use SoilStateInitTimeConstMod , only : SoilStateInitTimeConst - use SoilHydrologyInitTimeConstMod , only : SoilHydrologyInitTimeConst - use SurfaceAlbedoMod , only : SurfaceAlbedoInitTimeConst - use LakeCon , only : LakeConInit - use SoilBiogeochemPrecisionControlMod, only: SoilBiogeochemPrecisionControlInit ! implicit none public ! By default everything is public @@ -83,305 +31,42 @@ module clm_instMod !----------------------------------------- ! Physics types - type(aerosol_type) :: aerosol_inst - type(canopystate_type) :: canopystate_inst - type(energyflux_type) :: energyflux_inst - type(frictionvel_type) :: frictionvel_inst - type(glacier_smb_type) :: glacier_smb_inst - type(lakestate_type) :: lakestate_inst - class(ozone_base_type), allocatable :: ozone_inst - type(photosyns_type) :: photosyns_inst - type(soilstate_type) :: soilstate_inst - type(soilhydrology_type) :: soilhydrology_inst - type(solarabs_type) :: solarabs_inst - type(surfalb_type) :: surfalb_inst - type(surfrad_type) :: surfrad_inst - type(temperature_type) :: temperature_inst - type(urbanparams_type) :: urbanparams_inst - type(waterflux_type) :: waterflux_inst - type(waterstate_type) :: waterstate_inst type(atm2lnd_type) :: atm2lnd_inst - type(glc2lnd_type) :: glc2lnd_inst type(lnd2atm_type) :: lnd2atm_inst - type(lnd2glc_type) :: lnd2glc_inst - type(glc_behavior_type), target :: glc_behavior - type(topo_type) :: topo_inst - class(soil_water_retention_curve_type) , allocatable :: soil_water_retention_curve - - ! CN vegetation types - ! Eventually bgc_vegetation_inst will be an allocatable instance of an abstract - ! interface - type(cn_vegetation_type) :: bgc_vegetation_inst - - ! Soil biogeochem types - type(soilbiogeochem_state_type) :: soilbiogeochem_state_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_carbonflux_type) :: soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonflux_type) :: c13_soilbiogeochem_carbonflux_inst - type(soilbiogeochem_carbonflux_type) :: c14_soilbiogeochem_carbonflux_inst - type(soilbiogeochem_nitrogenstate_type) :: soilbiogeochem_nitrogenstate_inst - type(soilbiogeochem_nitrogenflux_type) :: soilbiogeochem_nitrogenflux_inst - - ! General biogeochem types - type(ch4_type) :: ch4_inst - type(crop_type) :: crop_inst - type(dust_type) :: dust_inst - !type(vocemis_type) :: vocemis_inst - type(drydepvel_type) :: drydepvel_inst - - ! FATES - ! public :: clm_instInit ! Initialize - public :: clm_instReadNML ! Read in namelist public :: clm_instRest ! Setup restart !----------------------------------------------------------------------- contains - !----------------------------------------------------------------------- - subroutine clm_instReadNML( NLFilename ) - ! - ! !ARGUMENTS - implicit none - character(len=*), intent(IN) :: NLFilename ! Namelist filename - ! Read in any namelists that must be read for any clm object instances that need it - call canopystate_inst%ReadNML( NLFilename ) - !call photosyns_inst%ReadNML( NLFilename ) - !if (use_cn) then - !call crop_inst%ReadNML( NLFilename ) - !end if - - end subroutine clm_instReadNML - !----------------------------------------------------------------------- subroutine clm_instInit(bounds) - ! - ! !USES: - use clm_varpar , only : nlevsno, numpft - use controlMod , only : nlfilename, fsurdat - use domainMod , only : ldomain - use SoilBiogeochemDecompCascadeBGCMod , only : init_decompcascade_bgc - use SoilBiogeochemDecompCascadeCNMod , only : init_decompcascade_cn - use SoilBiogeochemDecompCascadeContype , only : init_decomp_cascade_constants - use initVerticalMod , only : initVertical - use accumulMod , only : print_accum_fields - use SoilWaterRetentionCurveFactoryMod , only : create_soil_water_retention_curve - use decompMod , only : get_proc_bounds ! ! !ARGUMENTS type(bounds_type), intent(in) :: bounds ! processor bounds ! ! !LOCAL VARIABLES: - integer :: c,l,g - integer :: nclumps,nc - integer :: begp, endp - integer :: begc, endc - integer :: begl, endl - type(bounds_type) :: bounds_clump - real(r8), allocatable :: h2osno_col(:) - real(r8), allocatable :: snow_depth_col(:) - - integer :: dummy_to_make_pgi_happy !---------------------------------------------------------------------- - ! Note: h2osno_col and snow_depth_col are initialized as local variable - ! since they are needed to initialize vertical data structures - - begp = bounds%begp; endp = bounds%endp - begc = bounds%begc; endc = bounds%endc - begl = bounds%begl; endl = bounds%endl - - allocate (h2osno_col(begc:endc)) - allocate (snow_depth_col(begc:endc)) - - ! snow water - do c = begc,endc - l = col%landunit(c) - g = col%gridcell(c) - - ! In areas that should be snow-covered, it can be problematic to start with 0 snow - ! cover, because this can affect the long-term state through soil heating, albedo - ! feedback, etc. On the other hand, we would introduce hysteresis by putting too - ! much snow in places that are in a net melt regime, because the melt-albedo - ! feedback may not activate on time (or at all). So, as a compromise, we start with - ! a small amount of snow in places that are likely to be snow-covered for much or - ! all of the year. - if (lun%itype(l)==istice_mec) then - h2osno_col(c) = 100._r8 - else if (lun%itype(l)==istsoil .and. abs(grc%latdeg(g)) >= 60._r8) then - h2osno_col(c) = 100._r8 - else - h2osno_col(c) = 0._r8 - endif - snow_depth_col(c) = h2osno_col(c) / bdsno - end do - - ! Initialize urban constants - - call urbanparams_inst%Init(bounds) - - ! Initialize vertical data components - - call initVertical(bounds, & - glc_behavior, & - snow_depth_col(begc:endc), & - urbanparams_inst%thick_wall(begl:endl), & - urbanparams_inst%thick_roof(begl:endl)) - ! Initialize clm->drv and drv->clm data structures - call atm2lnd_inst%Init( bounds, NLFilename ) - call lnd2atm_inst%Init( bounds, NLFilename ) - - call glc2lnd_inst%Init( bounds, glc_behavior ) - call lnd2glc_inst%Init( bounds ) + call atm2lnd_inst%Init(bounds) + call lnd2atm_inst%Init(bounds) ! Initialization of public data types - call temperature_inst%Init(bounds, & - urbanparams_inst%em_roof(begl:endl), & - urbanparams_inst%em_wall(begl:endl), & - urbanparams_inst%em_improad(begl:endl), & - urbanparams_inst%em_perroad(begl:endl), & - IsSimpleBuildTemp(), IsProgBuildTemp() ) - - call canopystate_inst%Init(bounds) - - call soilstate_inst%Init(bounds) - call SoilStateInitTimeConst(bounds, soilstate_inst, nlfilename) ! sets hydraulic and thermal soil properties - - call waterstate_inst%Init(bounds, & - h2osno_col(begc:endc), & - snow_depth_col(begc:endc), & - soilstate_inst%watsat_col(begc:endc, 1:), & - temperature_inst%t_soisno_col(begc:endc, -nlevsno+1:) ) - - call waterflux_inst%Init(bounds) - - call glacier_smb_inst%Init(bounds) - - ! COMPILER_BUG(wjs, 2014-11-29, pgi 14.7) Without the following assignment, the - ! assertion in energyflux_inst%Init fails with pgi 14.7 on yellowstone, presumably due - ! to a compiler bug. - dummy_to_make_pgi_happy = ubound(temperature_inst%t_grnd_col, 1) - call energyflux_inst%Init(bounds, temperature_inst%t_grnd_col(begc:endc), & - IsSimpleBuildTemp(), IsProgBuildTemp() ) - - !call aerosol_inst%Init(bounds, NLFilename) - - call frictionvel_inst%Init(bounds) - - call lakestate_inst%Init(bounds) - call LakeConInit() - - allocate(ozone_inst, source = create_and_init_ozone_type(bounds)) - - call photosyns_inst%Init(bounds) - - call soilhydrology_inst%Init(bounds, nlfilename) - call SoilHydrologyInitTimeConst(bounds, soilhydrology_inst) ! sets time constant properties - - call solarabs_inst%Init(bounds) - - call surfalb_inst%Init(bounds) - call SurfaceAlbedoInitTimeConst(bounds) - - call surfrad_inst%Init(bounds) - - call dust_inst%Init(bounds) - - call topo_inst%Init(bounds) - - ! Note - always initialize the memory for ch4_inst - !call ch4_inst%Init(bounds, soilstate_inst%cellorg_col(begc:endc, 1:), fsurdat, nlfilename) - - !call vocemis_inst%Init(bounds) - - !call drydepvel_inst%Init(bounds) - - if (use_cn ) then - - ! Initialize soilbiogeochem_state_inst - - call soilbiogeochem_state_inst%Init(bounds) +! TODO SLIM: slevis keeping an example of an accumulated field as template +! ! ------------------------------------------------------------------------ +! ! Initialize accumulated fields +! ! ------------------------------------------------------------------------ - ! Initialize decompcascade constants - ! Note that init_decompcascade_bgc and init_decompcascade_cn need - ! soilbiogeochem_state_inst to be initialized +! ! The time manager needs to be initialized before this called is made, since +! ! the step size is needed. - call init_decomp_cascade_constants() - 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 - - ! Initalize soilbiogeochem carbon types - - call soilbiogeochem_carbonstate_inst%Init(bounds, carbon_type='c12', ratio=1._r8) - - end if - - if ( use_cn ) then - - ! Initalize soilbiogeochem nitrogen types - - call soilbiogeochem_nitrogenstate_inst%Init(bounds, & - soilbiogeochem_carbonstate_inst%decomp_cpools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools), & - soilbiogeochem_carbonstate_inst%decomp_cpools_col(begc:endc,1:ndecomp_pools), & - soilbiogeochem_carbonstate_inst%decomp_cpools_1m_col(begc:endc, 1:ndecomp_pools)) - - call soilbiogeochem_nitrogenflux_inst%Init(bounds) - - ! Initialize precision control for soil biogeochemistry - call SoilBiogeochemPrecisionControlInit( soilbiogeochem_carbonstate_inst, c13_soilbiogeochem_carbonstate_inst, & - c14_soilbiogeochem_carbonstate_inst, soilbiogeochem_nitrogenstate_inst) - - end if ! end of if use_cn - - ! Note - always call Init for bgc_vegetation_inst: some pieces need to be initialized always - call bgc_vegetation_inst%Init(bounds, nlfilename) - - if (use_cn ) then - call crop_inst%Init(bounds) - end if - - - deallocate (h2osno_col) - deallocate (snow_depth_col) - - ! ------------------------------------------------------------------------ - ! Initialize accumulated fields - ! ------------------------------------------------------------------------ - - ! The time manager needs to be initialized before this called is made, since - ! the step size is needed. - - call t_startf('init_accflds') - - call atm2lnd_inst%InitAccBuffer(bounds) - - call temperature_inst%InitAccBuffer(bounds) - - call waterflux_inst%InitAccBuffer(bounds) - - call energyflux_inst%InitAccBuffer(bounds) - - call canopystate_inst%InitAccBuffer(bounds) - - call bgc_vegetation_inst%InitAccBuffer(bounds) - - if (use_crop) then - call crop_inst%InitAccBuffer(bounds) - end if - - call print_accum_fields() - - call t_stopf('init_accflds') +! call t_startf('init_accflds') +! call atm2lnd_inst%InitAccBuffer(bounds) +! call t_stopf('init_accflds') end subroutine clm_instInit @@ -390,85 +75,18 @@ subroutine clm_instRest(bounds, ncid, flag) ! ! !USES: use ncdio_pio , only : file_desc_t - use UrbanParamsType , only : IsSimpleBuildTemp, IsProgBuildTemp - use decompMod , only : get_proc_bounds, get_proc_clumps, get_clump_bounds - ! ! !DESCRIPTION: ! Define/write/read CLM restart file. ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds - type(file_desc_t) , intent(inout) :: ncid ! netcdf id character(len=*) , intent(in) :: flag ! 'define', 'write', 'read' - - ! Local variables - integer :: nc, nclumps - type(bounds_type) :: bounds_clump - !----------------------------------------------------------------------- call atm2lnd_inst%restart (bounds, ncid, flag=flag) - call canopystate_inst%restart (bounds, ncid, flag=flag) - - call energyflux_inst%restart (bounds, ncid, flag=flag, & - is_simple_buildtemp=IsSimpleBuildTemp(), is_prog_buildtemp=IsProgBuildTemp()) - - call frictionvel_inst% restart (bounds, ncid, flag=flag) - - call lakestate_inst%restart (bounds, ncid, flag=flag) - - call ozone_inst%restart (bounds, ncid, flag=flag) - - call photosyns_inst%restart (bounds, ncid, flag=flag) - - call soilhydrology_inst%restart (bounds, ncid, flag=flag) - - call solarabs_inst%restart (bounds, ncid, flag=flag) - - call temperature_inst%restart (bounds, ncid, flag=flag, & - is_simple_buildtemp=IsSimpleBuildTemp(), is_prog_buildtemp=IsProgBuildTemp()) - - call soilstate_inst%restart (bounds, ncid, flag=flag) - - call waterflux_inst%restart (bounds, ncid, flag=flag) - - call waterstate_inst%restart (bounds, ncid, flag=flag, & - watsat_col=soilstate_inst%watsat_col(bounds%begc:bounds%endc,:)) - - !call aerosol_inst%restart (bounds, ncid, flag=flag, & - !h2osoi_ice_col=waterstate_inst%h2osoi_ice_col(bounds%begc:bounds%endc,:), & - !h2osoi_liq_col=waterstate_inst%h2osoi_liq_col(bounds%begc:bounds%endc,:)) - - call surfalb_inst%restart (bounds, ncid, flag=flag, & - tlai_patch=canopystate_inst%tlai_patch(bounds%begp:bounds%endp), & - tsai_patch=canopystate_inst%tsai_patch(bounds%begp:bounds%endp)) - - call topo_inst%restart (bounds, ncid, flag=flag) - - if ( use_cn ) then - ! Need to do vegetation restart before soil bgc restart to get totvegc_col for purpose - ! of resetting soil carbon at exit spinup when no vegetation is growing. - call bgc_vegetation_inst%restart(bounds, ncid, flag=flag) - - call soilbiogeochem_nitrogenstate_inst%restart(bounds, ncid, flag=flag, & - totvegc_col=bgc_vegetation_inst%get_totvegc_col(bounds)) - call soilbiogeochem_nitrogenflux_inst%restart(bounds, ncid, flag=flag) - - call crop_inst%restart(bounds, ncid, flag=flag) - end if - - if (use_cn ) then - - call soilbiogeochem_state_inst%restart(bounds, ncid, flag=flag) - call soilbiogeochem_carbonstate_inst%restart(bounds, ncid, flag=flag, carbon_type='c12', & - totvegc_col=bgc_vegetation_inst%get_totvegc_col(bounds)) - - call soilbiogeochem_carbonflux_inst%restart(bounds, ncid, flag=flag) - endif - end subroutine clm_instRest end module clm_instMod diff --git a/src/main/clm_varcon.F90 b/src/main/clm_varcon.F90 index d0a20535..48ea6c65 100644 --- a/src/main/clm_varcon.F90 +++ b/src/main/clm_varcon.F90 @@ -14,10 +14,6 @@ module clm_varcon SHR_CONST_PDB, SHR_CONST_PI, SHR_CONST_CDAY, & SHR_CONST_RGAS, SHR_CONST_PSTD, & SHR_CONST_MWDAIR, SHR_CONST_MWWV - use clm_varpar , only: numrad, nlevgrnd, nlevlak, nlevdecomp_full - use clm_varpar , only: ngases - use clm_varpar , only: nlayer - ! ! !PUBLIC TYPES: implicit none @@ -42,10 +38,7 @@ module clm_varcon ! Initialize physical constants !------------------------------------------------------------------ - real(r8), parameter :: n_melt=0.7 ! fsca shape parameter - real(r8), parameter :: e_ice=6.0 ! soil ice impedance factor real(r8), parameter :: pc = 0.4 ! threshold probability - real(r8), parameter :: mu = 0.13889 ! connectivity exponent real(r8), parameter :: secsphr = 3600._r8 ! Seconds in an hour integer, parameter :: isecsphr = int(secsphr) ! Integer seconds in an hour integer, parameter :: isecspmin= 60 ! Integer seconds in a minute @@ -88,9 +81,6 @@ module clm_varcon 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 ! ------------------------------------------------------------------------ @@ -106,111 +96,14 @@ module clm_varcon ! 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) :: zlnd = 0.01_r8 ! Roughness length for soil [m] - real(r8) :: zsno = 0.0024_r8 ! Roughness length for snow [m] - real(r8) :: csoilc = 0.004_r8 ! Drag coefficient for soil under canopy [-] - real(r8) :: capr = 0.34_r8 ! Tuning factor to turn first layer T into surface T - real(r8) :: cnfac = 0.5_r8 ! Crank Nicholson factor between 0 and 1 - real(r8) :: ssi = 0.033_r8 ! Irreducible water saturation of snow - real(r8) :: wimp = 0.05_r8 ! Water impremeable if porosity less than wimp - real(r8) :: pondmx = 0.0_r8 ! Ponding depth (mm) - real(r8) :: pondmx_urban = 1.0_r8 ! Ponding depth for urban roof and impervious road (mm) - - real(r8) :: thk_bedrock = 3.0_r8 ! thermal conductivity of 'typical' saturated granitic rock - ! (Clauser and Huenges, 1995)(W/m/K) - real(r8) :: csol_bedrock = 2.0e6_r8 ! vol. heat capacity of granite/sandstone J/(m3 K)(Shabbir, 2000) !scs - real(r8), parameter :: zmin_bedrock = 0.4_r8 ! minimum soil depth [m] - - real(r8), parameter :: aquifer_water_baseline = 5000._r8 ! baseline value for water in the unconfined aquifer [mm] - - !!! 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 - - ! typical del13C for C3 photosynthesis (permil, relative to PDB) - real(r8), parameter :: c3_del13c = -28._r8 - - ! typical del13C for C4 photosynthesis (permil, relative to PDB) - real(r8), parameter :: c4_del13c = -13._r8 - - ! isotope ratio (13c/12c) for C3 photosynthesis - real(r8), parameter :: c3_r1 = SHR_CONST_PDB + ((c3_del13c*SHR_CONST_PDB)/1000._r8) - - ! isotope ratio (13c/[12c+13c]) for C3 photosynthesis - real(r8), parameter :: c3_r2 = c3_r1/(1._r8 + c3_r1) - - ! isotope ratio (13c/12c) for C4 photosynthesis - real(r8), parameter :: c4_r1 = SHR_CONST_PDB + ((c4_del13c*SHR_CONST_PDB)/1000._r8) - - ! isotope ratio (13c/[12c+13c]) for C4 photosynthesis - real(r8), parameter :: c4_r2 = c4_r1/(1._r8 + c4_r1) - - !!! C14 - real(r8) :: 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) :: ht_wasteheat_factor = 0.2_r8 ! wasteheat factor for urban heating (-) - real(r8) :: ac_wasteheat_factor = 0.6_r8 ! wasteheat factor for urban air conditioning (-) - real(r8) :: em_roof_int = 0.9_r8 ! emissivity of interior surface of roof (Bueno et al. 2012, GMD) - real(r8) :: em_sunw_int = 0.9_r8 ! emissivity of interior surface of sunwall (Bueno et al. 2012, GMD) - real(r8) :: em_shdw_int = 0.9_r8 ! emissivity of interior surface of shadewall Bueno et al. 2012, GMD) - real(r8) :: em_floor_int = 0.9_r8 ! emissivity of interior surface of floor (Bueno et al. 2012, GMD) - real(r8) :: hcv_roof = 0.948_r8 ! interior convective heat transfer coefficient for roof (Bueno et al. 2012, GMD) (W m-2 K-1) - real(r8) :: 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) :: hcv_floor = 0.948_r8 ! interior convective heat transfer coefficient for floor (Bueno et al. 2012, GMD) (W m-2 K-1) - real(r8) :: 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) :: hcv_sunw = 3.076_r8 ! interior convective heat transfer coefficient for sunwall (Bueno et al. 2012, GMD) (W m-2 K-1) - real(r8) :: hcv_shdw = 3.076_r8 ! interior convective heat transfer coefficient for shadewall (Bueno et al. 2012, GMD) (W m-2 K-1) - real(r8) :: dz_floor = 0.1_r8 ! floor thickness - concrete (Salmanca et al. 2010, TAC) (m) - real(r8), parameter :: dens_floor = 2.35e3_r8 ! density of floor - concrete (Salmanca et al. 2010, TAC) (kg m-3) - real(r8), parameter :: sh_floor = 880._r8 ! specific heat of floor - concrete (Salmanca et al. 2010, TAC) (J kg-1 K-1) - real(r8) :: cp_floor = dens_floor*sh_floor ! volumetric heat capacity of floor - concrete (Salmanca et al. 2010, TAC) (J m-3 K-1) - real(r8) :: vent_ach = 0.3 ! ventilation rate (air exchanges per hour) - - real(r8) :: wasteheat_limit = 100._r8 ! limit on wasteheat (W/m2) - - !------------------------------------------------------------------ - - real(r8) :: h2osno_max = -999.0_r8 ! max allowed snow thickness (mm H2O) - real(r8) :: int_snow_max = -999.0_r8 ! limit applied to integrated snowfall when determining changes in snow-covered fraction during melt (mm H2O) - real(r8) :: n_melt_glcmec = -999.0_r8 ! SCA shape parameter for glc_mec columns - 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), 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) - !------------------------------------------------------------------ ! Set subgrid names !------------------------------------------------------------------ character(len=16), parameter :: grlnd = 'lndgrid' ! name of lndgrid - character(len=16), parameter :: namea = 'gridcellatm' ! name of atmgrid character(len=16), parameter :: nameg = 'gridcell' ! name of gridcells - character(len=16), parameter :: namel = 'landunit' ! name of landunits - character(len=16), parameter :: namec = 'column' ! name of columns - character(len=16), parameter :: namep = 'pft' ! name of patches - character(len=16), parameter :: nameCohort = 'cohort' ! name of cohorts (ED specific) - - !------------------------------------------------------------------ - ! Initialize miscellaneous radiation constants - !------------------------------------------------------------------ - - real(r8) :: betads = 0.5_r8 ! two-stream parameter betad for snow - real(r8) :: betais = 0.5_r8 ! two-stream parameter betai for snow - real(r8) :: omegas(numrad) ! two-stream parameter omega for snow by band - data (omegas(i),i=1,numrad) /0.8_r8, 0.4_r8/ - - ! Lake Model Constants will be defined in LakeCon. !------------------------------------------------------------------ ! Soil depths are constants for now; lake depths can vary by gridcell @@ -218,86 +111,28 @@ module clm_varcon ! The values for the following arrays are set in routine iniTimeConst !------------------------------------------------------------------ - real(r8), allocatable :: zlak(:) !lake z (layers) - real(r8), allocatable :: dzlak(:) !lake dz (thickness) real(r8), allocatable :: zsoi(:) !soil z (layers) - real(r8), allocatable :: dzsoi(:) !soil dz (thickness) - real(r8), allocatable :: zisoi(:) !soil zi (interfaces) - real(r8), allocatable :: dzsoi_decomp(:) !soil dz (thickness) - integer , allocatable :: nlvic(:) !number of CLM layers in each VIC layer (#) - real(r8), allocatable :: dzvic(:) !soil dz (thickness) of each VIC layer - real(r8) ,allocatable :: zsoifl(:) !original soil midpoint (used in interpolation of sand and clay) - real(r8) ,allocatable :: zisoifl(:) !original soil interface depth (used in interpolation of sand and clay) - real(r8) ,allocatable :: dzsoifl(:) !original soil thickness (used in interpolation of sand and clay) - - !------------------------------------------------------------------ - ! (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) - !----------------------------------------------------------------------- contains !------------------------------------------------------------------------------ - subroutine clm_varcon_init( is_simple_buildtemp ) + subroutine clm_varcon_init() ! ! !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, nlevsoifl, nlayer + use clm_varpar, only: nlevgrnd ! ! !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 )) - allocate( zsoifl(1:nlevsoifl )) - allocate( zisoifl(0:nlevsoifl )) - allocate( dzsoifl(1:nlevsoifl )) - - ! 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 diff --git a/src/main/clm_varctl.F90 b/src/main/clm_varctl.F90 index e66ebbcf..ed776822 100644 --- a/src/main/clm_varctl.F90 +++ b/src/main/clm_varctl.F90 @@ -11,8 +11,6 @@ module clm_varctl ! !PUBLIC MEMBER FUNCTIONS: implicit none public :: clm_varctl_set ! Set variables - public :: cnallocate_carbon_only_set - public :: cnallocate_carbon_only ! private save @@ -85,31 +83,20 @@ module clm_varctl !---------------------------------------------------------- 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 !---------------------------------------------------------- ! MML input files !---------------------------------------------------------- character(len=fname_len), public :: mml_surdat = ' ' ! MML surface data file for simple model - !---------------------------------------------------------- - ! 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 @@ -118,157 +105,13 @@ module clm_varctl character(len=fname_len), public :: finidat_interp_source = ' ' character(len=fname_len), public :: finidat_interp_dest = 'finidat_interp_dest.nc' - !---------------------------------------------------------- - ! 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 = .true. - - ! do not irrigate by default - logical, public :: irrigate = .false. - - !---------------------------------------------------------- - ! Other subgrid logic - !---------------------------------------------------------- - - ! true => make ALL patches, cols & landunits active (even if weight is 0) - logical, public :: all_active = .false. - - !---------------------------------------------------------- - ! 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 - integer, public :: subgridflag = 1 - ! 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 - - !---------------------------------------------------------- - ! FATES switches - !---------------------------------------------------------- - - logical, public :: use_fates = .false. ! true => use fates - - ! These are INTERNAL to the FATES module - logical, public :: use_fates_spitfire = .false. ! true => use spitfire model - 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_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 - 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 - - !---------------------------------------------------------- - ! lai streams switch for Sat. Phenology - !---------------------------------------------------------- - - logical, public :: use_lai_streams = .false. ! true => use lai streams in SatellitePhenologyMod.F90 - - !---------------------------------------------------------- - ! bedrock / soil depth switch - !---------------------------------------------------------- - - logical, public :: use_bedrock = .false. ! true => use spatially variable soil depth - character(len=16), public :: soil_layerstruct = '10SL_3.5m' - - !---------------------------------------------------------- - ! 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 !---------------------------------------------------------- @@ -302,37 +145,11 @@ module clm_varctl ! 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. - - !---------------------------------------------------------- - ! FATES - !---------------------------------------------------------- - character(len=fname_len), public :: fates_paramfile = ' ' - !---------------------------------------------------------- ! 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 !---------------------------------------------------------- @@ -382,15 +199,4 @@ subroutine clm_varctl_set( caseid_in, ctitle_in, brnch_retain_casename_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/src/main/clm_varpar.F90 b/src/main/clm_varpar.F90 index d2011dca..46343210 100644 --- a/src/main/clm_varpar.F90 +++ b/src/main/clm_varpar.F90 @@ -7,84 +7,21 @@ module clm_varpar ! !USES: use shr_kind_mod , only: r8 => shr_kind_r8 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, soil_layerstruct - use clm_varctl , only: use_fates + use clm_varctl , only: iulog - ! ! !PUBLIC TYPES: implicit none save ! Note - model resolution is read in from the surface dataset - integer, parameter :: nlev_equalspace = 15 - integer, parameter :: toplev_equalspace = 6 - integer :: nlevsoi ! number of hydrologically active soil layers - integer :: nlevsoifl ! number of soil layers on input file integer :: nlevgrnd ! number of ground layers ! (includes lower layers that are hydrologically inactive) - integer :: nlevurb ! number of urban layers - integer :: nlevlak ! number of lake layers - integer :: nlevdecomp ! number of biogeochemically active soil layers - integer :: nlevdecomp_full ! number of biogeochemical layers ! (includes lower layers that are biogeochemically inactive) - integer :: nlevsno = -1 ! maximum number of snow layers - integer, parameter :: ngases = 3 ! CH4, O2, & CO2 - integer, parameter :: nlevcan = 1 ! number of leaf layers in canopy layer - integer, parameter :: nvegwcs = 4 ! number of vegetation water conductance segments !ED variables - integer, parameter :: numwat = 5 ! number of water types (soil, ice, 2 lakes, wetland) integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir - integer, parameter :: ivis = 1 ! index for visible band - integer, parameter :: inir = 2 ! index for near-infrared band - integer, parameter :: numsolar = 2 ! number of solar type bands: direct, diffuse integer, parameter :: ndst = 4 ! number of dust size classes (BGC only) - integer, parameter :: dst_src_nbr = 3 ! number of size distns in src soil (BGC only) - integer, parameter :: sz_nbr = 200 ! number of sub-grid bins in large bin of dust size distribution (BGC only) - integer, parameter :: 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, parameter :: numveg = 16 ! number of veg types (without specific crop) - integer, parameter :: nlayer = 3 ! number of VIC soil layer --Added by AWang - integer :: nlayert ! number of VIC soil layer + 3 lower thermal layers - integer, parameter :: nvariants = 2 ! number of variants of PFT constants - - integer :: numpft = mxpft ! actual # of pfts (without bare) - integer :: numcft = 64 ! actual # of crops (includes unused CFTs that are merged into other CFTs) - integer :: maxpatch_urb= 5 ! max number of urban patches (columns) in urban landunit - - integer :: maxpatch_pft ! max number of plant functional types in naturally vegetated landunit (namelist setting) - - ! constants for decomposition cascade - - integer, parameter :: i_met_lit = 1 - integer, parameter :: i_cel_lit = i_met_lit + 1 - integer, parameter :: i_lig_lit = i_cel_lit + 1 - integer :: i_cwd - - integer :: ndecomp_pools - integer :: ndecomp_cascade_transitions - ! Indices used in surface file read and set in clm_varpar_init - - integer :: natpft_lb ! In PATCH arrays, lower bound of Patches on the natural veg landunit (i.e., bare ground index) - integer :: natpft_ub ! In PATCH arrays, upper bound of Patches on the natural veg landunit - integer :: 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 :: cft_lb ! In arrays of PFTs, lower bound of PFTs on the crop landunit - integer :: cft_ub ! In arrays of PFTs, upper bound of PFTs on the crop landunit - integer :: cft_size ! Number of PFTs on crop landunit in arrays of PFTs - - integer :: maxpatch_glcmec ! max number of elevation classes - integer :: max_patch_per_col - ! ! !PUBLIC MEMBER FUNCTIONS: public clm_varpar_init ! set parameters ! @@ -106,110 +43,14 @@ subroutine clm_varpar_init() character(len=32) :: subname = 'clm_varpar_init' ! subroutine name !------------------------------------------------------------------------------ - ! Crop settings and consistency checks - - if (use_crop) then - numpft = mxpft ! actual # of patches (without bare) - numcft = 64 ! actual # of crops - else - numpft = numveg ! actual # of patches (without bare) - numcft = 2 ! actual # of crops - end if - - ! 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 = (numpft + 1) - numcft ! note that numpft doesn't include bare ground -- thus we add 1 - cft_size = numcft - else - natpft_size = numpft + 1 ! note that numpft doesn't include bare ground -- thus we add 1 - 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 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(numpft+1, numcft, maxpatch_urb) - - nlevsoifl = 10 - nlevurb = 5 - if ( masterproc ) write(iulog, *) 'soil_layerstruct varpar ',soil_layerstruct - if ( soil_layerstruct == '10SL_3.5m' ) then - nlevsoi = nlevsoifl - nlevgrnd = 15 - else if ( soil_layerstruct == '23SL_3.5m' ) then - nlevsoi = 8 + nlev_equalspace - nlevgrnd = 15 + nlev_equalspace - else if ( soil_layerstruct == '49SL_10m' ) then - nlevsoi = 49 ! 10x10 + 9x100 + 30x300 = 1e4mm = 10m -! nlevsoi = 29 ! 10x10 + 9x100 + 10x300 = 4e3mm = 4m - nlevgrnd = nlevsoi+5 - else if ( soil_layerstruct == '20SL_8.5m' ) then - nlevsoi = 20 - nlevgrnd = nlevsoi+5 - endif - if ( masterproc ) write(iulog, *) 'soil_layerstruct varpar ',soil_layerstruct,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 + nlevgrnd = 15 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 - else - ndecomp_pools = 8 - ndecomp_cascade_transitions = 9 - end if - endif - end subroutine clm_varpar_init end module clm_varpar diff --git a/src/main/clm_varsur.F90 b/src/main/clm_varsur.F90 deleted file mode 100644 index a86fe08c..00000000 --- a/src/main/clm_varsur.F90 +++ /dev/null @@ -1,45 +0,0 @@ -module clm_instur - - !----------------------------------------------------------------------- - ! Module containing 2-d surface boundary data information - ! surface boundary data, these are all "gdc" local - ! Note that some of these need to be pointers (as opposed to just allocatable arrays) to - ! match the ncd_io interface; for consistency, we make them all pointers - ! - ! !USES: - use shr_kind_mod, only : r8 => shr_kind_r8 - ! - ! !PUBLIC TYPES: - implicit none - save - ! - ! weight of each landunit on the grid cell - real(r8), pointer :: wt_lunit(:,:) - - ! whether we have valid urban data in each grid cell - logical , pointer :: urban_valid(:) - - ! for natural veg landunit, weight of each patch on the landunit (adds to 1.0 on the - ! landunit for all all grid cells, even! those without any natural pft) - ! (second dimension goes natpft_lb:natpft_ub) - real(r8), pointer :: wt_nat_patch(:,:) - - ! for crop landunit, weight of each cft on the landunit (adds to 1.0 on the - ! landunit for all all grid cells, even those without any crop) - ! (second dimension goes cft_lb:cft_ub) - real(r8), pointer :: wt_cft(:,:) - - ! for each cft on the crop landunit prescribe annual fertilizer - ! landunit for all all grid cells, even those without any crop) - ! (second dimension goes cft_lb:cft_ub) - real(r8), pointer :: fert_cft(:,:) - - ! for glc_mec landunits, weight of glacier in each elevation class (adds to 1.0 on the - ! landunit for all grid cells, even those without any glacier) - real(r8), pointer :: wt_glc_mec(:,:) - - ! subgrid glacier_mec sfc elevation - real(r8), pointer :: topo_glc_mec(:,:) - !----------------------------------------------------------------------- - -end module clm_instur diff --git a/src/main/column_varcon.F90 b/src/main/column_varcon.F90 deleted file mode 100644 index 287df93b..00000000 --- a/src/main/column_varcon.F90 +++ /dev/null @@ -1,171 +0,0 @@ -module column_varcon - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Module containing column indices and associated variables and routines. - ! - ! !USES: -#include "shr_assert.h" - use shr_log_mod , only : errMsg => shr_log_errMsg - 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((1 <= icemec_class .and. icemec_class <= maxpatch_glcmec), errMsg(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((1 <= icemec_class .and. icemec_class <= maxpatch_glcmec), errMsg(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/src/main/controlMod.F90 b/src/main/controlMod.F90 index f6f8c63e..a05ac5e5 100644 --- a/src/main/controlMod.F90 +++ b/src/main/controlMod.F90 @@ -17,24 +17,14 @@ module controlMod use abortutils , only: endrun use spmdMod , only: masterproc use decompMod , only: clump_pproc - use clm_varcon , only: h2osno_max, int_snow_max, n_melt_glcmec - use clm_varpar , only: maxpatch_pft, maxpatch_glcmec, numrad, nlevsno - use initInterpMod , only: initInterp_readnl - use UrbanParamsType , only: UrbanReadNML - use SurfaceAlbedoMod , only: albice - use CNSharedParamsMod , only: use_fun + use clm_varpar , only: numrad use clm_varctl , only: iundef, rundef, nsrest, caseid, ctitle, nsrStartup, nsrContinue use clm_varctl , only: nsrBranch, brnch_retain_casename, hostname, username, source, version, conventions - use clm_varctl , only: iulog, outnc_large_files, finidat, fsurdat, fatmgrid, paramfile - use clm_varctl , only: all_active, co2_type - use clm_varctl , only: wrtdia, co2_ppmv, use_bedrock, soil_layerstruct, nsegspc, rpntdir, rpntfil - use clm_varctl , only: use_cn, NLFilename_in, use_century_decomp - use clm_varctl , only: use_nitrif_denitrif, create_crop_landunit, glc_snow_persistence_max_days - use clm_varctl , only: subgridflag, use_nguardrail, nfix_timeconst, use_vertsoilc + use clm_varctl , only: iulog, outnc_large_files, finidat, fatmgrid + use clm_varctl , only: wrtdia, nsegspc, rpntdir, rpntfil + use clm_varctl , only: NLFilename_in use clm_varctl , only: clm_varctl_set - use clm_varctl , only: use_lch4, irrigate, create_crop_landunit, use_crop, use_dynroot - use clm_varctl , only: use_fates, use_flexiblecn, use_hydrstress, use_luna, spinup_state - use clm_varctl , only: single_column, nrevsn, finidat_interp_source + use clm_varctl , only: single_column ! ! !PUBLIC TYPES: implicit none @@ -106,7 +96,6 @@ subroutine control_init( ) integer :: ierr ! error code integer :: unitn ! unit for namelist file integer :: dtime ! Integer time-step - integer :: override_nsrest ! If want to override the startup type sent from driver !------------------------------------------------------------------------ ! ---------------------------------------------------------------------- @@ -117,64 +106,15 @@ subroutine control_init( ) ! Input datasets - namelist /clm_inparm/ & - fsurdat, & - paramfile - - ! BGC info - - namelist /clm_inparm / & - co2_type - - namelist /clm_inparm / use_fun - - ! Glacier_mec info - namelist /clm_inparm/ & - maxpatch_glcmec, & - glc_snow_persistence_max_days, & - nlevsno, h2osno_max, int_snow_max, n_melt_glcmec - ! Other options namelist /clm_inparm/ & - clump_pproc, wrtdia, & - create_crop_landunit, co2_ppmv, override_nsrest, & - albice, soil_layerstruct, subgridflag, & - all_active - - namelist /clm_inparm/ use_bedrock + clump_pproc, wrtdia ! All old cpp-ifdefs are below and have been converted to namelist variables - ! max number of plant functional types in naturally vegetated landunit - namelist /clm_inparm/ maxpatch_pft - - namelist /clm_inparm/ & - use_vertsoilc, & - use_century_decomp, use_cn, & - use_nguardrail, use_nitrif_denitrif - ! Items not really needed, but do need to be properly set as they are used - namelist / clm_inparm/ & - use_lch4, & - irrigate, & - create_crop_landunit, & - use_crop, & - use_dynroot, & - use_fates, & - use_flexiblecn, & - use_hydrstress, & - use_luna, & - spinup_state, & - single_column - - logical :: use_fertilizer = .false. - logical :: use_grainproduct = .false. - logical :: use_lai_streams = .false. - character(len=256) :: fsnowaging, fsnowoptics - namelist /clm_inparm/ use_fertilizer, use_grainproduct, use_lai_streams, & - fsnowaging, fsnowoptics - + namelist / clm_inparm/ single_column ! ---------------------------------------------------------------------- ! Default values @@ -199,13 +139,6 @@ subroutine control_init( ) #else clump_pproc = 1 #endif - maxpatch_glcmec = 10 - nlevsno = 5 - h2osno_max = 1000.0_r8 - int_snow_max = 1.e30_r8 - n_melt_glcmec = 10.0_r8 - - override_nsrest = nsrest if (masterproc) then @@ -236,79 +169,17 @@ subroutine control_init( ) ! ---------------------------------------------------------------------- ! Check for namelist variables that SLIM can NOT use - if ( use_fates )then - call endrun(msg='ERROR SLIM can NOT run with use_fates on'//errMsg(sourcefile, __LINE__)) - end if - if ( use_lai_streams )then - call endrun(msg='ERROR SLIM can NOT run with use_lai_streams on'//errMsg(sourcefile, __LINE__)) - end if - if ( use_dynroot )then - call endrun(msg='ERROR SLIM can NOT run with use_dynroot on'//errMsg(sourcefile, __LINE__)) - end if if ( single_column )then call endrun(msg='ERROR SLIM can NOT run with single_column on'//errMsg(sourcefile, __LINE__)) end if - ! Override start-type (can only override to branch (3) and only - ! if the driver is a startup type - if ( override_nsrest /= nsrest )then - if ( override_nsrest /= nsrBranch .and. nsrest /= nsrStartup )then - call endrun(msg= ' ERROR: can ONLY override clm start-type ' // & - 'to branch type and ONLY if driver is a startup type'// & - errMsg(sourcefile, __LINE__)) - end if - call clm_varctl_set( nsrest_in=override_nsrest ) - end if - - if (maxpatch_glcmec <= 0) then - call endrun(msg=' ERROR: maxpatch_glcmec must be at least 1 ' // & - errMsg(sourcefile, __LINE__)) - end if - - ! If nfix_timeconst is equal to the junk default value, then it was not specified - ! by the user namelist and we need to assign it the correct default value. If the - ! user specified it in the namelist, we leave it alone. - - 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 - - ! If nlevsno, h2osno_max, int_snow_max or n_melt_glcmec are equal to their junk - ! default value, then they were not specified by the user namelist and we generate - ! an error message. Also check nlevsno for bounds. - if (nlevsno < 3 .or. nlevsno > 12) then - write(iulog,*)'ERROR: nlevsno = ',nlevsno,' is not supported, must be in range 3-12.' - call endrun(msg=' ERROR: invalid value for nlevsno in CLM namelist. '//& - errMsg(sourcefile, __LINE__)) - endif - if (h2osno_max <= 0.0_r8) then - write(iulog,*)'ERROR: h2osno_max = ',h2osno_max,' is not supported, must be greater than 0.0.' - call endrun(msg=' ERROR: invalid value for h2osno_max in CLM namelist. '//& - errMsg(sourcefile, __LINE__)) - endif - if (int_snow_max <= 0.0_r8) then - write(iulog,*)'ERROR: int_snow_max = ',int_snow_max,' is not supported, must be greater than 0.0.' - call endrun(msg=' ERROR: invalid value for int_snow_max in CLM namelist. '//& - errMsg(sourcefile, __LINE__)) - endif - if (n_melt_glcmec <= 0.0_r8) then - write(iulog,*)'ERROR: n_melt_glcmec = ',n_melt_glcmec,' is not supported, must be greater than 0.0.' - call endrun(msg=' ERROR: invalid value for n_melt_glcmec in CLM namelist. '//& - errMsg(sourcefile, __LINE__)) - endif - endif ! end of if-masterproc if-block ! ---------------------------------------------------------------------- ! Read in other namelists for other modules ! ---------------------------------------------------------------------- - call initInterp_readnl( NLFilename ) - call UrbanReadNML ( NLFilename ) +! call initInterp_readnl( NLFilename ) ! ---------------------------------------------------------------------- ! Broadcast all control information if appropriate @@ -320,38 +191,11 @@ subroutine control_init( ) ! consistency checks ! ---------------------------------------------------------------------- - ! 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 endrun(msg=' ERROR:: choices are constant, prognostic or diagnostic'//& - errMsg(sourcefile, __LINE__)) - end if - ! Check on run type if (nsrest == iundef) then call endrun(msg=' ERROR:: must set nsrest'//& errMsg(sourcefile, __LINE__)) end if - if (nsrest == nsrBranch .and. nrevsn == ' ') then - call endrun(msg=' ERROR: need to set restart data file name'//& - errMsg(sourcefile, __LINE__)) - end if - - ! Consistency settings for co2_ppvm - if ( (co2_ppmv <= 0.0_r8) .or. (co2_ppmv > 3000.0_r8) ) then - call endrun(msg=' ERROR: co2_ppmv is out of a reasonable range'//& - errMsg(sourcefile, __LINE__)) - end if - - ! Consistency settings for nrevsn - - if (nsrest == nsrStartup ) nrevsn = ' ' - if (nsrest == nsrContinue) nrevsn = 'set by restart pointer file file' - if (nsrest /= nsrStartup .and. nsrest /= nsrContinue .and. nsrest /= nsrBranch ) then - call endrun(msg=' ERROR: nsrest NOT set to a valid value'//& - errMsg(sourcefile, __LINE__)) - end if - if (masterproc) then write(iulog,*) 'Successfully initialized run control settings' write(iulog,*) @@ -493,70 +337,9 @@ subroutine control_spmd() call mpi_bcast (username, len(username), MPI_CHARACTER, 0, mpicom, ier) call mpi_bcast (nsrest, 1, MPI_INTEGER, 0, mpicom, ier) - call mpi_bcast (use_lch4, 1, MPI_LOGICAL, 0, mpicom, ier) - call mpi_bcast (use_nitrif_denitrif, 1, MPI_LOGICAL, 0, mpicom, ier) - call mpi_bcast (use_vertsoilc, 1, MPI_LOGICAL, 0, mpicom, ier) - call mpi_bcast (use_century_decomp, 1, MPI_LOGICAL, 0, mpicom, ier) - call mpi_bcast (use_cn, 1, MPI_LOGICAL, 0, mpicom, ier) - call mpi_bcast (use_nguardrail, 1, MPI_LOGICAL, 0, mpicom, ier) - call mpi_bcast (use_crop, 1, MPI_LOGICAL, 0, mpicom, ier) - - ! initial file variables - call mpi_bcast (fsurdat, len(fsurdat), MPI_CHARACTER, 0, mpicom, ier) - call mpi_bcast (paramfile, len(paramfile) , MPI_CHARACTER, 0, mpicom, ier) - - ! Irrigation - call mpi_bcast(irrigate, 1, MPI_LOGICAL, 0, mpicom, ier) - - ! Landunit generation - call mpi_bcast(create_crop_landunit, 1, MPI_LOGICAL, 0, mpicom, ier) - - ! Other subgrid logic - call mpi_bcast(all_active, 1, MPI_LOGICAL, 0, mpicom, ier) - - ! max number of plant functional types in naturally vegetated landunit - call mpi_bcast(maxpatch_pft, 1, MPI_LOGICAL, 0, mpicom, ier) - - ! BGC - call mpi_bcast (co2_type, len(co2_type), MPI_CHARACTER, 0, mpicom, ier) - if (use_cn) then - call mpi_bcast (nfix_timeconst, 1, MPI_REAL8, 0, mpicom, ier) - call mpi_bcast (spinup_state, 1, MPI_INTEGER, 0, mpicom, ier) - end if - - call mpi_bcast (use_fates, 1, MPI_LOGICAL, 0, mpicom, ier) - ! flexibleCN nitrogen model - call mpi_bcast (use_flexibleCN, 1, MPI_LOGICAL, 0, mpicom, ier) - - call mpi_bcast (use_luna, 1, MPI_LOGICAL, 0, mpicom, ier) - - call mpi_bcast (use_bedrock, 1, MPI_LOGICAL, 0, mpicom, ier) - - call mpi_bcast (use_hydrstress, 1, MPI_LOGICAL, 0, mpicom, ier) - - call mpi_bcast (use_dynroot, 1, MPI_LOGICAL, 0, mpicom, ier) - - if (use_cn) then - call mpi_bcast (use_fun, 1, MPI_LOGICAL, 0, mpicom, ier) - end if - ! physics variables - call mpi_bcast (subgridflag , 1, MPI_INTEGER, 0, mpicom, ier) call mpi_bcast (wrtdia, 1, MPI_LOGICAL, 0, mpicom, ier) call mpi_bcast (single_column,1, MPI_LOGICAL, 0, mpicom, ier) - call mpi_bcast (co2_ppmv, 1, MPI_REAL8,0, mpicom, ier) - call mpi_bcast (albice, 2, MPI_REAL8,0, mpicom, ier) - call mpi_bcast (soil_layerstruct,len(soil_layerstruct), MPI_CHARACTER, 0, mpicom, ier) - - ! snow pack variables - call mpi_bcast (nlevsno, 1, MPI_INTEGER, 0, mpicom, ier) - call mpi_bcast (h2osno_max, 1, MPI_REAL8, 0, mpicom, ier) - call mpi_bcast (int_snow_max, 1, MPI_REAL8, 0, mpicom, ier) - call mpi_bcast (n_melt_glcmec, 1, MPI_REAL8, 0, mpicom, ier) - - ! glacier_mec variables - call mpi_bcast (maxpatch_glcmec, 1, MPI_INTEGER, 0, mpicom, ier) - call mpi_bcast (glc_snow_persistence_max_days, 1, MPI_INTEGER, 0, mpicom, ier) ! restart file variables @@ -590,47 +373,8 @@ subroutine control_print () write(iulog,*) ' username = ',trim(username) write(iulog,*) ' hostname = ',trim(hostname) write(iulog,*) 'process control parameters:' - write(iulog,*) ' use_nitrif_denitrif = ', use_nitrif_denitrif - write(iulog,*) ' use_vertsoilc = ', use_vertsoilc - write(iulog,*) ' use_century_decomp = ', use_century_decomp - write(iulog,*) ' use_cn = ', use_cn write(iulog,*) 'input data files:' - write(iulog,*) ' PFT physiology and parameters file = ',trim(paramfile) - if (fsurdat == ' ') then - write(iulog,*) ' fsurdat, surface dataset not set' - else - write(iulog,*) ' surface data = ',trim(fsurdat) - end if - if (use_cn) then - if (nfix_timeconst /= 0._r8) then - write(iulog,*) ' nfix_timeconst, timescale for smoothing npp in N fixation term: ', nfix_timeconst - else - write(iulog,*) ' nfix_timeconst == zero, use standard N fixation scheme. ' - end if - - end if - - write(iulog,*) ' Number of snow layers =', nlevsno - write(iulog,*) ' Max snow depth (mm) =', h2osno_max - write(iulog,*) ' Limit applied to integrated snowfall when determining changes in' - write(iulog,*) ' snow-covered fraction during melt (mm) =', int_snow_max - write(iulog,*) ' SCA shape parameter for glc_mec columns (n_melt_glcmec) =', n_melt_glcmec - - write(iulog,*) ' glc number of elevation classes =', maxpatch_glcmec - write(iulog,*) ' glc snow persistence max days = ', glc_snow_persistence_max_days - - if (nsrest == nsrStartup) then - if (finidat /= ' ') then - write(iulog,*) ' initial data: ', trim(finidat) - else if (finidat_interp_source /= ' ') then - write(iulog,*) ' initial data interpolated from: ', trim(finidat_interp_source) - else - write(iulog,*) ' initial data created by model (cold start)' - end if - else - write(iulog,*) ' restart data = ',trim(nrevsn) - end if write(iulog,*) ' atmospheric forcing data is from cesm atm model' write(iulog,*) 'Restart parameters:' @@ -638,14 +382,6 @@ subroutine control_print () write(iulog,*)' restart pointer file name = ',trim(rpntfil) write(iulog,*) 'model physics parameters:' - if ( trim(co2_type) == 'constant' )then - write(iulog,*) ' CO2 volume mixing ratio (umol/mol) = ', co2_ppmv - else - write(iulog,*) ' CO2 volume mixing ratio = ', co2_type - end if - - write(iulog,*) ' land-ice albedos (unitless 0-1) = ', albice - write(iulog,*) ' soil layer structure = ', soil_layerstruct if (nsrest == nsrContinue) then write(iulog,*) 'restart warning:' write(iulog,*) ' Namelist not checked for agreement with initial run.' @@ -656,7 +392,6 @@ subroutine control_print () write(iulog,*) ' Namelist not checked for agreement with initial run.' write(iulog,*) ' Surface data set and reference date should not differ from initial run' end if - write(iulog,*) ' maxpatch_pft = ',maxpatch_pft end subroutine control_print diff --git a/src/main/decompInitMod.F90 b/src/main/decompInitMod.F90 index 810c7c96..7aecff63 100644 --- a/src/main/decompInitMod.F90 +++ b/src/main/decompInitMod.F90 @@ -14,10 +14,6 @@ module decompInitMod use clm_varctl , only : iulog use clm_varcon , only : grlnd use GridcellType , only : grc - use LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch - use glcBehaviorMod , only : glc_behavior_type use decompMod use mct_mod , only : mct_gsMap_init, mct_gsMap_ngseg, mct_gsMap_nlseg, mct_gsmap_gsize ! @@ -97,20 +93,8 @@ subroutine decompInit_lnd(lni,lnj,amask) procinfo%nclumps = clump_pproc procinfo%cid(:) = -1 procinfo%ncells = 0 - procinfo%nlunits = 0 - procinfo%ncols = 0 - procinfo%npatches = 0 - procinfo%nCohorts = 0 procinfo%begg = 1 - procinfo%begl = 1 - procinfo%begc = 1 - procinfo%begp = 1 - procinfo%begCohort = 1 procinfo%endg = 0 - procinfo%endl = 0 - procinfo%endc = 0 - procinfo%endp = 0 - procinfo%endCohort = 0 allocate(clumps(nclumps), stat=ier) if (ier /= 0) then @@ -119,20 +103,8 @@ subroutine decompInit_lnd(lni,lnj,amask) end if clumps(:)%owner = -1 clumps(:)%ncells = 0 - clumps(:)%nlunits = 0 - clumps(:)%ncols = 0 - clumps(:)%npatches = 0 - clumps(:)%nCohorts = 0 clumps(:)%begg = 1 - clumps(:)%begl = 1 - clumps(:)%begc = 1 - clumps(:)%begp = 1 - clumps(:)%begCohort = 1 clumps(:)%endg = 0 - clumps(:)%endl = 0 - clumps(:)%endc = 0 - clumps(:)%endp = 0 - clumps(:)%endCohort = 0 ! assign clumps to proc round robin cid = 0 @@ -312,7 +284,7 @@ subroutine decompInit_lnd(lni,lnj,amask) end subroutine decompInit_lnd !------------------------------------------------------------------------------ - subroutine decompInit_clumps(lns,lni,lnj,glc_behavior) + subroutine decompInit_clumps(lns,lni,lnj) ! ! !DESCRIPTION: ! This subroutine initializes the land surface decomposition into a clump @@ -320,13 +292,11 @@ subroutine decompInit_clumps(lns,lni,lnj,glc_behavior) ! set by clump_pproc ! ! !USES: - use subgridMod, only : subgrid_get_gcellinfo use spmdMod ! ! !ARGUMENTS: implicit none integer , intent(in) :: lns,lni,lnj ! land domain global size - type(glc_behavior_type), intent(in) :: glc_behavior ! ! !LOCAL VARIABLES: integer :: ln,an ! indices @@ -336,10 +306,6 @@ subroutine decompInit_clumps(lns,lni,lnj,glc_behavior) integer :: anumg ! lnd num gridcells integer :: icells ! temporary integer :: begg, endg ! temporary - integer :: ilunits ! temporary - integer :: icols ! temporary - integer :: ipatches ! temporary - integer :: icohorts ! temporary integer :: ier ! error code integer, allocatable :: allvecg(:,:) ! temporary vector "global" integer, allocatable :: allvecl(:,:) ! temporary vector "local" @@ -350,18 +316,11 @@ subroutine decompInit_clumps(lns,lni,lnj,glc_behavior) !--- assign gridcells to clumps (and thus pes) --- call get_proc_bounds(begg, endg) - allocate(allvecl(nclumps,5)) ! local clumps [gcells,lunit,cols,patches,coh] - allocate(allvecg(nclumps,5)) ! global clumps [gcells,lunit,cols,patches,coh] + allocate(allvecl(nclumps,5)) ! local clumps [gcells] + allocate(allvecg(nclumps,5)) ! global clumps [gcells] - ! Determine the number of gridcells, landunits, columns, and patches, cohorts + ! Determine the number of gridcells ! on this processor - ! Determine number of landunits, columns and patches for each global - ! gridcell index (an) that is associated with the local gridcell index (ln) - - ilunits=0 - icols=0 - ipatches=0 - icohorts=0 allvecg= 0 allvecl= 0 @@ -369,101 +328,28 @@ subroutine decompInit_clumps(lns,lni,lnj,glc_behavior) an = ldecomp%gdc2glo(anumg) cid = lcid(an) ln = anumg - call subgrid_get_gcellinfo (ln, nlunits=ilunits, ncols=icols, npatches=ipatches, & - ncohorts=icohorts, glc_behavior=glc_behavior) allvecl(cid,1) = allvecl(cid,1) + 1 - allvecl(cid,2) = allvecl(cid,2) + ilunits ! number of landunits for local clump cid - allvecl(cid,3) = allvecl(cid,3) + icols ! number of columns for local clump cid - allvecl(cid,4) = allvecl(cid,4) + ipatches ! number of patches for local clump cid - allvecl(cid,5) = allvecl(cid,5) + icohorts ! number of cohorts for local clump cid enddo call mpi_allreduce(allvecl,allvecg,size(allvecg),MPI_INTEGER,MPI_SUM,mpicom,ier) - ! Determine overall total gridcells, landunits, columns and patches and distribute + ! Determine overall total gridcells and distribute ! gridcells over clumps numg = 0 - numl = 0 - numc = 0 - nump = 0 - numCohort = 0 do cid = 1,nclumps icells = allvecg(cid,1) ! number of all clump cid gridcells (over all processors) - ilunits = allvecg(cid,2) ! number of all clump cid landunits (over all processors) - icols = allvecg(cid,3) ! number of all clump cid columns (over all processors) - ipatches = allvecg(cid,4) ! number of all clump cid patches (over all processors) - icohorts = allvecg(cid,5) ! number of all clump cid cohorts (over all processors) !--- overall total --- numg = numg + icells ! total number of gridcells - numl = numl + ilunits ! total number of landunits - numc = numc + icols ! total number of columns - nump = nump + ipatches ! total number of patches - numCohort = numCohort + icohorts ! total number of cohorts - - !--- give gridcell to cid --- - !--- increment the beg and end indices --- - clumps(cid)%nlunits = clumps(cid)%nlunits + ilunits - clumps(cid)%ncols = clumps(cid)%ncols + icols - clumps(cid)%npatches = clumps(cid)%npatches + ipatches - clumps(cid)%nCohorts = clumps(cid)%nCohorts + icohorts - - do m = 1,nclumps - if ((clumps(m)%owner > clumps(cid)%owner) .or. & - (clumps(m)%owner == clumps(cid)%owner .and. m > cid)) then - clumps(m)%begl = clumps(m)%begl + ilunits - clumps(m)%begc = clumps(m)%begc + icols - clumps(m)%begp = clumps(m)%begp + ipatches - clumps(m)%begCohort = clumps(m)%begCohort + icohorts - endif - - if ((clumps(m)%owner > clumps(cid)%owner) .or. & - (clumps(m)%owner == clumps(cid)%owner .and. m >= cid)) then - clumps(m)%endl = clumps(m)%endl + ilunits - clumps(m)%endc = clumps(m)%endc + icols - clumps(m)%endp = clumps(m)%endp + ipatches - clumps(m)%endCohort = clumps(m)%endCohort + icohorts - endif - enddo !--- give gridcell to the proc that owns the cid --- !--- increment the beg and end indices --- - if (iam == clumps(cid)%owner) then - procinfo%nlunits = procinfo%nlunits + ilunits - procinfo%ncols = procinfo%ncols + icols - procinfo%npatches = procinfo%npatches + ipatches - procinfo%nCohorts = procinfo%nCohorts + icohorts - endif - - if (iam > clumps(cid)%owner) then - procinfo%begl = procinfo%begl + ilunits - procinfo%begc = procinfo%begc + icols - procinfo%begp = procinfo%begp + ipatches - procinfo%begCohort = procinfo%begCohort + icohorts - endif - - if (iam >= clumps(cid)%owner) then - procinfo%endl = procinfo%endl + ilunits - procinfo%endc = procinfo%endc + icols - procinfo%endp = procinfo%endp + ipatches - procinfo%endCohort = procinfo%endCohort + icohorts - endif - enddo + end do do n = 1,nclumps - if (clumps(n)%ncells /= allvecg(n,1) .or. & - clumps(n)%nlunits /= allvecg(n,2) .or. & - clumps(n)%ncols /= allvecg(n,3) .or. & - clumps(n)%npatches /= allvecg(n,4) .or. & - clumps(n)%nCohorts /= allvecg(n,5)) then - + if (clumps(n)%ncells /= allvecg(n,1)) then write(iulog ,*) 'decompInit_glcp(): allvecg error ncells ',iam,n,clumps(n)%ncells ,allvecg(n,1) - write(iulog ,*) 'decompInit_glcp(): allvecg error lunits ',iam,n,clumps(n)%nlunits ,allvecg(n,2) - write(iulog ,*) 'decompInit_glcp(): allvecg error ncols ',iam,n,clumps(n)%ncols ,allvecg(n,3) - write(iulog ,*) 'decompInit_glcp(): allvecg error patches',iam,n,clumps(n)%npatches ,allvecg(n,4) - write(iulog ,*) 'decompInit_glcp(): allvecg error cohorts',iam,n,clumps(n)%nCohorts ,allvecg(n,5) - call endrun(msg=errMsg(sourcefile, __LINE__)) endif enddo @@ -474,7 +360,7 @@ subroutine decompInit_clumps(lns,lni,lnj,glc_behavior) end subroutine decompInit_clumps !------------------------------------------------------------------------------ - subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) + subroutine decompInit_glcp(lns,lni,lnj) ! ! !DESCRIPTION: ! Determine gsMaps for landunits, columns, patches and cohorts @@ -482,32 +368,18 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) ! !USES: use spmdMod use spmdGathScatMod - use subgridMod, only : subgrid_get_gcellinfo ! ! !ARGUMENTS: implicit none integer , intent(in) :: lns,lni,lnj ! land domain global size - type(glc_behavior_type), intent(in) :: glc_behavior ! ! !LOCAL VARIABLES: integer :: gi,li,ci,pi,coi ! indices integer :: i,g,k,l,n,np ! indices integer :: cid,pid ! indices integer :: begg,endg ! beg,end gridcells - integer :: begl,endl ! beg,end landunits - integer :: begc,endc ! beg,end columns - integer :: begp,endp ! beg,end patches - integer :: begCohort,endCohort! beg,end cohorts 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 patches across all processors - integer :: numCohort ! fates cohorts integer :: icells ! temporary - integer :: ilunits ! temporary - integer :: icols ! temporary - integer :: ipatches ! temporary - integer :: icohorts ! temporary integer :: ier ! error code integer :: npmin,npmax,npint ! do loop values for printing integer :: clmin,clmax ! do loop values for printing @@ -517,9 +389,6 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) integer, pointer :: gindex(:) ! global index for gsMap init integer, pointer :: arrayglob(:) ! temporaroy integer, pointer :: gstart(:), gcount(:) - integer, pointer :: lstart(:), lcount(:) - integer, pointer :: cstart(:), ccount(:) - integer, pointer :: pstart(:), pcount(:) integer, pointer :: ioff(:) integer, parameter :: dbug=1 ! 0 = min, 1=normal, 2=much, 3=max character(len=32), parameter :: subname = 'decompInit_glcp' @@ -527,9 +396,8 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) !init - call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp, & - begCohort, endCohort) - call get_proc_global(ng=numg, nl=numl, nc=numc, np=nump, nCohorts=numCohort) + call get_proc_bounds(begg, endg) + call get_proc_global(ng=numg) ! Determine global seg megs @@ -537,33 +405,16 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) gstart(:) = 0 allocate(gcount(begg:endg)) gcount(:) = 0 - allocate(lstart(begg:endg)) - lstart(:) = 0 - allocate(lcount(begg:endg)) - lcount(:) = 0 - allocate(cstart(begg:endg)) - cstart(:) = 0 - allocate(ccount(begg:endg)) - ccount(:) = 0 - allocate(pstart(begg:endg)) - pstart(:) = 0 - allocate(pcount(begg:endg)) - pcount(:) = 0 allocate(ioff(begg:endg)) ioff(:) = 0 - ! Determine gcount, lcount, ccount and pcount + ! Determine gcount do gi = begg,endg - call subgrid_get_gcellinfo (gi, nlunits=ilunits, ncols=icols, npatches=ipatches, & - ncohorts=icohorts, glc_behavior=glc_behavior) gcount(gi) = 1 ! number of gridcells for local gridcell index gi - lcount(gi) = ilunits ! number of landunits for local gridcell index gi - ccount(gi) = icols ! number of columns for local gridcell index gi - pcount(gi) = ipatches ! number of patches for local gridcell index gi enddo - ! Determine gstart, lstart, cstart, pstart for the OUTPUT 1d data structures + ! Determine gstart ! gather the gdc subgrid counts to masterproc in glo order ! compute glo ordered start indices from the counts @@ -586,48 +437,6 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) endif call scatter_data_from_master(gstart, arrayglob, grlnd) - ! lstart for gridcell (n) is the total number of the landunits - ! over gridcells 1->n-1 - - arrayglob(:) = 0 - call gather_data_to_master(lcount, arrayglob, grlnd) - if (masterproc) then - val1 = arrayglob(1) - arrayglob(1) = 1 - do n = 2,ng - val2 = arrayglob(n) - arrayglob(n) = arrayglob(n-1) + val1 - val1 = val2 - enddo - endif - call scatter_data_from_master(lstart, arrayglob, grlnd) - - arrayglob(:) = 0 - call gather_data_to_master(ccount, arrayglob, grlnd) - if (masterproc) then - val1 = arrayglob(1) - arrayglob(1) = 1 - do n = 2,ng - val2 = arrayglob(n) - arrayglob(n) = arrayglob(n-1) + val1 - val1 = val2 - enddo - endif - call scatter_data_from_master(cstart, arrayglob, grlnd) - - arrayglob(:) = 0 - call gather_data_to_master(pcount, arrayglob, grlnd) - if (masterproc) then - val1 = arrayglob(1) - arrayglob(1) = 1 - do n = 2,ng - val2 = arrayglob(n) - arrayglob(n) = arrayglob(n-1) + val1 - val1 = val2 - enddo - endif - call scatter_data_from_master(pstart, arrayglob, grlnd) - deallocate(arrayglob) ! Gridcell gsmap (compressed, no ocean points) @@ -656,56 +465,8 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) call mct_gsMap_init(gsmap_gce_gdc2glo, gindex, mpicom, comp_id, locsize, globsize) deallocate(gindex) - ! Landunit gsmap - - allocate(gindex(begl:endl)) - ioff(:) = 0 - do li = begl,endl - gi = lun%gridcell(li) !===this is determined internally from how landunits are spread out in memory - gindex(li) = lstart(gi) + ioff(gi) !=== the output gindex is ALWAYS the same regardless of how landuntis are spread out in memory - ioff(gi) = ioff(gi) + 1 - ! check that this is less than [lstart(gi) + lcount(gi)] - enddo - locsize = endl-begl+1 - globsize = numl - call mct_gsMap_init(gsmap_lun_gdc2glo, gindex, mpicom, comp_id, locsize, globsize) - deallocate(gindex) - - ! Column gsmap - - allocate(gindex(begc:endc)) - ioff(:) = 0 - do ci = begc,endc - gi = col%gridcell(ci) - gindex(ci) = cstart(gi) + ioff(gi) - ioff(gi) = ioff(gi) + 1 - ! check that this is less than [cstart(gi) + ccount(gi)] - enddo - locsize = endc-begc+1 - globsize = numc - call mct_gsMap_init(gsmap_col_gdc2glo, gindex, mpicom, comp_id, locsize, globsize) - deallocate(gindex) - - ! PATCH gsmap - - allocate(gindex(begp:endp)) - ioff(:) = 0 - do pi = begp,endp - gi = patch%gridcell(pi) - gindex(pi) = pstart(gi) + ioff(gi) - ioff(gi) = ioff(gi) + 1 - ! check that this is less than [pstart(gi) + pcount(gi)] - enddo - locsize = endp-begp+1 - globsize = nump - call mct_gsMap_init(gsmap_patch_gdc2glo, gindex, mpicom, comp_id, locsize, globsize) - deallocate(gindex) - ! Deallocate start/count arrays deallocate(gstart, gcount) - deallocate(lstart, lcount) - deallocate(cstart, ccount) - deallocate(pstart, pcount) deallocate(ioff) ! Diagnostic output @@ -715,19 +476,11 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) write(iulog,*)' longitude points = ',lni write(iulog,*)' latitude points = ',lnj write(iulog,*)' total number of gridcells = ',numg - write(iulog,*)' total number of landunits = ',numl - write(iulog,*)' total number of columns = ',numc - write(iulog,*)' total number of patches = ',nump - write(iulog,*)' total number of cohorts = ',numCohort write(iulog,*)' Decomposition Characteristics' write(iulog,*)' clumps per process = ',clump_pproc write(iulog,*)' gsMap Characteristics' write(iulog,*) ' lnd gsmap glo num of segs = ',mct_gsMap_ngseg(gsMap_lnd_gdc2glo) write(iulog,*) ' gce gsmap glo num of segs = ',mct_gsMap_ngseg(gsMap_gce_gdc2glo) - write(iulog,*) ' lun gsmap glo num of segs = ',mct_gsMap_ngseg(gsMap_lun_gdc2glo) - write(iulog,*) ' col gsmap glo num of segs = ',mct_gsMap_ngseg(gsMap_col_gdc2glo) - write(iulog,*) ' patch gsmap glo num of segs = ',mct_gsMap_ngseg(gsMap_patch_gdc2glo) - write(iulog,*) ' coh gsmap glo num of segs = ',mct_gsMap_ngseg(gsMap_cohort_gdc2glo) write(iulog,*) end if @@ -762,40 +515,12 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) ' beg gridcell= ',procinfo%begg, & ' end gridcell= ',procinfo%endg, & ' total gridcells per proc= ',procinfo%ncells - write(iulog,*)'proc= ',pid,& - ' beg landunit= ',procinfo%begl, & - ' end landunit= ',procinfo%endl, & - ' total landunits per proc= ',procinfo%nlunits - write(iulog,*)'proc= ',pid,& - ' beg column = ',procinfo%begc, & - ' end column = ',procinfo%endc, & - ' total columns per proc = ',procinfo%ncols - write(iulog,*)'proc= ',pid,& - ' beg patch = ',procinfo%begp, & - ' end patch = ',procinfo%endp, & - ' total patches per proc = ',procinfo%npatches - write(iulog,*)'proc= ',pid,& - ' beg coh = ',procinfo%begCohort, & - ' end coh = ',procinfo%endCohort, & - ' total coh per proc = ',procinfo%nCohorts write(iulog,*)'proc= ',pid,& ' lnd ngseg = ',mct_gsMap_ngseg(gsMap_lnd_gdc2glo), & ' lnd nlseg = ',mct_gsMap_nlseg(gsMap_lnd_gdc2glo,iam) write(iulog,*)'proc= ',pid,& ' gce ngseg = ',mct_gsMap_ngseg(gsMap_gce_gdc2glo), & ' gce nlseg = ',mct_gsMap_nlseg(gsMap_gce_gdc2glo,iam) - write(iulog,*)'proc= ',pid,& - ' lun ngseg = ',mct_gsMap_ngseg(gsMap_lun_gdc2glo), & - ' lun nlseg = ',mct_gsMap_nlseg(gsMap_lun_gdc2glo,iam) - write(iulog,*)'proc= ',pid,& - ' col ngseg = ',mct_gsMap_ngseg(gsMap_col_gdc2glo), & - ' col nlseg = ',mct_gsMap_nlseg(gsMap_col_gdc2glo,iam) - write(iulog,*)'proc= ',pid,& - ' patch ngseg = ',mct_gsMap_ngseg(gsMap_patch_gdc2glo), & - ' patch nlseg = ',mct_gsMap_nlseg(gsMap_patch_gdc2glo,iam) - write(iulog,*)'proc= ',pid,& - ' coh ngseg = ',mct_gsMap_ngseg(gsMap_cohort_gdc2glo), & - ' coh nlseg = ',mct_gsMap_nlseg(gsMap_cohort_gdc2glo,iam) write(iulog,*)'proc= ',pid,' nclumps = ',procinfo%nclumps clmin = 1 @@ -812,26 +537,6 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) ' beg gridcell= ',clumps(cid)%begg, & ' end gridcell= ',clumps(cid)%endg, & ' total gridcells per clump= ',clumps(cid)%ncells - write(iulog,*)'proc= ',pid,' clump no = ',n, & - ' clump id= ',procinfo%cid(n), & - ' beg landunit= ',clumps(cid)%begl, & - ' end landunit= ',clumps(cid)%endl, & - ' total landunits per clump = ',clumps(cid)%nlunits - write(iulog,*)'proc= ',pid,' clump no = ',n, & - ' clump id= ',procinfo%cid(n), & - ' beg column = ',clumps(cid)%begc, & - ' end column = ',clumps(cid)%endc, & - ' total columns per clump = ',clumps(cid)%ncols - write(iulog,*)'proc= ',pid,' clump no = ',n, & - ' clump id= ',procinfo%cid(n), & - ' beg patch = ',clumps(cid)%begp, & - ' end patch = ',clumps(cid)%endp, & - ' total patches per clump = ',clumps(cid)%npatches - write(iulog,*)'proc= ',pid,' clump no = ',n, & - ' clump id= ',procinfo%cid(n), & - ' beg cohort = ',clumps(cid)%begCohort, & - ' end cohort = ',clumps(cid)%endCohort, & - ' total cohorts per clump = ',clumps(cid)%nCohorts end do end if call shr_sys_flush(iulog) diff --git a/src/main/decompMod.F90 b/src/main/decompMod.F90 index 13204fab..84b70ab3 100644 --- a/src/main/decompMod.F90 +++ b/src/main/decompMod.F90 @@ -10,7 +10,7 @@ module decompMod ! 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 clm_varcon , only : grlnd, nameg use mct_mod , only : mct_gsMap ! ! !PUBLIC TYPES: @@ -19,10 +19,6 @@ module decompMod ! 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 @@ -33,8 +29,8 @@ module decompMod 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_proc_total ! total no. of gridcells for any processor + public get_proc_global ! total gridcells across all processors public get_clmlevel_gsize ! get global size associated with clmlevel public get_clmlevel_gsmap ! get gsmap associated with clmlevel @@ -42,13 +38,13 @@ module decompMod 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 + public get_clump_bounds ! clump beg and end gridcell 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 + public get_proc_bounds ! this processor beg and end gridcell ! !PRIVATE MEMBER FUNCTIONS: ! @@ -57,18 +53,9 @@ module decompMod 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 @@ -79,15 +66,7 @@ module decompMod 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 @@ -96,15 +75,7 @@ module decompMod 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(:) @@ -118,12 +89,11 @@ module decompMod public decomp_type type(decomp_type),public,target :: ldecomp + integer, public, pointer :: gindex_global(:) => null() ! includes ocean points + integer, public, pointer :: gindex_grc(:) => null() ! does not include ocean points + type(mct_gsMap) ,public,target :: gsMap_lnd_gdc2glo type(mct_gsMap) ,public,target :: gsMap_gce_gdc2glo - type(mct_gsMap) ,public,target :: gsMap_lun_gdc2glo - type(mct_gsMap) ,public,target :: gsMap_col_gdc2glo - type(mct_gsMap) ,public,target :: gsMap_patch_gdc2glo - type(mct_gsMap) ,public,target :: gsMap_cohort_gdc2glo !------------------------------------------------------------------------------ contains @@ -135,7 +105,7 @@ pure function get_beg(bounds, subgrid_level) result(beg_index) ! 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. + ! BOUNDS_SUBGRID_GRIDCELL, etc. ! ! Returns -1 for invalid subgrid_level (does not abort in this case, in order to keep ! this function pure). @@ -155,14 +125,6 @@ pure function get_beg(bounds, subgrid_level) result(beg_index) 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 @@ -176,7 +138,7 @@ pure function get_end(bounds, subgrid_level) result(end_index) ! 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. + ! BOUNDS_SUBGRID_GRIDCELL, etc. ! ! Returns -1 for invalid subgrid_level (does not abort in this case, in order to keep ! this function pure). @@ -196,14 +158,6 @@ pure function get_end(bounds, subgrid_level) result(end_index) 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 @@ -231,26 +185,14 @@ subroutine get_clump_bounds_new (n, bounds) !------------------------------------------------------------------------------ ! 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 @@ -258,28 +200,15 @@ subroutine get_clump_bounds_new (n, bounds) end subroutine get_clump_bounds_new !------------------------------------------------------------------------------ - subroutine get_clump_bounds_old (n, begg, endg, begl, endl, begc, endc, begp, endp, & - begCohort, endCohort) + subroutine get_clump_bounds_old (n, begg, endg) 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 !------------------------------------------------------------------------------ @@ -301,25 +230,13 @@ subroutine get_proc_bounds_new (bounds) !------------------------------------------------------------------------------ ! 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 @@ -327,81 +244,48 @@ subroutine get_proc_bounds_new (bounds) end subroutine get_proc_bounds_new !------------------------------------------------------------------------------ - subroutine get_proc_bounds_old (begg, endg, begl, endl, begc, endc, begp, endp, & - begCohort, endCohort) + subroutine get_proc_bounds_old (begg, endg) - 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) + subroutine get_proc_total(pid, ncells) ! ! !DESCRIPTION: - ! Count up gridcells, landunits, columns, and patchs on process. + ! Count up gridcells 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) + subroutine get_proc_global(ng) ! ! !DESCRIPTION: - ! Return number of gridcells, landunits, columns, and patchs across all processes. + ! Return number of gridcells 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 @@ -434,14 +318,6 @@ integer function get_clmlevel_gsize (clmlevel) 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() @@ -465,14 +341,6 @@ subroutine get_clmlevel_gsmap (clmlevel, gsmap) 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() diff --git a/src/main/filterColMod.F90 b/src/main/filterColMod.F90 deleted file mode 100644 index 0c3e63ce..00000000 --- a/src/main/filterColMod.F90 +++ /dev/null @@ -1,444 +0,0 @@ -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 shr_log_mod , only : errMsg => shr_log_errMsg - 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(indices_col >= bounds%begc, errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL(indices_col <= bounds%endc, errMsg(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((ubound(logical_col) == (/bounds%endc/)), errMsg(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((ubound(logical_col) == (/bounds%endc/)), errMsg(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((ubound(lunflags) == (/bounds%endl/)), errMsg(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((ubound(grcflags) == (/bounds%endg/)), errMsg(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((ubound(logical_col) == (/bounds%endc/)), errMsg(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/src/main/filterMod.F90 b/src/main/filterMod.F90 deleted file mode 100644 index 1201582a..00000000 --- a/src/main/filterMod.F90 +++ /dev/null @@ -1,584 +0,0 @@ -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 - - 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)) - - 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(bounds%level == BOUNDS_LEVEL_CLUMP, errMsg(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(bounds%level == BOUNDS_LEVEL_CLUMP, errMsg(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(bounds%level == BOUNDS_LEVEL_CLUMP, errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(frac_veg_nosno) == (/bounds%endp/)), errMsg(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/src/main/glc2lndMod.F90 b/src/main/glc2lndMod.F90 deleted file mode 100644 index d27d2e53..00000000 --- a/src/main/glc2lndMod.F90 +++ /dev/null @@ -1,579 +0,0 @@ -module glc2lndMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Handle arrays used for exchanging data from glc to clm. - ! - ! !USES: -#include "shr_assert.h" - use decompMod , only : bounds_type - use shr_log_mod , only : errMsg => shr_log_errMsg - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use clm_varpar , only : maxpatch_glcmec - use clm_varctl , only : iulog, glc_do_dynglacier - use clm_varcon , only : nameg, spval, ispval - use abortutils , only : endrun - use GridcellType , only : grc - use LandunitType , only : lun - use ColumnType , only : col - use landunit_varcon, only : istice_mec - use glcBehaviorMod , only : glc_behavior_type - ! - ! !REVISION HISTORY: - ! Created by William Lipscomb, Dec. 2007, based on clm_atmlnd.F90. - ! - ! !PUBLIC TYPES: - implicit none - private - save - - ! glc -> land variables structure - type, public :: glc2lnd_type - - ! ------------------------------------------------------------------------ - ! Public data - ! ------------------------------------------------------------------------ - - ! Where we should do runoff routing that is appropriate for having a dynamic icesheet underneath. - real(r8), pointer :: glc_dyn_runoff_routing_grc (:) => null() - - ! ------------------------------------------------------------------------ - ! Private data - ! ------------------------------------------------------------------------ - - type(glc_behavior_type), pointer, private :: glc_behavior ! reference to the glc_behavior instance - - real(r8), pointer, private :: frac_grc (:,:) => null() - real(r8), pointer, private :: topo_grc (:,:) => null() - real(r8), pointer, private :: hflx_grc (:,:) => null() - - ! Area in which GLC model can accept surface mass balance, received from glc (0-1) - real(r8), pointer, private :: icemask_grc (:) => null() - - ! icemask_coupled_fluxes_grc is like icemask_grc, but the mask only contains icesheet - ! points that potentially send non-zero fluxes to the coupler. i.e., it does not - ! contain icesheets that are diagnostic only, because for those diagnostic ice sheets - ! (which do not send calving fluxes to the coupler), we need to use the non-dynamic - ! form of runoff routing in CLM in order to conserve water properly. - ! - ! (However, note that this measure of "diagnostic-only" does not necessarily - ! correspond to whether CLM is updating its glacier areas there - for example, we - ! could theoretically have an icesheet whose areas are evolving, and CLM is updating - ! its glacier areas to match, but where we're zeroing out the fluxes sent to the - ! coupler, and so we're using the non-dynamic form of runoff routing in CLM.) - real(r8), pointer, private :: icemask_coupled_fluxes_grc (:) => null() - - contains - - ! ------------------------------------------------------------------------ - ! Public routines - ! ------------------------------------------------------------------------ - - procedure, public :: Init - procedure, public :: Clean - - ! In each timestep, these routines should be called in order (though they don't need - ! to be called all at once): - ! - set_glc2lnd_fields - ! - update_glc2lnd_topo - procedure, public :: set_glc2lnd_fields ! set coupling fields sent from glc to lnd - procedure, public :: update_glc2lnd_topo ! update topographic heights - - ! For unit testing only: - procedure, public :: for_test_set_glc2lnd_fields_directly ! set glc2lnd fields directly in a unit testing context - - ! ------------------------------------------------------------------------ - ! Private routines - ! ------------------------------------------------------------------------ - - procedure, private :: InitAllocate - procedure, private :: InitHistory - procedure, private :: InitCold - - ! sanity-check icemask from GLC - procedure, private :: check_glc2lnd_icemask - - ! sanity-check icemask_coupled_fluxes from GLC - procedure, private :: check_glc2lnd_icemask_coupled_fluxes - - ! update glc_dyn_runoff_routing field based on input from GLC - procedure, private :: update_glc2lnd_dyn_runoff_routing - - end type glc2lnd_type - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - - !------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, bounds, glc_behavior) - - class(glc2lnd_type) :: this - type(bounds_type), intent(in) :: bounds - type(glc_behavior_type), intent(in), target :: glc_behavior - - call this%InitAllocate(bounds) - call this%InitHistory(bounds) - call this%InitCold(bounds, glc_behavior) - - end subroutine Init - - !------------------------------------------------------------------------ - subroutine InitAllocate(this, bounds) - ! - ! !DESCRIPTION: - ! Initialize glc variables required by the land - ! - ! !ARGUMENTS: - class (glc2lnd_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begg,endg - !------------------------------------------------------------------------ - - begg = bounds%begg; endg = bounds%endg - - allocate(this%frac_grc (begg:endg,0:maxpatch_glcmec)) ; this%frac_grc (:,:) = nan - allocate(this%topo_grc (begg:endg,0:maxpatch_glcmec)) ; this%topo_grc (:,:) = nan - allocate(this%hflx_grc (begg:endg,0:maxpatch_glcmec)) ; this%hflx_grc (:,:) = nan - allocate(this%icemask_grc (begg:endg)) ; this%icemask_grc (:) = nan - allocate(this%icemask_coupled_fluxes_grc (begg:endg)) ; this%icemask_coupled_fluxes_grc (:) = nan - allocate(this%glc_dyn_runoff_routing_grc (begg:endg)) ; this%glc_dyn_runoff_routing_grc (:) = nan - - end subroutine InitAllocate - - !----------------------------------------------------------------------- - subroutine InitHistory(this, bounds) - ! - ! !USES: - use histFileMod, only : hist_addfld1d - ! - ! !ARGUMENTS: - class(glc2lnd_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begg, endg - - character(len=*), parameter :: subname = 'InitHistory' - !----------------------------------------------------------------------- - - begg = bounds%begg - endg = bounds%endg - - this%icemask_grc(begg:endg) = spval - call hist_addfld1d (fname='ICE_MODEL_FRACTION', units='unitless', & - avgflag='I', long_name='Ice sheet model fractional coverage', & - ptr_gcell=this%icemask_grc, default='inactive') - - end subroutine InitHistory - - !----------------------------------------------------------------------- - subroutine InitCold(this, bounds, glc_behavior) - ! - ! !USES: - use domainMod , only : ldomain - ! - ! !ARGUMENTS: - class(glc2lnd_type) :: this - type(bounds_type), intent(in) :: bounds - type(glc_behavior_type), intent(in), target :: glc_behavior - ! - ! !LOCAL VARIABLES: - integer :: begg, endg - - character(len=*), parameter :: subname = 'InitCold' - !----------------------------------------------------------------------- - - begg = bounds%begg - endg = bounds%endg - - this%glc_behavior => glc_behavior - - this%frac_grc(begg:endg, :) = 0.0_r8 - this%topo_grc(begg:endg, :) = 0.0_r8 - this%hflx_grc(begg:endg, :) = 0.0_r8 - - ! When running with a stub glc model, it's important that icemask_grc be initialized - ! to 0 everywhere. With an active glc model, icemask_grc will be updated in the first - ! time step, and it isn't needed before then, so it's safe to initialize it to 0. - ! Since icemask is 0, icemask_coupled_fluxes needs to be 0, too (and the latter is - ! safest in case we aren't coupled to CISM, to ensure that we use the uncoupled form - ! of runoff routing). - this%icemask_grc(begg:endg) = 0.0_r8 - this%icemask_coupled_fluxes_grc(begg:endg) = 0.0_r8 - - call this%update_glc2lnd_dyn_runoff_routing(bounds) - - end subroutine InitCold - - - !----------------------------------------------------------------------- - subroutine Clean(this) - ! - ! !DESCRIPTION: - ! Deallocate memory in this object - ! - ! !ARGUMENTS: - class(glc2lnd_type), intent(inout) :: this - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'Clean' - !----------------------------------------------------------------------- - - deallocate(this%frac_grc) - deallocate(this%topo_grc) - deallocate(this%hflx_grc) - deallocate(this%icemask_grc) - deallocate(this%icemask_coupled_fluxes_grc) - deallocate(this%glc_dyn_runoff_routing_grc) - - end subroutine Clean - - !----------------------------------------------------------------------- - subroutine set_glc2lnd_fields(this, bounds, glc_present, x2l, & - index_x2l_Sg_ice_covered, index_x2l_Sg_topo, index_x2l_Flgg_hflx, & - index_x2l_Sg_icemask, index_x2l_Sg_icemask_coupled_fluxes) - ! - ! !DESCRIPTION: - ! Set coupling fields sent from glc to lnd - ! - ! If glc_present is true, then the given fields are all assumed to be valid; if - ! glc_present is false, then these fields are ignored. - ! - ! !ARGUMENTS: - class(glc2lnd_type), intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - logical , intent(in) :: glc_present ! true if running with a non-stub glc model - real(r8) , intent(in) :: x2l(:, bounds%begg: ) ! driver import state to land model [field, gridcell] - integer , intent(in) :: index_x2l_Sg_ice_covered( 0: ) ! indices of ice-covered field in x2l, for each elevation class - integer , intent(in) :: index_x2l_Sg_topo( 0: ) ! indices of topo field in x2l, for each elevation class - integer , intent(in) :: index_x2l_Flgg_hflx( 0: ) ! indices of heat flux field in x2l, for each elevation class - integer , intent(in) :: index_x2l_Sg_icemask ! index of icemask field in x2l - integer , intent(in) :: index_x2l_Sg_icemask_coupled_fluxes ! index of icemask_coupled_fluxes field in x2l - ! - ! !LOCAL VARIABLES: - integer :: g - integer :: icemec_class - - character(len=*), parameter :: subname = 'set_glc2lnd_fields' - !----------------------------------------------------------------------- - - SHR_ASSERT((ubound(x2l, 2) == bounds%endg), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(index_x2l_Sg_ice_covered) == (/maxpatch_glcmec/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(index_x2l_Sg_topo) == (/maxpatch_glcmec/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(index_x2l_Flgg_hflx) == (/maxpatch_glcmec/)), errMsg(sourcefile, __LINE__)) - - if (glc_present) then - call endrun(' ERROR: SLIM can NOT run with an active ice sheet model' ) - end if - if (glc_do_dynglacier) then - call endrun(' ERROR: With glc_present false (e.g., a stub glc model), glc_do_dynglacier must be false '// & - errMsg(sourcefile, __LINE__)) - end if - - end subroutine set_glc2lnd_fields - - !----------------------------------------------------------------------- - subroutine for_test_set_glc2lnd_fields_directly(this, bounds, & - topo, icemask) - ! - ! !DESCRIPTION: - ! Set glc2lnd fields directly in a unit testing context - ! - ! This currently only provides a mechanism to set fields that are actually needed in - ! our unit tests. More could be added later. - ! - ! Also: In contrast to the production version (set_glc2lnd_fields), this does NOT - ! currently update glc2lnd_dyn_runoff_routing (because doing so would require having a - ! sensible glc_behavior, which we may not have; and also, we currently don't need this - ! field in a unit testing context). (Note: If we eventually want/need to update - ! glc2lnd_dyn_runoff_routing, and thus need a fully sensible glc_behavior, then we - ! should extract the self-calls at the end of set_glc2lnd_fields - ! (check_glc2lnd_icemask, check_glc2lnd_icemask_coupled_fluxes, - ! update_glc2lnd_dyn_runoff_routing) into a private routine like - ! set_glc2lnd_fields_wrapup, which could be called by both set_glc2lnd_fields and this - ! routine.) - ! - ! !ARGUMENTS: - class(glc2lnd_type), intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - real(r8), intent(in), optional :: topo( bounds%begg: , 0: ) ! topographic height [gridcell, elevclass] - real(r8), intent(in), optional :: icemask( bounds%begg: ) - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'for_test_set_glc2lnd_fields_directly' - !----------------------------------------------------------------------- - - if (present(topo)) then - SHR_ASSERT_ALL((ubound(topo) == (/bounds%endg, maxpatch_glcmec/)), errMsg(sourcefile, __LINE__)) - this%topo_grc(bounds%begg:bounds%endg, 0:maxpatch_glcmec) = topo(bounds%begg:bounds%endg, 0:maxpatch_glcmec) - end if - - if (present(icemask)) then - SHR_ASSERT_ALL((ubound(icemask) == (/bounds%endg/)), errMsg(sourcefile, __LINE__)) - this%icemask_grc(bounds%begg:bounds%endg) = icemask(bounds%begg:bounds%endg) - end if - - end subroutine for_test_set_glc2lnd_fields_directly - - !----------------------------------------------------------------------- - subroutine check_glc2lnd_icemask(this, bounds) - ! - ! !DESCRIPTION: - ! Do a sanity check on the icemask received from CISM via coupler. - ! - ! !USES: - use domainMod , only : ldomain - ! - ! !ARGUMENTS: - class(glc2lnd_type), intent(in) :: this - type(bounds_type) , intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: g ! grid cell index - - character(len=*), parameter :: subname = 'check_glc2lnd_icemask' - !----------------------------------------------------------------------- - - do g = bounds%begg, bounds%endg - - if (this%icemask_grc(g) > 0._r8) then - - ! Ensure that icemask is a subset of has_virtual_columns. This is needed because - ! we allocated memory based on has_virtual_columns, so it is a problem if the - ! ice sheet tries to expand beyond the area defined by has_virtual_columns. - if (.not. this%glc_behavior%has_virtual_columns_grc(g)) then - write(iulog,'(a)') subname//' ERROR: icemask must be a subset of has_virtual_columns.' - write(iulog,'(a)') 'Ensure that the glacier_region_behavior namelist item is set correctly.' - write(iulog,'(a)') '(It should specify "virtual" for the region corresponding to the GLC domain.)' - write(iulog,'(a)') 'If glacier_region_behavior is set correctly, then you can fix this problem' - write(iulog,'(a)') 'by modifying GLACIER_REGION on the surface dataset.' - write(iulog,'(a)') '(Expand the region that corresponds to the GLC domain' - write(iulog,'(a)') '- i.e., the region specified as "virtual" in glacier_region_behavior.)' - call endrun(decomp_index=g, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) - end if - - ! Ensure that icemask is a subset of melt_replaced_by_ice. This is needed - ! because we only compute SMB in the region given by melt_replaced_by_ice - ! (according to the logic for building the do_smb filter), and we need SMB - ! everywhere inside the icemask. - if (.not. this%glc_behavior%melt_replaced_by_ice_grc(g)) then - write(iulog,'(a)') subname//' ERROR: icemask must be a subset of melt_replaced_by_ice.' - write(iulog,'(a)') 'Ensure that the glacier_region_melt_behavior namelist item is set correctly.' - write(iulog,'(a)') '(It should specify "replaced_by_ice" for the region corresponding to the GLC domain.)' - write(iulog,'(a)') 'If glacier_region_behavior is set correctly, then you can fix this problem' - write(iulog,'(a)') 'by modifying GLACIER_REGION on the surface dataset.' - write(iulog,'(a)') '(Expand the region that corresponds to the GLC domain' - write(iulog,'(a)') '- i.e., the region specified as "replaced_by_ice" in glacier_region_melt_behavior.)' - call endrun(decomp_index=g, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) - end if - - end if - end do - - end subroutine check_glc2lnd_icemask - - !----------------------------------------------------------------------- - subroutine check_glc2lnd_icemask_coupled_fluxes(this, bounds) - ! - ! !DESCRIPTION: - ! Do a sanity check on the icemask_coupled_fluxes field received from CISM via coupler. - ! - ! !USES: - ! - ! !ARGUMENTS: - class(glc2lnd_type), intent(in) :: this - type(bounds_type) , intent(in) :: bounds ! bounds - ! - ! !LOCAL VARIABLES: - integer :: g ! grid cell index - - character(len=*), parameter :: subname = 'check_glc2lnd_icemask_coupled_fluxes' - !----------------------------------------------------------------------- - - do g = bounds%begg, bounds%endg - - ! Ensure that icemask_coupled_fluxes is a subset of icemask. Although there - ! currently is no code in CLM that depends on this relationship, it seems helpful - ! to ensure that this intuitive relationship holds, so that code developed in the - ! future can rely on it. - if (this%icemask_coupled_fluxes_grc(g) > 0._r8 .and. this%icemask_grc(g) == 0._r8) then - write(iulog,*) subname//' ERROR: icemask_coupled_fluxes must be a subset of icemask.' - call endrun(decomp_index=g, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) - end if - - end do - - end subroutine check_glc2lnd_icemask_coupled_fluxes - - !----------------------------------------------------------------------- - subroutine update_glc2lnd_dyn_runoff_routing(this, bounds) - ! - ! !DESCRIPTION: - ! Update glc_dyn_runoff_routing field based on updated icemask_coupled_fluxes field - ! - ! !USES: - use domainMod , only : ldomain - ! - ! !ARGUMENTS: - class(glc2lnd_type), intent(inout) :: this - type(bounds_type) , intent(in) :: bounds ! bounds - ! - ! !LOCAL VARIABLES: - integer :: g ! grid cell index - - character(len=*), parameter :: subname = 'update_glc2lnd_dyn_runoff_routing' - !----------------------------------------------------------------------- - - ! Wherever we have an icesheet that is computing and sending fluxes to the coupler - - ! which particularly means it is computing a calving flux - we will use the - ! "glc_dyn_runoff_routing" scheme, with 0 < glc_dyn_runoff_routing <= 1. - ! In these places, all or part of the snowcap flux goes to CISM rather than the runoff model. - ! In other places - including places where CISM is not running at all, as well as places - ! where CISM is running in diagnostic-only mode and therefore is not sending a calving flux - - ! we have glc_dyn_runoff_routing = 0, and the snowcap flux goes to the runoff model. - ! This is needed to conserve water correctly in the absence of a calving flux. - - do g = bounds%begg, bounds%endg - - ! Set glc_dyn_runoff_routing_grc(g) to a value in the range [0,1]. - ! - ! This value gives the grid cell fraction that is deemed to be coupled to the - ! dynamic ice sheet model. For this fraction of the grid cell, snowcap fluxes are - ! sent to the ice sheet model. The remainder of the grid cell sends snowcap fluxes - ! to the runoff model. - ! - ! Note: The coupler (in prep_glc_mod.F90) assumes that the fraction coupled to the - ! dynamic ice sheet model is min(lfrac, Sg_icemask_l), where lfrac is the - ! "frac" component of fraction_lx, and Sg_icemask_l is obtained by mapping - ! Sg_icemask_g from the glc to the land grid. Here, ldomain%frac is - ! equivalent to lfrac, and this%icemask_grc is equivalent to Sg_icemask_l. - ! However, here we use icemask_coupled_fluxes_grc, so that we route all snow - ! capping to runoff in areas where the ice sheet is not generating calving - ! fluxes. In addition, here we need to divide by lfrac, because the coupler - ! multiplies by it later (and, for example, if lfrac = 0.1 and - ! icemask_coupled_fluxes = 1, we want all snow capping to go to the ice - ! sheet model, not to the runoff model). - ! - ! Note: In regions where CLM overlaps the CISM domain, this%icemask_grc(g) typically - ! is nearly equal to ldomain%frac(g). So an alternative would be to simply set - ! glc_dyn_runoff_routing_grc(g) = icemask_grc(g). - ! The reason to cap glc_dyn_runoff_routing at lfrac is to avoid sending the - ! ice sheet model a greater mass of water (in the form of snowcap fluxes) - ! than is allowed to fall on a CLM grid cell that is part ocean. - - ! TODO(wjs, 2017-05-08) Ideally, we wouldn't have this duplication in logic - ! between the coupler and CLM. The best solution would be to have the coupler - ! itself do the partitioning of the snow capping flux between the ice sheet model - ! and the runoff model. A next-best solution would be to have the coupler send a - ! field to CLM telling it what fraction of snow capping should go to the runoff - ! model in each grid cell. - - if (ldomain%frac(g) == 0._r8) then - ! Avoid divide by 0; note that, in this case, the amount going to runoff isn't - ! important for system-wide conservation, so we could really choose anything we - ! want. - this%glc_dyn_runoff_routing_grc(g) = this%icemask_coupled_fluxes_grc(g) - else - this%glc_dyn_runoff_routing_grc(g) = & - min(ldomain%frac(g), this%icemask_coupled_fluxes_grc(g)) / & - ldomain%frac(g) - end if - - if (this%glc_dyn_runoff_routing_grc(g) > 0.0_r8) then - - ! Ensure that glc_dyn_runoff_routing is a subset of melt_replaced_by_ice. This - ! is needed because glacial melt is only sent to the runoff stream in the region - ! given by melt_replaced_by_ice (because the latter is used to create the do_smb - ! filter, and the do_smb filter controls where glacial melt is computed). - if (.not. this%glc_behavior%melt_replaced_by_ice_grc(g)) then - write(iulog,'(a)') subname//' ERROR: icemask_coupled_fluxes must be a subset of melt_replaced_by_ice.' - write(iulog,'(a)') 'Ensure that the glacier_region_melt_behavior namelist item is set correctly.' - write(iulog,'(a)') '(It should specify "replaced_by_ice" for the region corresponding to the GLC domain.)' - write(iulog,'(a)') 'If glacier_region_behavior is set correctly, then you can fix this problem' - write(iulog,'(a)') 'by modifying GLACIER_REGION on the surface dataset.' - write(iulog,'(a)') '(Expand the region that corresponds to the GLC domain' - write(iulog,'(a)') '- i.e., the region specified as "replaced_by_ice" in glacier_region_melt_behavior.)' - call endrun(decomp_index=g, clmlevel=nameg, msg=errMsg(sourcefile, __LINE__)) - end if - end if - end do - - end subroutine update_glc2lnd_dyn_runoff_routing - - - - !----------------------------------------------------------------------- - subroutine update_glc2lnd_topo(this, bounds, topo_col, needs_downscaling_col) - ! - ! !DESCRIPTION: - ! Update column-level topographic heights based on input from GLC (via the coupler). - ! - ! Also updates the logical array, needs_downscaling_col: Sets this array to true - ! anywhere where topo_col is updated, because these points will need downscaling. - ! (Leaves other array elements in needs_downscaling_col untouched.) - ! - ! If glc_do_dynglacier is false, then both topographic heights and - ! needs_downscaling_col are left unchanged. - ! - ! !USES: - use landunit_varcon , only : istice_mec - use column_varcon , only : col_itype_to_icemec_class - ! - ! !ARGUMENTS: - class(glc2lnd_type) , intent(in) :: this - type(bounds_type) , intent(in) :: bounds ! bounds - real(r8) , intent(inout) :: topo_col( bounds%begc: ) ! topographic height (m) - logical , intent(inout) :: needs_downscaling_col( bounds%begc: ) - ! - ! !LOCAL VARIABLES: - integer :: c, l, g ! indices - integer :: icemec_class ! current icemec class (1..maxpatch_glcmec) - - character(len=*), parameter :: subname = 'update_glc2lnd_topo' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(topo_col) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(needs_downscaling_col) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - if (glc_do_dynglacier) then - do c = bounds%begc, bounds%endc - l = col%landunit(c) - g = col%gridcell(c) - - ! Values from GLC are only valid within the icemask, so we only update CLM's topo values there - if (this%icemask_grc(g) > 0._r8) then - if (lun%itype(l) == istice_mec) then - icemec_class = col_itype_to_icemec_class(col%itype(c)) - else - ! If not on a glaciated column, assign topography to the bare-land value determined by GLC. - icemec_class = 0 - end if - - ! Note that we do downscaling over all column types. This is for consistency: - ! interpretation of results would be difficult if some non-glacier column types - ! were downscaled but others were not. - ! - ! BUG(wjs, 2016-11-15, bugz 2377) Actually, do not downscale over urban points: - ! this currently isn't allowed because the urban code references some - ! non-downscaled, gridcell-level atmospheric forcings - if (.not. lun%urbpoi(l)) then - topo_col(c) = this%topo_grc(g, icemec_class) - needs_downscaling_col(c) = .true. - end if - end if - end do - end if - - end subroutine update_glc2lnd_topo - -end module glc2lndMod - diff --git a/src/main/glcBehaviorMod.F90 b/src/main/glcBehaviorMod.F90 deleted file mode 100644 index 111db6d5..00000000 --- a/src/main/glcBehaviorMod.F90 +++ /dev/null @@ -1,996 +0,0 @@ -module glcBehaviorMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Determines a number of aspects of the behavior of glacier_mec classes in each grid - ! cell. - ! - ! !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 clm_varctl , only : iulog - use landunit_varcon, only : istice_mec - use clm_instur , only : wt_lunit, wt_glc_mec - use decompMod , only : bounds_type - use filterColMod , only : filter_col_type - use ColumnType , only : col - - ! !PUBLIC TYPES: - implicit none - private - save - - type, public :: glc_behavior_type - private - - ! ------------------------------------------------------------------------ - ! Public data - ! ------------------------------------------------------------------------ - - ! If has_virtual_columns_grc(g) is true, then grid cell g has virtual columns for - ! all possible glc_mec columns. - ! - ! For the sake of coupling with CISM, this should only be needed within the icemask, - ! where we need virtual columns for the sake of coupling with CISM. This is needed in - ! order to (1) provide SMB in all elevation classes, in case it is being used with - ! 1-way coupling (or to force a later TG run); (2) even with two-way coupling, - ! provide SMB in the elevation classes above and below existing elevation classes, - ! for the sake of vertical interpolation; (3) provide place-holder columns (which are - ! already spun-up) for dynamic landunits; (4) ensure that all glacier columns are - ! given spun-up initial conditions by init_interp. - ! - ! More details on (4) (echoing the similar comment in subgridWeightsMod): We need all - ! glacier and vegetated points to be active in the icemask region for the sake of - ! init_interp - since we only interpolate onto active points, and we don't know which - ! points will have non-zero area until after initialization (as long as we can't send - ! information from glc to clm in initialization). (If we had an inactive glacier - ! point in the icemask region, according to the weights on the surface dataset, and - ! ran init_interp, this point would keep its cold start initialization values. Then, - ! in the first time step of the run loop, it's possible that this point would become - ! active because, according to glc, there is actually > 0% glacier in that grid - ! cell. We don't do any state / flux adjustments in the first time step after - ! init_interp due to glacier area changes, so this glacier column would remain at its - ! cold start initialization values, which would be a Bad Thing. Ensuring that all - ! glacier points within the icemask are active gets around this problem - as well as - ! having other benefits, as noted above.) - ! - ! However, by making this part of the user-modifiable "glc behavior", we make it easy - ! for the user to add virtual columns, if this is desired for diagnostic - ! purposes. One important reason why this may be desired is to produce coupler - ! history forcings to force a later TG run, with SMB forcings outside the original - ! CISM area. (Also, we cannot use icemask for all purposes, because it isn't known at - ! initialization.) - logical, allocatable, public :: has_virtual_columns_grc(:) - - ! If allow_multiple_columns_grc(g) is true, then grid cell g may have multiple - ! glacier columns, for the different elevation classes. If - ! allow_multiple_columns_grc(g) is false, then grid cell g is guaranteed to have at - ! most one glacier column. - logical, allocatable, public :: allow_multiple_columns_grc(:) - - ! If melt_replaced_by_ice_grc(g) is true, then any glacier ice melt in gridcell g - ! runs off and is replaced by ice. Note that SMB cannot be computed in gridcell g if - ! melt_replaced_by_ice_grc(g) is false, since we can't compute a sensible negative - ! smb in that case. - logical, allocatable, public :: melt_replaced_by_ice_grc(:) - - ! If ice_runoff_melted_grc(g) is true, then ice runoff generated by the - ! CLM physics over glacier columns in gridcell g is melted (generating a negative - ! sensible heat flux) and runs off as liquid. If it is false, then ice runoff is - ! sent to the river model as ice (a crude parameterization of iceberg calving). - logical, allocatable, public :: ice_runoff_melted_grc(:) - - ! ------------------------------------------------------------------------ - ! Private data - ! ------------------------------------------------------------------------ - - ! If collapse_to_atm_topo_grc(g) is true, then grid cell g has at most one glc_mec - ! column, whose topographic height exactly matches the atmosphere's topographic - ! height for that grid cell (so that there is no adjustment of atmospheric - ! forcings). - ! - ! Note that has_virtual_columns_grc(g) is guaranteed to be false if - ! collapse_to_atm_topo_grc(g) is true. - logical, allocatable :: collapse_to_atm_topo_grc(:) - - contains - - ! ------------------------------------------------------------------------ - ! Public routines - ! ------------------------------------------------------------------------ - - procedure, public :: Init ! version of Init meant for production use - procedure, public :: InitFromInputs ! version of Init meant for unit testing (and called by other code in this class) - procedure, public :: InitSetDirectly ! version of Init meant for unit testing - - ! get number of subgrid units in glc_mec landunit on one grid cell - procedure, public :: get_num_glc_mec_subgrid - - ! returns true if memory should be allocated for the given glc_mec column, and its - ! weight on the landunit - procedure, public :: glc_mec_col_exists - - ! returns true if glc_mec columns on the given grid cell have dynamic type (type - ! potentially changing at runtime) - procedure, public :: cols_have_dynamic_type - - ! Sets a column-level logical array to true for any ice_mec column that needs - ! downscaling, false for any ice_mec column that does not need downscaling - procedure, public :: icemec_cols_need_downscaling - - ! update the column class types of any glc_mec columns that need to be updated - procedure, public :: update_glc_classes - - ! ------------------------------------------------------------------------ - ! Public routines, for unit tests only - ! ------------------------------------------------------------------------ - - ! get the value of collapse_to_atm_topo at a given grid cell - procedure, public :: get_collapse_to_atm_topo - - ! ------------------------------------------------------------------------ - ! Private routines - ! ------------------------------------------------------------------------ - - procedure, private :: InitAllocate - - ! reads GLACIER_REGION field from surface dataset - procedure, private, nopass :: read_surface_dataset - - ! reads local namelist items - procedure, private, nopass :: read_namelist - - ! returns a column-level filter of ice_mec columns with the collapse_to_atm_topo - ! behavior - procedure, private :: collapse_to_atm_topo_icemec_filterc - - ! update class of glc_mec columns in regions where these are collapsed to a single - ! column, given a filter - procedure, private :: update_collapsed_columns_classes - - end type glc_behavior_type - - ! !PRIVATE MEMBER DATA: - - ! Longest name allowed for glacier_region_behavior, glacier_region_melt_behavior and - ! glacier_region_ice_runoff_behavior - integer, parameter :: max_behavior_name_len = 32 - - ! Smallest and largest allowed values for a glacier region ID - integer, parameter :: min_glacier_region_id = 0 - integer, parameter :: max_glacier_region_id = 10 - - ! Value indicating that a namelist item has not been set - character(len=*), parameter :: behavior_str_unset = 'UNSET' - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - -contains - - !----------------------------------------------------------------------- - subroutine Init(this, begg, endg, NLFilename) - ! - ! !DESCRIPTION: - ! Initialize a glc_behavior_type object. - ! - ! This version of Init is the one intended for production code use. It reads the - ! information it needs from the surface dataset and namelist. - ! - ! !USES: - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(inout) :: this - integer, intent(in) :: begg ! beginning gridcell index - integer, intent(in) :: endg ! ending gridcell index - character(len=*), intent(in) :: NLFilename ! Namelist filename - ! - ! !LOCAL VARIABLES: - integer, allocatable :: glacier_region_map(:) - character(len=max_behavior_name_len) :: glacier_region_behavior(min_glacier_region_id:max_glacier_region_id) - character(len=max_behavior_name_len) :: glacier_region_melt_behavior(min_glacier_region_id:max_glacier_region_id) - character(len=max_behavior_name_len) :: glacier_region_ice_runoff_behavior(min_glacier_region_id:max_glacier_region_id) - - character(len=*), parameter :: subname = 'Init' - !----------------------------------------------------------------------- - - allocate(glacier_region_map(begg:endg)) - call this%read_surface_dataset(begg, endg, glacier_region_map(begg:endg)) - call this%read_namelist(NLFilename, glacier_region_behavior, & - glacier_region_melt_behavior, glacier_region_ice_runoff_behavior) - - call this%InitFromInputs(begg, endg, & - glacier_region_map(begg:endg), glacier_region_behavior, & - glacier_region_melt_behavior, glacier_region_ice_runoff_behavior) - - end subroutine Init - - !----------------------------------------------------------------------- - subroutine InitFromInputs(this, begg, endg, & - glacier_region_map, glacier_region_behavior_str, glacier_region_melt_behavior_str, & - glacier_region_ice_runoff_behavior_str) - ! - ! !DESCRIPTION: - ! Initialize a glc_behavior_type object given a map of glacier region IDs and an - ! array of behavior specifications for each of these IDs. - ! - ! This version should generally only be called directly by tests, but it is also used - ! by the main production Init method. - ! - ! !USES: - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(inout) :: this - integer, intent(in) :: begg ! beginning gridcell index - integer, intent(in) :: endg ! ending gridcell index - - ! map of glacier region IDs - integer, intent(in) :: glacier_region_map(begg:) - - ! string giving behavior for each glacier region ID - ! allowed values are: - ! - 'multiple': grid cells can potentially have multiple glacier elevation classes, - ! but no virtual columns - ! - 'virtual': grid cells have virtual columns: values are computed for every glacier - ! elevation class, even those with 0 area - ! - 'single_at_atm_topo': glacier landunits in these grid cells have a single column, - ! whose elevation matches the atmosphere's topographic height (so that there is no - ! adjustment due to downscaling) - character(len=*), intent(in) :: glacier_region_behavior_str(min_glacier_region_id:) - - ! string giving treatment of ice melt for each glacier region ID - ! allowed values are: - ! - 'replaced_by_ice' - ! - 'remains_in_place' - character(len=*), intent(in) :: glacier_region_melt_behavior_str(min_glacier_region_id:) - - ! string giving treatment of ice runoff for each glacier region ID - ! allowed values are: - ! - 'remains_ice' - ! - 'melted' - character(len=*), intent(in) :: glacier_region_ice_runoff_behavior_str(min_glacier_region_id:) - - ! - ! !LOCAL VARIABLES: - ! whether each glacier region ID is present in the glacier_region_map - logical :: glacier_region_present(min_glacier_region_id:max_glacier_region_id) - - ! integer codes corresponding to glacier_region_behavior_str - integer :: glacier_region_behavior(min_glacier_region_id:max_glacier_region_id) - - ! integer codes corresponding to glacier_region_melt_behavior_str - integer :: glacier_region_melt_behavior(min_glacier_region_id:max_glacier_region_id) - - ! integer codes corresponding to glacier_region_ice_runoff_behavior_str - integer :: glacier_region_ice_runoff_behavior(min_glacier_region_id:max_glacier_region_id) - - integer :: g - integer :: my_id - integer :: my_behavior - integer :: my_melt_behavior - integer :: my_ice_runoff_behavior - - ! possible glacier_region_behavior codes - integer, parameter :: BEHAVIOR_MULTIPLE = 1 - integer, parameter :: BEHAVIOR_VIRTUAL = 2 - integer, parameter :: BEHAVIOR_SINGLE_AT_ATM_TOPO = 3 - - ! possible glacier_region_melt_behavior codes - integer, parameter :: MELT_BEHAVIOR_REPLACED_BY_ICE = 1 - integer, parameter :: MELT_BEHAVIOR_REMAINS_IN_PLACE = 2 - - ! possible glacier_region_ice_runoff_behavior codes - integer, parameter :: ICE_RUNOFF_BEHAVIOR_REMAINS_ICE = 1 - integer, parameter :: ICE_RUNOFF_BEHAVIOR_MELTED = 2 - - ! value indicating that a behavior code has not been set (for glacier_region_behavior, - ! glacier_region_melt_behavior or glacier_region_ice_runoff_behavior) - integer, parameter :: BEHAVIOR_UNSET = -1 - - character(len=*), parameter :: subname = 'InitFromInputs' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(glacier_region_map) == (/endg/)), errMsg(sourcefile, __LINE__)) - - call check_glacier_region_map - - call determine_region_presence - - call translate_glacier_region_behavior - call translate_glacier_region_melt_behavior - call translate_glacier_region_ice_runoff_behavior - - call this%InitAllocate(begg, endg) - - do g = begg, endg - my_id = glacier_region_map(g) - my_behavior = glacier_region_behavior(my_id) - my_melt_behavior = glacier_region_melt_behavior(my_id) - my_ice_runoff_behavior = glacier_region_ice_runoff_behavior(my_id) - - ! This should only happen due to a programming error, not due to a user input error - SHR_ASSERT(my_behavior /= BEHAVIOR_UNSET, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(my_melt_behavior /= BEHAVIOR_UNSET, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(my_ice_runoff_behavior /= BEHAVIOR_UNSET, errMsg(sourcefile, __LINE__)) - - if (my_behavior == BEHAVIOR_VIRTUAL) then - this%has_virtual_columns_grc(g) = .true. - else - this%has_virtual_columns_grc(g) = .false. - end if - - if (my_melt_behavior == MELT_BEHAVIOR_REMAINS_IN_PLACE) then - this%melt_replaced_by_ice_grc(g) = .false. - else - this%melt_replaced_by_ice_grc(g) = .true. - end if - - if (my_ice_runoff_behavior == ICE_RUNOFF_BEHAVIOR_MELTED) then - this%ice_runoff_melted_grc(g) = .true. - else - this%ice_runoff_melted_grc(g) = .false. - end if - - ! For now, allow_multiple_columns_grc is simply the opposite of - ! collapse_to_atm_topo_grc. However, we maintain the separate - ! allow_multiple_columns_grc so that the public interface can stay the same if we - ! differentiate between the two in the future - e.g., allowing for the possibility - ! of a behavior where we have at most one glacier column, but not forced to the - ! atmosphere's elevation. - if (my_behavior == BEHAVIOR_SINGLE_AT_ATM_TOPO) then - this%collapse_to_atm_topo_grc(g) = .true. - this%allow_multiple_columns_grc(g) = .false. - else - this%collapse_to_atm_topo_grc(g) = .false. - this%allow_multiple_columns_grc(g) = .true. - end if - end do - - contains - subroutine check_glacier_region_map - if (minval(glacier_region_map) < min_glacier_region_id) then - write(iulog,*) subname//' ERROR: Expect GLACIER_REGION to be >= ', min_glacier_region_id - write(iulog,*) 'minval = ', minval(glacier_region_map) - call endrun(msg=' ERROR: GLACIER_REGION smaller than expected'// & - errMsg(sourcefile, __LINE__)) - end if - - if (maxval(glacier_region_map) > max_glacier_region_id) then - write(iulog,*) subname//' ERROR: Max GLACIER_REGION is ', & - maxval(glacier_region_map) - write(iulog,*) 'but max_glacier_region_id is only ', max_glacier_region_id - write(iulog,*) 'Try increasing max_glacier_region_id in ', sourcefile - call endrun(msg=' ERROR: GLACIER_REGION larger than expected'// & - errMsg(sourcefile, __LINE__)) - end if - end subroutine check_glacier_region_map - - subroutine determine_region_presence - integer :: g - integer :: my_id - - glacier_region_present(:) = .false. - do g = begg, endg - my_id = glacier_region_map(g) - glacier_region_present(my_id) = .true. - end do - end subroutine determine_region_presence - - subroutine translate_glacier_region_behavior - integer :: i - - do i = min_glacier_region_id, max_glacier_region_id - glacier_region_behavior(i) = BEHAVIOR_UNSET - - if (glacier_region_present(i)) then - SHR_ASSERT_ALL((ubound(glacier_region_behavior_str) >= (/i/)), errMsg(sourcefile, __LINE__)) - - select case (glacier_region_behavior_str(i)) - case ('multiple') - glacier_region_behavior(i) = BEHAVIOR_MULTIPLE - case ('virtual') - glacier_region_behavior(i) = BEHAVIOR_VIRTUAL - case ('single_at_atm_topo') - glacier_region_behavior(i) = BEHAVIOR_SINGLE_AT_ATM_TOPO - case (behavior_str_unset) - write(iulog,*) ' ERROR: glacier_region_behavior not specified for ID ', i - write(iulog,*) 'You probably need to extend the glacier_region_behavior namelist array' - call endrun(msg=' ERROR: glacier_region_behavior not specified for ID '// & - errMsg(sourcefile, __LINE__)) - case default - write(iulog,*) ' ERROR: Unknown glacier_region_behavior for ID ', i - write(iulog,*) glacier_region_behavior_str(i) - write(iulog,*) 'Allowable values are: multiple, virtual, single_at_atm_topo' - call endrun(msg=' ERROR: Unknown glacier_region_behavior'// & - errMsg(sourcefile, __LINE__)) - end select - - end if - end do - end subroutine translate_glacier_region_behavior - - subroutine translate_glacier_region_melt_behavior - integer :: i - - do i = min_glacier_region_id, max_glacier_region_id - glacier_region_melt_behavior(i) = BEHAVIOR_UNSET - - if (glacier_region_present(i)) then - SHR_ASSERT_ALL((ubound(glacier_region_melt_behavior_str) >= (/i/)), errMsg(sourcefile, __LINE__)) - - select case (glacier_region_melt_behavior_str(i)) - case ('replaced_by_ice') - glacier_region_melt_behavior(i) = MELT_BEHAVIOR_REPLACED_BY_ICE - case ('remains_in_place') - glacier_region_melt_behavior(i) = MELT_BEHAVIOR_REMAINS_IN_PLACE - case (behavior_str_unset) - write(iulog,*) ' ERROR: glacier_region_melt_behavior not specified for ID ', i - write(iulog,*) 'You probably need to extend the glacier_region_melt_behavior namelist array' - call endrun(msg=' ERROR: glacier_region_melt_behavior not specified for ID '// & - errMsg(sourcefile, __LINE__)) - case default - write(iulog,*) ' ERROR: Unknown glacier_region_melt_behavior for ID ', i - write(iulog,*) glacier_region_melt_behavior_str(i) - write(iulog,*) 'Allowable values are: replaced_by_ice, remains_in_place' - call endrun(msg=' ERROR: Unknown glacier_region_melt_behavior'// & - errMsg(sourcefile, __LINE__)) - end select - - end if - end do - end subroutine translate_glacier_region_melt_behavior - - subroutine translate_glacier_region_ice_runoff_behavior - integer :: i - - do i = min_glacier_region_id, max_glacier_region_id - glacier_region_ice_runoff_behavior(i) = BEHAVIOR_UNSET - - if (glacier_region_present(i)) then - SHR_ASSERT_ALL((ubound(glacier_region_ice_runoff_behavior_str) >= (/i/)), errMsg(sourcefile, __LINE__)) - - select case (glacier_region_ice_runoff_behavior_str(i)) - case ('remains_ice') - glacier_region_ice_runoff_behavior(i) = ICE_RUNOFF_BEHAVIOR_REMAINS_ICE - case('melted') - glacier_region_ice_runoff_behavior(i) = ICE_RUNOFF_BEHAVIOR_MELTED - case (behavior_str_unset) - write(iulog,*) ' ERROR: glacier_region_ice_runoff_behavior not specified for ID ', i - write(iulog,*) 'You probably need to extend the glacier_region_ice_runoff_behavior namelist array' - call endrun(msg=' ERROR: glacier_region_ice_runoff_behavior not specified for ID '// & - errMsg(sourcefile, __LINE__)) - case default - write(iulog,*) ' ERROR: Unknown glacier_region_ice_runoff_behavior for ID ', i - write(iulog,*) glacier_region_ice_runoff_behavior_str(i) - write(iulog,*) 'Allowable values are: remains_ice, melted' - call endrun(msg=' ERROR: Unknown glacier_region_ice_runoff_behavior'// & - errMsg(sourcefile, __LINE__)) - end select - end if - end do - end subroutine translate_glacier_region_ice_runoff_behavior - - end subroutine InitFromInputs - - - !----------------------------------------------------------------------- - subroutine InitSetDirectly(this, begg, endg, & - has_virtual_columns, collapse_to_atm_topo) - ! - ! !DESCRIPTION: - ! Initialize a glc_behavior_type object by directly setting has_virtual_columns and - ! collapse_to_atm_topo - ! - ! This version is meant for testing - ! - ! !USES: - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(inout) :: this - integer, intent(in) :: begg ! beginning gridcell index - integer, intent(in) :: endg ! ending gridcell index - logical, intent(in) :: has_virtual_columns(begg:) - logical, intent(in) :: collapse_to_atm_topo(begg:) - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'InitForTesting' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(has_virtual_columns) == (/endg/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(collapse_to_atm_topo) == (/endg/)), errMsg(sourcefile, __LINE__)) - - call this%InitAllocate(begg, endg) - this%has_virtual_columns_grc(:) = has_virtual_columns(:) - this%collapse_to_atm_topo_grc(:) = collapse_to_atm_topo(:) - - end subroutine InitSetDirectly - - - !----------------------------------------------------------------------- - subroutine InitAllocate(this, begg, endg) - ! - ! !DESCRIPTION: - ! Allocate variables in this object - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(inout) :: this - integer, intent(in) :: begg ! beginning gridcell index - integer, intent(in) :: endg ! ending gridcell index - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'InitAllocate' - !----------------------------------------------------------------------- - - allocate(this%has_virtual_columns_grc (begg:endg)); this%has_virtual_columns_grc (:) = .false. - allocate(this%allow_multiple_columns_grc(begg:endg)); this%allow_multiple_columns_grc(:) = .false. - allocate(this%melt_replaced_by_ice_grc(begg:endg)); this%melt_replaced_by_ice_grc(:) = .false. - allocate(this%collapse_to_atm_topo_grc(begg:endg)); this%collapse_to_atm_topo_grc(:) = .false. - allocate(this%ice_runoff_melted_grc(begg:endg)); this%ice_runoff_melted_grc(:) = .false. - - end subroutine InitAllocate - - !----------------------------------------------------------------------- - subroutine read_surface_dataset(begg, endg, glacier_region_map) - ! - ! !DESCRIPTION: - ! Reads GLACIER_REGION field from surface dataset, returns it in glacier_region_map - ! - ! !USES: - use clm_varctl , only : fsurdat - use fileutils , only : getfil - use ncdio_pio , only : file_desc_t, ncd_io, ncd_pio_openfile, ncd_pio_closefile - use spmdMod , only : masterproc - use clm_varcon , only : grlnd - ! - ! !ARGUMENTS: - integer, intent(in) :: begg ! beginning grid cell index - integer, intent(in) :: endg ! ending grid cell index - integer, intent(out) :: glacier_region_map(begg:) - ! - ! !LOCAL VARIABLES: - integer, pointer :: glacier_region_map_ptr(:) ! pointer version needed for ncd_io interface - character(len=256) :: locfn ! local filename - type(file_desc_t) :: ncid ! netcdf id - logical :: readvar - - character(len=*), parameter :: subname = 'read_surface_dataset' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(glacier_region_map) == (/endg/)), errMsg(sourcefile, __LINE__)) - - if (masterproc) then - write(iulog,*) 'Attempting to read GLACIER_REGION...' - end if - call getfil(fsurdat, locfn, 0) - call ncd_pio_openfile(ncid, locfn, 0) - allocate(glacier_region_map_ptr(begg:endg)) - call ncd_io(ncid=ncid, varname='GLACIER_REGION', flag='read', & - data=glacier_region_map_ptr, dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - call endrun(msg=' ERROR: GLACIER_REGION NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - end if - call ncd_pio_closefile(ncid) - glacier_region_map(begg:endg) = glacier_region_map_ptr(begg:endg) - deallocate(glacier_region_map_ptr) - - end subroutine read_surface_dataset - - !----------------------------------------------------------------------- - subroutine read_namelist(NLFilename, glacier_region_behavior, & - glacier_region_melt_behavior, glacier_region_ice_runoff_behavior) - ! - ! !DESCRIPTION: - ! Read local namelist items - ! - ! !USES: - use fileutils , only : getavu, relavu, opnfil - use shr_nl_mod , only : shr_nl_find_group_name - use clm_nlUtilsMod , only : find_nlgroup_name - use spmdMod , only : masterproc, mpicom - use shr_mpi_mod , only : shr_mpi_bcast - ! - ! !ARGUMENTS: - character(len=*), intent(in) :: NLFilename ! Namelist filename - character(len=max_behavior_name_len), intent(out) :: & - glacier_region_behavior(min_glacier_region_id:max_glacier_region_id) - character(len=max_behavior_name_len), intent(out) :: & - glacier_region_melt_behavior(min_glacier_region_id:max_glacier_region_id) - character(len=max_behavior_name_len), intent(out) :: & - glacier_region_ice_runoff_behavior(min_glacier_region_id:max_glacier_region_id) - ! - ! !LOCAL VARIABLES: - integer :: unitn ! unit for namelist file - integer :: nml_error ! namelist i/o error flag - - character(len=*), parameter :: subname = 'read_namelist' - !----------------------------------------------------------------------- - - namelist /clm_glacier_behavior/ & - glacier_region_behavior, glacier_region_melt_behavior, & - glacier_region_ice_runoff_behavior - - ! Initialize options to default values - glacier_region_behavior(:) = behavior_str_unset - glacier_region_melt_behavior(:) = behavior_str_unset - glacier_region_ice_runoff_behavior(:) = behavior_str_unset - glacier_region_behavior(0:3) = (/ 'single_at_atm_topo','virtual ','virtual ','multiple ' /) - glacier_region_ice_runoff_behavior(0:3) = (/ 'melted ','melted ','remains_ice','remains_ice' /) - glacier_region_melt_behavior(0:3) = (/ 'remains_in_place','replaced_by_ice ','replaced_by_ice ','replaced_by_ice ' /) - - if (masterproc) then - unitn = getavu() - call opnfil(NLFilename, unitn, 'F') - call shr_nl_find_group_name(unitn, 'clm_glacier_behavior', status=nml_error) - if (nml_error == 0) then - read(unitn, nml=clm_glacier_behavior, iostat=nml_error) - if (nml_error /= 0) then - call endrun(msg='ERROR reading clm_glacier_behavior namelist'// & - errMsg(sourcefile, __LINE__)) - end if - else - write(iulog,*) 'Could not find clm_glacier_behavior namelist' - end if - call relavu( unitn ) - endif - - call shr_mpi_bcast(glacier_region_behavior, mpicom) - call shr_mpi_bcast(glacier_region_melt_behavior, mpicom) - call shr_mpi_bcast(glacier_region_ice_runoff_behavior, mpicom) - - if (masterproc) then - write(iulog,*) ' ' - write(iulog,*) 'clm_glacier_behavior settings:' - write(iulog,nml=clm_glacier_behavior) - write(iulog,*) ' ' - end if - - end subroutine read_namelist - - - !----------------------------------------------------------------------- - subroutine get_num_glc_mec_subgrid(this, gi, atm_topo, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Get number of subgrid units in glc_mec landunit on one grid cell - ! - ! !USES: - use clm_varpar , only : maxpatch_glcmec - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(in) :: this - integer , intent(in) :: gi ! grid cell index - real(r8), intent(in) :: atm_topo ! atmosphere's topographic height for this grid cell (m) - integer , intent(out) :: npatches ! number of glacier_mec patches in this grid cell - integer , intent(out) :: ncols ! number of glacier_mec columns in this grid cell - integer , intent(out) :: nlunits ! number of glacier_mec landunits in this grid cell - ! - ! !LOCAL VARIABLES: - integer :: m ! loop index - logical :: col_exists - real(r8) :: col_wt_lunit - - character(len=*), parameter :: subname = 'get_num_glc_mec_subgrid' - !----------------------------------------------------------------------- - - ncols = 0 - - do m = 1, maxpatch_glcmec - call this%glc_mec_col_exists(gi = gi, elev_class = m, atm_topo = atm_topo, & - exists = col_exists, col_wt_lunit = col_wt_lunit) - if (col_exists) then - ncols = ncols + 1 - end if - end do - - if (this%collapse_to_atm_topo_grc(gi) .and. & - wt_lunit(gi, istice_mec) > 0.0_r8) then - ! For grid cells with the collapse_to_atm_topo behavior, with a non-zero weight - ! ice_mec landunit, we expect exactly one column - SHR_ASSERT(ncols == 1, errMsg(sourcefile, __LINE__)) - end if - - if (ncols > 0) then - npatches = ncols - nlunits = 1 - else - npatches = 0 - nlunits = 0 - end if - - end subroutine get_num_glc_mec_subgrid - - !----------------------------------------------------------------------- - subroutine glc_mec_col_exists(this, gi, elev_class, atm_topo, exists, col_wt_lunit) - ! - ! !DESCRIPTION: - ! For the given glc_mec column, with elevation class index elev_class, in grid cell - ! gi: sets exists to true if memory should be allocated for this column, and sets - ! col_wt_lunit to the column's weight on the icemec landunit. - ! - ! If exists is false, then col_wt_lunit is arbitrary and should be ignored. - ! - ! !USES: - use glc_elevclass_mod, only : glc_get_elevation_class, GLC_ELEVCLASS_ERR_NONE - use glc_elevclass_mod, only : GLC_ELEVCLASS_ERR_TOO_LOW, GLC_ELEVCLASS_ERR_TOO_HIGH - use glc_elevclass_mod, only : glc_errcode_to_string - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(in) :: this - integer, intent(in) :: gi ! grid cell index - integer, intent(in) :: elev_class ! elevation class index - real(r8), intent(in) :: atm_topo ! atmosphere's topographic height for this grid cell (m) - logical, intent(out) :: exists ! whether memory should be allocated for this column - real(r8), intent(out) :: col_wt_lunit ! column's weight on the icemec landunit - ! - ! !LOCAL VARIABLES: - integer :: atm_elev_class ! elevation class corresponding to atmosphere topographic height - integer :: err_code - - character(len=*), parameter :: subname = 'glc_mec_col_exists' - !----------------------------------------------------------------------- - - ! Set default outputs - exists = .false. - col_wt_lunit = wt_glc_mec(gi, elev_class) - - if (this%collapse_to_atm_topo_grc(gi)) then - if (wt_lunit(gi, istice_mec) > 0.0_r8) then - call glc_get_elevation_class(atm_topo, atm_elev_class, err_code) - if ( err_code == GLC_ELEVCLASS_ERR_NONE .or. & - err_code == GLC_ELEVCLASS_ERR_TOO_LOW .or. & - err_code == GLC_ELEVCLASS_ERR_TOO_HIGH) then - ! These are all acceptable "errors" - it is even okay for these purposes if - ! the elevation is lower than the lower bound of elevation class 1, or - ! higher than the upper bound of the top elevation class. - - ! Do nothing - else - write(iulog,*) subname, ': ERROR getting elevation class for topo = ', atm_topo - write(iulog,*) glc_errcode_to_string(err_code) - call endrun(msg=subname//': ERROR getting elevation class') - end if - - if (elev_class == atm_elev_class) then - exists = .true. - col_wt_lunit = 1._r8 - else - exists = .false. - col_wt_lunit = 0._r8 - end if - end if - - else ! collapse_to_atm_topo_grc .false. - if (this%has_virtual_columns_grc(gi)) then - exists = .true. - else if (wt_lunit(gi, istice_mec) > 0.0_r8 .and. & - wt_glc_mec(gi, elev_class) > 0.0_r8) then - ! If the landunit has non-zero weight on the grid cell, and this column has - ! non-zero weight on the landunit... - exists = .true. - end if - end if - - end subroutine glc_mec_col_exists - - !----------------------------------------------------------------------- - function cols_have_dynamic_type(this, gi) - ! - ! !DESCRIPTION: - ! Returns true if glc_mec columns on the given grid cell have dynamic type (i.e., - ! type potentially changing at runtime) - ! - ! !USES: - ! - ! !ARGUMENTS: - logical :: cols_have_dynamic_type ! function result - class(glc_behavior_type), intent(in) :: this - integer, intent(in) :: gi ! grid cell index - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'cols_have_dynamic_type' - !----------------------------------------------------------------------- - - if (this%collapse_to_atm_topo_grc(gi)) then - cols_have_dynamic_type = .true. - else - cols_have_dynamic_type = .false. - end if - - end function cols_have_dynamic_type - - !----------------------------------------------------------------------- - subroutine icemec_cols_need_downscaling(this, bounds, num_icemecc, filter_icemecc, & - needs_downscaling_col) - ! - ! !DESCRIPTION: - ! Sets needs_downscaling_col to true for any ice_mec column that needs downscaling, - ! false for any ice_mec column that does not need downscaling. - ! - ! Outside of filter_icemecc, leaves needs_downscaling_col untouched. - ! - ! !USES: - ! - ! !ARGUMENTS: - class(glc_behavior_type) , intent(in) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_icemecc ! number of points in filter_icemecc - integer , intent(in) :: filter_icemecc(:) ! col filter for ice_mec - logical , intent(inout) :: needs_downscaling_col( bounds%begc: ) - ! - ! !LOCAL VARIABLES: - integer :: fc - integer :: c - integer :: g - - character(len=*), parameter :: subname = 'icemec_cols_need_downscaling' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(needs_downscaling_col) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - do fc = 1, num_icemecc - c = filter_icemecc(fc) - g = col%gridcell(c) - - if (this%collapse_to_atm_topo_grc(g)) then - needs_downscaling_col(c) = .false. - else - needs_downscaling_col(c) = .true. - end if - end do - - end subroutine icemec_cols_need_downscaling - - !----------------------------------------------------------------------- - subroutine update_glc_classes(this, bounds, topo_col) - ! - ! !DESCRIPTION: - ! Update the column class types of any glc_mec columns that need to be updated. - ! - ! Assumes that topo_col has already been set appropriately. - ! - ! !USES: - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(in) :: this - type(bounds_type), intent(in) :: bounds - real(r8), intent(in) :: topo_col( bounds%begc: ) - ! - ! !LOCAL VARIABLES: - type(filter_col_type) :: collapse_filterc - - character(len=*), parameter :: subname = 'update_glc_classes' - !----------------------------------------------------------------------- - - collapse_filterc = this%collapse_to_atm_topo_icemec_filterc(bounds) - call this%update_collapsed_columns_classes(bounds, collapse_filterc, topo_col) - - end subroutine update_glc_classes - - !----------------------------------------------------------------------- - subroutine update_collapsed_columns_classes(this, bounds, collapse_filterc, topo_col) - ! - ! !DESCRIPTION: - ! Update class of glc_mec columns in regions where these are collapsed to a single - ! column, given a filter. - ! - ! Assumes that topo_col has already been updated appropriately for these columns. - ! - ! !USES: - use glc_elevclass_mod, only : glc_get_elevation_class, GLC_ELEVCLASS_ERR_NONE - use glc_elevclass_mod, only : GLC_ELEVCLASS_ERR_TOO_LOW, GLC_ELEVCLASS_ERR_TOO_HIGH - use glc_elevclass_mod, only : glc_errcode_to_string - use column_varcon , only : icemec_class_to_col_itype - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(in) :: this - type(bounds_type), intent(in) :: bounds - type(filter_col_type), intent(in) :: collapse_filterc - real(r8), intent(in) :: topo_col( bounds%begc: ) - ! - ! !LOCAL VARIABLES: - integer :: fc ! filter index - integer :: c ! column index - integer :: elev_class ! elevation class of the single column on the ice_mec landunit - integer :: err_code - integer :: new_coltype - - character(len=*), parameter :: subname = 'update_collapsed_columns_classes' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(topo_col) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - do fc = 1, collapse_filterc%num - c = collapse_filterc%indices(fc) - - call glc_get_elevation_class(topo_col(c), elev_class, err_code) - if ( err_code == GLC_ELEVCLASS_ERR_NONE .or. & - err_code == GLC_ELEVCLASS_ERR_TOO_LOW .or. & - err_code == GLC_ELEVCLASS_ERR_TOO_HIGH) then - ! These are all acceptable "errors" - it is even okay for these purposes if - ! the elevation is lower than the lower bound of elevation class 1, or - ! higher than the upper bound of the top elevation class. - - ! Do nothing - else - write(iulog,*) subname, ': ERROR getting elevation class for topo = ', & - topo_col(c) - write(iulog,*) glc_errcode_to_string(err_code) - call endrun(msg=subname//': ERROR getting elevation class') - end if - - new_coltype = icemec_class_to_col_itype(elev_class) - if (new_coltype /= col%itype(c)) then - call col%update_itype(c = c, itype = new_coltype) - end if - end do - - end subroutine update_collapsed_columns_classes - - !----------------------------------------------------------------------- - function collapse_to_atm_topo_icemec_filterc(this, bounds) result(filter) - ! - ! !DESCRIPTION: - ! Returns a column-level filter of ice_mec columns with the collapse_to_atm_topo behavior - ! - ! !USES: - use filterColMod, only : filter_col_type, col_filter_from_grcflags_ltypes - ! - ! !ARGUMENTS: - class(glc_behavior_type), intent(in) :: this - type(filter_col_type) :: filter ! function result - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'collapse_to_atm_topo_icemec_filterc' - !----------------------------------------------------------------------- - - ! Currently this creates the filter on the fly, recreating it every time this - ! function is called. Since this is a static filter, we could just compute it once - ! and save it, returning the already-computed filter when this function is called. - ! However, the problem with that is the need to have a different filter for each - ! clump (and potentially another filter for calls from outside a clump loop). This - ! will become easier to handle if we rework CLM's threading so that there is a - ! separate instance of each object for each clump: in that case, we'll have multiple - ! instances of glc_behavior_type, each corresponding to one clump, each with its own - ! filter. - - filter = col_filter_from_grcflags_ltypes( & - bounds = bounds, & - grcflags = this%collapse_to_atm_topo_grc(bounds%begg:bounds%endg), & - ltypes = [istice_mec], & - include_inactive = .true.) - - end function collapse_to_atm_topo_icemec_filterc - - !----------------------------------------------------------------------- - function get_collapse_to_atm_topo(this, gi) result(collapse_to_atm_topo) - ! - ! !DESCRIPTION: - ! Get the value of collapse_to_atm_topo at a given grid cell - ! - ! This function just exists to support unit testing, and should not be called from - ! production code. - ! - ! !USES: - ! - ! !ARGUMENTS: - logical :: collapse_to_atm_topo ! function result - class(glc_behavior_type), intent(in) :: this - integer, intent(in) :: gi ! grid cell index - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'get_collapse_to_atm_topo' - !----------------------------------------------------------------------- - - collapse_to_atm_topo = this%collapse_to_atm_topo_grc(gi) - - end function get_collapse_to_atm_topo - -end module glcBehaviorMod diff --git a/src/main/histFileMod.F90 b/src/main/histFileMod.F90 index 4e2347a3..614dc61f 100644 --- a/src/main/histFileMod.F90 +++ b/src/main/histFileMod.F90 @@ -12,14 +12,11 @@ module histFileMod use shr_sys_mod , only : shr_sys_flush use spmdMod , only : masterproc use abortutils , only : endrun - use clm_varctl , only : iulog, use_vertsoilc - use clm_varcon , only : spval, ispval, dzsoi_decomp - use clm_varcon , only : grlnd, nameg, namel, namec, namep, nameCohort + use clm_varctl , only : iulog + use clm_varcon , only : spval, ispval + use clm_varcon , only : grlnd, nameg use decompMod , only : get_proc_bounds, get_proc_global, bounds_type use GridcellType , only : grc - use LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch use ncdio_pio ! @@ -38,16 +35,6 @@ module histFileMod integer , private, parameter :: avgflag_strlen = 3 ! maximum number of characters for avgflag integer , private, parameter :: hist_dim_name_length = 16 ! lenngth of character strings in dimension names - ! Possible ways to treat multi-layer snow fields at times when no snow is present in a - ! given layer. Note that the public parameters are the only ones that can be used by - ! calls to hist_addfld2d; the private parameters are just used internally by the - ! histFile implementation. - integer , private, parameter :: no_snow_MIN = 1 ! minimum valid value for this flag - integer , public , parameter :: no_snow_normal = 1 ! normal treatment, which should be used for most fields (use spval when snow layer not present) - integer , public , parameter :: no_snow_zero = 2 ! average in a 0 value for times when the snow layer isn't present - integer , private, parameter :: no_snow_MAX = 2 ! maximum valid value for this flag - integer , private, parameter :: no_snow_unset = no_snow_MIN - 1 ! flag specifying that field is NOT a multi-layer snow field - ! ! Counters ! integer , public :: ntapes = 0 ! index of max history file requested @@ -108,7 +95,6 @@ module histFileMod public :: hist_readNML ! Read in the history namelist settings public :: hist_addfld1d ! Add a 1d single-level field to the master field list public :: hist_addfld2d ! Add a 2d multi-level field to the master field list - public :: hist_addfld_decomp ! Add a 2d multi-level field to the master field list public :: hist_add_subscript ! Add a 2d subscript dimension public :: hist_printflds ! Print summary of master field list public :: hist_htapes_build ! Initialize history file handler for initial or continue run @@ -124,10 +110,6 @@ module histFileMod private :: masterlist_change_timeavg ! Override default history tape contents for specific tape private :: htape_addfld ! Add a field to the active list for a history tape private :: htape_create ! Define contents of history file t - private :: htape_add_ltype_metadata ! Add global metadata defining landunit types - private :: htape_add_ctype_metadata ! Add global metadata defining column types - private :: htape_add_natpft_metadata ! Add global metadata defining natpft types - private :: htape_add_cft_metadata ! Add global metadata defining cft types private :: htape_timeconst ! Write time constant values to history tape private :: htape_timeconst3D ! Write time constant 3D values to primary history tape private :: hfields_normalize ! Normalize history file fields by number of accumulations @@ -136,7 +118,6 @@ module histFileMod private :: hfields_1dinfo ! Define/output 1d subgrid info if appropriate private :: hist_update_hbuf_field_1d ! Updates history buffer for specific field and tape private :: hist_update_hbuf_field_2d ! Updates history buffer for specific field and tape - private :: hist_set_snow_field_2d ! Set values in history field dimensioned by levsno private :: list_index ! Find index of field in exclude list private :: set_hist_filename ! Determine history dataset filenames private :: getname ! Retrieve name portion of input "inname" @@ -163,7 +144,7 @@ module histFileMod character(len=max_chars) :: units ! units character(len=hist_dim_name_length) :: type1d ! pointer to first dimension type from data type (nameg, etc) character(len=hist_dim_name_length) :: type1d_out ! hbuf first dimension type from data type (nameg, etc) - character(len=hist_dim_name_length) :: type2d ! hbuf second dimension type ["levgrnd","levlak","numrad","ltype","natpft","cft","glc_nec","elevclas","subname(n)"] + character(len=hist_dim_name_length) :: type2d ! hbuf second dimension type ["levgrnd","numrad","ltype","subname(n)"] integer :: beg1d ! on-node 1d clm pointer start index integer :: end1d ! on-node 1d clm pointer end index integer :: num1d ! size of clm pointer first dimension (all nodes) @@ -172,10 +153,6 @@ module histFileMod integer :: num1d_out ! size of hbuf first dimension (all nodes) integer :: num2d ! size of hbuf second dimension (e.g. number of vertical levels) integer :: hpindex ! history pointer index - character(len=scale_type_strlen) :: p2c_scale_type ! scale factor when averaging patch to column - character(len=scale_type_strlen) :: c2l_scale_type ! scale factor when averaging column to landunit - character(len=scale_type_strlen) :: l2g_scale_type ! scale factor when averaging landunit to gridcell - integer :: no_snow_behavior ! for multi-layer snow fields, flag saying how to treat times when a given snow layer is absent end type field_info type master_entry @@ -286,9 +263,7 @@ end subroutine hist_printflds !----------------------------------------------------------------------- subroutine masterlist_addfld (fname, type1d, type1d_out, & - type2d, num2d, units, avgflag, long_name, hpindex, & - p2c_scale_type, c2l_scale_type, l2g_scale_type, & - no_snow_behavior) + type2d, num2d, units, avgflag, long_name, hpindex) ! ! !DESCRIPTION: ! Add a field to the master field list. Put input arguments of @@ -309,19 +284,12 @@ subroutine masterlist_addfld (fname, type1d, type1d_out, & character(len=*), intent(in) :: avgflag ! time averaging flag character(len=*), intent(in) :: long_name ! long name of field integer , intent(in) :: hpindex ! data type index for history buffer output - character(len=*), intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column - character(len=*), intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits - character(len=*), intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells - integer, intent(in), optional :: no_snow_behavior ! if a multi-layer snow field, behavior to use for absent snow layers ! ! !LOCAL VARIABLES: integer :: n ! loop index integer :: f ! masterlist index integer :: numa ! total number of atm cells across all processors 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 type(bounds_type) :: bounds character(len=*),parameter :: subname = 'masterlist_addfld' !------------------------------------------------------------------------ @@ -334,7 +302,7 @@ subroutine masterlist_addfld (fname, type1d, type1d_out, & ! Determine bounds call get_proc_bounds(bounds) - call get_proc_global(ng=numg, nl=numl, nc=numc, np=nump) + call get_proc_global(ng=numg) ! Ensure that new field is not all blanks @@ -381,9 +349,6 @@ subroutine masterlist_addfld (fname, type1d, type1d_out, & masterlist(f)%field%type2d = type2d masterlist(f)%field%num2d = num2d masterlist(f)%field%hpindex = hpindex - masterlist(f)%field%p2c_scale_type = p2c_scale_type - masterlist(f)%field%c2l_scale_type = c2l_scale_type - masterlist(f)%field%l2g_scale_type = l2g_scale_type select case (type1d) case (grlnd) @@ -394,29 +359,11 @@ subroutine masterlist_addfld (fname, type1d, type1d_out, & masterlist(f)%field%beg1d = bounds%begg masterlist(f)%field%end1d = bounds%endg masterlist(f)%field%num1d = numg - case (namel) - masterlist(f)%field%beg1d = bounds%begl - masterlist(f)%field%end1d = bounds%endl - masterlist(f)%field%num1d = numl - case (namec) - masterlist(f)%field%beg1d = bounds%begc - masterlist(f)%field%end1d = bounds%endc - masterlist(f)%field%num1d = numc - case (namep) - masterlist(f)%field%beg1d = bounds%begp - masterlist(f)%field%end1d = bounds%endp - masterlist(f)%field%num1d = nump case default write(iulog,*) trim(subname),' ERROR: unknown 1d output type= ',type1d call endrun(msg=errMsg(sourcefile, __LINE__)) end select - if (present(no_snow_behavior)) then - masterlist(f)%field%no_snow_behavior = no_snow_behavior - else - masterlist(f)%field%no_snow_behavior = no_snow_unset - end if - ! The following two fields are used only in master field list, ! NOT in the runtime active field list ! ALL FIELDS IN THE MASTER LIST ARE INITIALIZED WITH THE ACTIVE @@ -454,7 +401,7 @@ subroutine hist_htapes_build () !----------------------------------------------------------------------- if (masterproc) then - write(iulog,*) trim(subname),' Initializing clm2 history files' + write(iulog,*) trim(subname),' Initializing slim history files' write(iulog,'(72a1)') ("-",i=1,60) call shr_sys_flush(iulog) endif @@ -501,7 +448,7 @@ subroutine hist_htapes_build () end do if (masterproc) then - write(iulog,*) trim(subname),' Successfully initialized clm2 history files' + write(iulog,*) trim(subname),' Successfully initialized slim history files' write(iulog,'(72a1)') ("-",i=1,60) call shr_sys_flush(iulog) endif @@ -832,25 +779,6 @@ logical function is_mapping_upto_subgrid( type1d, type1d_out ) result ( mapping) character(len=8), intent(in) :: type1d_out ! history buffer 1d type ! mapping = .false. - if (type1d_out == nameg .or. type1d_out == grlnd) then - if (type1d == namep) then - mapping = .true. - else if (type1d == namec) then - mapping = .true. - else if (type1d == namel) then - mapping = .true. - end if - else if (type1d_out == namel ) then - if (type1d == namep) then - mapping = .true. - else if (type1d == namec) then - mapping = .true. - end if - else if (type1d_out == namec ) then - if (type1d == namep) then - mapping = .true. - end if - end if end function is_mapping_upto_subgrid !----------------------------------------------------------------------- @@ -871,9 +799,6 @@ subroutine htape_addfld (t, f, avgflag) character(len=hist_dim_name_length) :: type1d_out ! history buffer 1d type integer :: numa ! total number of atm cells across all processors 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 integer :: num2d ! size of second dimension (e.g. .number of vertical levels) integer :: beg1d_out,end1d_out ! history output per-proc 1d beginning and ending indices integer :: beg1d,end1d ! beginning and ending indices for this field (assume already set) @@ -900,7 +825,7 @@ subroutine htape_addfld (t, f, avgflag) ! Determine bounds call get_proc_bounds(bounds) - call get_proc_global(ng=numg, nl=numl, nc=numc, np=nump) + call get_proc_global(ng=numg) ! Modify type1d_out if necessary @@ -912,10 +837,7 @@ subroutine htape_addfld (t, f, avgflag) type1d = tape(t)%hlist(n)%field%type1d - if (type1d == nameg .or. & - type1d == namel .or. & - type1d == namec .or. & - type1d == namep) then + if (type1d == nameg) then tape(t)%hlist(n)%field%type1d_out = grlnd end if if (type1d == grlnd) then @@ -932,12 +854,6 @@ subroutine htape_addfld (t, f, avgflag) select case (trim(hist_type1d_pertape(t))) case('GRID') tape(t)%hlist(n)%field%type1d_out = nameg - case('LAND') - tape(t)%hlist(n)%field%type1d_out = namel - case('COLS') - tape(t)%hlist(n)%field%type1d_out = namec - case ('PFTS') - tape(t)%hlist(n)%field%type1d_out = namep case default write(iulog,*) trim(subname),' ERROR: unknown input hist_type1d_pertape= ', hist_type1d_pertape(t) call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -956,18 +872,6 @@ subroutine htape_addfld (t, f, avgflag) beg1d_out = bounds%begg end1d_out = bounds%endg num1d_out = numg - else if (type1d_out == namel) then - beg1d_out = bounds%begl - end1d_out = bounds%endl - num1d_out = numl - else if (type1d_out == namec) then - beg1d_out = bounds%begc - end1d_out = bounds%endc - num1d_out = numc - else if (type1d_out == namep) then - beg1d_out = bounds%begp - end1d_out = bounds%endp - num1d_out = nump else write(iulog,*) trim(subname),' ERROR: incorrect value of type1d_out= ',type1d_out call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1026,7 +930,7 @@ subroutine hist_update_hbuf(bounds) integer :: f ! field index integer :: num2d ! size of second dimension (e.g. number of vertical levels) character(len=*),parameter :: subname = 'hist_update_hbuf' - character(len=hist_dim_name_length) :: type2d ! hbuf second dimension type ["levgrnd","levlak","numrad","ltype","natpft","cft","glc_nec","elevclas","subname(n)"] + character(len=hist_dim_name_length) :: type2d ! hbuf second dimension type ["levgrnd","numrad","ltype","subname(n)"] !----------------------------------------------------------------------- do t = 1,ntapes @@ -1055,7 +959,6 @@ subroutine hist_update_hbuf_field_1d (t, f, bounds) ! call to p2g, and the lack of explicit bounds on its arguments; see also bug 1786) ! ! !USES: - use subgridAveMod , only : p2g, c2g, l2g, p2l, c2l, p2c use decompMod , only : BOUNDS_LEVEL_PROC ! ! !ARGUMENTS: @@ -1065,23 +968,16 @@ subroutine hist_update_hbuf_field_1d (t, f, bounds) ! ! !LOCAL VARIABLES: integer :: hpindex ! history pointer index - integer :: k ! gridcell, landunit, column or patch index + integer :: k ! gridcell index integer :: beg1d,end1d ! beginning and ending indices integer :: beg1d_out,end1d_out ! beginning and ending indices on output grid - logical :: check_active ! true => check 'active' flag of each point (this refers to a point being active, NOT a history field being active) logical :: valid ! true => history operation is valid - logical :: map2gcell ! true => map clm pointer field to gridcell - character(len=hist_dim_name_length) :: type1d ! 1d clm pointerr type ["gridcell","landunit","column","pft"] - character(len=hist_dim_name_length) :: type1d_out ! 1d history buffer type ["gridcell","landunit","column","pft"] + character(len=hist_dim_name_length) :: type1d ! 1d clm pointerr type ["gridcell"] + character(len=hist_dim_name_length) :: type1d_out ! 1d history buffer type ["gridcell"] character(len=avgflag_strlen) :: avgflag ! time averaging flag - character(len=scale_type_strlen) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column - character(len=scale_type_strlen) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits - character(len=scale_type_strlen) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells real(r8), pointer :: hbuf(:,:) ! history buffer integer , pointer :: nacs(:,:) ! accumulation counter real(r8), pointer :: field(:) ! clm 1d pointer field - logical , pointer :: active(:) ! flag saying whether each point is active (used for type1d = landunit/column/pft) (this refers to a point being active, NOT a history field being active) - real(r8), allocatable :: field_gcell(:) ! gricell level field (used if mapping to gridcell is done) integer j character(len=*),parameter :: subname = 'hist_update_hbuf_field_1d' integer k_offset ! offset for mapping sliced subarray pointers when outputting variables in PFT/col vector form @@ -1098,167 +994,20 @@ subroutine hist_update_hbuf_field_1d (t, f, bounds) end1d_out = tape(t)%hlist(f)%field%end1d_out type1d = tape(t)%hlist(f)%field%type1d type1d_out = tape(t)%hlist(f)%field%type1d_out - p2c_scale_type = tape(t)%hlist(f)%field%p2c_scale_type - c2l_scale_type = tape(t)%hlist(f)%field%c2l_scale_type - l2g_scale_type = tape(t)%hlist(f)%field%l2g_scale_type hpindex = tape(t)%hlist(f)%field%hpindex field => clmptr_rs(hpindex)%ptr ! set variables to check weights when allocate all pfts - map2gcell = .false. if (type1d_out == nameg .or. type1d_out == grlnd) then SHR_ASSERT(beg1d_out == bounds%begg, errMsg(sourcefile, __LINE__)) SHR_ASSERT(end1d_out == bounds%endg, errMsg(sourcefile, __LINE__)) - if (type1d == namep) then - ! In this and the following calls, we do NOT explicitly subset field using - ! bounds (e.g., we do NOT do field(bounds%begp:bounds%endp). This is because, - ! for some fields, the lower bound has been reset to 1 due to taking a pointer - ! to an array slice. Thus, this code will NOT work properly if done within a - ! threaded region! (See also bug 1786) - allocate( field_gcell(beg1d_out:end1d_out) ) - call p2g(bounds, & - field, & - field_gcell(bounds%begg:bounds%endg), & - p2c_scale_type, c2l_scale_type, l2g_scale_type) - map2gcell = .true. - else if (type1d == namec) then - allocate( field_gcell(beg1d_out:end1d_out) ) - call c2g(bounds, & - field, & - field_gcell(bounds%begg:bounds%endg), & - c2l_scale_type, l2g_scale_type) - map2gcell = .true. - else if (type1d == namel) then - allocate( field_gcell(beg1d_out:end1d_out) ) - call l2g(bounds, & - field, & - field_gcell(bounds%begg:bounds%endg), & - l2g_scale_type) - map2gcell = .true. - end if - end if - if (type1d_out == namel ) then - SHR_ASSERT(beg1d_out == bounds%begl, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(end1d_out == bounds%endl, errMsg(sourcefile, __LINE__)) - if (type1d == namep) then - ! In this and the following calls, we do NOT explicitly subset field using - ! bounds (e.g., we do NOT do field(bounds%begp:bounds%endp). This is because, - ! for some fields, the lower bound has been reset to 1 due to taking a pointer - ! to an array slice. Thus, this code will NOT work properly if done within a - ! threaded region! (See also bug 1786) - allocate( field_gcell(beg1d_out:end1d_out) ) - call p2l(bounds, & - field, & - field_gcell(beg1d_out:end1d_out), & - p2c_scale_type, c2l_scale_type) - map2gcell = .true. - else if (type1d == namec) then - allocate( field_gcell(beg1d_out:end1d_out) ) - call c2l(bounds, & - field, & - field_gcell(beg1d_out:end1d_out), & - c2l_scale_type) - map2gcell = .true. - end if - end if - if (type1d_out == namec ) then - SHR_ASSERT(beg1d_out == bounds%begc, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(end1d_out == bounds%endc, errMsg(sourcefile, __LINE__)) - if (type1d == namep) then - ! In this and the following calls, we do NOT explicitly subset field using - ! bounds (e.g., we do NOT do field(bounds%begp:bounds%endp). This is because, - ! for some fields, the lower bound has been reset to 1 due to taking a pointer - ! to an array slice. Thus, this code will NOT work properly if done within a - ! threaded region! (See also bug 1786) - allocate( field_gcell(beg1d_out:end1d_out) ) - call p2c(bounds, & - field, & - field_gcell(beg1d_out:end1d_out), & - p2c_scale_type) - map2gcell = .true. - end if - end if - if ( map2gcell .and. .not. is_mapping_upto_subgrid(type1d, type1d_out) )then - call endrun(msg=trim(subname)//' ERROR: mapping upto subgrid level is inconsistent'//errMsg(sourcefile, __LINE__)) end if - if ( .not. map2gcell .and. is_mapping_upto_subgrid(type1d, type1d_out) )then - call endrun(msg=trim(subname)//' ERROR: mapping upto subgrid level is inconsistent'//errMsg(sourcefile, __LINE__)) - end if - - if (map2gcell) then ! Map to gridcell - - ! note that in this case beg1d = begg and end1d=endg - select case (avgflag) - case ('I') ! Instantaneous - do k = beg1d_out, end1d_out - if (field_gcell(k) /= spval) then - hbuf(k,1) = field_gcell(k) - else - hbuf(k,1) = spval - end if - nacs(k,1) = 1 - end do - case ('A', 'SUM') ! Time average / sum - do k = beg1d_out, end1d_out - if (field_gcell(k) /= spval) then - if (nacs(k,1) == 0) hbuf(k,1) = 0._r8 - hbuf(k,1) = hbuf(k,1) + field_gcell(k) - nacs(k,1) = nacs(k,1) + 1 - else - if (nacs(k,1) == 0) hbuf(k,1) = spval - end if - end do - case ('X') ! Maximum over time - do k = beg1d_out, end1d_out - if (field_gcell(k) /= spval) then - if (nacs(k,1) == 0) hbuf(k,1) = -1.e50_r8 - hbuf(k,1) = max( hbuf(k,1), field_gcell(k) ) - else - hbuf(k,1) = spval - endif - nacs(k,1) = 1 - end do - case ('M') ! Minimum over time - do k = beg1d_out, end1d_out - if (field_gcell(k) /= spval) then - if (nacs(k,1) == 0) hbuf(k,1) = +1.e50_r8 - hbuf(k,1) = min( hbuf(k,1), field_gcell(k) ) - else - hbuf(k,1) = spval - endif - nacs(k,1) = 1 - end do - case default - write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - deallocate( field_gcell ) - - else ! Do not map to gridcell - - ! For data defined on the pft, col or landunit, we need to check if a point is active - ! to determine whether that point should be assigned spval - if (type1d == namep) then - check_active = .true. - active => patch%active - else if (type1d == namec) then - check_active = .true. - active => col%active - else if (type1d == namel) then - check_active = .true. - active =>lun%active - else - check_active = .false. - end if select case (avgflag) case ('I') ! Instantaneous do k = beg1d,end1d valid = .true. - if (check_active) then - if (.not. active(k)) valid = .false. - end if if (valid) then if (field(k) /= spval) then hbuf(k,1) = field(k) @@ -1275,13 +1024,10 @@ subroutine hist_update_hbuf_field_1d (t, f, bounds) if ( end1d .eq. ubound(field,1) ) then k_offset = 0 else - k_offset = 1 - beg1d + k_offset = 1 - beg1d endif do k = beg1d,end1d valid = .true. - if (check_active) then - if (.not. active(k)) valid = .false. - end if if (valid) then if (field(k+k_offset) /= spval) then ! add k_offset if (nacs(k,1) == 0) hbuf(k,1) = 0._r8 @@ -1297,9 +1043,6 @@ subroutine hist_update_hbuf_field_1d (t, f, bounds) case ('X') ! Maximum over time do k = beg1d,end1d valid = .true. - if (check_active) then - if (.not. active(k)) valid = .false. - end if if (valid) then if (field(k) /= spval) then if (nacs(k,1) == 0) hbuf(k,1) = -1.e50_r8 @@ -1315,9 +1058,6 @@ subroutine hist_update_hbuf_field_1d (t, f, bounds) case ('M') ! Minimum over time do k = beg1d,end1d valid = .true. - if (check_active) then - if (.not. active(k)) valid = .false. - end if if (valid) then if (field(k) /= spval) then if (nacs(k,1) == 0) hbuf(k,1) = +1.e50_r8 @@ -1334,7 +1074,6 @@ subroutine hist_update_hbuf_field_1d (t, f, bounds) write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag call endrun(msg=errMsg(sourcefile, __LINE__)) end select - end if end subroutine hist_update_hbuf_field_1d @@ -1349,7 +1088,6 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) ! call to p2g, and the lack of explicit bounds on its arguments; see also bug 1786) ! ! !USES: - use subgridAveMod , only : p2g, c2g, l2g, p2l, c2l, p2c use decompMod , only : BOUNDS_LEVEL_PROC ! ! !ARGUMENTS: @@ -1360,27 +1098,18 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) ! ! !LOCAL VARIABLES: integer :: hpindex ! history pointer index - integer :: k ! gridcell, landunit, column or patch index + integer :: k ! gridcell index integer :: j ! level index integer :: beg1d,end1d ! beginning and ending indices integer :: beg1d_out,end1d_out ! beginning and ending indices for output level - logical :: check_active ! true => check 'active' flag of each point (this refers to a point being active, NOT a history field being active) logical :: valid ! true => history operation is valid - logical :: map2gcell ! true => map clm pointer field to gridcell - character(len=hist_dim_name_length) :: type1d ! 1d clm pointerr type ["gridcell","landunit","column","pft"] - character(len=hist_dim_name_length) :: type1d_out ! 1d history buffer type ["gridcell","landunit","column","pft"] + character(len=hist_dim_name_length) :: type1d ! 1d clm pointerr type ["gridcell"] + character(len=hist_dim_name_length) :: type1d_out ! 1d history buffer type ["gridcell"] character(len=avgflag_strlen) :: avgflag ! time averaging flag - character(len=scale_type_strlen) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column - character(len=scale_type_strlen) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits - character(len=scale_type_strlen) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells - integer :: no_snow_behavior ! for multi-layer snow fields, behavior to use when a given layer is absent real(r8), pointer :: hbuf(:,:) ! history buffer integer , pointer :: nacs(:,:) ! accumulation counter real(r8), pointer :: field(:,:) ! clm 2d pointer field logical :: field_allocated! whether 'field' was allocated here - logical , pointer :: active(:) ! flag saying whether each point is active (used for type1d = landunit/column/pft) - !(this refers to a point being active, NOT a history field being active) - real(r8), allocatable :: field_gcell(:,:) ! gridcell level field (used if mapping to gridcell is done) character(len=*),parameter :: subname = 'hist_update_hbuf_field_2d' !----------------------------------------------------------------------- @@ -1395,189 +1124,18 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) end1d_out = tape(t)%hlist(f)%field%end1d_out type1d = tape(t)%hlist(f)%field%type1d type1d_out = tape(t)%hlist(f)%field%type1d_out - p2c_scale_type = tape(t)%hlist(f)%field%p2c_scale_type - c2l_scale_type = tape(t)%hlist(f)%field%c2l_scale_type - l2g_scale_type = tape(t)%hlist(f)%field%l2g_scale_type - no_snow_behavior = tape(t)%hlist(f)%field%no_snow_behavior hpindex = tape(t)%hlist(f)%field%hpindex - if (no_snow_behavior /= no_snow_unset) then - ! For multi-layer snow fields, build a special output variable that handles - ! missing snow layers appropriately - - ! Note, regarding bug 1786: The following allocation is not what we would want if - ! this routine were operating in a threaded region (or, more generally, within a - ! loop over nclumps) - in that case we would want to use the bounds information for - ! this clump. But currently that's not possible because the bounds of some fields - ! have been reset to 1 - see also bug 1786. Similarly, if we wanted to allow - ! operation within a loop over clumps, we would need to pass 'bounds' to - ! hist_set_snow_field_2d rather than relying on beg1d & end1d (which give the proc, - ! bounds not the clump bounds) - - allocate(field(lbound(clmptr_ra(hpindex)%ptr, 1) : ubound(clmptr_ra(hpindex)%ptr, 1), 1:num2d)) - field_allocated = .true. - - call hist_set_snow_field_2d(field, clmptr_ra(hpindex)%ptr, no_snow_behavior, type1d, & - beg1d, end1d) - else field => clmptr_ra(hpindex)%ptr(:,1:num2d) field_allocated = .false. - end if ! set variables to check weights when allocate all pfts - map2gcell = .false. if (type1d_out == nameg .or. type1d_out == grlnd) then SHR_ASSERT(beg1d_out == bounds%begg, errMsg(sourcefile, __LINE__)) SHR_ASSERT(end1d_out == bounds%endg, errMsg(sourcefile, __LINE__)) - if (type1d == namep) then - ! In this and the following calls, we do NOT explicitly subset field using - ! (e.g., we do NOT do field(bounds%begp:bounds%endp). This is because, - ! for some fields, the lower bound has been reset to 1 due to taking a pointer - ! to an array slice. Thus, this code will NOT work properly if done within a - ! threaded region! (See also bug 1786) - allocate(field_gcell(bounds%begg:bounds%endg,num2d) ) - call p2g(bounds, num2d, & - field, & - field_gcell(bounds%begg:bounds%endg, :), & - p2c_scale_type, c2l_scale_type, l2g_scale_type) - map2gcell = .true. - else if (type1d == namec) then - allocate(field_gcell(bounds%begg:bounds%endg,num2d) ) - call c2g(bounds, num2d, & - field, & - field_gcell(bounds%begg:bounds%endg, :), & - c2l_scale_type, l2g_scale_type) - map2gcell = .true. - else if (type1d == namel) then - allocate(field_gcell(bounds%begg:bounds%endg,num2d) ) - call l2g(bounds, num2d, & - field, & - field_gcell(bounds%begg:bounds%endg, :), & - l2g_scale_type) - map2gcell = .true. - end if - else if ( type1d_out == namel )then - SHR_ASSERT(beg1d_out == bounds%begl, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(end1d_out == bounds%endl, errMsg(sourcefile, __LINE__)) - if (type1d == namep) then - ! In this and the following calls, we do NOT explicitly subset field using - ! (e.g., we do NOT do field(bounds%begp:bounds%endp). This is because, - ! for some fields, the lower bound has been reset to 1 due to taking a pointer - ! to an array slice. Thus, this code will NOT work properly if done within a - ! threaded region! (See also bug 1786) - allocate(field_gcell(beg1d_out:end1d_out,num2d)) - call p2l(bounds, num2d, & - field, & - field_gcell(beg1d_out:end1d_out, :), & - p2c_scale_type, c2l_scale_type) - map2gcell = .true. - else if (type1d == namec) then - allocate(field_gcell(beg1d_out:end1d_out,num2d)) - call c2l(bounds, num2d, & - field, & - field_gcell(beg1d_out:end1d_out, :), & - c2l_scale_type) - map2gcell = .true. - end if - else if ( type1d_out == namec )then - SHR_ASSERT(beg1d_out == bounds%begc, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(end1d_out == bounds%endc, errMsg(sourcefile, __LINE__)) - if (type1d == namep) then - ! In this and the following calls, we do NOT explicitly subset field using - ! (e.g., we do NOT do field(bounds%begp:bounds%endp). This is because, - ! for some fields, the lower bound has been reset to 1 due to taking a pointer - ! to an array slice. Thus, this code will NOT work properly if done within a - ! threaded region! (See also bug 1786) - allocate(field_gcell(beg1d_out:end1d_out,num2d)) - call p2c(bounds, num2d, & - field, & - field_gcell(beg1d_out:end1d_out, :), & - p2c_scale_type) - map2gcell = .true. - end if - end if - if ( map2gcell .and. .not. is_mapping_upto_subgrid(type1d, type1d_out) )then - call endrun(msg=trim(subname)//' ERROR: mapping upto subgrid level is inconsistent'//errMsg(sourcefile, __LINE__)) - end if - if ( .not. map2gcell .and. is_mapping_upto_subgrid(type1d, type1d_out) )then - call endrun(msg=trim(subname)//' ERROR: mapping upto subgrid level is inconsistent'//errMsg(sourcefile, __LINE__)) end if - if (map2gcell) then ! Map to gridcell - - ! note that in this case beg1d = begg and end1d=endg - select case (avgflag) - case ('I') ! Instantaneous - do j = 1,num2d - do k = beg1d_out, end1d_out - if (field_gcell(k,j) /= spval) then - hbuf(k,j) = field_gcell(k,j) - else - hbuf(k,j) = spval - end if - nacs(k,j) = 1 - end do - end do - case ('A', 'SUM') ! Time average / sum - do j = 1,num2d - do k = beg1d_out, end1d_out - if (field_gcell(k,j) /= spval) then - if (nacs(k,j) == 0) hbuf(k,j) = 0._r8 - hbuf(k,j) = hbuf(k,j) + field_gcell(k,j) - nacs(k,j) = nacs(k,j) + 1 - else - if (nacs(k,j) == 0) hbuf(k,j) = spval - endif - end do - end do - case ('X') ! Maximum over time - do j = 1,num2d - do k = beg1d_out, end1d_out - if (field_gcell(k,j) /= spval) then - if (nacs(k,j) == 0) hbuf(k,j) = -1.e50_r8 - hbuf(k,j) = max( hbuf(k,j), field_gcell(k,j) ) - else - hbuf(k,j) = spval - endif - nacs(k,j) = 1 - end do - end do - case ('M') ! Minimum over time - do j = 1,num2d - do k = beg1d_out, end1d_out - if (field_gcell(k,j) /= spval) then - if (nacs(k,j) == 0) hbuf(k,j) = +1.e50_r8 - hbuf(k,j) = min( hbuf(k,j), field_gcell(k,j) ) - else - hbuf(k,j) = spval - endif - nacs(k,j) = 1 - end do - end do - case default - write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - deallocate( field_gcell ) - - else ! Do not map to gridcell - - ! For data defined on the pft, col or landunit, we need to check if a point is active - ! to determine whether that point should be assigned spval - if (type1d == namep) then - check_active = .true. - active => patch%active - else if (type1d == namec) then - check_active = .true. - active => col%active - else if (type1d == namel) then - check_active = .true. - active =>lun%active - else - check_active = .false. - end if - ! Note that since field points to an array section the ! bounds are field(1:end1d-beg1d+1, num2d) - therefore ! need to do the shifting below @@ -1587,9 +1145,6 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) do j = 1,num2d do k = beg1d,end1d valid = .true. - if (check_active) then - if (.not. active(k)) valid = .false. - end if if (valid) then if (field(k-beg1d+1,j) /= spval) then hbuf(k,j) = field(k-beg1d+1,j) @@ -1606,9 +1161,6 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) do j = 1,num2d do k = beg1d,end1d valid = .true. - if (check_active) then - if (.not. active(k)) valid = .false. - end if if (valid) then if (field(k-beg1d+1,j) /= spval) then if (nacs(k,j) == 0) hbuf(k,j) = 0._r8 @@ -1626,9 +1178,6 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) do j = 1,num2d do k = beg1d,end1d valid = .true. - if (check_active) then - if (.not. active(k)) valid = .false. - end if if (valid) then if (field(k-beg1d+1,j) /= spval) then if (nacs(k,j) == 0) hbuf(k,j) = -1.e50_r8 @@ -1646,9 +1195,6 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) do j = 1,num2d do k = beg1d,end1d valid = .true. - if (check_active) then - if (.not. active(k)) valid = .false. - end if if (valid) then if (field(k-beg1d+1,j) /= spval) then if (nacs(k,j) == 0) hbuf(k,j) = +1.e50_r8 @@ -1666,7 +1212,6 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag call endrun(msg=errMsg(sourcefile, __LINE__)) end select - end if if (field_allocated) then deallocate(field) @@ -1674,99 +1219,6 @@ subroutine hist_update_hbuf_field_2d (t, f, bounds, num2d) end subroutine hist_update_hbuf_field_2d - !----------------------------------------------------------------------- - subroutine hist_set_snow_field_2d (field_out, field_in, no_snow_behavior, type1d, beg1d, end1d) - ! - ! !DESCRIPTION: - ! Set values in history field dimensioned by levsno. - ! - ! This routine handles what to do when a given snow layer doesn't exist for a given - ! point, based on the no_snow_behavior argument. Options are: - ! - ! - no_snow_normal: This is the normal behavior, which applies to most snow fields: - ! Use spval (missing value flag). This means that temporal averages will just - ! consider times when a particular snow layer actually existed - ! - ! - no_snow_zero: Average in a 0 value for times when the snow layer isn't present - ! - ! Input and output fields can be defined at the patch or column level - ! - ! !ARGUMENTS: - integer , intent(in) :: beg1d ! beginning spatial index - integer , intent(in) :: end1d ! ending spatial index - real(r8) , intent(out) :: field_out( beg1d: , 1: ) ! output field [point, lev] - real(r8) , intent(in) :: field_in ( beg1d: , 1: ) ! input field [point, lev] - integer , intent(in) :: no_snow_behavior ! behavior to use when a snow layer is absent - character(len=*), intent(in) :: type1d ! 1d clm pointer type ("column" or "pft") - ! - ! !LOCAL VARIABLES: - integer :: num_levels ! total number of possible snow layers - integer :: point - integer :: level - integer :: num_snow_layers ! number of snow layers that exist at a point - integer :: num_nonexistent_layers - integer :: c ! column index - real(r8):: no_snow_val ! value to use when a snow layer is missing - character(len=*), parameter :: subname = 'hist_set_snow_field_2d' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(field_out, 1) == end1d), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(field_in , 1) == end1d), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(field_out, 2) == ubound(field_in, 2)), errMsg(sourcefile, __LINE__)) - - associate(& - snl => col%snl & ! Input: [integer (:)] number of snow layers (negative) - ) - - num_levels = ubound(field_in, 2) - - ! Determine no_snow_val - select case (no_snow_behavior) - case (no_snow_normal) - no_snow_val = spval - case (no_snow_zero) - no_snow_val = 0._r8 - case default - write(iulog,*) trim(subname), ' ERROR: unrecognized no_snow_behavior: ', & - no_snow_behavior - call endrun() - end select - - do point = beg1d, end1d - - ! Get number of snow layers at this point - - if (type1d == namec) then - c = point - else if (type1d == namep) then - c = patch%column(point) - else - write(iulog,*) trim(subname), ' ERROR: Only implemented for patch and col-level fields' - write(iulog,*) 'type1d = ', trim(type1d) - call endrun() - end if - - num_snow_layers = abs(snl(c)) - num_nonexistent_layers = num_levels - num_snow_layers - - ! Fill output field appropriately for each layer - ! When only a subset of snow layers exist, it is the LAST num_snow_layers that exist - ! Levels are rearranged such that the top snow layer (surface layer) becomes level 1, etc. - - do level = num_levels, (num_levels-num_nonexistent_layers+1), -1 - field_out(point, level) = no_snow_val - end do - do level = (num_levels-num_nonexistent_layers), 1, -1 - field_out(point, level) = field_in(point, level+num_nonexistent_layers) - end do - - end do - - end associate - - end subroutine hist_set_snow_field_2d - - !----------------------------------------------------------------------- subroutine hfields_normalize (t) ! @@ -1853,10 +1305,8 @@ subroutine htape_create (t, histrest) ! wrapper calls to define the history file contents. ! ! !USES: - use clm_varpar , only : nlevgrnd, nlevsno, nlevlak, nlevurb, numrad, nlevcan, nvegwcs,nlevsoi - use clm_varpar , only : natpft_size, cft_size, maxpatch_glcmec, nlevdecomp_full - use landunit_varcon , only : max_lunit - use clm_varctl , only : caseid, ctitle, fsurdat, finidat, paramfile + use clm_varpar , only : nlevgrnd, numrad + use clm_varctl , only : caseid, ctitle, mml_surdat, finidat use clm_varctl , only : version, hostname, username, conventions, source use domainMod , only : ldomain use fileutils , only : get_filename @@ -1877,9 +1327,6 @@ subroutine htape_create (t, histrest) integer :: omode ! returned mode from netCDF call integer :: ncprec ! output netCDF write precision integer :: ret ! netCDF error status - integer :: nump ! total number of pfts across all processors - integer :: numc ! total number of columns across all processors - integer :: numl ! total number of landunits across all processors integer :: numg ! total number of gridcells across all processors integer :: numa ! total number of atm cells across all processors logical :: avoid_pnetcdf ! whether we should avoid using pnetcdf @@ -1901,7 +1348,7 @@ subroutine htape_create (t, histrest) ! Determine necessary indices - call get_proc_global(ng=numg, nl=numl, nc=numc, np=nump) + call get_proc_global(ng=numg) ! define output write precsion for tape @@ -1966,7 +1413,7 @@ subroutine htape_create (t, histrest) call ncd_putatt(lnfid, ncd_global, 'revision_id', trim(str)) call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) - str = get_filename(fsurdat) + str = get_filename(mml_surdat) call ncd_putatt(lnfid, ncd_global, 'Surface_dataset', trim(str)) if (finidat == ' ') then str = 'arbitrary initialization' @@ -1974,8 +1421,6 @@ subroutine htape_create (t, histrest) str = get_filename(finidat) endif call ncd_putatt(lnfid, ncd_global, 'Initial_conditions_dataset', trim(str)) - str = get_filename(paramfile) - call ncd_putatt(lnfid, ncd_global, 'PFT_physiological_constants_dataset', trim(str)) ! Define dimensions. ! Time is an unlimited dimension. Character string is treated as an array of characters. @@ -1990,40 +1435,16 @@ subroutine htape_create (t, histrest) ! Global compressed dimensions (not including non-land points) call ncd_defdim(lnfid, trim(nameg), numg, dimid) - call ncd_defdim(lnfid, trim(namel), numl, dimid) - call ncd_defdim(lnfid, trim(namec), numc, dimid) - call ncd_defdim(lnfid, trim(namep), nump, dimid) ! "level" dimensions call ncd_defdim(lnfid, 'levgrnd', nlevgrnd, dimid) - call ncd_defdim(lnfid, 'levsoi', nlevsoi, dimid) - if (nlevurb > 0) then - call ncd_defdim(lnfid, 'levurb' , nlevurb, dimid) - end if - call ncd_defdim(lnfid, 'levlak' , nlevlak, dimid) call ncd_defdim(lnfid, 'numrad' , numrad , dimid) - call ncd_defdim(lnfid, 'levsno' , nlevsno , dimid) - call ncd_defdim(lnfid, 'ltype', max_lunit, dimid) - call ncd_defdim(lnfid, 'nlevcan',nlevcan, dimid) - call ncd_defdim(lnfid, 'nvegwcs',nvegwcs, dimid) - call htape_add_ltype_metadata(lnfid) - call htape_add_ctype_metadata(lnfid) - call ncd_defdim(lnfid, 'natpft', natpft_size, dimid) - if (cft_size > 0) then - call ncd_defdim(lnfid, 'cft', cft_size, dimid) - call htape_add_cft_metadata(lnfid) - end if - call ncd_defdim(lnfid, 'glc_nec' , maxpatch_glcmec , dimid) - ! elevclas (in contrast to glc_nec) includes elevation class 0 (bare land) - ! (although on the history file it will go 1:(nec+1) rather than 0:nec) - call ncd_defdim(lnfid, 'elevclas' , maxpatch_glcmec + 1, dimid) do n = 1,num_subs call ncd_defdim(lnfid, subs_name(n), subs_dim(n), dimid) end do call ncd_defdim(lnfid, 'string_length', hist_dim_name_length, strlen_dimid) call ncd_defdim(lnfid, 'scale_type_string_length', scale_type_strlen, dimid) - call ncd_defdim( lnfid, 'levdcmp', nlevdecomp_full, dimid) ! MML: adding a mml soiz dimension: call ncd_defdim(lnfid, 'mml_lev', 10, dimid); ! hard-coded for 10 soil layers; make more clever. call ncd_defdim(lnfid, 'mml_dust', 4, dimid); ! hard-coded for 4 dust bins @@ -2048,117 +1469,7 @@ subroutine htape_create (t, histrest) end subroutine htape_create !----------------------------------------------------------------------- - subroutine htape_add_ltype_metadata(lnfid) - ! - ! !DESCRIPTION: - ! Add global metadata defining landunit types - ! - ! !USES: - use landunit_varcon, only : max_lunit, landunit_names, landunit_name_length - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: lnfid ! local file id - ! - ! !LOCAL VARIABLES: - integer :: ltype ! landunit type - character(len=*), parameter :: att_prefix = 'ltype_' ! prefix for attributes - character(len=len(att_prefix)+landunit_name_length) :: attname ! attribute name - - character(len=*), parameter :: subname = 'htape_add_ltype_metadata' - !----------------------------------------------------------------------- - - do ltype = 1, max_lunit - attname = att_prefix // landunit_names(ltype) - call ncd_putatt(lnfid, ncd_global, attname, ltype) - end do - - end subroutine htape_add_ltype_metadata - - !----------------------------------------------------------------------- - subroutine htape_add_ctype_metadata(lnfid) - ! - ! !DESCRIPTION: - ! Add global metadata defining column types - ! - ! !USES: - use column_varcon, only : write_coltype_metadata - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: lnfid ! local file id - ! - ! !LOCAL VARIABLES: - character(len=*), parameter :: att_prefix = 'ctype_' ! prefix for attributes - - character(len=*), parameter :: subname = 'htape_add_ctype_metadata' - !----------------------------------------------------------------------- - - call write_coltype_metadata(att_prefix, lnfid) - - end subroutine htape_add_ctype_metadata - - !----------------------------------------------------------------------- - subroutine htape_add_natpft_metadata(lnfid) - ! - ! !DESCRIPTION: - ! Add global metadata defining natpft types - ! - ! !USES: - use clm_varpar, only : natpft_lb, natpft_ub - use pftconMod , only : pftname_len, pftname - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: lnfid ! local file id - ! - ! !LOCAL VARIABLES: - integer :: ptype ! patch type - integer :: ptype_1_indexing ! patch type, translated to 1 indexing - character(len=*), parameter :: att_prefix = 'natpft_' ! prefix for attributes - character(len=len(att_prefix)+pftname_len) :: attname ! attribute name - - character(len=*), parameter :: subname = 'htape_add_natpft_metadata' - !----------------------------------------------------------------------- - - do ptype = natpft_lb, natpft_ub - ptype_1_indexing = ptype + (1 - natpft_lb) - attname = att_prefix // pftname(ptype) - call ncd_putatt(lnfid, ncd_global, attname, ptype_1_indexing) - end do - - end subroutine htape_add_natpft_metadata - - !----------------------------------------------------------------------- - subroutine htape_add_cft_metadata(lnfid) - ! - ! !DESCRIPTION: - ! Add global metadata defining natpft types - ! - ! !USES: - use clm_varpar, only : cft_lb, cft_ub - use pftconMod , only : pftname_len, pftname - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: lnfid ! local file id - ! - ! !LOCAL VARIABLES: - integer :: ptype ! patch type - integer :: ptype_1_indexing ! patch type, translated to 1 indexing - character(len=*), parameter :: att_prefix = 'cft_' ! prefix for attributes - character(len=len(att_prefix)+pftname_len) :: attname ! attribute name - - character(len=*), parameter :: subname = 'htape_add_cft_metadata' - !----------------------------------------------------------------------- - - do ptype = cft_lb, cft_ub - ptype_1_indexing = ptype + (1 - cft_lb) - attname = att_prefix // pftname(ptype) - call ncd_putatt(lnfid, ncd_global, attname, ptype_1_indexing) - end do - - end subroutine htape_add_cft_metadata - - !----------------------------------------------------------------------- - subroutine htape_timeconst3D(t, & - bounds, watsat_col, sucsat_col, bsw_col, hksat_col, mode) + subroutine htape_timeconst3D(t, bounds, mode) ! ! !DESCRIPTION: ! Write time constant 3D variables to history tapes. @@ -2168,18 +1479,13 @@ subroutine htape_timeconst3D(t, & ! contents. ! ! !USES: - use subgridAveMod , only : c2g - use clm_varpar , only : nlevgrnd ,nlevlak + use clm_varpar , only : nlevgrnd use shr_string_mod , only : shr_string_listAppend use domainMod , only : ldomain ! ! !ARGUMENTS: integer , intent(in) :: t ! tape index type(bounds_type) , intent(in) :: bounds - real(r8) , intent(in) :: watsat_col( bounds%begc:,1: ) - real(r8) , intent(in) :: sucsat_col( bounds%begc:,1: ) - real(r8) , intent(in) :: bsw_col( bounds%begc:,1: ) - real(r8) , intent(in) :: hksat_col( bounds%begc:,1: ) character(len=*) , intent(in) :: mode ! 'define' or 'write' ! ! !LOCAL VARIABLES: @@ -2188,34 +1494,11 @@ subroutine htape_timeconst3D(t, & character(len=max_chars) :: long_name ! variable long name character(len=max_namlen):: varname ! variable name character(len=max_namlen):: units ! variable units - character(len=scale_type_strlen) :: l2g_scale_type ! scale type for subgrid averaging of landunits to grid cells ! - real(r8), pointer :: histi(:,:) ! temporary real(r8), pointer :: histo(:,:) ! temporary - integer, parameter :: nflds = 6 ! Number of 3D time-constant fields + integer, parameter :: nflds = 1 ! Number of 3D time-constant fields character(len=*),parameter :: subname = 'htape_timeconst3D' - character(len=*),parameter :: varnames(nflds) = (/ & - 'ZSOI ', & - 'DZSOI ', & - 'WATSAT', & - 'SUCSAT', & - 'BSW ', & - 'HKSAT ' & - /) - real(r8), pointer :: histil(:,:) ! temporary - real(r8), pointer :: histol(:,:) - integer, parameter :: nfldsl = 2 - character(len=*),parameter :: varnamesl(nfldsl) = (/ & - 'ZLAKE ', & - 'DZLAKE' & - /) - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(watsat_col) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(sucsat_col) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(bsw_col) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(hksat_col) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - + character(len=*),parameter :: varnames(nflds) = (/ 'ZSOI ' /) !------------------------------------------------------------------------------- !*** Non-time varying 3D fields *** !*** Only write out when this subroutine is called *** @@ -2228,16 +1511,6 @@ subroutine htape_timeconst3D(t, & ! Field indices MUST match varnames array order above! if (ifld == 1) then long_name='soil depth'; units = 'm' - else if (ifld == 2) then - long_name='soil thickness'; units = 'm' - else if (ifld == 3) then - long_name='saturated soil water content (porosity)'; units = 'mm3/mm3' - else if (ifld == 4) then - long_name='saturated soil matric potential'; units = 'mm' - else if (ifld == 5) then - long_name='slope of soil water retention curve'; units = 'unitless' - else if (ifld == 6) then - long_name='saturated hydraulic conductivity'; units = 'mm s-1' else call endrun(msg=' ERROR: bad 3D time-constant field index'//errMsg(sourcefile, __LINE__)) end if @@ -2248,25 +1521,15 @@ subroutine htape_timeconst3D(t, & long_name=long_name, units=units, missing_value=spval, fill_value=spval) else call ncd_defvar(ncid=nfid(t), varname=trim(varnames(ifld)), xtype=tape(t)%ncprec, & - dim1name=grlnd, dim2name='levgrnd', & + dim1name=grlnd, dim2name='levgrnd', & long_name=long_name, units=units, missing_value=spval, fill_value=spval) end if - else - call ncd_defvar(ncid=nfid(t), varname=trim(varnames(ifld)), xtype=tape(t)%ncprec, & - dim1name=namec, dim2name='levgrnd', & - long_name=long_name, units=units, missing_value=spval, fill_value=spval) end if call shr_string_listAppend(TimeConst3DVars,varnames(ifld)) end do else if (mode == 'write') then - allocate(histi(bounds%begc:bounds%endc,nlevgrnd), stat=ier) - if (ier /= 0) then - write(iulog,*) trim(subname),' ERROR: allocation error for histi' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - ! Write time constant fields if (tape(t)%dov2xy) then @@ -2279,51 +1542,9 @@ subroutine htape_timeconst3D(t, & do ifld = 1,nflds - ! WJS (10-25-11): Note about l2g_scale_type in the following: ZSOI & DZSOI are - ! currently constant in space, except for urban points, so their scale type - ! doesn't matter at the moment as long as it excludes urban points. I am using - ! 'nonurb' so that the values are output everywhere where the fields are - ! constant (i.e., everywhere except urban points). For the other fields, I am - ! using 'veg' to be consistent with the l2g_scale_type that is now used for many - ! of the 3-d time-variant fields; in theory, though, one might want versions of - ! these variables output for different landunits. - - ! Field indices MUST match varnames array order above! - if (ifld == 1) then ! ZSOI - l2g_scale_type = 'nonurb' - else if (ifld == 2) then ! DZSOI - l2g_scale_type = 'nonurb' - else if (ifld == 3) then ! WATSAT - l2g_scale_type = 'veg' - else if (ifld == 4) then ! SUCSAT - l2g_scale_type = 'veg' - else if (ifld == 5) then ! BSW - l2g_scale_type = 'veg' - else if (ifld == 6) then ! HKSAT - l2g_scale_type = 'veg' - end if - - histi(:,:) = spval - do lev = 1,nlevgrnd - do c = bounds%begc,bounds%endc - l = col%landunit(c) - ! Field indices MUST match varnames array order above! - if (ifld ==1) histi(c,lev) = col%z(c,lev) - if (ifld ==2) histi(c,lev) = col%dz(c,lev) - if (ifld ==3) histi(c,lev) = watsat_col(c,lev) - if (ifld ==4) histi(c,lev) = sucsat_col(c,lev) - if (ifld ==5) histi(c,lev) = bsw_col(c,lev) - if (ifld ==6) histi(c,lev) = hksat_col(c,lev) - end do - end do if (tape(t)%dov2xy) then histo(:,:) = spval - call c2g(bounds, nlevgrnd, & - histi(bounds%begc:bounds%endc, :), & - histo(bounds%begg:bounds%endg, :), & - c2l_scale_type='unity', l2g_scale_type=l2g_scale_type) - if (ldomain%isgrid2d) then call ncd_io(varname=trim(varnames(ifld)), dim1name=grlnd, & data=histo, ncid=nfid(t), flag='write') @@ -2331,96 +1552,10 @@ subroutine htape_timeconst3D(t, & call ncd_io(varname=trim(varnames(ifld)), dim1name=grlnd, & data=histo, ncid=nfid(t), flag='write') end if - else - call ncd_io(varname=trim(varnames(ifld)), dim1name=namec, & - data=histi, ncid=nfid(t), flag='write') end if end do if (tape(t)%dov2xy) deallocate(histo) - deallocate(histi) - - end if ! (define/write mode - - if (mode == 'define') then - do ifld = 1,nfldsl - ! Field indices MUST match varnamesl array order above! - if (ifld == 1) then - long_name='lake layer node depth'; units = 'm' - else if (ifld == 2) then - long_name='lake layer thickness'; units = 'm' - else - call endrun(msg=' ERROR: bad 3D time-constant field index'//errMsg(sourcefile, __LINE__)) - end if - if (tape(t)%dov2xy) then - if (ldomain%isgrid2d) then - call ncd_defvar(ncid=nfid(t), varname=trim(varnamesl(ifld)), xtype=tape(t)%ncprec,& - dim1name='lon', dim2name='lat', dim3name='levlak', & - long_name=long_name, units=units, missing_value=spval, fill_value=spval) - else - call ncd_defvar(ncid=nfid(t), varname=trim(varnamesl(ifld)), xtype=tape(t)%ncprec, & - dim1name=grlnd, dim2name='levlak', & - long_name=long_name, units=units, missing_value=spval, fill_value=spval) - end if - else - call ncd_defvar(ncid=nfid(t), varname=trim(varnamesl(ifld)), xtype=tape(t)%ncprec, & - dim1name=namec, dim2name='levlak', & - long_name=long_name, units=units, missing_value=spval, fill_value=spval) - end if - call shr_string_listAppend(TimeConst3DVars,varnamesl(ifld)) - end do - - else if (mode == 'write') then - - allocate(histil(bounds%begc:bounds%endc,nlevlak), stat=ier) - if (ier /= 0) then - write(iulog,*) trim(subname),' ERROR: allocation error for histil' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Write time constant fields - - if (tape(t)%dov2xy) then - allocate(histol(bounds%begg:bounds%endg,nlevlak), stat=ier) - if (ier /= 0) then - write(iulog,*) trim(subname),' ERROR: allocation error for histol' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - do ifld = 1,nfldsl - histil(:,:) = spval - do lev = 1,nlevlak - do c = bounds%begc,bounds%endc - l = col%landunit(c) - if (lun%lakpoi(l)) then - ! Field indices MUST match varnamesl array order above! - if (ifld ==1) histil(c,lev) = col%z_lake(c,lev) - if (ifld ==2) histil(c,lev) = col%dz_lake(c,lev) - end if - end do - end do - if (tape(t)%dov2xy) then - histol(:,:) = spval - call c2g(bounds, nlevlak, & - histil(bounds%begc:bounds%endc, :), & - histol(bounds%begg:bounds%endg, :), & - c2l_scale_type='unity', l2g_scale_type='lake') - if (ldomain%isgrid2d) then - call ncd_io(varname=trim(varnamesl(ifld)), dim1name=grlnd, & - data=histol, ncid=nfid(t), flag='write') - else - call ncd_io(varname=trim(varnamesl(ifld)), dim1name=grlnd, & - data=histol, ncid=nfid(t), flag='write') - end if - else - call ncd_io(varname=trim(varnamesl(ifld)), dim1name=namec, & - data=histil, ncid=nfid(t), flag='write') - end if - end do - - if (tape(t)%dov2xy) deallocate(histol) - deallocate(histil) end if ! (define/write mode @@ -2436,7 +1571,7 @@ subroutine htape_timeconst(t, mode) ! contents. ! ! !USES: - use clm_varcon , only : zsoi, zlak, secspday, isecspday, isecsphr, isecspmin + use clm_varcon , only : secspday, isecspday, isecsphr, isecspmin use domainMod , only : ldomain, lon1d, lat1d use clm_time_manager, only : get_nstep, get_curr_date, get_curr_time use clm_time_manager, only : get_ref_date, get_calendar, NO_LEAP_C, GREGORIAN_C @@ -2473,11 +1608,11 @@ subroutine htape_timeconst(t, mode) character(len=256):: str ! global attribute string real(r8), pointer :: histo(:,:) ! temporary integer :: status - real(r8) :: zsoi_1d(1) character(len=*),parameter :: subname = 'htape_timeconst' ! MML soil z: real(r8) :: mml_zsoi(10) ! MML soil levels (hard coding to have 6...) + real(r8) :: mml_dust(4) integer :: mml_nsoi integer :: ind @@ -2506,40 +1641,25 @@ subroutine htape_timeconst(t, mode) + + mml_dust = spval !------------------------------------------------------------------------------- !*** Time constant grid variables only on first time-sample of file *** !------------------------------------------------------------------------------- if (tape(t)%ntimes == 1) then if (mode == 'define') then - call ncd_defvar(varname='levgrnd', xtype=tape(t)%ncprec, & - dim1name='levgrnd', & - long_name='coordinate soil levels', units='m', ncid=nfid(t)) - call ncd_defvar(varname='levlak', xtype=tape(t)%ncprec, & - dim1name='levlak', & - long_name='coordinate lake levels', units='m', ncid=nfid(t)) - call ncd_defvar(varname='levdcmp', xtype=tape(t)%ncprec, dim1name='levdcmp', & - long_name='coordinate soil levels', units='m', ncid=nfid(t)) - ! Add MML soil layers call ncd_defvar(varname='mml_lev', xtype=tape(t)%ncprec, dim1name='mml_lev', & - long_name='mml soil levels', units='m', ncid=nfid(t)) + long_name='mml soil levels', units='m', ncid=nfid(t), missing_value=spval, fill_value=spval) ! Add MML dust bins call ncd_defvar(varname='mml_dust', xtype=tape(t)%ncprec, dim1name='mml_dust', & - long_name='mml dust bins', units='unknown', ncid=nfid(t)) + long_name='mml dust bins', units='unknown', ncid=nfid(t), missing_value=spval, fill_value=spval) elseif (mode == 'write') then - if ( masterproc ) write(iulog, *) ' zsoi:',zsoi - call ncd_io(varname='levgrnd', data=zsoi, ncid=nfid(t), flag='write') - call ncd_io(varname='levlak' , data=zlak, ncid=nfid(t), flag='write') - if (use_vertsoilc) then - call ncd_io(varname='levdcmp', data=zsoi, ncid=nfid(t), flag='write') - else - zsoi_1d(1) = 1._r8 - call ncd_io(varname='levdcmp', data=zsoi_1d, ncid=nfid(t), flag='write') - end if ! Add MML soil layers call ncd_io(varname='mml_lev', data=mml_zsoi, ncid=nfid(t), flag='write') + call ncd_io(varname='mml_dust', data=mml_dust, ncid=nfid(t), flag='write') endif endif @@ -2563,7 +1683,7 @@ subroutine htape_timeconst(t, mode) dim1id(1) = time_dimid str = 'days since ' // basedate // " " // basesec call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & - long_name='time',units=str) + long_name='time',units=str, missing_value=spval, fill_value=spval) cal = get_calendar() if ( trim(cal) == NO_LEAP_C )then caldesc = "noleap" @@ -2703,39 +1823,19 @@ subroutine htape_timeconst(t, mode) long_name='land fraction', ncid=nfid(t), & missing_value=spval, fill_value=spval) end if - if (ldomain%isgrid2d) then - call ncd_defvar(varname='landmask', xtype=ncd_int, & - dim1name='lon', dim2name='lat', & - long_name='land/ocean mask (0.=ocean and 1.=land)', ncid=nfid(t), & - imissing_value=ispval, ifill_value=ispval) - else - call ncd_defvar(varname='landmask', xtype=ncd_int, & - dim1name=grlnd, & - long_name='land/ocean mask (0.=ocean and 1.=land)', ncid=nfid(t), & - imissing_value=ispval, ifill_value=ispval) - end if - if (ldomain%isgrid2d) then - call ncd_defvar(varname='pftmask' , xtype=ncd_int, & - dim1name='lon', dim2name='lat', & - long_name='pft real/fake mask (0.=fake and 1.=real)', ncid=nfid(t), & - imissing_value=ispval, ifill_value=ispval) - else - call ncd_defvar(varname='pftmask' , xtype=ncd_int, & - dim1name=grlnd, & - long_name='pft real/fake mask (0.=fake and 1.=real)', ncid=nfid(t), & - imissing_value=ispval, ifill_value=ispval) - end if - if (ldomain%isgrid2d) then - call ncd_defvar(varname='nbedrock' , xtype=ncd_int, & - dim1name='lon', dim2name='lat', & - long_name='index of shallowest bedrock layer', ncid=nfid(t), & - imissing_value=ispval, ifill_value=ispval) - else - call ncd_defvar(varname='nbedrock' , xtype=ncd_int, & - dim1name=grlnd, & - long_name='index of shallowest bedrock layer', ncid=nfid(t), & - imissing_value=ispval, ifill_value=ispval) - end if + ! ---- Comment out writing of landmask because of #82 -- EBK 06/11/2023 ---- + !if (ldomain%isgrid2d) then + !call ncd_defvar(varname='landmask', xtype=ncd_int, & + !dim1name='lon', dim2name='lat', & + !long_name='land/ocean mask (0.=ocean and 1.=land)', ncid=nfid(t), & + !imissing_value=ispval, ifill_value=ispval) + !else + !call ncd_defvar(varname='landmask', xtype=ncd_int, & + !dim1name=grlnd, & + !long_name='land/ocean mask (0.=ocean and 1.=land)', ncid=nfid(t), & + !imissing_value=ispval, ifill_value=ispval) + !end if + ! -------------------------------------------------------------------------- else if (mode == 'write') then @@ -2751,9 +1851,9 @@ subroutine htape_timeconst(t, mode) end if call ncd_io(varname='area' , data=ldomain%area, dim1name=grlnd, ncid=nfid(t), flag='write') call ncd_io(varname='landfrac', data=ldomain%frac, dim1name=grlnd, ncid=nfid(t), flag='write') - call ncd_io(varname='landmask', data=ldomain%mask, dim1name=grlnd, ncid=nfid(t), flag='write') - call ncd_io(varname='pftmask' , data=ldomain%pftm, dim1name=grlnd, ncid=nfid(t), flag='write') - call ncd_io(varname='nbedrock' , data=grc%nbedrock, dim1name=grlnd, ncid=nfid(t), flag='write') + ! ---- Comment out writing of landmask because of #82 -- EBK 06/11/2023 ---- + !call ncd_io(varname='landmask', data=ldomain%mask, dim1name=grlnd, ncid=nfid(t), flag='write') + ! -------------------------------------------------------------------------- end if ! (define/write mode @@ -2967,130 +2067,20 @@ subroutine hfields_1dinfo(t, mode) ! Define gridcell info call ncd_defvar(varname='grid1d_lon', xtype=ncd_double, dim1name=nameg, & - long_name='gridcell longitude', units='degrees_east', ncid=ncid) + long_name='gridcell longitude', units='degrees_east', ncid=ncid, & + missing_value=spval, fill_value=spval) call ncd_defvar(varname='grid1d_lat', xtype=ncd_double, dim1name=nameg, & - long_name='gridcell latitude', units='degrees_north', ncid=ncid) + long_name='gridcell latitude', units='degrees_north', ncid=ncid, & + missing_value=spval, fill_value=spval) call ncd_defvar(varname='grid1d_ixy', xtype=ncd_int, dim1name=nameg, & - long_name='2d longitude index of corresponding gridcell', ncid=ncid) + long_name='2d longitude index of corresponding gridcell', ncid=ncid, & + missing_value=spval, fill_value=spval) call ncd_defvar(varname='grid1d_jxy', xtype=ncd_int, dim1name=nameg, & - long_name='2d latitude index of corresponding gridcell', ncid=ncid) - - ! Define landunit info - - call ncd_defvar(varname='land1d_lon', xtype=ncd_double, dim1name=namel, & - long_name='landunit longitude', units='degrees_east', ncid=ncid) - - call ncd_defvar(varname='land1d_lat', xtype=ncd_double, dim1name=namel, & - long_name='landunit latitude', units='degrees_north', ncid=ncid) - - call ncd_defvar(varname='land1d_ixy', xtype=ncd_int, dim1name=namel, & - long_name='2d longitude index of corresponding landunit', ncid=ncid) - - call ncd_defvar(varname='land1d_jxy', xtype=ncd_int, dim1name=namel, & - long_name='2d latitude index of corresponding landunit', ncid=ncid) - - ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 - !call ncd_defvar(varname='land1d_gi', xtype=ncd_int, dim1name='landunit', & - ! long_name='1d grid index of corresponding landunit', ncid=ncid) - ! ---------------------------------------------------------------- - - call ncd_defvar(varname='land1d_wtgcell', xtype=ncd_double, dim1name=namel, & - long_name='landunit weight relative to corresponding gridcell', ncid=ncid) - - call ncd_defvar(varname='land1d_ityplunit', xtype=ncd_int, dim1name=namel, & - long_name='landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & - ncid=ncid) - - call ncd_defvar(varname='land1d_active', xtype=ncd_log, dim1name=namel, & - long_name='true => do computations on this landunit', ncid=ncid) - - ! Define column info - - call ncd_defvar(varname='cols1d_lon', xtype=ncd_double, dim1name=namec, & - long_name='column longitude', units='degrees_east', ncid=ncid) - - call ncd_defvar(varname='cols1d_lat', xtype=ncd_double, dim1name=namec, & - long_name='column latitude', units='degrees_north', ncid=ncid) - - call ncd_defvar(varname='cols1d_ixy', xtype=ncd_int, dim1name=namec, & - long_name='2d longitude index of corresponding column', ncid=ncid) - - call ncd_defvar(varname='cols1d_jxy', xtype=ncd_int, dim1name=namec, & - long_name='2d latitude index of corresponding column', ncid=ncid) - - ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 - !call ncd_defvar(varname='cols1d_gi', xtype=ncd_int, dim1name='column', & - ! long_name='1d grid index of corresponding column', ncid=ncid) - - !call ncd_defvar(varname='cols1d_li', xtype=ncd_int, dim1name='column', & - ! long_name='1d landunit index of corresponding column', ncid=ncid) - ! ---------------------------------------------------------------- - - call ncd_defvar(varname='cols1d_wtgcell', xtype=ncd_double, dim1name=namec, & - long_name='column weight relative to corresponding gridcell', ncid=ncid) - - call ncd_defvar(varname='cols1d_wtlunit', xtype=ncd_double, dim1name=namec, & - long_name='column weight relative to corresponding landunit', ncid=ncid) - - call ncd_defvar(varname='cols1d_itype_col', xtype=ncd_int, dim1name=namec, & - long_name='column type (see global attributes)', ncid=ncid) - - call ncd_defvar(varname='cols1d_itype_lunit', xtype=ncd_int, dim1name=namec, & - long_name='column landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & - ncid=ncid) - - call ncd_defvar(varname='cols1d_active', xtype=ncd_log, dim1name=namec, & - long_name='true => do computations on this column', ncid=ncid) - - ! Define patch info - - call ncd_defvar(varname='pfts1d_lon', xtype=ncd_double, dim1name=namep, & - long_name='pft longitude', units='degrees_east', ncid=ncid) - - call ncd_defvar(varname='pfts1d_lat', xtype=ncd_double, dim1name=namep, & - long_name='pft latitude', units='degrees_north', ncid=ncid) - - call ncd_defvar(varname='pfts1d_ixy', xtype=ncd_int, dim1name=namep, & - long_name='2d longitude index of corresponding pft', ncid=ncid) - - call ncd_defvar(varname='pfts1d_jxy', xtype=ncd_int, dim1name=namep, & - long_name='2d latitude index of corresponding pft', ncid=ncid) - - ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 - !call ncd_defvar(varname='pfts1d_gi', xtype=ncd_int, dim1name='pft', & - ! long_name='1d grid index of corresponding pft', ncid=ncid) - - !call ncd_defvar(varname='pfts1d_li', xtype=ncd_int, dim1name='pft', & - ! long_name='1d landunit index of corresponding pft', ncid=ncid) - - !call ncd_defvar(varname='pfts1d_ci', xtype=ncd_int, dim1name='pft', & - ! long_name='1d column index of corresponding pft', ncid=ncid) - ! ---------------------------------------------------------------- - - call ncd_defvar(varname='pfts1d_wtgcell', xtype=ncd_double, dim1name=namep, & - long_name='pft weight relative to corresponding gridcell', ncid=ncid) - - call ncd_defvar(varname='pfts1d_wtlunit', xtype=ncd_double, dim1name=namep, & - long_name='pft weight relative to corresponding landunit', ncid=ncid) - - call ncd_defvar(varname='pfts1d_wtcol', xtype=ncd_double, dim1name=namep, & - long_name='pft weight relative to corresponding column', ncid=ncid) - - call ncd_defvar(varname='pfts1d_itype_veg', xtype=ncd_int, dim1name=namep, & - long_name='pft vegetation type', ncid=ncid) - - call ncd_defvar(varname='pfts1d_itype_col', xtype=ncd_int, dim1name=namep, & - long_name='pft column type (see global attributes)', ncid=ncid) - - call ncd_defvar(varname='pfts1d_itype_lunit', xtype=ncd_int, dim1name=namep, & - long_name='pft landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & - ncid=ncid) - - call ncd_defvar(varname='pfts1d_active', xtype=ncd_log, dim1name=namep, & - long_name='true => do computations on this pft', ncid=ncid) + long_name='2d latitude index of corresponding gridcell', ncid=ncid, & + missing_value=spval, fill_value=spval) else if (mode == 'write') then @@ -3098,9 +2088,6 @@ subroutine hfields_1dinfo(t, mode) allocate(& rgarr(bounds%begg:bounds%endg),& - rlarr(bounds%begl:bounds%endl),& - rcarr(bounds%begc:bounds%endc),& - rparr(bounds%begp:bounds%endp),& stat=ier) if (ier /= 0) then call endrun(msg=' hfields_1dinfo allocation error of rarrs'//errMsg(sourcefile, __LINE__)) @@ -3108,9 +2095,7 @@ subroutine hfields_1dinfo(t, mode) allocate(& igarr(bounds%begg:bounds%endg),& - ilarr(bounds%begl:bounds%endl),& - icarr(bounds%begc:bounds%endc),& - iparr(bounds%begp:bounds%endp),stat=ier) + stat=ier) if (ier /= 0) then call endrun(msg=' hfields_1dinfo allocation error of iarrs'//errMsg(sourcefile, __LINE__)) end if @@ -3128,114 +2113,15 @@ subroutine hfields_1dinfo(t, mode) enddo call ncd_io(varname='grid1d_jxy', data=igarr , dim1name=nameg, ncid=ncid, flag='write') - ! Write landunit info - - do l = bounds%begl,bounds%endl - rlarr(l) = grc%londeg(lun%gridcell(l)) - enddo - call ncd_io(varname='land1d_lon', data=rlarr, dim1name=namel, ncid=ncid, flag='write') - do l = bounds%begl,bounds%endl - rlarr(l) = grc%latdeg(lun%gridcell(l)) - enddo - call ncd_io(varname='land1d_lat', data=rlarr, dim1name=namel, ncid=ncid, flag='write') - do l= bounds%begl,bounds%endl - ilarr(l) = mod(ldecomp%gdc2glo(lun%gridcell(l))-1,ldomain%ni) + 1 - enddo - call ncd_io(varname='land1d_ixy', data=ilarr, dim1name=namel, ncid=ncid, flag='write') - do l = bounds%begl,bounds%endl - ilarr(l) = (ldecomp%gdc2glo(lun%gridcell(l))-1)/ldomain%ni + 1 - enddo - call ncd_io(varname='land1d_jxy' , data=ilarr , dim1name=namel, ncid=ncid, flag='write') - ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 Bug 1310 - !call ncd_io(varname='land1d_gi' , data=lun%gridcell, dim1name=namel, ncid=ncid, flag='write') - ! ---------------------------------------------------------------- - call ncd_io(varname='land1d_wtgcell' , data=lun%wtgcell , dim1name=namel, ncid=ncid, flag='write') - call ncd_io(varname='land1d_ityplunit', data=lun%itype , dim1name=namel, ncid=ncid, flag='write') - call ncd_io(varname='land1d_active' , data=lun%active , dim1name=namel, ncid=ncid, flag='write') - - ! Write column info - - do c = bounds%begc,bounds%endc - rcarr(c) = grc%londeg(col%gridcell(c)) - enddo - call ncd_io(varname='cols1d_lon', data=rcarr, dim1name=namec, ncid=ncid, flag='write') - do c = bounds%begc,bounds%endc - rcarr(c) = grc%latdeg(col%gridcell(c)) - enddo - call ncd_io(varname='cols1d_lat', data=rcarr, dim1name=namec, ncid=ncid, flag='write') - do c = bounds%begc,bounds%endc - icarr(c) = mod(ldecomp%gdc2glo(col%gridcell(c))-1,ldomain%ni) + 1 - enddo - call ncd_io(varname='cols1d_ixy', data=icarr, dim1name=namec, ncid=ncid, flag='write') - do c = bounds%begc,bounds%endc - icarr(c) = (ldecomp%gdc2glo(col%gridcell(c))-1)/ldomain%ni + 1 - enddo - call ncd_io(varname='cols1d_jxy' , data=icarr ,dim1name=namec, ncid=ncid, flag='write') - ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 Bug 1310 - !call ncd_io(varname='cols1d_gi' , data=col%gridcell, dim1name=namec, ncid=ncid, flag='write') - !call ncd_io(varname='cols1d_li' , data=col%landunit, dim1name=namec, ncid=ncid, flag='write') - ! ---------------------------------------------------------------- - call ncd_io(varname='cols1d_wtgcell', data=col%wtgcell , dim1name=namec, ncid=ncid, flag='write') - call ncd_io(varname='cols1d_wtlunit', data=col%wtlunit , dim1name=namec, ncid=ncid, flag='write') - call ncd_io(varname='cols1d_itype_col', data=col%itype , dim1name=namec, ncid=ncid, flag='write') - - do c = bounds%begc,bounds%endc - icarr(c) = lun%itype(col%landunit(c)) - enddo - call ncd_io(varname='cols1d_itype_lunit', data=icarr , dim1name=namec, ncid=ncid, flag='write') - - call ncd_io(varname='cols1d_active' , data=col%active , dim1name=namec, ncid=ncid, flag='write') - - ! Write patch info - - do p = bounds%begp,bounds%endp - rparr(p) = grc%londeg(patch%gridcell(p)) - enddo - call ncd_io(varname='pfts1d_lon', data=rparr, dim1name=namep, ncid=ncid, flag='write') - do p = bounds%begp,bounds%endp - rparr(p) = grc%latdeg(patch%gridcell(p)) - enddo - call ncd_io(varname='pfts1d_lat', data=rparr, dim1name=namep, ncid=ncid, flag='write') - do p = bounds%begp,bounds%endp - iparr(p) = mod(ldecomp%gdc2glo(patch%gridcell(p))-1,ldomain%ni) + 1 - enddo - call ncd_io(varname='pfts1d_ixy', data=iparr, dim1name=namep, ncid=ncid, flag='write') - do p = bounds%begp,bounds%endp - iparr(p) = (ldecomp%gdc2glo(patch%gridcell(p))-1)/ldomain%ni + 1 - enddo - call ncd_io(varname='pfts1d_jxy' , data=iparr , dim1name=namep, ncid=ncid, flag='write') - ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 - !call ncd_io(varname='pfts1d_gi' , data=patch%gridcell, dim1name=namep, ncid=ncid, flag='write') - !call ncd_io(varname='pfts1d_li' , data=patch%landunit, dim1name=namep, ncid=ncid, flag='write') - !call ncd_io(varname='pfts1d_ci' , data=patch%column , dim1name=namep, ncid=ncid, flag='write') - ! ---------------------------------------------------------------- - call ncd_io(varname='pfts1d_wtgcell' , data=patch%wtgcell , dim1name=namep, ncid=ncid, flag='write') - call ncd_io(varname='pfts1d_wtlunit' , data=patch%wtlunit , dim1name=namep, ncid=ncid, flag='write') - call ncd_io(varname='pfts1d_wtcol' , data=patch%wtcol , dim1name=namep, ncid=ncid, flag='write') - call ncd_io(varname='pfts1d_itype_veg', data=patch%itype , dim1name=namep, ncid=ncid, flag='write') - - do p = bounds%begp,bounds%endp - iparr(p) = col%itype(patch%column(p)) - end do - call ncd_io(varname='pfts1d_itype_col', data=iparr , dim1name=namep, ncid=ncid, flag='write') - - do p = bounds%begp,bounds%endp - iparr(p) = lun%itype(patch%landunit(p)) - enddo - call ncd_io(varname='pfts1d_itype_lunit', data=iparr , dim1name=namep, ncid=ncid, flag='write') - - call ncd_io(varname='pfts1d_active' , data=patch%active , dim1name=namep, ncid=ncid, flag='write') - - deallocate(rgarr,rlarr,rcarr,rparr) - deallocate(igarr,ilarr,icarr,iparr) + deallocate(rgarr) + deallocate(igarr) end if end subroutine hfields_1dinfo !----------------------------------------------------------------------- - subroutine hist_htapes_wrapup( rstwr, nlend, bounds, & - watsat_col, sucsat_col, bsw_col, hksat_col) + subroutine hist_htapes_wrapup( rstwr, nlend, bounds) ! ! !DESCRIPTION: ! Write history tape(s) @@ -3267,10 +2153,6 @@ subroutine hist_htapes_wrapup( rstwr, nlend, bounds, & logical, intent(in) :: rstwr ! true => write restart file this step logical, intent(in) :: nlend ! true => end of run on this step type(bounds_type) , intent(in) :: bounds - real(r8) , intent(in) :: watsat_col( bounds%begc:,1: ) - real(r8) , intent(in) :: sucsat_col( bounds%begc:,1: ) - real(r8) , intent(in) :: bsw_col( bounds%begc:,1: ) - real(r8) , intent(in) :: hksat_col( bounds%begc:,1: ) ! ! !LOCAL VARIABLES: integer :: t ! tape index @@ -3294,11 +2176,6 @@ subroutine hist_htapes_wrapup( rstwr, nlend, bounds, & character(len=*),parameter :: subname = 'hist_htapes_wrapup' !----------------------------------------------------------------------- - SHR_ASSERT_ALL((ubound(watsat_col) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(sucsat_col) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(bsw_col) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(hksat_col) == (/bounds%endc, nlevgrnd/)), errMsg(sourcefile, __LINE__)) - ! get current step nstep = get_nstep() @@ -3367,37 +2244,18 @@ subroutine hist_htapes_wrapup( rstwr, nlend, bounds, & ! Define time-constant field variables call htape_timeconst(t, mode='define') - !write(iulog,*)'MML define 3D' - ! Define 3D time-constant field variables only to first primary tape - if ( do_3Dtconst .and. t == 1 ) then - call htape_timeconst3D(t, & - bounds, watsat_col, sucsat_col, bsw_col, hksat_col, mode='define') - TimeConst3DVars_Filename = trim(locfnh(t)) - end if - - !write(iulog,*)'MML define model field vars' ! Define model field variables call hfields_write(t, mode='define') - !write(iulog,*)'MML run away' ! Exit define model call ncd_enddef(nfid(t)) call t_stopf('hist_htapes_wrapup_define') endif - !write(iulog,*)'MML before htape_teimconst' call t_startf('hist_htapes_wrapup_tconst') ! Write time constant history variables call htape_timeconst(t, mode='write') - !write(iulog,*)'MML write 3D time const' - ! Write 3D time constant history variables only to first primary tape - if ( do_3Dtconst .and. t == 1 .and. tape(t)%ntimes == 1 )then - call htape_timeconst3D(t, & - bounds, watsat_col, sucsat_col, bsw_col, hksat_col, mode='write') - do_3Dtconst = .false. - end if - if (masterproc) then write(iulog,*) write(iulog,*) trim(subname),' : Writing current time sample to local history file ', & @@ -3487,7 +2345,7 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) use clm_varctl , only : nsrest, caseid, inst_suffix, nsrStartup, nsrBranch use fileutils , only : getfil use domainMod , only : ldomain - use clm_varpar , only : nlevgrnd, nlevlak, numrad, nlevdecomp_full + use clm_varpar , only : nlevgrnd, numrad use clm_time_manager, only : is_restart use restUtilMod , only : iflag_skip use pio @@ -3505,9 +2363,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) integer :: num2d ! 2d size (e.g. number of vertical levels) integer :: numa ! total number of atm cells across all processors 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=max_namlen) :: name ! variable name character(len=max_namlen) :: name_acc ! accumulator variable name character(len=max_namlen) :: long_name ! long name of variable @@ -3520,9 +2375,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) character(len=max_namlen),allocatable :: tname(:) character(len=max_chars), allocatable :: tunits(:),tlongname(:) character(len=hist_dim_name_length), allocatable :: tmpstr(:,:) - character(len=scale_type_strlen), allocatable :: p2c_scale_type(:) - character(len=scale_type_strlen), allocatable :: c2l_scale_type(:) - character(len=scale_type_strlen), allocatable :: l2g_scale_type(:) character(len=avgflag_strlen), allocatable :: tavgflag(:) integer :: start(2) @@ -3539,9 +2391,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) type(var_desc_t) :: type1d_out_desc ! variable descriptor for type1d_out type(var_desc_t) :: type2d_desc ! variable descriptor for type2d type(var_desc_t) :: avgflag_desc ! variable descriptor for avgflag - type(var_desc_t) :: p2c_scale_type_desc ! variable descriptor for p2c_scale_type - type(var_desc_t) :: c2l_scale_type_desc ! variable descriptor for c2l_scale_type - type(var_desc_t) :: l2g_scale_type_desc ! variable descriptor for l2g_scale_type integer :: status ! error status integer :: dimid ! dimension ID integer :: k ! 1d index @@ -3560,7 +2409,7 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) character(len=*),parameter :: subname = 'hist_restart_ncd' !------------------------------------------------------------------------ - call get_proc_global(ng=numg, nl=numl, nc=numc, np=nump) + call get_proc_global(ng=numg) ! If branch run, initialize file times and return @@ -3624,7 +2473,7 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) ! Create the restart history filename and open it write(hnum,'(i1.1)') t-1 - locfnhr(t) = "./" // trim(caseid) //".clm2"// trim(inst_suffix) & + locfnhr(t) = "./" // trim(caseid) //".slim"// trim(inst_suffix) & // ".rh" // hnum //"."// trim(rdate) //".nc" call htape_create( t, histrest=.true. ) @@ -3658,33 +2507,41 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) if (num2d == 1) then call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & dim1name=dim1name, & - long_name=trim(long_name), units=trim(units)) + long_name=trim(long_name), units=trim(units), & + missing_value=spval, fill_value=spval) call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & dim1name=dim1name, & - long_name=trim(long_name_acc), units=trim(units_acc)) + long_name=trim(long_name_acc), units=trim(units_acc), & + missing_value=spval, fill_value=spval) else call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & dim1name=dim1name, dim2name=type2d, & - long_name=trim(long_name), units=trim(units)) + long_name=trim(long_name), units=trim(units), & + missing_value=spval, fill_value=spval) call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & dim1name=dim1name, dim2name=type2d, & - long_name=trim(long_name_acc), units=trim(units_acc)) + long_name=trim(long_name_acc), units=trim(units_acc), & + missing_value=spval, fill_value=spval) end if else if (num2d == 1) then call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & dim1name=dim1name, dim2name=dim2name, & - long_name=trim(long_name), units=trim(units)) + long_name=trim(long_name), units=trim(units), & + missing_value=spval, fill_value=spval) call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & dim1name=dim1name, dim2name=dim2name, & - long_name=trim(long_name_acc), units=trim(units_acc)) + long_name=trim(long_name_acc), units=trim(units_acc), & + missing_value=spval, fill_value=spval) else call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & dim1name=dim1name, dim2name=dim2name, dim3name=type2d, & - long_name=trim(long_name), units=trim(units)) + long_name=trim(long_name), units=trim(units), & + missing_value=spval, fill_value=spval) call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & dim1name=dim1name, dim2name=dim2name, dim3name=type2d, & - long_name=trim(long_name_acc), units=trim(units_acc)) + long_name=trim(long_name_acc), units=trim(units_acc), & + missing_value=spval, fill_value=spval) end if endif end do @@ -3770,15 +2627,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) call ncd_defvar(ncid=ncid_hist(t), varname='type2d', xtype=ncd_char, & long_name="2nd dimension type", & dim1name='string_length', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='p2c_scale_type', xtype=ncd_char, & - long_name="PFT to column scale type", & - dim1name='scale_type_string_length', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='c2l_scale_type', xtype=ncd_char, & - long_name="column to landunit scale type", & - dim1name='scale_type_string_length', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='l2g_scale_type', xtype=ncd_char, & - long_name="landunit to gridpoint scale type", & - dim1name='scale_type_string_length', dim2name='max_nflds' ) call ncd_enddef(ncid_hist(t)) @@ -3851,9 +2699,7 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) call ncd_io('ncprec', tape(t)%ncprec, 'write', ncid_hist(t) ) call ncd_io('begtime', tape(t)%begtime, 'write', ncid_hist(t) ) allocate(tmpstr(tape(t)%nflds,3 ),tname(tape(t)%nflds), & - tavgflag(tape(t)%nflds),tunits(tape(t)%nflds),tlongname(tape(t)%nflds), & - p2c_scale_type(tape(t)%nflds), c2l_scale_type(tape(t)%nflds), & - l2g_scale_type(tape(t)%nflds)) + tavgflag(tape(t)%nflds),tunits(tape(t)%nflds),tlongname(tape(t)%nflds)) do f=1,tape(t)%nflds tname(f) = tape(t)%hlist(f)%field%name tunits(f) = tape(t)%hlist(f)%field%units @@ -3862,9 +2708,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) tmpstr(f,2) = tape(t)%hlist(f)%field%type1d_out tmpstr(f,3) = tape(t)%hlist(f)%field%type2d tavgflag(f) = tape(t)%hlist(f)%avgflag - p2c_scale_type(f) = tape(t)%hlist(f)%field%p2c_scale_type - c2l_scale_type(f) = tape(t)%hlist(f)%field%c2l_scale_type - l2g_scale_type(f) = tape(t)%hlist(f)%field%l2g_scale_type end do call ncd_io( 'name', tname, 'write',ncid_hist(t)) call ncd_io('long_name', tlongname, 'write', ncid_hist(t)) @@ -3873,11 +2716,7 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) call ncd_io('type1d_out', tmpstr(:,2), 'write', ncid_hist(t)) call ncd_io('type2d', tmpstr(:,3), 'write', ncid_hist(t)) call ncd_io('avgflag',tavgflag , 'write', ncid_hist(t)) - call ncd_io('p2c_scale_type', p2c_scale_type, 'write', ncid_hist(t)) - call ncd_io('c2l_scale_type', c2l_scale_type, 'write', ncid_hist(t)) - call ncd_io('l2g_scale_type', l2g_scale_type, 'write', ncid_hist(t)) deallocate(tname,tlongname,tunits,tmpstr,tavgflag) - deallocate(p2c_scale_type, c2l_scale_type, l2g_scale_type) enddo deallocate(itemp) @@ -3928,9 +2767,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) call ncd_inqvid(ncid_hist(t), 'type1d_out', varid, type1d_out_desc) call ncd_inqvid(ncid_hist(t), 'type2d', varid, type2d_desc) call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) - call ncd_inqvid(ncid_hist(t), 'p2c_scale_type', varid, p2c_scale_type_desc) - call ncd_inqvid(ncid_hist(t), 'c2l_scale_type', varid, c2l_scale_type_desc) - call ncd_inqvid(ncid_hist(t), 'l2g_scale_type', varid, l2g_scale_type_desc) call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='read') @@ -3977,21 +2813,12 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) 'read', ncid_hist(t), start ) call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & 'read', ncid_hist(t), start ) - call ncd_io( p2c_scale_type_desc, tape(t)%hlist(f)%field%p2c_scale_type, & - 'read', ncid_hist(t), start ) - call ncd_io( c2l_scale_type_desc, tape(t)%hlist(f)%field%c2l_scale_type, & - 'read', ncid_hist(t), start ) - call ncd_io( l2g_scale_type_desc, tape(t)%hlist(f)%field%l2g_scale_type, & - 'read', ncid_hist(t), start ) call strip_null(tape(t)%hlist(f)%field%name) call strip_null(tape(t)%hlist(f)%field%long_name) call strip_null(tape(t)%hlist(f)%field%units) call strip_null(tape(t)%hlist(f)%field%type1d) call strip_null(tape(t)%hlist(f)%field%type1d_out) call strip_null(tape(t)%hlist(f)%field%type2d) - call strip_null(tape(t)%hlist(f)%field%p2c_scale_type) - call strip_null(tape(t)%hlist(f)%field%c2l_scale_type) - call strip_null(tape(t)%hlist(f)%field%l2g_scale_type) call strip_null(tape(t)%hlist(f)%avgflag) type1d_out = trim(tape(t)%hlist(f)%field%type1d_out) @@ -4004,18 +2831,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) num1d_out = numg beg1d_out = bounds%begg end1d_out = bounds%endg - case (namel) - num1d_out = numl - beg1d_out = bounds%begl - end1d_out = bounds%endl - case (namec) - num1d_out = numc - beg1d_out = bounds%begc - end1d_out = bounds%endc - case (namep) - num1d_out = nump - beg1d_out = bounds%begp - end1d_out = bounds%endp case default write(iulog,*) trim(subname),' ERROR: read unknown 1d output type=',trim(type1d_out) call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -4046,18 +2861,6 @@ subroutine hist_restart_ncd (bounds, ncid, flag, rdate) num1d = numg beg1d = bounds%begg end1d = bounds%endg - case (namel) - num1d = numl - beg1d = bounds%begl - end1d = bounds%endl - case (namec) - num1d = numc - beg1d = bounds%begc - end1d = bounds%endc - case (namep) - num1d = nump - beg1d = bounds%begp - end1d = bounds%endp case default write(iulog,*) trim(subname),' ERROR: read unknown 1d type=',type1d call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -4356,7 +3159,7 @@ character(len=max_length_filename) function set_hist_filename (hist_freq, hist_m write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec endif write(hist_index,'(i1.1)') hist_file - 1 - set_hist_filename = "./"//trim(caseid)//".clm2"//trim(inst_suffix)//& + set_hist_filename = "./"//trim(caseid)//".slim"//trim(inst_suffix)//& ".h"//hist_index//"."//trim(cdate)//".nc" ! check to see if the concatenated filename exceeded the @@ -4442,15 +3245,15 @@ subroutine hist_readNML ( NLFilename ) hist_nhtfrq(i) = nint(-hist_nhtfrq(i)*SHR_CONST_CDAY/(24._r8*dtime)) endif end do + if ( masterproc )then + if ( use_noio ) write(iulog,*) ' History output is turned off with use_noio = ', use_noio + end if end subroutine hist_readNML !----------------------------------------------------------------------- subroutine hist_addfld1d (fname, units, avgflag, long_name, type1d_out, & - ptr_gcell, ptr_lunit, ptr_col, ptr_patch, ptr_lnd, & - ptr_atm, p2c_scale_type, c2l_scale_type, & - l2g_scale_type, set_lake, set_nolake, set_urb, set_nourb, & - set_noglcmec, set_spec, default) + ptr_gcell, ptr_lnd, ptr_atm, default) ! ! !DESCRIPTION: ! Initialize a single level history field. The pointer, ptrhist, @@ -4469,20 +3272,8 @@ subroutine hist_addfld1d (fname, units, avgflag, long_name, type1d_out, & character(len=*), intent(in) :: long_name ! long name of field character(len=*), optional, intent(in) :: type1d_out ! output type (from data type) real(r8) , optional, pointer :: ptr_gcell(:) ! pointer to gridcell array - real(r8) , optional, pointer :: ptr_lunit(:) ! pointer to landunit array - real(r8) , optional, pointer :: ptr_col(:) ! pointer to column array - real(r8) , optional, pointer :: ptr_patch(:) ! pointer to patch array real(r8) , optional, pointer :: ptr_lnd(:) ! pointer to lnd array real(r8) , optional, pointer :: ptr_atm(:) ! pointer to atm array - real(r8) , optional, intent(in) :: set_lake ! value to set lakes to - real(r8) , optional, intent(in) :: set_nolake ! value to set non-lakes to - real(r8) , optional, intent(in) :: set_urb ! value to set urban to - real(r8) , optional, intent(in) :: set_nourb ! value to set non-urban to - real(r8) , optional, intent(in) :: set_noglcmec ! value to set non-glacier_mec to - real(r8) , optional, intent(in) :: set_spec ! value to set special to - character(len=*), optional, intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column - character(len=*), optional, intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits - character(len=*), optional, intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells character(len=*), optional, intent(in) :: default ! if set to 'inactive, field will not appear on primary tape ! ! !LOCAL VARIABLES: @@ -4490,9 +3281,6 @@ subroutine hist_addfld1d (fname, units, avgflag, long_name, type1d_out, & integer :: hpindex ! history buffer pointer index character(len=hist_dim_name_length) :: l_type1d ! 1d data type character(len=hist_dim_name_length) :: l_type1d_out ! 1d output type - character(len=scale_type_strlen) :: scale_type_p2c ! scale type for subgrid averaging of pfts to column - character(len=scale_type_strlen) :: scale_type_c2l ! scale type for subgrid averaging of columns to landunits - character(len=scale_type_strlen) :: scale_type_l2g ! scale type for subgrid averaging of landunits to gridcells type(bounds_type):: bounds ! boudns character(len=16):: l_default ! local version of 'default' character(len=*),parameter :: subname = 'hist_addfld1d' @@ -4515,142 +3303,22 @@ subroutine hist_addfld1d (fname, units, avgflag, long_name, type1d_out, & l_type1d = nameg l_type1d_out = nameg clmptr_rs(hpindex)%ptr => ptr_gcell - - else if (present(ptr_lunit)) then - l_type1d = namel - l_type1d_out = namel - clmptr_rs(hpindex)%ptr => ptr_lunit - if (present(set_lake)) then - do l = bounds%begl,bounds%endl - if (lun%lakpoi(l)) ptr_lunit(l) = set_lake - end do - end if - if (present(set_nolake)) then - do l = bounds%begl,bounds%endl - if (.not.(lun%lakpoi(l))) ptr_lunit(l) = set_nolake - end do - end if - if (present(set_urb)) then - do l = bounds%begl,bounds%endl - if (lun%urbpoi(l)) ptr_lunit(l) = set_urb - end do - end if - if (present(set_nourb)) then - do l = bounds%begl,bounds%endl - if (.not.(lun%urbpoi(l))) ptr_lunit(l) = set_nourb - end do - end if - if (present(set_spec)) then - do l = bounds%begl,bounds%endl - if (lun%ifspecial(l)) ptr_lunit(l) = set_spec - end do - end if - - else if (present(ptr_col)) then - l_type1d = namec - l_type1d_out = namec - clmptr_rs(hpindex)%ptr => ptr_col - if (present(set_lake)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (lun%lakpoi(l)) ptr_col(c) = set_lake - end do - end if - if (present(set_nolake)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (.not.(lun%lakpoi(l))) ptr_col(c) = set_nolake - end do - end if - if (present(set_urb)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (lun%urbpoi(l)) ptr_col(c) = set_urb - end do - end if - if (present(set_nourb)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (.not.(lun%urbpoi(l))) ptr_col(c) = set_nourb - end do - end if - if (present(set_spec)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (lun%ifspecial(l)) ptr_col(c) = set_spec - end do - end if - if (present(set_noglcmec)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (.not.(lun%glcmecpoi(l))) ptr_col(c) = set_noglcmec - end do - endif - - else if (present(ptr_patch)) then - l_type1d = namep - l_type1d_out = namep - clmptr_rs(hpindex)%ptr => ptr_patch - if (present(set_lake)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (lun%lakpoi(l)) ptr_patch(p) = set_lake - end do - end if - if (present(set_nolake)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (.not.(lun%lakpoi(l))) ptr_patch(p) = set_nolake - end do - end if - if (present(set_urb)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (lun%urbpoi(l)) ptr_patch(p) = set_urb - end do - end if - if (present(set_nourb)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (.not.(lun%urbpoi(l))) ptr_patch(p) = set_nourb - end do - end if - if (present(set_spec)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (lun%ifspecial(l)) ptr_patch(p) = set_spec - end do - end if - if (present(set_noglcmec)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (.not.(lun%glcmecpoi(l))) ptr_patch(p) = set_noglcmec - end do - end if else write(iulog,*) trim(subname),' ERROR: must specify a valid pointer index,', & - ' choices are [ptr_atm, ptr_lnd, ptr_gcell, ptr_lunit, ptr_col, ptr_patch] ' + ' choices are [ptr_atm, ptr_lnd, ptr_gcell] ' call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! Set scaling factor - scale_type_p2c = 'unity' - scale_type_c2l = 'unity' - scale_type_l2g = 'unity' - - if (present(p2c_scale_type)) scale_type_p2c = p2c_scale_type - if (present(c2l_scale_type)) scale_type_c2l = c2l_scale_type - if (present(l2g_scale_type)) scale_type_l2g = l2g_scale_type if (present(type1d_out)) l_type1d_out = type1d_out ! Add field to masterlist call masterlist_addfld (fname=trim(fname), type1d=l_type1d, type1d_out=l_type1d_out, & type2d='unset', num2d=1, & - units=units, avgflag=avgflag, long_name=long_name, hpindex=hpindex, & - p2c_scale_type=scale_type_p2c, c2l_scale_type=scale_type_c2l, l2g_scale_type=scale_type_l2g) + units=units, avgflag=avgflag, long_name=long_name, hpindex=hpindex) l_default = 'active' if (present(default)) then @@ -4666,10 +3334,7 @@ end subroutine hist_addfld1d !----------------------------------------------------------------------- subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, & - ptr_gcell, ptr_lunit, ptr_col, ptr_patch, ptr_lnd, ptr_atm, & - p2c_scale_type, c2l_scale_type, l2g_scale_type, & - set_lake, set_nolake, set_urb, set_nourb, set_spec, & - no_snow_behavior, mml_dim, default) + ptr_gcell, ptr_lnd, ptr_atm, mml_dim, default) ! ! !DESCRIPTION: ! Initialize a single level history field. The pointer, ptrhist, @@ -4682,9 +3347,7 @@ subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, ! initial or branch run to initialize the actual history tapes. ! ! !USES: - use clm_varpar , only : nlevgrnd, nlevsno, nlevlak, numrad, nlevdecomp_full, nlevcan, nvegwcs,nlevsoi - use clm_varpar , only : natpft_size, cft_size, maxpatch_glcmec - use landunit_varcon , only : max_lunit + use clm_varpar , only : nlevgrnd, numrad ! ! !ARGUMENTS: character(len=*), intent(in) :: fname ! field name @@ -4696,18 +3359,6 @@ subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, real(r8) , optional, pointer :: ptr_atm(:,:) ! pointer to atm array real(r8) , optional, pointer :: ptr_lnd(:,:) ! pointer to lnd array real(r8) , optional, pointer :: ptr_gcell(:,:) ! pointer to gridcell array - real(r8) , optional, pointer :: ptr_lunit(:,:) ! pointer to landunit array - real(r8) , optional, pointer :: ptr_col(:,:) ! pointer to column array - real(r8) , optional, pointer :: ptr_patch(:,:) ! pointer to patch array - real(r8) , optional, intent(in) :: set_lake ! value to set lakes to - real(r8) , optional, intent(in) :: set_nolake ! value to set non-lakes to - real(r8) , optional, intent(in) :: set_urb ! value to set urban to - real(r8) , optional, intent(in) :: set_nourb ! value to set non-urban to - real(r8) , optional, intent(in) :: set_spec ! value to set special to - integer , optional, intent(in) :: no_snow_behavior ! if a multi-layer snow field, behavior to use for absent snow layers (should be one of the public no_snow_* parameters defined above) - character(len=*), optional, intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column - character(len=*), optional, intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits - character(len=*), optional, intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells integer , optional, intent(in) :: mml_dim ! size of second dimension for MML variables character(len=*), optional, intent(in) :: default ! if set to 'inactive, field will not appear on primary tape ! @@ -4717,9 +3368,6 @@ subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, integer :: hpindex ! history buffer index character(len=hist_dim_name_length) :: l_type1d ! 1d data type character(len=hist_dim_name_length) :: l_type1d_out ! 1d output type - character(len=scale_type_strlen) :: scale_type_p2c ! scale type for subgrid averaging of pfts to column - character(len=scale_type_strlen) :: scale_type_c2l ! scale type for subgrid averaging of columns to landunits - character(len=scale_type_strlen) :: scale_type_l2g ! scale type for subgrid averaging of landunits to gridcells type(bounds_type):: bounds character(len=16):: l_default ! local version of 'default' character(len=*),parameter :: subname = 'hist_addfld2d' @@ -4727,76 +3375,22 @@ subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, call get_proc_bounds(bounds) - ! Error-check no_snow_behavior optional argument: It should be present if and only if - ! type2d is 'levsno', and its value should be one of the public no_snow_* parameters - ! defined above. - if (present(no_snow_behavior)) then - if (type2d /= 'levsno') then - write(iulog,*) trim(subname), & - ' ERROR: Only specify no_snow_behavior for fields with dimension levsno' - call endrun() - end if - - if (no_snow_behavior < no_snow_MIN .or. no_snow_behavior > no_snow_MAX) then - write(iulog,*) trim(subname), & - ' ERROR: Invalid value for no_snow_behavior: ', no_snow_behavior - call endrun() - end if - - else ! no_snow_behavior is absent - if (type2d == 'levsno') then - write(iulog,*) trim(subname), & - ' ERROR: must specify no_snow_behavior for fields with dimension levsno' - call endrun() - end if - end if - ! Determine second dimension size select case (type2d) case ('levgrnd') num2d = nlevgrnd - case ('levsoi') - num2d = nlevsoi - case ('levlak') - num2d = nlevlak case ('numrad') num2d = numrad - case ('levdcmp') - num2d = nlevdecomp_full - case ('ltype') - num2d = max_lunit - case ('natpft') - num2d = natpft_size - case('cft') - if (cft_size > 0) then - num2d = cft_size - else - write(iulog,*) trim(subname),' ERROR: 2d type =', trim(type2d), & - ' only valid for cft_size > 0' - call endrun() - end if - case ('glc_nec') - num2d = maxpatch_glcmec - case ('elevclas') - ! add one because indexing starts at 0 (elevclas, unlike glc_nec, includes the - ! bare ground "elevation class") - num2d = maxpatch_glcmec + 1 - case ('levsno') - num2d = nlevsno - case ('nlevcan') - num2d = nlevcan ! MML: adding my own case ('mml_lev') num2d = 10 !mml_nsoi ! mml_dim ! mml_nsoi not defined in this subroutine, so hard coding until I get more clever... case ('mml_dust') num2d = 4 - case ('nvegwcs') - num2d = nvegwcs case default write(iulog,*) trim(subname),' ERROR: unsupported 2d type ',type2d, & ' currently supported types for multi level fields are: ', & - '[levgrnd,levsoi,levlak,numrad,levdcmp,levtrc,ltype,natpft,cft,glc_nec,elevclas,levsno,nvegwcs]' + '[levgrnd,levsoi,numrad,ltype]' call endrun(msg=errMsg(sourcefile, __LINE__)) end select @@ -4813,132 +3407,22 @@ subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, l_type1d = nameg l_type1d_out = nameg clmptr_ra(hpindex)%ptr => ptr_gcell - - else if (present(ptr_lunit)) then - l_type1d = namel - l_type1d_out = namel - clmptr_ra(hpindex)%ptr => ptr_lunit - if (present(set_lake)) then - do l = bounds%begl,bounds%endl - if (lun%lakpoi(l)) ptr_lunit(l,:) = set_lake - end do - end if - if (present(set_nolake)) then - do l = bounds%begl,bounds%endl - if (.not.(lun%lakpoi(l))) ptr_lunit(l,:) = set_nolake - end do - end if - if (present(set_urb)) then - do l = bounds%begl,bounds%endl - if (lun%urbpoi(l)) ptr_lunit(l,:) = set_urb - end do - end if - if (present(set_nourb)) then - do l = bounds%begl,bounds%endl - if (.not.(lun%urbpoi(l))) ptr_lunit(l,:) = set_nourb - end do - end if - if (present(set_spec)) then - do l = bounds%begl,bounds%endl - if (lun%ifspecial(l)) ptr_lunit(l,:) = set_spec - end do - end if - - else if (present(ptr_col)) then - l_type1d = namec - l_type1d_out = namec - clmptr_ra(hpindex)%ptr => ptr_col - if (present(set_lake)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (lun%lakpoi(l)) ptr_col(c,:) = set_lake - end do - end if - if (present(set_nolake)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (.not.(lun%lakpoi(l))) ptr_col(c,:) = set_nolake - end do - end if - if (present(set_urb)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (lun%urbpoi(l)) ptr_col(c,:) = set_urb - end do - end if - if (present(set_nourb)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (.not.(lun%urbpoi(l))) ptr_col(c,:) = set_nourb - end do - end if - if (present(set_spec)) then - do c = bounds%begc,bounds%endc - l =col%landunit(c) - if (lun%ifspecial(l)) ptr_col(c,:) = set_spec - end do - end if - - else if (present(ptr_patch)) then - l_type1d = namep - l_type1d_out = namep - clmptr_ra(hpindex)%ptr => ptr_patch - if (present(set_lake)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (lun%lakpoi(l)) ptr_patch(p,:) = set_lake - end do - end if - if (present(set_nolake)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (.not.(lun%lakpoi(l))) ptr_patch(p,:) = set_nolake - end do - end if - if (present(set_urb)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (lun%urbpoi(l)) ptr_patch(p,:) = set_urb - end do - end if - if (present(set_nourb)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (.not.(lun%urbpoi(l))) ptr_patch(p,:) = set_nourb - end do - end if - if (present(set_spec)) then - do p = bounds%begp,bounds%endp - l =patch%landunit(p) - if (lun%ifspecial(l)) ptr_patch(p,:) = set_spec - end do - end if - else write(iulog,*) trim(subname),' ERROR: must specify a valid pointer index,', & - ' choices are ptr_atm, ptr_lnd, ptr_gcell, ptr_lunit, ptr_col, ptr_patch' + ' choices are ptr_atm, ptr_lnd, ptr_gcell' call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! Set scaling factor - scale_type_p2c = 'unity' - scale_type_c2l = 'unity' - scale_type_l2g = 'unity' - - if (present(p2c_scale_type)) scale_type_p2c = p2c_scale_type - if (present(c2l_scale_type)) scale_type_c2l = c2l_scale_type - if (present(l2g_scale_type)) scale_type_l2g = l2g_scale_type if (present(type1d_out)) l_type1d_out = type1d_out ! Add field to masterlist call masterlist_addfld (fname=trim(fname), type1d=l_type1d, type1d_out=l_type1d_out, & type2d=type2d, num2d=num2d, & - units=units, avgflag=avgflag, long_name=long_name, hpindex=hpindex, & - p2c_scale_type=scale_type_p2c, c2l_scale_type=scale_type_c2l, l2g_scale_type=scale_type_l2g, & - no_snow_behavior=no_snow_behavior) + units=units, avgflag=avgflag, long_name=long_name, hpindex=hpindex) l_default = 'active' if (present(default)) then @@ -4952,94 +3436,6 @@ subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, end subroutine hist_addfld2d - !----------------------------------------------------------------------- - subroutine hist_addfld_decomp (fname, type2d, units, avgflag, long_name, ptr_col, & - ptr_patch, l2g_scale_type, default) - - ! - ! !USES: - use clm_varpar , only : nlevdecomp_full - use clm_varctl , only : iulog - use abortutils , only : endrun - use shr_log_mod , only : errMsg => shr_log_errMsg - ! - ! !ARGUMENTS: - character(len=*), intent(in) :: fname ! field name - character(len=*), intent(in) :: type2d ! 2d output type - character(len=*), intent(in) :: units ! units of field - character(len=*), intent(in) :: avgflag ! time averaging flag - character(len=*), intent(in) :: long_name ! long name of field - real(r8) , optional, pointer :: ptr_col(:,:) ! pointer to column array - real(r8) , optional, pointer :: ptr_patch(:,:) ! pointer to patch array - character(len=*), optional, intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells - character(len=*), optional, intent(in) :: default ! if set to 'inactive, field will not appear on primary tape - ! - ! !LOCAL VARIABLES: - real(r8), pointer :: ptr_1d(:) - !----------------------------------------------------------------------- - - if (present(ptr_col)) then - - ! column-level data - if (present(default)) then - if ( nlevdecomp_full > 1 ) then - call hist_addfld2d (fname=trim(fname), units=units, type2d=type2d, & - avgflag=avgflag, long_name=long_name, & - ptr_col=ptr_col, l2g_scale_type=l2g_scale_type, default=default) - else - ptr_1d => ptr_col(:,1) - call hist_addfld1d (fname=trim(fname), units=units, & - avgflag=avgflag, long_name=long_name, & - ptr_col=ptr_1d, l2g_scale_type=l2g_scale_type, default=default) - endif - else - if ( nlevdecomp_full > 1 ) then - call hist_addfld2d (fname=trim(fname), units=units, type2d=type2d, & - avgflag=avgflag, long_name=long_name, & - ptr_col=ptr_col, l2g_scale_type=l2g_scale_type) - else - ptr_1d => ptr_col(:,1) - call hist_addfld1d (fname=trim(fname), units=units, & - avgflag=avgflag, long_name=long_name, & - ptr_col=ptr_1d, l2g_scale_type=l2g_scale_type) - endif - endif - - else if (present(ptr_patch)) then - - ! patch-level data - if (present(default)) then - if ( nlevdecomp_full > 1 ) then - call hist_addfld2d (fname=trim(fname), units=units, type2d=type2d, & - avgflag=avgflag, long_name=long_name, & - ptr_patch=ptr_patch, l2g_scale_type=l2g_scale_type, default=default) - else - ptr_1d => ptr_patch(:,1) - call hist_addfld1d (fname=trim(fname), units=units, & - avgflag=avgflag, long_name=long_name, & - ptr_patch=ptr_1d, l2g_scale_type=l2g_scale_type, default=default) - endif - else - if ( nlevdecomp_full > 1 ) then - call hist_addfld2d (fname=trim(fname), units=units, type2d=type2d, & - avgflag=avgflag, long_name=long_name, & - ptr_patch=ptr_patch, l2g_scale_type=l2g_scale_type) - else - ptr_1d => ptr_patch(:,1) - call hist_addfld1d (fname=trim(fname), units=units, & - avgflag=avgflag, long_name=long_name, & - ptr_patch=ptr_1d, l2g_scale_type=l2g_scale_type) - endif - endif - - else - write(iulog, *) ' error: hist_addfld_decomp needs either patch or column level pointer' - write(iulog, *) fname - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - - end subroutine hist_addfld_decomp - !----------------------------------------------------------------------- integer function pointer_index () ! diff --git a/src/main/initGridCellsMod.F90 b/src/main/initGridCellsMod.F90 deleted file mode 100644 index def9631a..00000000 --- a/src/main/initGridCellsMod.F90 +++ /dev/null @@ -1,571 +0,0 @@ -module initGridCellsMod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Initializes sub-grid mapping for each land grid cell. This module handles the high- - ! level logic that determines how the subgrid structure is set up in a CLM run. It - ! makes use of lower-level routines in initSubgridMod. - ! - ! TODO(wjs, 2015-12-08) Much of the logic here duplicates (in some sense) logic in - ! subgridMod. The duplication should probably be extracted into routines shared between - ! these modules (or the two modules should be combined into one). - ! - ! !USES: -#include "shr_assert.h" - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - use spmdMod , only : masterproc,iam - use abortutils , only : endrun - use clm_varctl , only : iulog - use clm_varcon , only : namep, namec, namel, nameg - use decompMod , only : bounds_type, ldecomp - use GridcellType , only : grc - use LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch - use initSubgridMod , only : clm_ptrs_compdown, clm_ptrs_check - use initSubgridMod , only : add_landunit, add_column, add_patch - use glcBehaviorMod , only : glc_behavior_type - ! - ! !PUBLIC TYPES: - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public initGridcells ! initialize sub-grid gridcell mapping - ! - ! !PRIVATE MEMBER FUNCTIONS: - private set_landunit_veg_compete - private set_landunit_wet_lake - private set_landunit_ice_mec - private set_landunit_crop_noncompete - private set_landunit_urban - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !------------------------------------------------------------------------ - subroutine initGridcells(glc_behavior) - ! - ! !DESCRIPTION: - ! Initialize sub-grid mapping and allocates space for derived type hierarchy. - ! For each land gridcell determine landunit, column and patch properties. - ! - ! !USES - use domainMod , only : ldomain - use decompMod , only : get_proc_bounds, get_clump_bounds, get_proc_clumps - use subgridWeightsMod , only : compute_higher_order_weights - use landunit_varcon , only : istsoil, istwet, istdlak, istice_mec - use landunit_varcon , only : isturb_tbd, isturb_hd, isturb_md, istcrop - use clm_varctl , only : use_fates - use shr_const_mod , only : SHR_CONST_PI - ! - ! !ARGUMENTS: - type(glc_behavior_type), intent(in) :: glc_behavior - ! - ! !LOCAL VARIABLES: - integer :: nc,li,ci,pi,gdc ! indices - integer :: nclumps ! number of clumps on this processor - type(bounds_type) :: bounds_proc - type(bounds_type) :: bounds_clump - !------------------------------------------------------------------------ - - ! Notes about how this routine is arranged, and its implications for the arrangement - ! of 1-d vectors in memory: - ! - ! (1) There is an outer loop over clumps; this results in all of a clump's points (at - ! the gridcell, landunit, column & patch level) being contiguous. This is important - ! for the use of begg:endg, etc., and also for performance. - ! - ! (2) Next, there is a section for each landunit, with the loop over grid cells - ! happening separately for each landunit. This means that, within a given clump, - ! points with the same landunit are grouped together (this is true at the - ! landunit, column and patch levels). Thus, different landunits for a given grid - ! cell are separated in memory. This improves performance in the many parts of - ! the code that operate over a single landunit, or two similar landunits. - ! - ! Example: landunit-level array: For a processor with 2 clumps, each of which has 2 - ! grid cells, each of which has 3 landunits, the layout of a landunit-level array - ! looks like the following: - ! - ! Array index: 1 2 3 4 5 6 7 8 9 10 11 12 - ! ------------------------------------------------------------ - ! Clump index: 1 1 1 1 1 1 2 2 2 2 2 2 - ! Gridcell: 1 2 1 2 1 2 3 4 3 4 3 4 - ! Landunit type: 1 1 2 2 3 3 1 1 2 2 3 3 - ! - ! Example: patch-level array: For a processor with 1 clump, which has 2 grid cells, each - ! of which has 2 landunits, each of which has 3 patchs, the layout of a patch-level array - ! looks like the following: - ! - ! Array index: 1 2 3 4 5 6 7 8 9 10 11 12 - ! ------------------------------------------------------------ - ! Gridcell: 1 1 1 2 2 2 1 1 1 2 2 2 - ! Landunit type: 1 1 1 1 1 1 2 2 2 2 2 2 - ! Patch type: 1 2 3 1 2 3 1 2 3 1 2 3 - ! - ! So note that clump index is most slowly varying, followed by landunit type, - ! followed by gridcell, followed by column and patch type. - ! - ! Cohort layout - ! Array index: 1 2 3 4 5 6 7 8 9 10 11 12 - ! ------------------------------------------------------------ - ! Gridcell: 1 1 1 1 2 2 2 2 3 3 3 3 - ! Column: 1 1 2 2 3 3 4 4 5 5 6 6 - ! Cohort: 1 2 1 2 1 2 1 2 1 2 1 2 - - nclumps = get_proc_clumps() - - ! FIX(SPM,032414) add private vars for cohort and perhaps patch dimension - !$OMP PARALLEL DO PRIVATE (nc, bounds_clump, li, ci, pi, gdc) - do nc = 1, nclumps - - call get_clump_bounds(nc, bounds_clump) - - ! For each land gridcell on global grid determine landunit, column and patch properties - - li = bounds_clump%begl-1 - ci = bounds_clump%begc-1 - pi = bounds_clump%begp-1 - - ! Determine naturally vegetated landunit - do gdc = bounds_clump%begg,bounds_clump%endg - call set_landunit_veg_compete( & - ltype=istsoil, gi=gdc, li=li, ci=ci, pi=pi) - end do - - ! Determine crop landunit - do gdc = bounds_clump%begg,bounds_clump%endg - call set_landunit_crop_noncompete( & - ltype=istcrop, gi=gdc, li=li, ci=ci, pi=pi) - end do - - ! Determine urban tall building district landunit - do gdc = bounds_clump%begg,bounds_clump%endg - call set_landunit_urban( & - ltype=isturb_tbd, gi=gdc, li=li, ci=ci, pi=pi) - - end do - - ! Determine urban high density landunit - do gdc = bounds_clump%begg,bounds_clump%endg - call set_landunit_urban( & - ltype=isturb_hd, gi=gdc, li=li, ci=ci, pi=pi) - end do - - ! Determine urban medium density landunit - do gdc = bounds_clump%begg,bounds_clump%endg - call set_landunit_urban( & - ltype=isturb_md, gi=gdc, li=li, ci=ci, pi=pi) - end do - - ! Determine lake, wetland and glacier landunits - do gdc = bounds_clump%begg,bounds_clump%endg - call set_landunit_wet_lake( & - ltype=istdlak, gi=gdc, li=li, ci=ci, pi=pi) - end do - - do gdc = bounds_clump%begg,bounds_clump%endg - call set_landunit_wet_lake( & - ltype=istwet, gi=gdc, li=li, ci=ci, pi=pi) - end do - - do gdc = bounds_clump%begg,bounds_clump%endg - call set_landunit_ice_mec( & - glc_behavior = glc_behavior, & - ltype=istice_mec, gi=gdc, li=li, ci=ci, pi=pi) - end do - - ! Ensure that we have set the expected number of patchs, cols and landunits for this clump - SHR_ASSERT(li == bounds_clump%endl, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(ci == bounds_clump%endc, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(pi == bounds_clump%endp, errMsg(sourcefile, __LINE__)) - - ! Set some other gridcell-level variables - - do gdc = bounds_clump%begg,bounds_clump%endg - grc%gindex(gdc) = ldecomp%gdc2glo(gdc) - grc%area(gdc) = ldomain%area(gdc) - grc%latdeg(gdc) = ldomain%latc(gdc) - grc%londeg(gdc) = ldomain%lonc(gdc) - grc%lat(gdc) = grc%latdeg(gdc) * SHR_CONST_PI/180._r8 - grc%lon(gdc) = grc%londeg(gdc) * SHR_CONST_PI/180._r8 - enddo - - ! Fill in subgrid datatypes - - call clm_ptrs_compdown(bounds_clump) - - ! By putting this check within the loop over clumps, we ensure that (for example) - ! if a clump is responsible for landunit L, then that same clump is also - ! responsible for all columns and patchs in L. - call clm_ptrs_check(bounds_clump) - - ! Set patch%wtlunit, patch%wtgcell and col%wtgcell - call compute_higher_order_weights(bounds_clump) - - end do - !$OMP END PARALLEL DO - - end subroutine initGridcells - - !------------------------------------------------------------------------ - subroutine set_landunit_veg_compete (ltype, gi, li, ci, pi) - ! - ! !DESCRIPTION: - ! Initialize vegetated landunit with competition - ! - ! !USES - use clm_instur, only : wt_lunit, wt_nat_patch - use subgridMod, only : subgrid_get_info_natveg - use clm_varpar, only : numpft, maxpatch_pft, natpft_lb, natpft_ub - ! - ! !ARGUMENTS: - integer , intent(in) :: ltype ! landunit type - integer , intent(in) :: gi ! gridcell index - integer , intent(inout) :: li ! landunit index - integer , intent(inout) :: ci ! column index - integer , intent(inout) :: pi ! patch index - ! - ! !LOCAL VARIABLES: - integer :: m ! index - integer :: npatches ! number of patches in landunit - integer :: ncols - integer :: nlunits - integer :: pitype ! patch itype - real(r8) :: wtlunit2gcell ! landunit weight in gridcell - !------------------------------------------------------------------------ - - ! Set decomposition properties - - call subgrid_get_info_natveg(gi, & - npatches=npatches, ncols=ncols, nlunits=nlunits) - wtlunit2gcell = wt_lunit(gi, ltype) - - if (npatches > 0) then - call add_landunit(li=li, gi=gi, ltype=ltype, wtgcell=wtlunit2gcell) - - ! Assume one column on the landunit - call add_column(ci=ci, li=li, ctype=1, wtlunit=1.0_r8) - - do m = natpft_lb,natpft_ub - call add_patch(pi=pi, ci=ci, ptype=m, wtcol=wt_nat_patch(gi,m)) - end do - end if - - end subroutine set_landunit_veg_compete - - !------------------------------------------------------------------------ - subroutine set_landunit_wet_lake (ltype, gi, li, ci, pi) - ! - ! !DESCRIPTION: - ! Initialize wetland and lake landunits - ! - ! !USES - use clm_instur , only : wt_lunit - use landunit_varcon , only : istwet, istdlak - use subgridMod , only : subgrid_get_info_wetland, subgrid_get_info_lake - use pftconMod , only : noveg - - ! - ! !ARGUMENTS: - integer , intent(in) :: ltype ! landunit type - integer , intent(in) :: gi ! gridcell index - integer , intent(inout) :: li ! landunit index - integer , intent(inout) :: ci ! column index - integer , intent(inout) :: pi ! patch index - ! - ! !LOCAL VARIABLES: - integer :: npatches ! number of pfts in landunit - integer :: ncols - integer :: nlunits - real(r8) :: wtlunit2gcell ! landunit weight in gridcell - !------------------------------------------------------------------------ - - ! Set decomposition properties - - if (ltype == istwet) then - call subgrid_get_info_wetland(gi, & - npatches=npatches, ncols=ncols, nlunits=nlunits) - else if (ltype == istdlak) then - call subgrid_get_info_lake(gi, & - npatches=npatches, ncols=ncols, nlunits=nlunits) - else - write(iulog,*)' set_landunit_wet_lake: ltype of ',ltype,' not valid' - write(iulog,*)' only istwet and istdlak ltypes are valid' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - wtlunit2gcell = wt_lunit(gi, ltype) - - if (npatches > 0) then - - if (npatches /= 1) then - write(iulog,*)' set_landunit_wet_lake: compete landunit must'// & - ' have one patch ' - write(iulog,*)' current value of npatches=',npatches - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Currently assume that each landunit only has only one column - ! and that each column has its own pft - - call add_landunit(li=li, gi=gi, ltype=ltype, wtgcell=wtlunit2gcell) - call add_column(ci=ci, li=li, ctype=ltype, wtlunit=1.0_r8) - call add_patch(pi=pi, ci=ci, ptype=noveg, wtcol=1.0_r8) - - endif ! npatches > 0 - - end subroutine set_landunit_wet_lake - - !----------------------------------------------------------------------- - subroutine set_landunit_ice_mec(glc_behavior, ltype, gi, li, ci, pi) - ! - ! !DESCRIPTION: - ! Initialize glacier_mec landunits - ! - ! !USES: - use clm_varpar , only : maxpatch_glcmec - use clm_instur , only : wt_lunit, wt_glc_mec - use landunit_varcon , only : istice_mec - use column_varcon , only : icemec_class_to_col_itype - use subgridMod , only : subgrid_get_info_glacier_mec - use pftconMod , only : noveg - ! - ! !ARGUMENTS: - type(glc_behavior_type), intent(in) :: glc_behavior - integer , intent(in) :: ltype ! landunit type - integer , intent(in) :: gi ! gridcell index - integer , intent(inout) :: li ! landunit index - integer , intent(inout) :: ci ! column index - integer , intent(inout) :: pi ! patch index - ! - ! !LOCAL VARIABLES: - integer :: m ! index - integer :: npatches ! number of patches in landunit - integer :: ncols - integer :: nlunits - logical :: col_exists - real(r8) :: wtlunit2gcell ! weight relative to gridcell of landunit - real(r8) :: wtcol2lunit ! col weight in landunit - logical :: type_is_dynamic - - ! We don't have a true atm_topo value at the point of this call, so arbitrarily use - ! 0. This will put glc_mec in elevation class 1 in some places where it should - ! actually be in a higher elevation class, but that will be adjusted in the run loop - ! (or upon reading the restart file). - real(r8), parameter :: atm_topo = 0._r8 - - character(len=*), parameter :: subname = 'set_landunit_ice_mec' - !----------------------------------------------------------------------- - - SHR_ASSERT(ltype == istice_mec, errMsg(sourcefile, __LINE__)) - - call subgrid_get_info_glacier_mec(gi, atm_topo, glc_behavior, & - npatches=npatches, ncols=ncols, nlunits=nlunits) - - if (nlunits == 1) then - wtlunit2gcell = wt_lunit(gi, ltype) - call add_landunit(li=li, gi=gi, ltype=ltype, wtgcell=wtlunit2gcell) - - ! Determine column and properties - ! (Each column has its own pft) - ! - ! For grid cells where the glc behavior indicates a need for virtual columns - ! (i.e., zero-weight columns that are nevertheless active), make sure all the - ! elevations classes are populated, even if some have zero fractional area. - ! This ensures that the ice sheet component, glc, will receive a surface mass - ! balance in each elevation class wherever the SMB is needed. - - type_is_dynamic = glc_behavior%cols_have_dynamic_type(gi) - do m = 1, maxpatch_glcmec - call glc_behavior%glc_mec_col_exists(gi = gi, elev_class = m, atm_topo = atm_topo, & - exists = col_exists, col_wt_lunit = wtcol2lunit) - if (col_exists) then - call add_column(ci=ci, li=li, ctype=icemec_class_to_col_itype(m), & - wtlunit=wtcol2lunit, type_is_dynamic=type_is_dynamic) - call add_patch(pi=pi, ci=ci, ptype=noveg, wtcol=1.0_r8) - endif - enddo - - else if (nlunits /= 0) then - call endrun(msg=subname//' ERROR: expect 0 or 1 landunits') - end if - - end subroutine set_landunit_ice_mec - - !------------------------------------------------------------------------ - - subroutine set_landunit_crop_noncompete (ltype, gi, li, ci, pi) - ! - ! !DESCRIPTION: - ! Initialize crop landunit without competition - ! - ! Note about the ltype input argument: This provides the value for this landunit index - ! (i.e., the crop landunit index). This may differ from the landunit's 'itype' value, - ! since itype is istsoil if we are running with create_crop_landunit but for - ! an older surface dataset that - ! - ! !USES - use clm_instur , only : wt_lunit, wt_cft - use landunit_varcon , only : istcrop, istsoil - use subgridMod , only : subgrid_get_info_crop, crop_patch_exists - use clm_varpar , only : maxpatch_pft, cft_lb, cft_ub - use clm_varctl , only : create_crop_landunit - ! - ! !ARGUMENTS: - integer , intent(in) :: ltype ! landunit type - integer , intent(in) :: gi ! gridcell index - integer , intent(inout) :: li ! landunit index - integer , intent(inout) :: ci ! column index - integer , intent(inout) :: pi ! patch index - ! - ! !LOCAL VARIABLES: - integer :: my_ltype ! landunit type for crops - integer :: cft ! crop functional type index - integer :: npatches ! number of pfts in landunit - integer :: ncols - integer :: nlunits - real(r8) :: wtlunit2gcell ! landunit weight in gridcell - !------------------------------------------------------------------------ - - ! Set decomposition properties - - call subgrid_get_info_crop(gi, & - npatches=npatches, ncols=ncols, nlunits=nlunits) - wtlunit2gcell = wt_lunit(gi, ltype) - - if (nlunits > 0) then - - ! Note that we cannot simply use the 'ltype' argument to set itype here, - ! because ltype will always indicate istcrop - if ( create_crop_landunit )then - my_ltype = ltype ! Will always be istcrop - if ( ltype /= istcrop )then - write(iulog,*)' create_crop_landunit on and ltype is not istcrop: ', ltype - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - else - my_ltype = istsoil - end if - - call add_landunit(li=li, gi=gi, ltype=my_ltype, wtgcell=wtlunit2gcell) - - ! Set column and patch properties for this landunit - ! (each column has its own pft) - - do cft = cft_lb, cft_ub - if (crop_patch_exists(gi, cft)) then - call add_column(ci=ci, li=li, ctype=((istcrop*100) + cft), wtlunit=wt_cft(gi,cft)) - call add_patch(pi=pi, ci=ci, ptype=cft, wtcol=1.0_r8) - end if - end do - - end if - - end subroutine set_landunit_crop_noncompete - - !------------------------------------------------------------------------------ - - subroutine set_landunit_urban (ltype, gi, li, ci, pi) - ! - ! !DESCRIPTION: - ! Initialize urban landunits - ! - ! !USES - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use column_varcon , only : icol_road_perv, icol_road_imperv - use landunit_varcon , only : isturb_tbd, isturb_hd, isturb_md, isturb_MIN - use clm_varpar , only : maxpatch_urb - use clm_instur , only : wt_lunit - use subgridMod , only : subgrid_get_info_urban_tbd, subgrid_get_info_urban_hd - use subgridMod , only : subgrid_get_info_urban_md - use UrbanParamsType , only : urbinp - use decompMod , only : ldecomp - use pftconMod , only : noveg - ! - ! !ARGUMENTS: - integer , intent(in) :: ltype ! landunit type - integer , intent(in) :: gi ! gridcell index - integer , intent(inout) :: li ! landunit index - integer , intent(inout) :: ci ! column index - integer , intent(inout) :: pi ! patch index - ! - ! !LOCAL VARIABLES: - integer :: m ! index - integer :: n ! urban density type index - integer :: ctype ! column type - integer :: npatches ! number of pfts in landunit - integer :: ncols - integer :: nlunits - real(r8) :: wtlunit2gcell ! weight relative to gridcell of landunit - real(r8) :: wtcol2lunit ! weight of column with respect to landunit - real(r8) :: wtlunit_roof ! weight of roof with respect to landunit - real(r8) :: wtroad_perv ! weight of pervious road column with respect to total road - integer :: ier ! error status - !------------------------------------------------------------------------ - - ! Set decomposition properties, and set variables specific to urban density type - - select case (ltype) - case (isturb_tbd) - call subgrid_get_info_urban_tbd(gi, & - npatches=npatches, ncols=ncols, nlunits=nlunits) - case (isturb_hd) - call subgrid_get_info_urban_hd(gi, & - npatches=npatches, ncols=ncols, nlunits=nlunits) - case (isturb_md) - call subgrid_get_info_urban_md(gi, & - npatches=npatches, ncols=ncols, nlunits=nlunits) - case default - write(iulog,*)' set_landunit_urban: unknown ltype: ', ltype - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - wtlunit2gcell = wt_lunit(gi, ltype) - - n = ltype - isturb_MIN + 1 - wtlunit_roof = urbinp%wtlunit_roof(gi,n) - wtroad_perv = urbinp%wtroad_perv(gi,n) - - if (npatches > 0) then - - call add_landunit(li=li, gi=gi, ltype=ltype, wtgcell=wtlunit2gcell) - - ! Loop through columns for this landunit and set the column and patch properties - ! For the urban landunits it is assumed that each column has its own pft - - do m = 1, maxpatch_urb - - if (m == 1) then - ctype = icol_roof - wtcol2lunit = wtlunit_roof - else if (m == 2) then - ctype = icol_sunwall - wtcol2lunit = (1. - wtlunit_roof)/3 - else if (m == 3) then - ctype = icol_shadewall - wtcol2lunit = (1. - wtlunit_roof)/3 - else if (m == 4) then - ctype = icol_road_imperv - wtcol2lunit = ((1. - wtlunit_roof)/3) * (1.-wtroad_perv) - else if (m == 5) then - ctype = icol_road_perv - wtcol2lunit = ((1. - wtlunit_roof)/3) * (wtroad_perv) - end if - - call add_column(ci=ci, li=li, ctype=ctype, wtlunit=wtcol2lunit) - - call add_patch(pi=pi, ci=ci, ptype=noveg, wtcol=1.0_r8) - - end do ! end of loop through urban columns-pfts - end if - - end subroutine set_landunit_urban - -end module initGridCellsMod diff --git a/src/main/initSubgridMod.F90 b/src/main/initSubgridMod.F90 deleted file mode 100644 index 57384dc4..00000000 --- a/src/main/initSubgridMod.F90 +++ /dev/null @@ -1,475 +0,0 @@ -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%type_is_dynamic(ci) = l_type_is_dynamic - col%hydrologically_active(ci) = is_hydrologically_active( & - col_itype = ctype, & - lun_itype = lun%itype(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/src/main/initVerticalMod.F90 b/src/main/initVerticalMod.F90 deleted file mode 100644 index 6fdaef70..00000000 --- a/src/main/initVerticalMod.F90 +++ /dev/null @@ -1,794 +0,0 @@ -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 - use clm_varctl , only : fsurdat, iulog - use clm_varctl , only : use_vancouver, use_mexicocity, use_vertsoilc, use_extralakelayers - use clm_varctl , only : use_bedrock, soil_layerstruct - 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 abortUtils , only : endrun - use ncdio_pio - ! - ! !PUBLIC TYPES: - implicit none - save - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: initVertical - ! !PRIVATE MEMBER FUNCTIONS: - private :: ReadNL - private :: hasBedrock ! true if the given column type includes bedrock layers - ! - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - - ! - !------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------ - subroutine ReadNL( ) - ! - ! !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 controlMod , only : NLFilename - ! - ! !ARGUMENTS: - ! - ! !LOCAL VARIABLES: - integer :: ierr ! error code - integer :: unitn ! unit for namelist file - character(len=32) :: subname = 'InitVertical_readnl' ! subroutine name - !----------------------------------------------------------------------- - - character(len=*), parameter :: nl_name = 'clm_inparm' ! Namelist name - - ! MUST agree with name in namelist and read - namelist /clm_inparm/ use_bedrock - - ! preset values - - use_bedrock = .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_inparm, iostat=ierr) - if (ierr /= 0) then - call endrun(msg="ERROR reading '//nl_name//' namelist"//errmsg(sourcefile, __LINE__)) - end if - else - write(iulog,*) "Could not find '//nl_name//' namelist" - end if - call relavu( unitn ) - - end if - - call shr_mpi_bcast(use_bedrock, mpicom) - - end subroutine ReadNL - - !------------------------------------------------------------------------ - subroutine initVertical(bounds, glc_behavior, snow_depth, thick_wall, thick_roof) - use clm_varcon, only : zmin_bedrock, n_melt_glcmec - ! - ! !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 - 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 - !------------------------------------------------------------------------ - - begc = bounds%begc; endc= bounds%endc - begl = bounds%begl; endl= bounds%endl - - SHR_ASSERT_ALL((ubound(snow_depth) == (/endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(thick_wall) == (/endl/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(thick_roof) == (/endl/)), errMsg(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 == '10SL_3.5m' ) then - do j = 1, nlevgrnd - zsoi(j) = scalez*(exp(0.5_r8*(j-0.5_r8))-1._r8) !node depths - enddo - - dzsoi(1) = 0.5_r8*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces - do j = 2,nlevgrnd-1 - dzsoi(j)= 0.5_r8*(zsoi(j+1)-zsoi(j-1)) - enddo - dzsoi(nlevgrnd) = zsoi(nlevgrnd)-zsoi(nlevgrnd-1) - - zisoi(0) = 0._r8 - do j = 1, nlevgrnd-1 - zisoi(j) = 0.5_r8*(zsoi(j)+zsoi(j+1)) !interface depths - enddo - zisoi(nlevgrnd) = zsoi(nlevgrnd) + 0.5_r8*dzsoi(nlevgrnd) - - else if ( soil_layerstruct == '23SL_3.5m' )then - ! Soil layer structure that starts with standard exponential - ! and then has several evenly spaced layers, then finishes off exponential. - ! this allows the upper soil to behave as standard, but then continues - ! with higher resolution to a deeper depth, so that, for example, 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 = 1, toplev_equalspace - zsoi(j) = scalez*(exp(0.5_r8*(j-0.5_r8))-1._r8) !node depths - enddo - - 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 - - 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 ( soil_layerstruct == '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 !10mm 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 meter bedrock layers - dzsoi(j)= 10._r8 - enddo - - 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 if ( soil_layerstruct == '20SL_8.5m' ) then - do j = 1,4 - dzsoi(j)= j*0.02_r8 ! linear increase in layer thickness of 2cm each layer - enddo - do j = 5,13 - dzsoi(j)= dzsoi(4)+(j-4)*0.04_r8 ! linear increase in layer thickness of 2cm each layer - enddo - do j = 14,nlevsoi - dzsoi(j)= dzsoi(13)+(j-13)*0.10_r8 ! linear increase in layer thickness of 2cm each layer - enddo - do j = nlevsoi+1,nlevgrnd !bedrock layers - dzsoi(j)= dzsoi(nlevsoi)+(((j-nlevsoi)*25._r8)**1.5_r8)/100._r8 ! bedrock layers - enddo - - 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 - end if - - ! 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. - 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) - 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) - 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) - 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) : nlevgrnd) = LEVGRND_CLASS_DEEP_BEDROCK - else - col%levgrnd_class(c, 1:nlevgrnd) = LEVGRND_CLASS_STANDARD - end if - end do - - do j = 1, nlevgrnd - 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 - l = col%landunit(c) - g = col%gridcell(c) - - if (lun%itype(l)==istice_mec .and. glc_behavior%allow_multiple_columns_grc(g)) then - ! ice_mec columns already account for subgrid topographic variability through - ! their use of multiple elevation classes; thus, to avoid double-accounting for - ! topographic variability in these columns, we ignore topo_std and use a fixed - ! value of n_melt. - col%n_melt(c) = n_melt_glcmec - else - col%n_melt(c) = 200.0/max(10.0_r8, col%topo_std(c)) - end if - - ! 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 - - !----------------------------------------------------------------------- - 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/src/main/landunit_varcon.F90 b/src/main/landunit_varcon.F90 deleted file mode 100644 index b6ddc7cf..00000000 --- a/src/main/landunit_varcon.F90 +++ /dev/null @@ -1,133 +0,0 @@ -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/src/main/lnd2atmMod.F90 b/src/main/lnd2atmMod.F90 deleted file mode 100644 index ebe7eea1..00000000 --- a/src/main/lnd2atmMod.F90 +++ /dev/null @@ -1,450 +0,0 @@ -module lnd2atmMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Handle lnd2atm mapping - ! - ! !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 shr_megan_mod , only : shr_megan_mechcomps_n - 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 seq_drydep_mod , only : n_drydep, drydep_method, DD_XLND - use decompMod , only : bounds_type - use subgridAveMod , only : p2g, c2g - use lnd2atmType , only : lnd2atm_type - use atm2lndType , only : atm2lnd_type - use ch4Mod , only : ch4_type - use DUSTMod , only : dust_type - use DryDepVelocity , only : drydepvel_type - use VocEmissionMod , only : vocemis_type - use EnergyFluxType , only : energyflux_type - use FrictionVelocityMod , only : frictionvel_type - use SolarAbsorbedType , only : solarabs_type - use SurfaceAlbedoType , only : surfalb_type - use TemperatureType , only : temperature_type - use WaterFluxType , only : waterflux_type - use WaterstateType , only : waterstate_type - use glcBehaviorMod , only : glc_behavior_type - use glc2lndMod , only : glc2lnd_type - use ColumnType , only : col - use LandunitType , only : lun - use GridcellType , only : grc - use landunit_varcon , only : istice_mec - ! - ! !PUBLIC TYPES: - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: lnd2atm - public :: lnd2atm_minimal - - ! - ! !PRIVATE MEMBER FUNCTIONS: - private :: handle_ice_runoff - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------ - subroutine lnd2atm_minimal(bounds, & - waterstate_inst, surfalb_inst, energyflux_inst, lnd2atm_inst) - ! - ! !DESCRIPTION: - ! Compute clm_l2a_inst component of gridcell derived type. This routine computes - ! the bare minimum of components necessary to get the first step of a - ! run started. - ! - ! !USES: - use clm_varcon, only : sb - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - type(waterstate_type) , intent(in) :: waterstate_inst - type(surfalb_type) , intent(in) :: surfalb_inst - type(energyflux_type) , intent(in) :: energyflux_inst - type(lnd2atm_type) , intent(inout) :: lnd2atm_inst - ! - ! !LOCAL VARIABLES: - integer :: g ! index - real(r8), parameter :: amC = 12.0_r8 ! Atomic mass number for Carbon - real(r8), parameter :: amO = 16.0_r8 ! Atomic mass number for Oxygen - real(r8), parameter :: amCO2 = amC + 2.0_r8*amO ! Atomic mass number for CO2 - ! The following converts g of C to kg of CO2 - real(r8), parameter :: convertgC2kgCO2 = 1.0e-3_r8 * (amCO2/amC) - !------------------------------------------------------------------------ - - call c2g(bounds, & - waterstate_inst%h2osno_col (bounds%begc:bounds%endc), & - lnd2atm_inst%h2osno_grc (bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity') - - do g = bounds%begg,bounds%endg - lnd2atm_inst%h2osno_grc(g) = lnd2atm_inst%h2osno_grc(g)/1000._r8 - end do - - call c2g(bounds, nlevgrnd, & - waterstate_inst%h2osoi_vol_col (bounds%begc:bounds%endc, :), & - lnd2atm_inst%h2osoi_vol_grc (bounds%begg:bounds%endg, :), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity') - - call p2g(bounds, numrad, & - surfalb_inst%albd_patch (bounds%begp:bounds%endp, :), & - lnd2atm_inst%albd_grc (bounds%begg:bounds%endg, :), & - p2c_scale_type='unity', c2l_scale_type= 'urbanf', l2g_scale_type='unity') - - call p2g(bounds, numrad, & - surfalb_inst%albi_patch (bounds%begp:bounds%endp, :), & - lnd2atm_inst%albi_grc (bounds%begg:bounds%endg, :), & - p2c_scale_type='unity', c2l_scale_type= 'urbanf', l2g_scale_type='unity') - - call p2g(bounds, & - energyflux_inst%eflx_lwrad_out_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%eflx_lwrad_out_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'urbanf', l2g_scale_type='unity') - - do g = bounds%begg,bounds%endg - lnd2atm_inst%t_rad_grc(g) = sqrt(sqrt(lnd2atm_inst%eflx_lwrad_out_grc(g)/sb)) - end do - - end subroutine lnd2atm_minimal - - !------------------------------------------------------------------------ - subroutine lnd2atm(bounds, & - atm2lnd_inst, surfalb_inst, temperature_inst, frictionvel_inst, & - waterstate_inst, waterflux_inst, energyflux_inst, & - solarabs_inst, drydepvel_inst, & - vocemis_inst, dust_inst, ch4_inst, glc_behavior, & - lnd2atm_inst, & - net_carbon_exchange_grc) - ! - ! !DESCRIPTION: - ! Compute lnd2atm_inst component of gridcell derived type - ! - ! !USES: - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(surfalb_type) , intent(in) :: surfalb_inst - type(temperature_type) , intent(in) :: temperature_inst - type(frictionvel_type) , intent(in) :: frictionvel_inst - type(waterstate_type) , intent(inout) :: waterstate_inst - type(waterflux_type) , intent(inout) :: waterflux_inst - type(energyflux_type) , intent(in) :: energyflux_inst - type(solarabs_type) , intent(in) :: solarabs_inst - type(drydepvel_type) , intent(in) :: drydepvel_inst - type(vocemis_type) , intent(in) :: vocemis_inst - type(dust_type) , intent(in) :: dust_inst - type(ch4_type) , intent(in) :: ch4_inst - type(glc_behavior_type) , intent(in) :: glc_behavior - type(lnd2atm_type) , intent(inout) :: lnd2atm_inst - real(r8) , intent(in) :: net_carbon_exchange_grc( bounds%begg: ) ! net carbon exchange between land and atmosphere, positive for source (gC/m2/s) - ! - ! !LOCAL VARIABLES: - integer :: c, g ! indices - real(r8) :: qflx_ice_runoff_col(bounds%begc:bounds%endc) ! total column-level ice runoff - real(r8) :: eflx_sh_ice_to_liq_grc(bounds%begg:bounds%endg) ! sensible heat flux generated from the ice to liquid conversion, averaged to gridcell - real(r8), parameter :: amC = 12.0_r8 ! Atomic mass number for Carbon - real(r8), parameter :: amO = 16.0_r8 ! Atomic mass number for Oxygen - real(r8), parameter :: amCO2 = amC + 2.0_r8*amO ! Atomic mass number for CO2 - ! The following converts g of C to kg of CO2 - real(r8), parameter :: convertgC2kgCO2 = 1.0e-3_r8 * (amCO2/amC) - !------------------------------------------------------------------------ - - SHR_ASSERT_ALL((ubound(net_carbon_exchange_grc) == (/bounds%endg/)), errMsg(sourcefile, __LINE__)) - - call handle_ice_runoff(bounds, waterflux_inst, glc_behavior, & - melt_non_icesheet_ice_runoff = lnd2atm_inst%params%melt_non_icesheet_ice_runoff, & - qflx_ice_runoff_col = qflx_ice_runoff_col(bounds%begc:bounds%endc), & - qflx_liq_from_ice_col = lnd2atm_inst%qflx_liq_from_ice_col(bounds%begc:bounds%endc), & - eflx_sh_ice_to_liq_col = lnd2atm_inst%eflx_sh_ice_to_liq_col(bounds%begc:bounds%endc)) - - !---------------------------------------------------- - ! lnd -> atm - !---------------------------------------------------- - - ! First, compute the "minimal" set of fields. - call lnd2atm_minimal(bounds, & - waterstate_inst, surfalb_inst, energyflux_inst, lnd2atm_inst) - - call p2g(bounds, & - temperature_inst%t_ref2m_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%t_ref2m_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - - call p2g(bounds, & - waterstate_inst%q_ref2m_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%q_ref2m_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - - call p2g(bounds, & - frictionvel_inst%u10_clm_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%u_ref10m_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - - call p2g(bounds, & - energyflux_inst%taux_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%taux_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - - call p2g(bounds, & - energyflux_inst%tauy_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%tauy_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - - call p2g(bounds, & - waterflux_inst%qflx_evap_tot_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%qflx_evap_tot_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'urbanf', l2g_scale_type='unity') - - call p2g(bounds, & - solarabs_inst%fsa_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%fsa_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'urbanf', l2g_scale_type='unity') - - call p2g(bounds, & - frictionvel_inst%fv_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%fv_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - - call p2g(bounds, & - frictionvel_inst%ram1_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%ram1_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - - call p2g( bounds, & - energyflux_inst%eflx_sh_tot_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%eflx_sh_tot_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity',c2l_scale_type='urbanf',l2g_scale_type='unity') - call c2g( bounds, & - energyflux_inst%eflx_sh_precip_conversion_col (bounds%begc:bounds%endc), & - lnd2atm_inst%eflx_sh_precip_conversion_grc (bounds%begg:bounds%endg), & - c2l_scale_type='urbanf', l2g_scale_type='unity') - call c2g( bounds, & - lnd2atm_inst%eflx_sh_ice_to_liq_col(bounds%begc:bounds%endc), & - eflx_sh_ice_to_liq_grc(bounds%begg:bounds%endg), & - c2l_scale_type='urbanf', l2g_scale_type='unity') - do g = bounds%begg, bounds%endg - lnd2atm_inst%eflx_sh_tot_grc(g) = lnd2atm_inst%eflx_sh_tot_grc(g) + & - lnd2atm_inst%eflx_sh_precip_conversion_grc(g) + & - eflx_sh_ice_to_liq_grc(g) - & - energyflux_inst%eflx_dynbal_grc(g) - enddo - - call p2g(bounds, & - energyflux_inst%eflx_lh_tot_patch (bounds%begp:bounds%endp), & - lnd2atm_inst%eflx_lh_tot_grc (bounds%begg:bounds%endg), & - p2c_scale_type='unity', c2l_scale_type= 'urbanf', l2g_scale_type='unity') - - do g = bounds%begg, bounds%endg - lnd2atm_inst%net_carbon_exchange_grc(g) = & - net_carbon_exchange_grc(g) - end do - ! Convert from gC/m2/s to kgCO2/m2/s - do g = bounds%begg,bounds%endg - lnd2atm_inst%net_carbon_exchange_grc(g) = & - lnd2atm_inst%net_carbon_exchange_grc(g)*convertgC2kgCO2 - end do - - ! drydepvel - if ( n_drydep > 0 .and. drydep_method == DD_XLND ) then - call p2g(bounds, n_drydep, & - drydepvel_inst%velocity_patch (bounds%begp:bounds%endp, :), & - lnd2atm_inst%ddvel_grc (bounds%begg:bounds%endg, :), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - endif - - ! voc emission flux - if (shr_megan_mechcomps_n>0) then - !call p2g(bounds, shr_megan_mechcomps_n, & - !vocemis_inst%vocflx_patch(bounds%begp:bounds%endp,:), & - !lnd2atm_inst%flxvoc_grc (bounds%begg:bounds%endg,:), & - !p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - end if - - ! dust emission flux - call p2g(bounds, ndst, & - dust_inst%flx_mss_vrt_dst_patch(bounds%begp:bounds%endp, :), & - lnd2atm_inst%flxdst_grc (bounds%begg:bounds%endg, :), & - p2c_scale_type='unity', c2l_scale_type= 'unity', l2g_scale_type='unity') - - - !---------------------------------------------------- - ! lnd -> rof - !---------------------------------------------------- - - call c2g( bounds, & - waterflux_inst%qflx_surf_col (bounds%begc:bounds%endc), & - lnd2atm_inst%qflx_rofliq_qsur_grc (bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - - call c2g( bounds, & - waterflux_inst%qflx_drain_col (bounds%begc:bounds%endc), & - lnd2atm_inst%qflx_rofliq_qsub_grc (bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - - do c = bounds%begc, bounds%endc - if (col%active(c)) then - ! It's not entirely appropriate to put qflx_liq_from_ice_col into - ! qflx_qrgwl_col, since this isn't necessarily just glaciers, wetlands and - ! lakes. But since we put the liquid portion of snow capping into - ! qflx_qrgwl_col, it seems reasonable to put qflx_liq_from_ice_col there as - ! well. - waterflux_inst%qflx_qrgwl_col(c) = waterflux_inst%qflx_qrgwl_col(c) + & - lnd2atm_inst%qflx_liq_from_ice_col(c) - - ! qflx_runoff is the sum of a number of terms, including qflx_qrgwl. Since we - ! are adjusting qflx_qrgwl above, we need to adjust qflx_runoff analogously. - waterflux_inst%qflx_runoff_col(c) = waterflux_inst%qflx_runoff_col(c) + & - lnd2atm_inst%qflx_liq_from_ice_col(c) - end if - end do - - call c2g( bounds, & - waterflux_inst%qflx_qrgwl_col (bounds%begc:bounds%endc), & - lnd2atm_inst%qflx_rofliq_qgwl_grc (bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - - call c2g( bounds, & - waterflux_inst%qflx_runoff_col (bounds%begc:bounds%endc), & - lnd2atm_inst%qflx_rofliq_grc (bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - - do g = bounds%begg, bounds%endg - lnd2atm_inst%qflx_rofliq_qgwl_grc(g) = lnd2atm_inst%qflx_rofliq_qgwl_grc(g) - waterflux_inst%qflx_liq_dynbal_grc(g) - lnd2atm_inst%qflx_rofliq_grc(g) = lnd2atm_inst%qflx_rofliq_grc(g) - waterflux_inst%qflx_liq_dynbal_grc(g) - enddo - - call c2g( bounds, & - waterflux_inst%qflx_h2osfc_surf_col (bounds%begc:bounds%endc), & - lnd2atm_inst%qflx_rofliq_h2osfc_grc(bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - - call c2g( bounds, & - waterflux_inst%qflx_drain_perched_col (bounds%begc:bounds%endc), & - lnd2atm_inst%qflx_rofliq_drain_perched_grc(bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - - call c2g( bounds, & - qflx_ice_runoff_col(bounds%begc:bounds%endc), & - lnd2atm_inst%qflx_rofice_grc(bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - do g = bounds%begg, bounds%endg - lnd2atm_inst%qflx_rofice_grc(g) = lnd2atm_inst%qflx_rofice_grc(g) - waterflux_inst%qflx_ice_dynbal_grc(g) - enddo - - ! calculate total water storage for history files - ! first set tws to gridcell total endwb - ! second add river storage as gridcell average depth (1.e-3 converts [m3/km2] to [mm]) - ! TODO - this was in BalanceCheckMod - not sure where it belongs? - - call c2g( bounds, & - waterstate_inst%endwb_col(bounds%begc:bounds%endc), & - waterstate_inst%tws_grc (bounds%begg:bounds%endg), & - c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) - do g = bounds%begg, bounds%endg - waterstate_inst%tws_grc(g) = waterstate_inst%tws_grc(g) + atm2lnd_inst%volr_grc(g) / grc%area(g) * 1.e-3_r8 - enddo - - end subroutine lnd2atm - - !----------------------------------------------------------------------- - subroutine handle_ice_runoff(bounds, waterflux_inst, glc_behavior, & - melt_non_icesheet_ice_runoff, & - qflx_ice_runoff_col, qflx_liq_from_ice_col, eflx_sh_ice_to_liq_col) - ! - ! !DESCRIPTION: - ! Take column-level ice runoff and divide it between (a) ice runoff, and (b) liquid - ! runoff with a compensating negative sensible heat flux. - ! - ! The rationale here is: Ice runoff is largely meant to represent a crude - ! parameterization of iceberg calving. Iceberg calving is mainly appropriate in - ! regions where an ice sheet terminates at the land-ocean boundary. Elsewhere, in - ! reality, we expect most ice runoff to flow downstream and melt before it reaches the - ! ocean. Furthermore, sending ice runoff directly to the ocean can lead to runaway sea - ! ice growth in some regions (around the Canadian archipelago, and possibly in more - ! wide-spread regions of the Arctic Ocean); melting this ice before it reaches the - ! ocean avoids this problem. - ! - ! If the river model were able to melt ice, then we might not need this routine. - ! - ! Note that this routine does NOT handle ice runoff generated via the dynamic - ! landunits adjustment fluxes (i.e., the fluxes that compensate for a difference in - ! ice content between the pre- and post-dynamic landunit areas). This is partly - ! because those gridcell-level dynamic landunits adjustment fluxes do not fit well - ! with this column-based infrastructure, and partly because either method of handling - ! these fluxes (i.e., sending an ice runoff or sending a liquid runoff with a - ! negative sensible heat flux) seems equally justifiable. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - type(waterflux_type), intent(in) :: waterflux_inst - type(glc_behavior_type), intent(in) :: glc_behavior - logical, intent(in) :: melt_non_icesheet_ice_runoff - real(r8), intent(out) :: qflx_ice_runoff_col( bounds%begc: ) ! total column-level ice runoff (mm H2O /s) - real(r8), intent(out) :: qflx_liq_from_ice_col( bounds%begc: ) ! liquid runoff from converted ice runoff (mm H2O /s) - real(r8), intent(out) :: eflx_sh_ice_to_liq_col( bounds%begc: ) ! sensible heat flux generated from the ice to liquid conversion (W/m2) (+ to atm) - - ! - ! !LOCAL VARIABLES: - integer :: c, l, g - logical :: do_conversion - - character(len=*), parameter :: subname = 'handle_ice_runoff' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(qflx_ice_runoff_col) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(qflx_liq_from_ice_col) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(eflx_sh_ice_to_liq_col) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - - do c = bounds%begc, bounds%endc - if (col%active(c)) then - qflx_ice_runoff_col(c) = waterflux_inst%qflx_ice_runoff_snwcp_col(c) + & - waterflux_inst%qflx_ice_runoff_xs_col(c) - qflx_liq_from_ice_col(c) = 0._r8 - eflx_sh_ice_to_liq_col(c) = 0._r8 - end if - end do - - if (melt_non_icesheet_ice_runoff) then - do c = bounds%begc, bounds%endc - if (col%active(c)) then - l = col%landunit(c) - g = col%gridcell(c) - do_conversion = .false. - if (lun%itype(l) /= istice_mec) then - do_conversion = .true. - else ! istice_mec - if (glc_behavior%ice_runoff_melted_grc(g)) then - do_conversion = .true. - else - do_conversion = .false. - end if - end if - if (do_conversion) then - ! ice to liquid absorbs energy, so results in a negative heat flux to atm - ! Note that qflx_ice_runoff_col is in mm H2O/s, which is the same as kg - ! m-2 s-1, so we can simply multiply by hfus. - eflx_sh_ice_to_liq_col(c) = -qflx_ice_runoff_col(c) * hfus - qflx_liq_from_ice_col(c) = qflx_ice_runoff_col(c) - qflx_ice_runoff_col(c) = 0._r8 - end if - end if - end do - end if - - end subroutine handle_ice_runoff - - -end module lnd2atmMod diff --git a/src/main/lnd2atmType.F90 b/src/main/lnd2atmType.F90 index cdc1e981..cb81fa11 100644 --- a/src/main/lnd2atmType.F90 +++ b/src/main/lnd2atmType.F90 @@ -13,26 +13,15 @@ module lnd2atmType use clm_varpar , only : numrad, ndst, nlevgrnd !ndst = number of dust bins. ! MML: ndst = 4 from clm varpar use clm_varcon , only : spval use clm_varctl , only : iulog - use shr_megan_mod , only : shr_megan_mechcomps_n - use shr_fire_emis_mod,only : shr_fire_emis_mechcomps_n - use seq_drydep_mod, only : n_drydep, drydep_method, DD_XLND ! ! !PUBLIC TYPES: implicit none private - type, public :: lnd2atm_params_type - ! true => ice runoff generated from non-glacier columns and glacier columns outside - ! icesheet regions is converted to liquid, with an appropriate sensible heat flux - logical, public :: melt_non_icesheet_ice_runoff - end type lnd2atm_params_type - ! ---------------------------------------------------- ! land -> atmosphere variables structure !---------------------------------------------------- type, public :: lnd2atm_type - type(lnd2atm_params_type) :: params - ! lnd->atm real(r8), pointer :: t_rad_grc (:) => null() ! radiative temperature (Kelvin) ! MML check tech note for examples on how to calculate this; use MO theory @@ -50,7 +39,6 @@ module lnd2atmType real(r8), pointer :: tauy_grc (:) => null() ! wind stress: n-s (kg/m/s**2) real(r8), pointer :: eflx_lh_tot_grc (:) => null() ! total latent HF (W/m**2) [+ to atm] real(r8), pointer :: eflx_sh_tot_grc (:) => null() ! total sensible HF (W/m**2) [+ to atm] - real(r8), pointer :: eflx_sh_precip_conversion_grc(:) => null() ! sensible HF from precipitation conversion (W/m**2) [+ to atm] real(r8), pointer :: eflx_sh_ice_to_liq_col(:) => null() ! sensible HF generated from conversion of ice runoff to liquid (W/m**2) [+ to atm] real(r8), pointer :: eflx_lwrad_out_grc (:) => null() ! IR (longwave) radiation (W/m**2) real(r8), pointer :: qflx_evap_tot_grc (:) => null() ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg @@ -61,10 +49,6 @@ module lnd2atmType real(r8), pointer :: fv_grc (:) => null() ! friction velocity (m/s) (for dust model) real(r8), pointer :: flxdst_grc (:,:) => null() ! dust flux (size bins) real(r8), pointer :: ddvel_grc (:,:) => null() ! dry deposition velocities - real(r8), pointer :: flxvoc_grc (:,:) => null() ! VOC flux (size bins) - real(r8), pointer :: fireflx_grc (:,:) => null() ! Wild Fire Emissions - real(r8), pointer :: fireztop_grc (:) => null() ! Wild Fire Emissions vertical distribution top - real(r8), pointer :: flux_ch4_grc (:) => null() ! net CH4 flux (kg C/m**2/s) [+ to atm] ! lnd->rof real(r8), pointer :: qflx_rofliq_grc (:) => null() ! rof liq forcing real(r8), pointer :: qflx_rofliq_qsur_grc (:) => null() ! rof liq -- surface runoff component @@ -73,59 +57,29 @@ module lnd2atmType real(r8), pointer :: qflx_rofliq_h2osfc_grc (:) => null() ! rof liq -- surface water runoff component real(r8), pointer :: qflx_rofliq_drain_perched_grc (:) => null() ! rof liq -- perched water table runoff component real(r8), pointer :: qflx_rofice_grc (:) => null() ! rof ice forcing - real(r8), pointer :: qflx_liq_from_ice_col(:) => null() ! liquid runoff from converted ice runoff - real(r8), pointer :: qirrig_grc (:) => null() ! irrigation flux contains procedure, public :: Init - procedure, private :: ReadNamelist procedure, private :: InitAllocate procedure, private :: InitHistory end type lnd2atm_type !------------------------------------------------------------------------ - interface lnd2atm_params_type - module procedure lnd2atm_params_constructor - end interface lnd2atm_params_type - character(len=*), parameter, private :: sourcefile = & __FILE__ !------------------------------------------------------------------------ contains - !----------------------------------------------------------------------- - function lnd2atm_params_constructor(melt_non_icesheet_ice_runoff) & - result(params) - ! - ! !DESCRIPTION: - ! Creates a new instance of lnd2atm_params_type - ! - ! !ARGUMENTS: - type(lnd2atm_params_type) :: params ! function result - logical, intent(in) :: melt_non_icesheet_ice_runoff - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'lnd2atm_params_type' - !----------------------------------------------------------------------- - - params%melt_non_icesheet_ice_runoff = melt_non_icesheet_ice_runoff - - end function lnd2atm_params_constructor - - !------------------------------------------------------------------------ - subroutine Init(this, bounds, NLFilename) + subroutine Init(this, bounds) class(lnd2atm_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 @@ -136,33 +90,32 @@ subroutine InitAllocate(this, bounds) ! !DESCRIPTION: ! Initialize lnd2atm derived type ! + ! !USES + use clm_varcon, only: sb, tfrz + ! ! !ARGUMENTS: class (lnd2atm_type) :: this type(bounds_type), intent(in) :: bounds ! ! !LOCAL VARIABLES: real(r8) :: ival = 0.0_r8 ! initial value - integer :: begc, endc integer :: begg, endg !------------------------------------------------------------------------ - begc = bounds%begc; endc = bounds%endc begg = bounds%begg; endg = bounds%endg - allocate(this%t_rad_grc (begg:endg)) ; this%t_rad_grc (:) =ival + allocate(this%t_rad_grc (begg:endg)) ; this%t_rad_grc (:) = tfrz + 2._r8 allocate(this%t_ref2m_grc (begg:endg)) ; this%t_ref2m_grc (:) =ival allocate(this%q_ref2m_grc (begg:endg)) ; this%q_ref2m_grc (:) =ival allocate(this%u_ref10m_grc (begg:endg)) ; this%u_ref10m_grc (:) =ival - allocate(this%h2osno_grc (begg:endg)) ; this%h2osno_grc (:) =ival + allocate(this%h2osno_grc (begg:endg)) ; this%h2osno_grc (:) = 0._r8 allocate(this%h2osoi_vol_grc (begg:endg,1:nlevgrnd)) ; this%h2osoi_vol_grc (:,:) =ival - allocate(this%albd_grc (begg:endg,1:numrad)) ; this%albd_grc (:,:) =ival - allocate(this%albi_grc (begg:endg,1:numrad)) ; this%albi_grc (:,:) =ival + allocate(this%albd_grc (begg:endg,1:numrad)) ; this%albd_grc (:,:) = 0.2_r8 + allocate(this%albi_grc (begg:endg,1:numrad)) ; this%albi_grc (:,:) = 0.2_r8 allocate(this%taux_grc (begg:endg)) ; this%taux_grc (:) =ival allocate(this%tauy_grc (begg:endg)) ; this%tauy_grc (:) =ival - allocate(this%eflx_lwrad_out_grc (begg:endg)) ; this%eflx_lwrad_out_grc (:) =ival + allocate(this%eflx_lwrad_out_grc (begg:endg)) ; this%eflx_lwrad_out_grc (:) = sb * tfrz**4 allocate(this%eflx_sh_tot_grc (begg:endg)) ; this%eflx_sh_tot_grc (:) =ival - allocate(this%eflx_sh_precip_conversion_grc(begg:endg)) ; this%eflx_sh_precip_conversion_grc(:) = ival - allocate(this%eflx_sh_ice_to_liq_col(begc:endc)) ; this%eflx_sh_ice_to_liq_col(:) = ival allocate(this%eflx_lh_tot_grc (begg:endg)) ; this%eflx_lh_tot_grc (:) =ival allocate(this%qflx_evap_tot_grc (begg:endg)) ; this%qflx_evap_tot_grc (:) =ival allocate(this%fsa_grc (begg:endg)) ; this%fsa_grc (:) =ival @@ -171,7 +124,6 @@ subroutine InitAllocate(this, bounds) allocate(this%ram1_grc (begg:endg)) ; this%ram1_grc (:) =ival allocate(this%fv_grc (begg:endg)) ; this%fv_grc (:) =ival allocate(this%flxdst_grc (begg:endg,1:ndst)) ; this%flxdst_grc (:,:) =ival - allocate(this%flux_ch4_grc (begg:endg)) ; this%flux_ch4_grc (:) =ival allocate(this%qflx_rofliq_grc (begg:endg)) ; this%qflx_rofliq_grc (:) =ival allocate(this%qflx_rofliq_qsur_grc (begg:endg)) ; this%qflx_rofliq_qsur_grc (:) =ival allocate(this%qflx_rofliq_qsub_grc (begg:endg)) ; this%qflx_rofliq_qsub_grc (:) =ival @@ -179,87 +131,9 @@ subroutine InitAllocate(this, bounds) allocate(this%qflx_rofliq_h2osfc_grc (begg:endg)) ; this%qflx_rofliq_h2osfc_grc (:) =ival allocate(this%qflx_rofliq_drain_perched_grc (begg:endg)) ; this%qflx_rofliq_drain_perched_grc (:) =ival allocate(this%qflx_rofice_grc (begg:endg)) ; this%qflx_rofice_grc (:) =ival - allocate(this%qflx_liq_from_ice_col(begc:endc)) ; this%qflx_liq_from_ice_col(:) = ival - allocate(this%qirrig_grc (begg:endg)) ; this%qirrig_grc (:) =ival - - if (shr_megan_mechcomps_n>0) then - allocate(this%flxvoc_grc(begg:endg,1:shr_megan_mechcomps_n)); this%flxvoc_grc(:,:)=ival - endif - if (shr_fire_emis_mechcomps_n>0) then - allocate(this%fireflx_grc(begg:endg,1:shr_fire_emis_mechcomps_n)) - this%fireflx_grc = ival - allocate(this%fireztop_grc(begg:endg)) - this%fireztop_grc = ival - endif - if ( n_drydep > 0 .and. drydep_method == DD_XLND )then - allocate(this%ddvel_grc(begg:endg,1:n_drydep)); this%ddvel_grc(:,:)=ival - end if end subroutine InitAllocate - !----------------------------------------------------------------------- - subroutine ReadNamelist(this, NLFilename) - ! - ! !DESCRIPTION: - ! Read the lnd2atm 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(lnd2atm_type), intent(inout) :: this - ! - ! !LOCAL VARIABLES: - - ! temporary variables corresponding to the components of lnd2atm_params_type - logical :: melt_non_icesheet_ice_runoff - - integer :: ierr ! error code - integer :: unitn ! unit for namelist file - character(len=*), parameter :: nmlname = 'lnd2atm_inparm' - - character(len=*), parameter :: subname = 'ReadNamelist' - !----------------------------------------------------------------------- - - namelist /lnd2atm_inparm/ melt_non_icesheet_ice_runoff - - ! Initialize namelist variables to defaults - melt_non_icesheet_ice_runoff = .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=lnd2atm_inparm, iostat=ierr) - if (ierr /= 0) then - call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) - end if - else - write(iulog,*) "could NOT find "//nmlname//"namelist" - end if - call relavu( unitn ) - end if - - call shr_mpi_bcast(melt_non_icesheet_ice_runoff, mpicom) - - if (masterproc) then - write(iulog,*) - write(iulog,*) nmlname, ' settings:' - write(iulog,nml=lnd2atm_inparm) - write(iulog,*) ' ' - end if - - this%params = lnd2atm_params_type( & - melt_non_icesheet_ice_runoff = melt_non_icesheet_ice_runoff) - - end subroutine ReadNamelist - !----------------------------------------------------------------------- subroutine InitHistory(this, bounds) ! @@ -271,11 +145,9 @@ subroutine InitHistory(this, bounds) 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%eflx_sh_tot_grc(begg:endg) = 0._r8 @@ -285,37 +157,6 @@ subroutine InitHistory(this, bounds) &(includes corrections for land use change, rain/snow conversion and conversion of ice runoff to liquid)', & ptr_lnd=this%eflx_sh_tot_grc) - this%eflx_sh_ice_to_liq_col(begc:endc) = 0._r8 - call hist_addfld1d (fname='FSH_RUNOFF_ICE_TO_LIQ', units='W/m^2', & - avgflag='A', & - long_name='sensible heat flux generated from conversion of ice runoff to liquid', & - ptr_col=this%eflx_sh_ice_to_liq_col) - - this%qflx_rofliq_grc(begg:endg) = 0._r8 - call hist_addfld1d (fname='QRUNOFF_TO_COUPLER', units='mm/s', & - avgflag='A', & - long_name='total liquid runoff sent to coupler (includes corrections for land use change)', & - ptr_lnd=this%qflx_rofliq_grc) - - this%qflx_rofice_grc(begg:endg) = 0._r8 - call hist_addfld1d (fname='QRUNOFF_ICE_TO_COUPLER', units='mm/s', & - avgflag='A', & - long_name='total ice runoff sent to coupler (includes corrections for land use change)', & - ptr_lnd=this%qflx_rofice_grc) - - this%qflx_liq_from_ice_col(begc:endc) = 0._r8 - call hist_addfld1d (fname='QRUNOFF_ICE_TO_LIQ', units='mm/s', & - avgflag='A', & - long_name='liquid runoff from converted ice runoff', & - ptr_col=this%qflx_liq_from_ice_col, default='inactive') - - this%net_carbon_exchange_grc(begg:endg) = spval - call hist_addfld1d(fname='FCO2', units='kgCO2/m2/s', & - avgflag='A', & - long_name='CO2 flux to atmosphere (+ to atm)', & - ptr_lnd=this%net_carbon_exchange_grc, & - default='inactive') - end subroutine InitHistory end module lnd2atmType diff --git a/src/main/lnd2glcMod.F90 b/src/main/lnd2glcMod.F90 deleted file mode 100644 index 9de7eba3..00000000 --- a/src/main/lnd2glcMod.F90 +++ /dev/null @@ -1,304 +0,0 @@ -module lnd2glcMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Handle arrays used for exchanging data from land model to glc - ! For now glc datais send and received on the lnd grid and decomposition. - ! - ! The fields sent from the lnd component to the glc component via - ! the coupler are labeled 's2x', or sno to coupler. - ! The fields received by the lnd component from the glc component - ! via the coupler are labeled 'x2s', or coupler to sno. - ! 'Sno' is a misnomer in that the exchanged data are related to - ! the ice beneath the snow, not the snow itself. But by CESM convention, - ! 'ice' refers to sea ice, not land ice. - ! - ! !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 : get_proc_bounds, bounds_type - use domainMod , only : ldomain - use clm_varpar , only : maxpatch_glcmec - use clm_varctl , only : iulog - use clm_varcon , only : spval, tfrz, namec - use column_varcon , only : col_itype_to_icemec_class - use landunit_varcon , only : istice_mec, istsoil - use abortutils , only : endrun - use GlacierSurfaceMassBalanceMod, only : glacier_smb_type - use TemperatureType , only : temperature_type - use LandunitType , only : lun - use ColumnType , only : col - use TopoMod , only : topo_type - ! - ! !PUBLIC TYPES: - implicit none - private - save - - ! land -> glc variables structure - type, public :: lnd2glc_type - real(r8), pointer :: tsrf_grc(:,:) => null() - real(r8), pointer :: topo_grc(:,:) => null() - real(r8), pointer :: qice_grc(:,:) => null() - - contains - - procedure, public :: Init - procedure, public :: update_lnd2glc - procedure, private :: InitAllocate - procedure, private :: InitHistory - - end type lnd2glc_type - - ! !PUBLIC MEMBER FUNCTIONS: - - ! The following is public simply to support unit testing, and should not generally be - ! called from outside this module. - ! - ! Note that it is not a type-bound procedure, because it doesn't actually involve the - ! lnd2glc_type. This suggests that perhaps it belongs in some other module. - public :: bareland_normalization ! compute normalization factor for fluxes from the bare land portion of the grid cell - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, bounds) - - class(lnd2glc_type) :: this - type(bounds_type), intent(in) :: bounds - - call this%InitAllocate(bounds) - call this%InitHistory(bounds) - - end subroutine Init - - !------------------------------------------------------------------------ - subroutine InitAllocate(this, bounds) - ! - ! !DESCRIPTION: - ! Initialize land variables required by glc - ! - ! !USES: - use clm_varcon , only : spval - use histFileMod, only : hist_addfld1d - ! - ! !ARGUMENTS: - class(lnd2glc_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: begg,endg - !------------------------------------------------------------------------ - - begg = bounds%begg; endg = bounds%endg - - allocate(this%tsrf_grc(begg:endg,0:maxpatch_glcmec)) ; this%tsrf_grc(:,:)=0.0_r8 - allocate(this%topo_grc(begg:endg,0:maxpatch_glcmec)) ; this%topo_grc(:,:)=0.0_r8 - allocate(this%qice_grc(begg:endg,0:maxpatch_glcmec)) ; this%qice_grc(:,:)=0.0_r8 - - end subroutine InitAllocate - - !------------------------------------------------------------------------ - subroutine InitHistory(this, bounds) - ! - ! !USES: - use histFileMod, only : hist_addfld1d,hist_addfld2d - ! - ! !ARGUMENTS: - class(lnd2glc_type) :: this - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - real(r8), pointer :: data2dptr(:,:) - integer :: begg, endg - !--------------------------------------------------------------------- - - begg = bounds%begg; endg = bounds%endg - - this%qice_grc(begg:endg,0:maxpatch_glcmec) = spval - ! For this and the following fields, set up a pointer to the field simply for the - ! sake of changing the indexing, so that levels start with an index of 1, as is - ! assumed by histFileMod - so levels go 1:(nec+1) rather than 0:nec - data2dptr => this%qice_grc(:,0:maxpatch_glcmec) - call hist_addfld2d (fname='QICE_FORC', units='mm/s', type2d='elevclas', & - avgflag='A', long_name='qice forcing sent to GLC', & - ptr_lnd=data2dptr, default='inactive') - - this%tsrf_grc(begg:endg,0:maxpatch_glcmec) = spval - data2dptr => this%tsrf_grc(:,0:maxpatch_glcmec) - call hist_addfld2d (fname='TSRF_FORC', units='K', type2d='elevclas', & - avgflag='A', long_name='surface temperature sent to GLC', & - ptr_lnd=data2dptr, default='inactive') - - this%topo_grc(begg:endg,0:maxpatch_glcmec) = spval - data2dptr => this%topo_grc(:,0:maxpatch_glcmec) - call hist_addfld2d (fname='TOPO_FORC', units='m', type2d='elevclas', & - avgflag='A', long_name='topograephic height sent to GLC', & - ptr_lnd=data2dptr, default='inactive') - - end subroutine InitHistory - - - !------------------------------------------------------------------------------ - subroutine update_lnd2glc(this, bounds, num_do_smb_c, filter_do_smb_c, & - temperature_inst, glacier_smb_inst, topo_inst, init) - ! - ! !DESCRIPTION: - ! Assign values to lnd2glc+ - ! - ! !ARGUMENTS: - class(lnd2glc_type) , intent(inout) :: this - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_do_smb_c ! number of columns in filter_do_smb_c - integer , intent(in) :: filter_do_smb_c(:) ! column filter: columns where smb calculations are performed - type(temperature_type) , intent(in) :: temperature_inst - type(glacier_smb_type) , intent(in) :: glacier_smb_inst - type(topo_type) , intent(in) :: topo_inst - logical , intent(in) :: init ! if true=>only set a subset of fields - ! - ! !LOCAL VARIABLES: - integer :: c, l, g, n, fc ! indices - logical, allocatable :: fields_assigned(:,:) ! tracks whether fields have already been assigned for each index [begg:endg, 0:maxpatch_glcmec] - real(r8) :: flux_normalization ! factor by which fluxes should be normalized - - character(len=*), parameter :: subname = 'update_lnd2glc' - !------------------------------------------------------------------------------ - - ! Initialize to reasonable defaults - - this%qice_grc(bounds%begg : bounds%endg, :) = 0._r8 - this%tsrf_grc(bounds%begg : bounds%endg, :) = tfrz - this%topo_grc(bounds%begg : bounds%endg, :) = 0._r8 - - ! Fill the lnd->glc data on the clm grid - - allocate(fields_assigned(bounds%begg:bounds%endg, 0:maxpatch_glcmec)) - fields_assigned(:,:) = .false. - - do fc = 1, num_do_smb_c - c = filter_do_smb_c(fc) - l = col%landunit(c) - g = col%gridcell(c) - - ! Set vertical index and a flux normalization, based on whether the column in question is glacier or vegetated. - if (lun%itype(l) == istice_mec) then - n = col_itype_to_icemec_class(col%itype(c)) - flux_normalization = 1.0_r8 - else if (lun%itype(l) == istsoil) then - n = 0 !0-level index (bareland information) - flux_normalization = bareland_normalization(c) - else - ! Other landunit types do not pass information in the lnd2glc fields. - ! Note: for this to be acceptable, we need virtual vegetated columns in any grid - ! cell that is made up solely of glacier plus some other special landunit (e.g., - ! glacier + lake) -- otherwise CISM wouldn't have any information for the non- - ! glaciated portion of the grid cell. - cycle - end if - - ! Make sure we haven't already assigned the coupling fields for this point - ! (this could happen, for example, if there were multiple columns in the - ! istsoil landunit, which we aren't prepared to handle) - if (fields_assigned(g,n)) then - write(iulog,*) subname//' ERROR: attempt to assign coupling fields twice for the same index.' - write(iulog,*) 'One possible cause is having multiple columns in the istsoil landunit,' - write(iulog,*) 'which this routine cannot handle.' - write(iulog,*) 'g, n = ', g, n - call endrun(decomp_index=c, clmlevel=namec, msg=errMsg(sourcefile, __LINE__)) - end if - - ! Send surface temperature, topography, and SMB flux (qice) to coupler. - ! t_soisno and topo_col are valid even in initialization, so tsrf and topo - ! are set here regardless of the value of init. But qflx_glcice is not valid - ! until the run loop; thus, in initialization, we will use the default value - ! for qice, as set above. - fields_assigned(g,n) = .true. - this%tsrf_grc(g,n) = temperature_inst%t_soisno_col(c,1) - this%topo_grc(g,n) = topo_inst%topo_col(c) - if (.not. init) then - this%qice_grc(g,n) = glacier_smb_inst%qflx_glcice_col(c) * flux_normalization - - ! Check for bad values of qice - if ( abs(this%qice_grc(g,n)) > 1.0_r8) then - write(iulog,*) 'WARNING: qice out of bounds: g, n, qice =', g, n, this%qice_grc(g,n) - end if - end if - - end do - - deallocate(fields_assigned) - - end subroutine update_lnd2glc - - !----------------------------------------------------------------------- - real(r8) function bareland_normalization(c) - ! - ! !DESCRIPTION: - ! Compute normalization factor for fluxes from the bare land portion of the grid - ! cell. Fluxes should be multiplied by this factor before being sent to CISM. - ! - ! The point of this is: CISM effectively has two land cover types: glaciated and - ! bare. CLM, on the other hand, subdivides the bare land portion of the grid cell into - ! multiple landunits. However, we currently don't do any sort of averaging of - ! quantities computed in the different "bare land" landunits - instead, we simply send - ! the values computed in the natural vegetated landunit - these fluxes (like SMB) are - ! 0 in the other landunits. To achieve conservation, we need to normalize these - ! natural veg. fluxes by the fraction of the "bare land" area accounted for by the - ! natural veg. landunit. - ! - ! For example, consider a grid cell that is: - ! 60% glacier_mec - ! 30% natural veg - ! 10% lake - ! - ! According to CISM, this grid cell is 60% icesheet, 40% "bare land". Now suppose CLM - ! has an SMB flux of 1m in the natural veg landunit. If we simply sent 1m of ice to - ! CISM, conservation would be broken, since it would also apply 1m of ice to the 10% - ! of the grid cell that CLM says is lake. So, instead, we must multiply the 1m of ice - ! by (0.3/0.4), thus "spreading out" the SMB from the natural veg. landunit, so that - ! 0.75m of ice is grown throughout the bare land portion of CISM. - ! - ! Note: If the non-glaciated area of the grid cell is 0, then we arbitrarily return a - ! normalization factor of 1.0, in order to avoid divide-by-zero errors. - ! - ! Note: We currently aren't careful about how we would handle things if there are - ! multiple columns within the vegetated landunit. If that possibility were introduced, - ! this code - as well as the code in update_clm_s2x - may need to be reworked somewhat. - ! - ! !USES: - use subgridWeightsMod , only : get_landunit_weight - ! - ! !ARGUMENTS: - integer, intent(in) :: c ! column index - ! - ! !LOCAL VARIABLES: - integer :: g ! grid cell index - real(r8) :: area_glacier ! fractional area of the glacier_mec landunit in this grid cell - real(r8) :: area_this_col ! fractional area of column c in the grid cell - - real(r8), parameter :: tol = 1.e-13_r8 ! tolerance for checking subgrid weight equality - character(len=*), parameter :: subname = 'bareland_normalization' - !----------------------------------------------------------------------- - - g = col%gridcell(c) - - area_glacier = get_landunit_weight(g, istice_mec) - - if (abs(area_glacier - 1.0_r8) < tol) then - ! If the whole grid cell is glacier, then the normalization factor is arbitrary; - ! set it to 1 so we don't do any normalization in this case - bareland_normalization = 1.0_r8 - else - area_this_col = col%wtgcell(c) - bareland_normalization = area_this_col / (1.0_r8 - area_glacier) - end if - - end function bareland_normalization - -end module lnd2glcMod - diff --git a/src/main/ncdio_pio.F90.in b/src/main/ncdio_pio.F90.in index 6ee65a7e..91312f67 100644 --- a/src/main/ncdio_pio.F90.in +++ b/src/main/ncdio_pio.F90.in @@ -17,7 +17,7 @@ module ncdio_pio 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_varcon , only : spval,ispval, grlnd, nameg use clm_varctl , only : single_column, iulog use shr_sys_mod , only : shr_sys_flush use decompMod , only : get_clmlevel_gsize,get_clmlevel_gsmap @@ -1057,15 +1057,31 @@ contains call ncd_putatt(ncid, varid, 'cell_methods', trim(str)) end if if (present(fill_value)) then + if ( lxtype /= ncd_float .and. lxtype /= ncd_double )then + call shr_sys_abort(' ERROR: fill_value given, but data type is NOT double or float'//& + errMsg(sourcefile, __LINE__)) + end if call ncd_putatt(ncid, varid, '_FillValue', fill_value, lxtype) end if if (present(missing_value)) then + if ( lxtype /= ncd_float .and. lxtype /= ncd_double )then + call shr_sys_abort(' ERROR: missing_value given, but data type is NOT double or float'//& + errMsg(sourcefile, __LINE__)) + end if call ncd_putatt(ncid, varid, 'missing_value', missing_value, lxtype) end if if (present(ifill_value)) then + if ( lxtype /= ncd_int )then + call shr_sys_abort(' ERROR: ifill_value given, but data type is NOT int'//& + errMsg(sourcefile, __LINE__)) + end if call ncd_putatt(ncid, varid, '_FillValue', ifill_value, lxtype) end if if (present(imissing_value)) then + if ( lxtype /= ncd_int )then + call shr_sys_abort(' ERROR: imissing_value given, but data type is NOT int'//& + errMsg(sourcefile, __LINE__)) + end if call ncd_putatt(ncid, varid, 'missing_value', imissing_value, lxtype) end if if (present(nvalid_range)) then @@ -1362,9 +1378,14 @@ contains call ncd_inqvid (ncid, varname, varid, vardesc) #if ({DIMS}==0) start(1) = 1 ; count(1) = 1 - if (present(nt)) start(1) = nt ; count(1) = 1 - temp(1) = data - status = pio_put_var(ncid, varid, start(1:1), count(1:1), temp) + if (present(nt))then + start(1) = nt + count(1) = 1 + temp(1) = data + 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 @@ -2062,15 +2083,6 @@ contains 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 @@ -2118,113 +2130,6 @@ contains 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 diff --git a/src/main/ndepStreamMod.F90 b/src/main/ndepStreamMod.F90 deleted file mode 100644 index c6147255..00000000 --- a/src/main/ndepStreamMod.F90 +++ /dev/null @@ -1,126 +0,0 @@ -module ndepStreamMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Contains methods for reading in nitrogen deposition data file - ! Also includes functions for dynamic ndep file handling and - ! interpolation. - ! - ! !USES - use shr_kind_mod, only: r8 => shr_kind_r8, CL => shr_kind_cl - use mct_mod , only: mct_ggrid - use spmdMod , only: mpicom, iam - use clm_varctl , only: iulog - use abortutils , only: endrun - use decompMod , only: bounds_type, gsmap_lnd_gdc2glo - use domainMod , only: ldomain - - ! !PUBLIC TYPES: - implicit none - private - save - - public :: clm_domain_mct ! Sets up MCT domain for this resolution - - ! ! PRIVATE TYPES - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !============================================================================== - -contains - - !============================================================================== - subroutine clm_domain_mct(bounds, dom_clm) - - !------------------------------------------------------------------- - ! Set domain data type for internal clm grid - use clm_varcon , only : re - use domainMod , only : ldomain - use seq_flds_mod - use mct_mod , only : mct_ggrid, mct_gsMap_lsize, mct_gGrid_init - use mct_mod , only : mct_gsMap_orderedPoints, mct_gGrid_importIAttr - use mct_mod , only : mct_gGrid_importRAttr - implicit none - ! - ! arguments - type(bounds_type), intent(in) :: bounds - type(mct_ggrid), intent(out) :: dom_clm ! Output domain information for land model - ! - ! local variables - integer :: g,i,j ! index - integer :: lsize ! land model domain data size - real(r8), pointer :: data(:) ! temporary - integer , pointer :: idata(:) ! temporary - !------------------------------------------------------------------- - ! - ! Initialize mct domain type - ! lat/lon in degrees, area in radians^2, mask is 1 (land), 0 (non-land) - ! Note that in addition land carries around landfrac for the purposes of domain checking - ! - lsize = mct_gsMap_lsize(gsmap_lnd_gdc2glo, mpicom) - call mct_gGrid_init( GGrid=dom_clm, CoordChars=trim(seq_flds_dom_coord), & - OtherChars=trim(seq_flds_dom_other), lsize=lsize ) - ! - ! Allocate memory - ! - allocate(data(lsize)) - ! - ! Determine global gridpoint number attribute, GlobGridNum, which is set automatically by MCT - ! - call mct_gsMap_orderedPoints(gsmap_lnd_gdc2glo, iam, idata) - call mct_gGrid_importIAttr(dom_clm,'GlobGridNum',idata,lsize) - ! - ! Determine domain (numbering scheme is: West to East and South to North to South pole) - ! Initialize attribute vector with special value - ! - data(:) = -9999.0_R8 - call mct_gGrid_importRAttr(dom_clm,"lat" ,data,lsize) - call mct_gGrid_importRAttr(dom_clm,"lon" ,data,lsize) - call mct_gGrid_importRAttr(dom_clm,"area" ,data,lsize) - call mct_gGrid_importRAttr(dom_clm,"aream",data,lsize) - data(:) = 0.0_R8 - call mct_gGrid_importRAttr(dom_clm,"mask" ,data,lsize) - ! - ! Determine bounds - ! - ! Fill in correct values for domain components - ! Note aream will be filled in in the atm-lnd mapper - ! - do g = bounds%begg,bounds%endg - i = 1 + (g - bounds%begg) - data(i) = ldomain%lonc(g) - end do - call mct_gGrid_importRattr(dom_clm,"lon",data,lsize) - - do g = bounds%begg,bounds%endg - i = 1 + (g - bounds%begg) - data(i) = ldomain%latc(g) - end do - call mct_gGrid_importRattr(dom_clm,"lat",data,lsize) - - do g = bounds%begg,bounds%endg - i = 1 + (g - bounds%begg) - data(i) = ldomain%area(g)/(re*re) - end do - call mct_gGrid_importRattr(dom_clm,"area",data,lsize) - - do g = bounds%begg,bounds%endg - i = 1 + (g - bounds%begg) - data(i) = real(ldomain%mask(g), r8) - end do - call mct_gGrid_importRattr(dom_clm,"mask",data,lsize) - - do g = bounds%begg,bounds%endg - i = 1 + (g - bounds%begg) - data(i) = real(ldomain%frac(g), r8) - end do - call mct_gGrid_importRattr(dom_clm,"frac",data,lsize) - - deallocate(data) - deallocate(idata) - - end subroutine clm_domain_mct - -end module ndepStreamMod - diff --git a/src/main/organicFileMod.F90 b/src/main/organicFileMod.F90 deleted file mode 100644 index 3adbd5b6..00000000 --- a/src/main/organicFileMod.F90 +++ /dev/null @@ -1,113 +0,0 @@ -module organicFileMod - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: organicFileMod -! -! !DESCRIPTION: -! Contains methods for reading in organic matter data file which has -! organic matter density for each grid point and soil level -! -! !USES - use abortutils , only : endrun - use clm_varctl , only : iulog - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varcon , only : grlnd -! -! !PUBLIC TYPES: - implicit none - private - save -! -! !PUBLIC MEMBER FUNCTIONS: - public :: organicrd ! Read organic matter dataset -! -! !REVISION HISTORY: -! Created by David Lawrence, 4 May 2006 -! Revised by David Lawrence, 21 September 2007 -! Revised by David Lawrence, 14 October 2008 -! -!EOP -! -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: organicrd -! -! !INTERFACE: - subroutine organicrd(organic) -! -! !DESCRIPTION: -! Read the organic matter dataset. -! -! !USES: - use clm_varctl , only : fsurdat, single_column - use fileutils , only : getfil - use spmdMod , only : masterproc - use domainMod , only : ldomain - use ncdio_pio -! -! !ARGUMENTS: - implicit none - real(r8), pointer :: organic(:,:) ! organic matter density (kg/m3) -! -! !CALLED FROM: -! subroutine initialize in module initializeMod -! -! !REVISION HISTORY: -! Created by David Lawrence, 4 May 2006 -! Revised by David Lawrence, 21 September 2007 -! -! -! !LOCAL VARIABLES: -!EOP - character(len=256) :: locfn ! local file name - type(file_desc_t) :: ncid ! netcdf id - integer :: ni,nj,ns ! dimension sizes - logical :: isgrid2d ! true => file is 2d - logical :: readvar ! true => variable is on dataset - character(len=32) :: subname = 'organicrd' ! subroutine name -!----------------------------------------------------------------------- - - ! Initialize data to zero - no organic matter dataset - - organic(:,:) = 0._r8 - - ! Read data if file was specified in namelist - - if (fsurdat /= ' ') then - if (masterproc) then - write(iulog,*) 'Attempting to read organic matter data .....' - write(iulog,*) subname,trim(fsurdat) - end if - - call getfil (fsurdat, locfn, 0) - call ncd_pio_openfile (ncid, locfn, 0) - - call ncd_inqfdims (ncid, isgrid2d, ni, nj, ns) - if (ldomain%ns /= ns .or. ldomain%ni /= ni .or. ldomain%nj /= nj) then - write(iulog,*)trim(subname), 'ldomain and input file do not match dims ' - write(iulog,*)trim(subname), 'ldomain%ni,ni,= ',ldomain%ni,ni - write(iulog,*)trim(subname), 'ldomain%nj,nj,= ',ldomain%nj,nj - write(iulog,*)trim(subname), 'ldomain%ns,ns,= ',ldomain%ns,ns - call endrun() - end if - - call ncd_io(ncid=ncid, varname='ORGANIC', flag='read', data=organic, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun('organicrd: errror reading ORGANIC') - - if ( masterproc )then - write(iulog,*) 'Successfully read organic matter data' - write(iulog,*) - end if - endif - - end subroutine organicrd - -end module organicFileMod diff --git a/src/main/paramUtilMod.F90 b/src/main/paramUtilMod.F90 deleted file mode 100644 index 96c95440..00000000 --- a/src/main/paramUtilMod.F90 +++ /dev/null @@ -1,291 +0,0 @@ -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, var_desc, readvar) - 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/src/main/pftconMod.F90 b/src/main/pftconMod.F90 deleted file mode 100644 index 4714fca0..00000000 --- a/src/main/pftconMod.F90 +++ /dev/null @@ -1,1374 +0,0 @@ -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 - ! - ! Vegetation type constants - ! - integer :: noveg ! value for not vegetated - integer :: ndllf_evr_tmp_tree ! value for Needleleaf evergreen temperate tree - integer :: ndllf_evr_brl_tree ! value for Needleleaf evergreen boreal tree - integer :: ndllf_dcd_brl_tree ! value for Needleleaf deciduous boreal tree - integer :: nbrdlf_evr_trp_tree ! value for Broadleaf evergreen tropical tree - integer :: nbrdlf_evr_tmp_tree ! value for Broadleaf evergreen temperate tree - integer :: nbrdlf_dcd_trp_tree ! value for Broadleaf deciduous tropical tree - integer :: nbrdlf_dcd_tmp_tree ! value for Broadleaf deciduous temperate tree - integer :: nbrdlf_dcd_brl_tree ! value for Broadleaf deciduous boreal tree - integer :: ntree ! value for last type of tree - integer :: nbrdlf_evr_shrub ! value for Broadleaf evergreen shrub - integer :: nbrdlf_dcd_tmp_shrub ! value for Broadleaf deciduous temperate shrub - integer :: nbrdlf_dcd_brl_shrub ! value for Broadleaf deciduous boreal shrub - integer :: nc3_arctic_grass ! value for C3 arctic grass - integer :: nc3_nonarctic_grass ! value for C3 non-arctic grass - integer :: nc4_grass ! value for C4 grass - integer :: npcropmin ! value for first crop - integer :: ntmp_corn ! value for temperate corn, rain fed (rf) - integer :: nirrig_tmp_corn ! value for temperate corn, irrigated (ir) - integer :: nswheat ! value for spring temperate cereal (rf) - integer :: nirrig_swheat ! value for spring temperate cereal (ir) - integer :: nwwheat ! value for winter temperate cereal (rf) - integer :: nirrig_wwheat ! value for winter temperate cereal (ir) - integer :: ntmp_soybean ! value for temperate soybean (rf) - integer :: nirrig_tmp_soybean ! value for temperate soybean (ir) - integer :: nbarley ! value for spring barley (rf) - integer :: nirrig_barley ! value for spring barley (ir) - integer :: nwbarley ! value for winter barley (rf) - integer :: nirrig_wbarley ! value for winter barley (ir) - integer :: nrye ! value for spring rye (rf) - integer :: nirrig_rye ! value for spring rye (ir) - integer :: nwrye ! value for winter rye (rf) - integer :: nirrig_wrye ! value for winter rye (ir) - integer :: ncassava ! ...and so on - integer :: nirrig_cassava - integer :: ncitrus - integer :: nirrig_citrus - integer :: ncocoa - integer :: nirrig_cocoa - integer :: ncoffee - integer :: nirrig_coffee - integer :: ncotton - integer :: nirrig_cotton - integer :: ndatepalm - integer :: nirrig_datepalm - integer :: nfoddergrass - integer :: nirrig_foddergrass - integer :: ngrapes - integer :: nirrig_grapes - integer :: ngroundnuts - integer :: nirrig_groundnuts - integer :: nmillet - integer :: nirrig_millet - integer :: noilpalm - integer :: nirrig_oilpalm - integer :: npotatoes - integer :: nirrig_potatoes - integer :: npulses - integer :: nirrig_pulses - integer :: nrapeseed - integer :: nirrig_rapeseed - integer :: nrice - integer :: nirrig_rice - integer :: nsorghum - integer :: nirrig_sorghum - integer :: nsugarbeet - integer :: nirrig_sugarbeet - integer :: nsugarcane - integer :: nirrig_sugarcane - integer :: nsunflower - integer :: nirrig_sunflower - integer :: nmiscanthus - integer :: nirrig_miscanthus - integer :: nswitchgrass - integer :: nirrig_switchgrass - integer :: ntrp_corn !value for tropical corn (rf) - integer :: nirrig_trp_corn !value for tropical corn (ir) - integer :: ntrp_soybean !value for tropical soybean (rf) - integer :: nirrig_trp_soybean !value for tropical soybean (ir) - integer :: npcropmax ! value for last prognostic crop in list - integer :: nc3crop ! value for generic crop (rf) - integer :: 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 :: num_cfts_known_to_model - - ! !PUBLIC TYPES: - type, public :: pftcon_type - - integer , allocatable :: noveg (:) ! value for not vegetated - integer , allocatable :: tree (:) ! tree 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 :: 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) - - ! 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) - 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 (:) - - ! 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, parameter :: pftname_len = 40 ! max length of pftname - character(len=pftname_len) :: pftname(0:mxpft) ! PFT description - - real(r8), parameter :: reinickerp = 1.6_r8 ! parameter in allometric equation - real(r8), parameter :: dwood = 2.5e5_r8 ! cn wood density (gC/m3); lpj:2.0e5 - real(r8), parameter :: allom1 = 100.0_r8 ! parameters in - real(r8), parameter :: allom2 = 40.0_r8 ! ...allometric - real(r8), parameter :: allom3 = 0.5_r8 ! ...equations - real(r8), parameter :: allom1s = 250.0_r8 ! modified for shrubs by - real(r8), parameter :: allom2s = 8.0_r8 ! X.D.Z -! root radius, density from Bonan, GMD, 2014 - real(r8), parameter :: root_density = 0.31e06_r8 !(g biomass / m3 root) - real(r8), 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%tree (0:mxpft)); this%tree (:) =huge(1) - - 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%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) ) - 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%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) ) - - - 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 : paramfile, use_flexibleCN, use_dynroot - use spmdMod , only : masterproc - ! - ! !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('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__)) - - 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('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 numpft - 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 - - if (m <= ntree) then - this%tree(m) = 1 - else - this%tree(m) = 0 - end if - 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_pio_closefile(ncid) - - do i = 0, mxpft - 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 - - 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 - - ntree = nbrdlf_dcd_brl_tree ! value for last type of tree - 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() - - if (use_cndv) then - this%fcur(:) = this%fcurdv(:) - end if - ! - ! Do some error checking. - ! - ! FIX(SPM,032414) double check if some of these should be on... - - 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 - end do - - 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%tree) - - 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%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) - 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%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) - - end subroutine Clean - -end module pftconMod - diff --git a/src/main/readParamsMod.F90 b/src/main/readParamsMod.F90 deleted file mode 100644 index d2c2393e..00000000 --- a/src/main/readParamsMod.F90 +++ /dev/null @@ -1,100 +0,0 @@ -module readParamsMod - - !----------------------------------------------------------------------- - ! - ! Read parameters - ! module used to read parameters for individual modules and/or for some - ! well defined functionality (eg. ED). - ! - ! ! USES: - use clm_varctl , only : paramfile, iulog, use_fates, use_cn - use spmdMod , only : masterproc - use fileutils , only : getfil - use ncdio_pio , only : ncd_pio_closefile, ncd_pio_openfile - use ncdio_pio , only : file_desc_t , ncd_inqdid, ncd_inqdlen - - implicit none - private - ! - public :: readParameters - - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine readParameters (photosyns_inst) - ! - ! ! USES: - use CNSharedParamsMod , only : CNParamsReadShared - use CNGapMortalityMod , only : readCNGapMortParams => readParams - use CNMRespMod , only : readCNMRespParams => readParams - use CNPhenologyMod , only : readCNPhenolParams => readParams - use SoilBiogeochemNLeachingMod , only : readSoilBiogeochemNLeachingParams => readParams - use SoilBiogeochemNitrifDenitrifMod , only : readSoilBiogeochemNitrifDenitrifParams => readParams - use SoilBiogeochemLittVertTranspMod , only : readSoilBiogeochemLittVertTranspParams => readParams - use SoilBiogeochemPotentialMod , only : readSoilBiogeochemPotentialParams => readParams - use SoilBiogeochemDecompMod , only : readSoilBiogeochemDecompParams => readParams - use SoilBiogeochemDecompCascadeBGCMod , only : readSoilBiogeochemDecompBgcParams => readParams - use SoilBiogeochemDecompCascadeCNMod , only : readSoilBiogeochemDecompCnParams => readParams - !use ch4Mod , only : readCH4Params => readParams - use clm_varctl, only : NLFilename_in - use PhotosynthesisMod , only : photosyns_type - ! - ! !ARGUMENTS: - type(photosyns_type) , intent(in) :: photosyns_inst - ! - ! !LOCAL VARIABLES: - character(len=256) :: locfn ! local file name - type(file_desc_t) :: ncid ! pio netCDF file id - integer :: dimid ! netCDF dimension id - integer :: npft ! number of pfts on pft-physiology file - character(len=32) :: subname = 'readParameters' - !----------------------------------------------------------------------- - - if (masterproc) then - write(iulog,*) 'paramMod.F90::'//trim(subname)//' :: reading CLM '//' parameters ' - 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) - - ! - ! Above ground biogeochemistry... - ! - if (use_cn) then - call readCNGapMortParams(ncid) - call readCNMRespParams(ncid) - call readCNPhenolParams(ncid) - end if - - ! - ! Soil biogeochemistry... - ! - if (use_cn .or. use_fates) then - call readSoilBiogeochemDecompBgcParams(ncid) - call readSoilBiogeochemDecompCnParams(ncid) - call readSoilBiogeochemDecompParams(ncid) - call readSoilBiogeochemLittVertTranspParams(ncid) - call readSoilBiogeochemNitrifDenitrifParams(ncid) - call readSoilBiogeochemNLeachingParams(ncid) - call readSoilBiogeochemPotentialParams(ncid) - call CNParamsReadShared(ncid, NLFilename_in) ! this is called CN params but really is for the soil biogeochem parameters - - !call readCH4Params (ncid) - end if - - ! - ! Biogeophysics - ! - call photosyns_inst%ReadParams( ncid ) - - - ! - call ncd_pio_closefile(ncid) - - end subroutine readParameters - -end module readParamsMod diff --git a/src/main/restFileMod.F90 b/src/main/restFileMod.F90 index 7d0354a9..531686d2 100644 --- a/src/main/restFileMod.F90 +++ b/src/main/restFileMod.F90 @@ -13,18 +13,15 @@ module restFileMod use abortutils , only : endrun use shr_log_mod , only : errMsg => shr_log_errMsg use clm_time_manager , only : timemgr_restart_io, get_nstep - use subgridRestMod , only : subgridRestWrite, subgridRestRead, subgridRest_read_cleanup + use subgridRestMod , only : subgridRestWrite use accumulMod , only : accumulRest use clm_instMod , only : clm_instRest use histFileMod , only : hist_restart_ncd - use clm_varctl , only : iulog, use_fates, use_hydrstress - use clm_varctl , only : create_crop_landunit, irrigate - use clm_varcon , only : nameg, namel, namec, namep, nameCohort + use clm_varctl , only : iulog + use clm_varcon , only : nameg use ncdio_pio , only : file_desc_t, ncd_pio_createfile, ncd_pio_openfile, ncd_global use ncdio_pio , only : ncd_pio_closefile, ncd_defdim, ncd_putatt, ncd_enddef, check_dim use ncdio_pio , only : check_att, ncd_getatt - use glcBehaviorMod , only : glc_behavior_type - use reweightMod , only : reweight_wrapup ! ! !PUBLIC TYPES: implicit none @@ -39,15 +36,11 @@ module restFileMod public :: restFile_filename ! Sets restart filename ! ! !PRIVATE MEMBER FUNCTIONS: - private :: restFile_set_derived ! On a read, set variables derived from others private :: restFile_read_pfile private :: restFile_write_pfile ! Writes restart pointer file private :: restFile_closeRestart ! Close restart file and write restart pointer file private :: restFile_dimset private :: restFile_add_flag_metadata ! Add global metadata for some logical flag - private :: restFile_add_ilun_metadata ! Add global metadata defining landunit types - private :: restFile_add_icol_metadata ! Add global metadata defining column types - private :: restFile_add_ipft_metadata ! Add global metadata defining patch types private :: restFile_dimcheck private :: restFile_enddef private :: restFile_check_consistency ! Perform consistency checks on the restart file @@ -139,7 +132,7 @@ subroutine restFile_write( bounds, file, rdate, noptr) end subroutine restFile_write !----------------------------------------------------------------------- - subroutine restFile_read( bounds_proc, file, glc_behavior ) + subroutine restFile_read( bounds_proc, file) ! ! !DESCRIPTION: ! Read a CLM restart file. @@ -147,7 +140,6 @@ subroutine restFile_read( bounds_proc, file, glc_behavior ) ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds_proc ! processor-level bounds character(len=*) , intent(in) :: file ! output netcdf restart file - type(glc_behavior_type), intent(in) :: glc_behavior ! ! !LOCAL VARIABLES: type(file_desc_t) :: ncid ! netcdf id @@ -172,29 +164,10 @@ subroutine restFile_read( bounds_proc, file, glc_behavior ) call restFile_dimcheck( ncid ) - call subgridRestRead(bounds_proc, ncid) - - ! Now that we have updated subgrid information, update the filters, active flags, - ! etc. accordingly. We do these updates as soon as possible so that the updated - ! filters and active flags are available to other restart routines - e.g., for the - ! sake of subgridAveMod calls like c2g. - ! - ! The reweight_wrapup call needs to be done inside a clump loop, so we set that up - ! here. - nclumps = get_proc_clumps() - !$OMP PARALLEL DO PRIVATE (nc, bounds_clump) - do nc = 1, nclumps - call get_clump_bounds(nc, bounds_clump) - call reweight_wrapup(bounds_clump, glc_behavior) - end do - !$OMP END PARALLEL DO - call accumulRest( ncid, flag='read' ) call clm_instRest( bounds_proc, ncid, flag='read' ) - call restFile_set_derived(bounds_proc, glc_behavior) - call hist_restart_ncd (bounds_proc, ncid, flag='read' ) ! Do error checking on file @@ -203,7 +176,6 @@ subroutine restFile_read( bounds_proc, file, glc_behavior ) ! Close file - call subgridRest_read_cleanup call restFile_close( ncid ) ! Write out diagnostic info @@ -259,8 +231,8 @@ subroutine restFile_getfile( file, path ) end if call getfil( path, file, 0 ) - ! tcraig, adding xx. and .clm2 makes this more robust - ctest = 'xx.'//trim(caseid)//'.clm2' + ! tcraig, adding xx. and .slim makes this more robust + ctest = 'xx.'//trim(caseid)//'.slim' ftest = 'xx.'//trim(file) status = index(trim(ftest),trim(ctest)) if (status /= 0 .and. .not.(brnch_retain_casename)) then @@ -278,34 +250,6 @@ subroutine restFile_getfile( file, path ) end subroutine restFile_getfile - !----------------------------------------------------------------------- - subroutine restFile_set_derived(bounds, glc_behavior) - ! - ! !DESCRIPTION: - ! Upon a restart read, set variables that are not on the restart file, but can be - ! derived from variables that are on the restart file. - ! - ! This should be called after variables are read from the restart file. - ! - ! !USES: - ! - ! NOTE(wjs, 2016-04-05) Is it an architectural violation to use topo_inst directly - ! here? I can't see a good way around it. - use clm_instMod, only : topo_inst - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - type(glc_behavior_type), intent(in) :: glc_behavior - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'restFile_set_derived' - !----------------------------------------------------------------------- - - call glc_behavior%update_glc_classes(bounds, topo_inst%topo_col(bounds%begc:bounds%endc)) - - end subroutine restFile_set_derived - !----------------------------------------------------------------------- subroutine restFile_read_pfile( pnamer ) ! @@ -465,7 +409,7 @@ character(len=256) function restFile_filename( rdate ) character(len=*), intent(in) :: rdate ! input date for restart file name !----------------------------------------------------------------------- - restFile_filename = "./"//trim(caseid)//".clm2"//trim(inst_suffix)//& + restFile_filename = "./"//trim(caseid)//".slim"//trim(inst_suffix)//& ".r."//trim(rdate)//".nc" if (masterproc) then write(iulog,*)'writing restart file ',trim(restFile_filename),' for model date = ',rdate @@ -481,10 +425,9 @@ subroutine restFile_dimset( ncid ) ! ! !USES: use clm_time_manager , only : get_nstep - use clm_varctl , only : caseid, ctitle, version, username, hostname, fsurdat + use clm_varctl , only : caseid, ctitle, version, username, hostname, mml_surdat use clm_varctl , only : conventions, source - use clm_varpar , only : numrad, nlevlak, nlevsno, nlevgrnd, nlevurb, nlevcan - use clm_varpar , only : maxpatch_glcmec, nvegwcs + use clm_varpar , only : numrad, nlevgrnd use decompMod , only : get_proc_global ! ! !ARGUMENTS: @@ -493,10 +436,6 @@ subroutine restFile_dimset( ncid ) ! !LOCAL VARIABLES: integer :: dimid ! netCDF dimension id 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 - integer :: numCohort ! total number of cohorts across all processors integer :: ier ! error status integer :: strlen_dimid ! string dimension id character(len= 8) :: curdate ! current date @@ -505,29 +444,15 @@ subroutine restFile_dimset( ncid ) character(len= 32) :: subname='restFile_dimset' ! subroutine name !------------------------------------------------------------------------ - call get_proc_global(ng=numg, nl=numl, nc=numc, np=nump, nCohorts=numCohort) + call get_proc_global(ng=numg) ! Define dimensions call ncd_defdim(ncid , nameg , numg , dimid) - call ncd_defdim(ncid , namel , numl , dimid) - call ncd_defdim(ncid , namec , numc , dimid) - call ncd_defdim(ncid , namep , nump , dimid) - call ncd_defdim(ncid , nameCohort , numCohort , dimid) call ncd_defdim(ncid , 'levgrnd' , nlevgrnd , dimid) - call ncd_defdim(ncid , 'levurb' , nlevurb , dimid) - call ncd_defdim(ncid , 'levlak' , nlevlak , dimid) - call ncd_defdim(ncid , 'levsno' , nlevsno , dimid) - call ncd_defdim(ncid , 'levsno1' , nlevsno+1 , dimid) - call ncd_defdim(ncid , 'levtot' , nlevsno+nlevgrnd, dimid) call ncd_defdim(ncid , 'numrad' , numrad , dimid) - call ncd_defdim(ncid , 'levcan' , nlevcan , dimid) - if ( use_hydrstress ) then - call ncd_defdim(ncid , 'vegwcs' , nvegwcs , dimid) - end if call ncd_defdim(ncid , 'string_length', 64 , dimid) - call ncd_defdim(ncid , 'glc_nec', maxpatch_glcmec, dimid) ! mml add my soil dimension call ncd_defdim(ncid , 'mml_lev' , 10 , dimid) ! mml: hard coded for six soil layers @@ -548,22 +473,9 @@ subroutine restFile_dimset( ncid ) call ncd_putatt(ncid, NCD_GLOBAL, 'revision_id' , trim(str)) call ncd_putatt(ncid, NCD_GLOBAL, 'case_title' , trim(ctitle)) call ncd_putatt(ncid, NCD_GLOBAL, 'case_id' , trim(caseid)) - call ncd_putatt(ncid, NCD_GLOBAL, 'surface_dataset', trim(fsurdat)) + call ncd_putatt(ncid, NCD_GLOBAL, 'surface_dataset', trim(mml_surdat)) call ncd_putatt(ncid, NCD_GLOBAL, 'title', 'CLM Restart information') - call restFile_add_flag_metadata(ncid, create_crop_landunit, 'create_crop_landunit') - call restFile_add_flag_metadata(ncid, irrigate, 'irrigate') - ! BACKWARDS_COMPATIBILITY(wjs, 2017-12-13) created_glacier_mec_landunits is always - ! true now. However, we can't remove the read of this field from init_interp until we - ! can reliably assume that all initial conditions files that might be used in - ! init_interp have this flag .true. So until then, we write the flag with a - ! hard-coded .true. value. - call restFile_add_flag_metadata(ncid, .true., 'created_glacier_mec_landunits') - - call restFile_add_ipft_metadata(ncid) - call restFile_add_icol_metadata(ncid) - call restFile_add_ilun_metadata(ncid) - end subroutine restFile_dimset !----------------------------------------------------------------------- @@ -593,86 +505,6 @@ subroutine restFile_add_flag_metadata(ncid, flag, flag_name) end subroutine restFile_add_flag_metadata - !----------------------------------------------------------------------- - subroutine restFile_add_ilun_metadata(ncid) - ! - ! !DESCRIPTION: - ! Add global metadata defining landunit types - ! - ! !USES: - use landunit_varcon, only : max_lunit, landunit_names, landunit_name_length - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: ncid ! local file id - ! - ! !LOCAL VARIABLES: - integer :: ltype ! landunit type - character(len=*), parameter :: att_prefix = 'ilun_' ! prefix for attributes - character(len=len(att_prefix)+landunit_name_length) :: attname ! attribute name - - character(len=*), parameter :: subname = 'restFile_add_ilun_metadata' - !----------------------------------------------------------------------- - - do ltype = 1, max_lunit - attname = att_prefix // landunit_names(ltype) - call ncd_putatt(ncid, ncd_global, attname, ltype) - end do - - end subroutine restFile_add_ilun_metadata - - !----------------------------------------------------------------------- - subroutine restFile_add_icol_metadata(ncid) - ! - ! !DESCRIPTION: - ! Add global metadata defining column types - ! - ! !USES: - use column_varcon, only : write_coltype_metadata - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: ncid ! local file id - ! - ! !LOCAL VARIABLES: - character(len=*), parameter :: att_prefix = 'icol_' ! prefix for attributes - - character(len=*), parameter :: subname = 'restFile_add_icol_metadata' - !----------------------------------------------------------------------- - - call write_coltype_metadata(att_prefix, ncid) - - end subroutine restFile_add_icol_metadata - - !----------------------------------------------------------------------- - subroutine restFile_add_ipft_metadata(ncid) - ! - ! !DESCRIPTION: - ! Add global metadata defining patch types - ! - ! !USES: - use clm_varpar, only : natpft_lb, mxpft, cft_lb, cft_ub - use pftconMod , only : pftname_len, pftname - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: ncid ! local file id - ! - ! !LOCAL VARIABLES: - integer :: ptype ! patch type - character(len=*), parameter :: att_prefix = 'ipft_' ! prefix for attributes - character(len=len(att_prefix)+pftname_len) :: attname ! attribute name - - character(len=*), parameter :: subname = 'restFile_add_ipft_metadata' - !----------------------------------------------------------------------- - - do ptype = natpft_lb, mxpft - attname = att_prefix // pftname(ptype) - call ncd_putatt(ncid, ncd_global, attname, ptype) - end do - - call ncd_putatt(ncid, ncd_global, 'cft_lb', cft_lb) - call ncd_putatt(ncid, ncd_global, 'cft_ub', cft_ub) - - end subroutine restFile_add_ipft_metadata - !----------------------------------------------------------------------- subroutine restFile_dimcheck( ncid ) ! @@ -681,7 +513,7 @@ subroutine restFile_dimcheck( ncid ) ! ! !USES: use decompMod, only : get_proc_global - use clm_varpar, only : nlevsno, nlevlak, nlevgrnd, nlevurb + use clm_varpar, only : nlevgrnd use clm_varctl, only : single_column, nsrest, nsrStartup ! ! !ARGUMENTS: @@ -689,10 +521,6 @@ subroutine restFile_dimcheck( ncid ) ! ! !LOCAL VARIABLES: 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 - integer :: numCohort ! total number of cohorts across all processors character(len=:), allocatable :: msg ! diagnostic message character(len=32) :: subname='restFile_dimcheck' ! subroutine name !----------------------------------------------------------------------- @@ -700,7 +528,7 @@ subroutine restFile_dimcheck( ncid ) ! Get relevant sizes if ( .not. single_column .or. nsrest /= nsrStartup )then - call get_proc_global(ng=numg, nl=numl, nc=numc, np=nump, nCohorts=numCohort) + call get_proc_global(ng=numg) msg = 'Did you mean to set use_init_interp = .true. in user_nl_clm?' // & new_line('x') // & '(Setting use_init_interp = .true. is needed when doing a' // & @@ -711,17 +539,8 @@ subroutine restFile_dimcheck( ncid ) new_line('x') // & 'or when running a resolution or configuration that differs from the initial conditions.)' call check_dim(ncid, nameg, numg, msg=msg) - call check_dim(ncid, namel, numl, msg=msg) - call check_dim(ncid, namec, numc, msg=msg) - call check_dim(ncid, namep, nump, msg=msg) - if ( use_fates ) call check_dim(ncid, nameCohort , numCohort, msg=msg) end if - call check_dim(ncid, 'levsno' , nlevsno, & - msg = 'You can deal with this mismatch by rerunning with ' // & - 'use_init_interp = .true. in user_nl_clm') call check_dim(ncid, 'levgrnd' , nlevgrnd) - call check_dim(ncid, 'levurb' , nlevurb) - call check_dim(ncid, 'levlak' , nlevlak) ! mml add check for my dim? call check_dim(ncid, 'mml_lev' , 10) ! mml add check for my dust dim? @@ -765,38 +584,28 @@ subroutine restFile_check_consistency(bounds, ncid) ! !DESCRIPTION: ! Perform some consistency checks on the restart file ! - ! !USES: - use subgridRestMod, only : subgridRest_check_consistency - ! ! !ARGUMENTS: type(bounds_type), intent(in) :: bounds ! bounds type(file_desc_t), intent(inout) :: ncid ! netcdf id ! ! !LOCAL VARIABLES: logical :: check_finidat_year_consistency ! whether to check consistency between year on finidat file and current year - logical :: check_finidat_pct_consistency ! whether to check consistency between pct_pft on finidat file and surface dataset character(len=*), parameter :: subname = 'restFile_check_consistency' !----------------------------------------------------------------------- call restFile_read_consistency_nl( & - check_finidat_year_consistency, & - check_finidat_pct_consistency) + check_finidat_year_consistency) if (check_finidat_year_consistency) then call restFile_check_year(ncid) end if - if (check_finidat_pct_consistency) then - call subgridRest_check_consistency(bounds) - end if - end subroutine restFile_check_consistency !----------------------------------------------------------------------- subroutine restFile_read_consistency_nl( & - check_finidat_year_consistency, & - check_finidat_pct_consistency) + check_finidat_year_consistency) ! ! !DESCRIPTION: @@ -810,7 +619,6 @@ subroutine restFile_read_consistency_nl( & ! ! !ARGUMENTS: logical, intent(out) :: check_finidat_year_consistency - logical, intent(out) :: check_finidat_pct_consistency ! ! !LOCAL VARIABLES: integer :: nu_nml ! unit for namelist file @@ -820,12 +628,10 @@ subroutine restFile_read_consistency_nl( & !----------------------------------------------------------------------- namelist /finidat_consistency_checks/ & - check_finidat_year_consistency, & - check_finidat_pct_consistency + check_finidat_year_consistency ! Set default namelist values check_finidat_year_consistency = .true. - check_finidat_pct_consistency = .true. ! Read namelist if (masterproc) then @@ -845,7 +651,6 @@ subroutine restFile_read_consistency_nl( & endif call shr_mpi_bcast (check_finidat_year_consistency, mpicom) - call shr_mpi_bcast (check_finidat_pct_consistency, mpicom) if (masterproc) then write(iulog,*) ' ' diff --git a/src/main/reweightMod.F90 b/src/main/reweightMod.F90 deleted file mode 100644 index 5816fa1d..00000000 --- a/src/main/reweightMod.F90 +++ /dev/null @@ -1,61 +0,0 @@ -module reweightMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Top level driver for things that happen when subgrid weights are changed. This is in - ! a separate module from subgridWeightsMod in order to keep subgridWeightsMod lower- - ! level - and particularly to break its dependency on filterMod. - ! - ! - ! !USES: -#include "shr_assert.h" - use shr_log_mod , only : errMsg => shr_log_errMsg - use shr_kind_mod , only : r8 => shr_kind_r8 - ! - ! PUBLIC TYPES: - implicit none - save - - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: reweight_wrapup ! do modifications and error-checks after modifying subgrid weights - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine reweight_wrapup(bounds, glc_behavior) - ! - ! !DESCRIPTION: - ! Do additional modifications and error-checks that should be done after modifying subgrid - ! weights - ! - ! This should be called whenever any weights change (e.g., patch weights on the column, - ! landunit weights on the grid cell, etc.). - ! - ! !USES: - use filterMod , only : setFilters - use subgridWeightsMod , only : set_active, check_weights - use decompMod , only : bounds_type, BOUNDS_LEVEL_CLUMP - use glcBehaviorMod , only : glc_behavior_type - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds ! clump bounds - type(glc_behavior_type), intent(in) :: glc_behavior - !------------------------------------------------------------------------ - - SHR_ASSERT(bounds%level == BOUNDS_LEVEL_CLUMP, errMsg(sourcefile, __LINE__)) - - call set_active(bounds, glc_behavior) - call check_weights(bounds, active_only=.false.) - call check_weights(bounds, active_only=.true.) - call setFilters(bounds, glc_behavior) - - end subroutine reweight_wrapup - -end module reweightMod diff --git a/src/main/subgridAveMod.F90 b/src/main/subgridAveMod.F90 deleted file mode 100644 index 3375add2..00000000 --- a/src/main/subgridAveMod.F90 +++ /dev/null @@ -1,1347 +0,0 @@ -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 - ! - ! !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((ubound(parr) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(carr) == (/bounds%endc/)), errMsg(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((ubound(parr) == (/bounds%endp, num2d/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(carr) == (/bounds%endc, num2d/)), errMsg(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((ubound(patcharr) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(colarr) == (/bounds%endc/)), errMsg(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((ubound(parr) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(larr) == (/bounds%endl/)), errMsg(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((ubound(parr) == (/bounds%endp, num2d/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(larr) == (/bounds%endl, num2d/)), errMsg(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((ubound(parr) == (/bounds%endp/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(garr) == (/bounds%endg/)), errMsg(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((ubound(parr) == (/bounds%endp, num2d/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(garr) == (/bounds%endg, num2d/)), errMsg(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) - ! - ! !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) - ! - ! !LOCAL VARIABLES: - 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((ubound(carr) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(larr) == (/bounds%endl/)), errMsg(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_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) .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((ubound(carr) == (/bounds%endc, num2d/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(larr) == (/bounds%endl, num2d/)), errMsg(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((ubound(carr) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(garr) == (/bounds%endg/)), errMsg(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((ubound(carr) == (/bounds%endc, num2d/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(garr) == (/bounds%endg, num2d/)), errMsg(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((ubound(larr) == (/bounds%endl/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(garr) == (/bounds%endg/)), errMsg(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((ubound(larr) == (/bounds%endl, num2d/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(garr) == (/bounds%endg, num2d/)), errMsg(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((ubound(scale_l2g) == (/bounds%endl/)), errMsg(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/src/main/subgridMod.F90 b/src/main/subgridMod.F90 deleted file mode 100644 index f844033a..00000000 --- a/src/main/subgridMod.F90 +++ /dev/null @@ -1,471 +0,0 @@ -module subgridMod - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! sub-grid data and mapping types and modules - ! - ! TODO(wjs, 2015-12-08) Much of the logic here duplicates (in some sense) logic in - ! initGridCellsMod. The duplication should probably be extracted into routines shared - ! between these modules (or the two modules should be combined into one). - ! - ! !USES: -#include "shr_assert.h" - 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 clm_instur , only : wt_lunit, urban_valid, wt_cft - use glcBehaviorMod , only : glc_behavior_type - - implicit none - private - save - - ! !PUBLIC MEMBER FUNCTIONS: - public :: subgrid_get_gcellinfo ! Obtain gridcell properties, summed across all landunits - - ! Routines to get info for each landunit: - public :: subgrid_get_info_natveg - public :: subgrid_get_info_cohort - public :: subgrid_get_info_urban_tbd - public :: subgrid_get_info_urban_hd - public :: subgrid_get_info_urban_md - public :: subgrid_get_info_lake - public :: subgrid_get_info_wetland - public :: subgrid_get_info_glacier_mec - public :: subgrid_get_info_crop - public :: crop_patch_exists ! returns true if the given crop patch should be created in memory - - ! !PRIVATE MEMBER FUNCTIONS: - private :: subgrid_get_info_urban - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !------------------------------------------------------------------------------ - subroutine subgrid_get_gcellinfo (gi, glc_behavior, & - nlunits, ncols, npatches, ncohorts) - ! - ! !DESCRIPTION: - ! Obtain gridcell properties, aggregated across all landunits - ! - ! !ARGUMENTS - integer , intent(in) :: gi ! grid cell index - type(glc_behavior_type), intent(in) :: glc_behavior - integer , intent(out) :: nlunits ! number of landunits - integer , intent(out) :: ncols ! number of columns - integer , intent(out) :: npatches ! number of patchs - integer , intent(out) :: ncohorts ! number of cohorts - ! - ! !LOCAL VARIABLES: - ! Counts from a single landunit: - integer :: ncohorts_temp - integer :: npatches_temp - integer :: ncols_temp - integer :: nlunits_temp - - ! atm_topo is arbitrary for the sake of getting these counts. We don't have a true - ! atm_topo value at the point of this call, so use 0. - real(r8), parameter :: atm_topo = 0._r8 - !------------------------------------------------------------------------------ - - npatches = 0 - ncols = 0 - nlunits = 0 - ncohorts = 0 - - call subgrid_get_info_natveg(gi, npatches_temp, ncols_temp, nlunits_temp) - call accumulate_counters() - - call subgrid_get_info_urban_tbd(gi, npatches_temp, ncols_temp, nlunits_temp) - call accumulate_counters() - - call subgrid_get_info_urban_hd(gi, npatches_temp, ncols_temp, nlunits_temp) - call accumulate_counters() - - call subgrid_get_info_urban_md(gi, npatches_temp, ncols_temp, nlunits_temp) - call accumulate_counters() - - call subgrid_get_info_lake(gi, npatches_temp, ncols_temp, nlunits_temp) - call accumulate_counters() - - call subgrid_get_info_wetland(gi, npatches_temp, ncols_temp, nlunits_temp) - call accumulate_counters() - - call subgrid_get_info_glacier_mec(gi, atm_topo, glc_behavior, & - npatches_temp, ncols_temp, nlunits_temp) - call accumulate_counters() - - call subgrid_get_info_crop(gi, npatches_temp, ncols_temp, nlunits_temp) - call accumulate_counters() - - call subgrid_get_info_cohort(gi,ncohorts) - - contains - subroutine accumulate_counters - ! Accumulate running sums of patches, columns and landunits. - ! - ! This uses local variables in the parent subroutine as both inputs and outputs - - npatches = npatches + npatches_temp - ncols = ncols + ncols_temp - nlunits = nlunits + nlunits_temp - - end subroutine accumulate_counters - - end subroutine subgrid_get_gcellinfo - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_natveg(gi, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for natural vegetated landunit in this grid cell - ! - ! !USES - use clm_varpar, only : natpft_size - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: npatches ! number of nat veg patches in this grid cell - integer, intent(out) :: ncols ! number of nat veg columns in this grid cell - integer, intent(out) :: nlunits ! number of nat veg landunits in this grid cell - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_natveg' - !----------------------------------------------------------------------- - - ! To support dynamic landunits, we have a naturally vegetated landunit in every grid - ! cell, because it might need to come into existence even if its weight is 0 at the - ! start of the run. And to support transient patches or dynamic vegetation, we always - ! allocate space for ALL patches on this landunit. - - npatches = natpft_size - - ! Assume that the vegetated landunit has one column - nlunits = 1 - ncols = 1 - - end subroutine subgrid_get_info_natveg - - ! ----------------------------------------------------------------------------- - - subroutine subgrid_get_info_cohort(gi, ncohorts) - ! - ! !DESCRIPTION: - ! Obtain cohort counts per each gridcell. - ! - ! !USES - use clm_varpar, only : natpft_size - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: ncohorts ! number of cohorts in this grid cell - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_cohort' - !----------------------------------------------------------------------- - - ! ------------------------------------------------------------------------- - ! Number of cohorts is set here - ! FATES cohorts populate all natural vegetation columns. - ! There is only one natural vegetation column per grid-cell. So allocations - ! are mapped to the gridcell. In the future we may have more than one site - ! per gridcell, and we just multiply that factor here. - ! It is possible that there may be gridcells that don't have a naturally - ! vegetated column. That case should be fine, as the cohort - ! restart vector will just be a little sparse. - ! ------------------------------------------------------------------------- - - ncohorts = 1 - - end subroutine subgrid_get_info_cohort - - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_urban_tbd(gi, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for urban tbd landunit in this grid cell - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: npatches ! number of urban tbd patches in this grid cell - integer, intent(out) :: ncols ! number of urban tbd columns in this grid cell - integer, intent(out) :: nlunits ! number of urban tbd landunits in this grid cell - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_urban_tbd' - !----------------------------------------------------------------------- - - call subgrid_get_info_urban(gi, npatches, ncols, nlunits) - - end subroutine subgrid_get_info_urban_tbd - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_urban_hd(gi, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for urban hd landunit in this grid cell - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: npatches ! number of urban hd patches in this grid cell - integer, intent(out) :: ncols ! number of urban hd columns in this grid cell - integer, intent(out) :: nlunits ! number of urban hd landunits in this grid cell - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_urban_hd' - !----------------------------------------------------------------------- - - call subgrid_get_info_urban(gi, npatches, ncols, nlunits) - - end subroutine subgrid_get_info_urban_hd - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_urban_md(gi, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for urban md landunit in this grid cell - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: npatches ! number of urban md patches in this grid cell - integer, intent(out) :: ncols ! number of urban md columns in this grid cell - integer, intent(out) :: nlunits ! number of urban md landunits in this grid cell - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_urban_md' - !----------------------------------------------------------------------- - - call subgrid_get_info_urban(gi, npatches, ncols, nlunits) - - end subroutine subgrid_get_info_urban_md - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_urban(gi, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for one of the urban landunits in this grid cell - ! - ! This is shared for all urban landunits, because currently they are all treated the same. - ! - ! !USES - use clm_varpar, only : maxpatch_urb - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: npatches ! number of urban patches in this grid cell, for one urban landunit - integer, intent(out) :: ncols ! number of urban columns in this grid cell, for one urban landunit - integer, intent(out) :: nlunits ! number of urban landunits in this grid cell, for one urban landunit - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_urban' - !----------------------------------------------------------------------- - - ! To support dynamic landunits, we have all urban landunits in every grid cell that - ! has valid urban parameters, because they might need to come into existence even if - ! their weight is 0 at the start of the run. And for simplicity, we always allocate - ! space for ALL columns on the urban landunits. - - if (urban_valid(gi)) then - npatches = maxpatch_urb - ncols = npatches - nlunits = 1 - else - npatches = 0 - ncols = 0 - nlunits = 0 - end if - - end subroutine subgrid_get_info_urban - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_lake(gi, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for lake landunit in this grid cell - ! - ! !USES: - use landunit_varcon, only : istdlak - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: npatches ! number of lake patches in this grid cell - integer, intent(out) :: ncols ! number of lake columns in this grid cell - integer, intent(out) :: nlunits ! number of lake landunits in this grid cell - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_lake' - !----------------------------------------------------------------------- - - ! We currently do NOT allow the lake landunit to expand via dynamic landunits, so we - ! only need to allocate space for it where its weight is currently non-zero. - - if (wt_lunit(gi, istdlak) > 0.0_r8) then - npatches = 1 - ncols = 1 - nlunits = 1 - else - npatches = 0 - ncols = 0 - nlunits = 0 - end if - - end subroutine subgrid_get_info_lake - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_wetland(gi, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for wetland landunit in this grid cell - ! - ! !USES: - use landunit_varcon, only : istwet - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: npatches ! number of wetland patches in this grid cell - integer, intent(out) :: ncols ! number of wetland columns in this grid cell - integer, intent(out) :: nlunits ! number of wetland landunits in this grid cell - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_wetland' - !----------------------------------------------------------------------- - - ! We currently do NOT allow the wetland landunit to expand via dynamic landunits, so we - ! only need to allocate space for it where its weight is currently non-zero. - - if (wt_lunit(gi, istwet) > 0.0_r8) then - npatches = 1 - ncols = 1 - nlunits = 1 - else - npatches = 0 - ncols = 0 - nlunits = 0 - end if - - end subroutine subgrid_get_info_wetland - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_glacier_mec(gi, atm_topo, glc_behavior, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for glacier_mec landunit in this grid cell - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - real(r8), intent(in) :: atm_topo ! atmosphere's topographic height for this grid cell (m) - type(glc_behavior_type), intent(in) :: glc_behavior - integer, intent(out) :: npatches ! number of glacier_mec patches in this grid cell - integer, intent(out) :: ncols ! number of glacier_mec columns in this grid cell - integer, intent(out) :: nlunits ! number of glacier_mec landunits in this grid cell - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgrid_get_info_glacier_mec' - !----------------------------------------------------------------------- - - call glc_behavior%get_num_glc_mec_subgrid(gi, atm_topo, npatches, ncols, nlunits) - - end subroutine subgrid_get_info_glacier_mec - - !----------------------------------------------------------------------- - subroutine subgrid_get_info_crop(gi, npatches, ncols, nlunits) - ! - ! !DESCRIPTION: - ! Obtain properties for crop landunit in this grid cell - ! - ! !USES: - use clm_varpar, only : cft_lb, cft_ub - ! - ! !ARGUMENTS: - integer, intent(in) :: gi ! grid cell index - integer, intent(out) :: npatches ! number of nat veg patches in this grid cell - integer, intent(out) :: ncols ! number of nat veg columns in this grid cell - integer, intent(out) :: nlunits ! number of nat veg landunits in this grid cell - ! - ! !LOCAL VARIABLES: - integer :: cft ! crop functional type index - - character(len=*), parameter :: subname = 'subgrid_get_info_crop' - !----------------------------------------------------------------------- - - npatches = 0 - - do cft = cft_lb, cft_ub - if (crop_patch_exists(gi, cft)) then - npatches = npatches + 1 - end if - end do - - if (npatches > 0) then - ncols = npatches - nlunits = 1 - else - ncols = 0 - nlunits = 0 - end if - - end subroutine subgrid_get_info_crop - - !----------------------------------------------------------------------- - function crop_patch_exists(gi, cft) result(exists) - ! - ! !DESCRIPTION: - ! Returns true if a patch should be created in memory for the given crop functional - ! type in this grid cell. - ! - ! This just applies to the crop landunit: it always returns .false. if - ! create_crop_landunit is .false. - ! - ! !USES: - use clm_varpar , only : cft_lb, cft_ub - use clm_varctl , only : create_crop_landunit - use pftconmod , only : pftcon - use landunit_varcon , only : istcrop - ! - ! !ARGUMENTS: - logical :: exists ! function result - integer, intent(in) :: gi ! grid cell index - integer, intent(in) :: cft ! crop functional type - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'crop_patch_exists' - !----------------------------------------------------------------------- - - if (create_crop_landunit) then - SHR_ASSERT(cft >= cft_lb, errMsg(sourcefile, __LINE__)) - SHR_ASSERT(cft <= cft_ub, errMsg(sourcefile, __LINE__)) - - ! For a run without transient crops, only allocate memory for crops that are - ! actually present in this run. (This will require running init_interp when - ! changing between a transient crop run and a non-transient run.) - if (wt_lunit(gi, istcrop) > 0.0_r8 .and. wt_cft(gi, cft) > 0.0_r8) then - exists = .true. - else - exists = .false. - end if - - else ! create_crop_landunit false - exists = .false. - end if - - end function crop_patch_exists - - - -end module subgridMod diff --git a/src/main/subgridRestMod.F90 b/src/main/subgridRestMod.F90 index 725db503..0ef02757 100644 --- a/src/main/subgridRestMod.F90 +++ b/src/main/subgridRestMod.F90 @@ -7,18 +7,12 @@ module subgridRestMod 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, BOUNDS_LEVEL_PROC, ldecomp + use decompMod , only : bounds_type, ldecomp use domainMod , only : ldomain - use clm_time_manager , only : get_curr_date - use clm_varcon , only : nameg, namel, namec, namep - use clm_varpar , only : nlevsno, nlevgrnd + use clm_varcon , only : nameg use pio , only : file_desc_t use ncdio_pio , only : ncd_int, ncd_double - use GetGlobalValuesMod , only : GetGlobalIndex use GridcellType , only : grc - use LandunitType , only : lun - use ColumnType , only : col - use PatchType , only : patch use restUtilMod ! ! !PUBLIC TYPES: @@ -28,17 +22,11 @@ module subgridRestMod ! ! !PUBLIC MEMBER FUNCTIONS: public :: subgridRestWrite ! handle restart writes of subgrid variables - public :: subgridRestRead ! handle restart reads of subgrid variables - public :: subgridRest_check_consistency ! check consistency of variables read by subgridRest - public :: subgridRest_read_cleanup ! do cleanup of variables allocated when reading the restart file; should be called after subgridRest and subgridRest_check_consistency are complete ! !PRIVATE MEMBER FUNCTIONS: private :: subgridRest_write_only ! handle restart of subgrid variables that only need to be written, not read - private :: subgridRest_write_and_read ! handle restart of subgrid variables that need to be read as well as written - private :: save_old_weights ! !PRIVATE TYPES: - real(r8), allocatable :: pft_wtlunit_before_rest_read(:) ! patch%wtlunit weights - saved values from before the restart read character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -63,29 +51,9 @@ subroutine subgridRestWrite(bounds, ncid, flag) !----------------------------------------------------------------------- call subgridRest_write_only(bounds, ncid, flag) - call subgridRest_write_and_read(bounds, ncid, flag) end subroutine subgridRestWrite - - !------------------------------------------------------------------------ - subroutine subgridRestRead(bounds, ncid) - ! - ! !DESCRIPTION: - ! Handle restart reads of subgrid variables - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds ! bounds - type(file_desc_t), intent(inout) :: ncid ! netCDF dataset id - ! - ! !LOCAL VARIABLES: - character(len=32) :: subname='subgridRestRead' ! subroutine name - !------------------------------------------------------------------------ - - call subgridRest_write_and_read(bounds, ncid, 'read') - - end subroutine subgridRestRead - !----------------------------------------------------------------------- subroutine subgridRest_write_only(bounds, ncid, flag) ! @@ -109,13 +77,7 @@ subroutine subgridRest_write_only(bounds, ncid, flag) integer :: g,l,c,p,i ! indices logical :: readvar ! temporary real(r8), pointer :: rgarr(:) ! temporary - real(r8), pointer :: rlarr(:) ! temporary - real(r8), pointer :: rcarr(:) ! temporary - real(r8), pointer :: rparr(:) ! temporary integer , pointer :: igarr(:) ! temporary - integer , pointer :: ilarr(:) ! temporary - integer , pointer :: icarr(:) ! temporary - integer , pointer :: iparr(:) ! temporary real(r8), pointer :: temp2d_r(:,:) ! temporary for multi-level variables integer , pointer :: temp2d_i(:,:) ! temporary for multi-level variables @@ -157,559 +119,6 @@ subroutine subgridRest_write_only(bounds, ncid, flag) deallocate(rgarr,igarr) - !------------------------------------------------------------------ - ! Write landunit info - !------------------------------------------------------------------ - - allocate(rlarr(bounds%begl:bounds%endl), ilarr(bounds%begl:bounds%endl)) - - do l=bounds%begl,bounds%endl - rlarr(l) = grc%londeg(lun%gridcell(l)) - enddo - - call restartvar(ncid=ncid, flag=flag, varname='land1d_lon', xtype=ncd_double, & - dim1name='landunit', & - long_name='landunit longitude', units='degrees_east', & - interpinic_flag='skip', readvar=readvar, data=rlarr) - - do l=bounds%begl,bounds%endl - rlarr(l) = grc%latdeg(lun%gridcell(l)) - enddo - call restartvar(ncid=ncid, flag=flag, varname='land1d_lat', xtype=ncd_double, & - dim1name='landunit', & - long_name='landunit latitude', units='degrees_north', & - interpinic_flag='skip', readvar=readvar, data=rlarr) - - do l=bounds%begl,bounds%endl - ilarr(l) = mod(ldecomp%gdc2glo(lun%gridcell(l))-1,ldomain%ni) + 1 - enddo - call restartvar(ncid=ncid, flag=flag, varname='land1d_ixy', xtype=ncd_int, & - dim1name='landunit', & - long_name='2d longitude index of corresponding landunit', & - interpinic_flag='skip', readvar=readvar, data=ilarr) - - do l=bounds%begl,bounds%endl - ilarr(l) = (ldecomp%gdc2glo(lun%gridcell(l))-1)/ldomain%ni + 1 - end do - call restartvar(ncid=ncid, flag=flag, varname='land1d_jxy', xtype=ncd_int, & - dim1name='landunit', & - long_name='2d latitude index of corresponding landunit', & - interpinic_flag='skip', readvar=readvar, data=ilarr) - - do l=bounds%begl,bounds%endl - ilarr(l) = GetGlobalIndex(decomp_index=lun%gridcell(l), clmlevel=nameg) - end do - call restartvar(ncid=ncid, flag=flag, varname='land1d_gridcell_index', xtype=ncd_int, & - dim1name='landunit', & - long_name='gridcell index of corresponding landunit', & - interpinic_flag='skip', readvar=readvar, data=ilarr) - - call restartvar(ncid=ncid, flag=flag, varname='land1d_ityplun', xtype=ncd_int, & - dim1name='landunit', & - long_name='landunit type (see global attributes)', units=' ', & - interpinic_flag='skip', readvar=readvar, data=lun%itype) - - do l=bounds%begl,bounds%endl - if (lun%active(l)) then - ilarr(l) = 1 - else - ilarr(l) = 0 - end if - enddo - call restartvar(ncid=ncid, flag=flag, varname='land1d_active', xtype=ncd_int, & - dim1name='landunit', & - long_name='landunit active flag (1=active, 0=inactive)', & - interpinic_flag='skip', readvar=readvar, data=ilarr) - - deallocate(rlarr, ilarr) - - !------------------------------------------------------------------ - ! Write column info - !------------------------------------------------------------------ - - allocate(rcarr(bounds%begc:bounds%endc), icarr(bounds%begc:bounds%endc)) - - do c= bounds%begc, bounds%endc - rcarr(c) = grc%londeg(col%gridcell(c)) - enddo - call restartvar(ncid=ncid, flag=flag, varname='cols1d_lon', xtype=ncd_double, & - dim1name='column', & - long_name='column longitude', units='degrees_east', & - interpinic_flag='skip', readvar=readvar, data=rcarr) - - do c= bounds%begc, bounds%endc - rcarr(c) = grc%latdeg(col%gridcell(c)) - enddo - call restartvar(ncid=ncid, flag=flag, varname='cols1d_lat', xtype=ncd_double, & - dim1name='column', & - long_name='column latitude', units='degrees_north', & - interpinic_flag='skip', readvar=readvar, data=rcarr) - - do c= bounds%begc, bounds%endc - icarr(c) = mod(ldecomp%gdc2glo(col%gridcell(c))-1,ldomain%ni) + 1 - enddo - call restartvar(ncid=ncid, flag=flag, varname='cols1d_ixy', xtype=ncd_int, & - dim1name='column', & - long_name='2d longitude index of corresponding column', units=' ', & - interpinic_flag='skip', readvar=readvar, data=icarr) - - do c= bounds%begc, bounds%endc - icarr(c) = (ldecomp%gdc2glo(col%gridcell(c))-1)/ldomain%ni + 1 - enddo - call restartvar(ncid=ncid, flag=flag, varname='cols1d_jxy', xtype=ncd_int, & - dim1name='column', & - long_name='2d latitude index of corresponding column', units=' ', & - interpinic_flag='skip', readvar=readvar, data=icarr) - - do c= bounds%begc, bounds%endc - icarr(c) = GetGlobalIndex(decomp_index=col%gridcell(c), clmlevel=nameg) - end do - call restartvar(ncid=ncid, flag=flag, varname='cols1d_gridcell_index', xtype=ncd_int, & - dim1name='column', & - long_name='gridcell index of corresponding column', & - interpinic_flag='skip', readvar=readvar, data=icarr) - - do c= bounds%begc, bounds%endc - icarr(c) = GetGlobalIndex(decomp_index=col%landunit(c), clmlevel=namel) - end do - call restartvar(ncid=ncid, flag=flag, varname='cols1d_landunit_index', xtype=ncd_int, & - dim1name='column', & - long_name='landunit index of corresponding column', & - interpinic_flag='skip', readvar=readvar, data=icarr) - - do c= bounds%begc, bounds%endc - icarr(c) = lun%itype(col%landunit(c)) - enddo - call restartvar(ncid=ncid, flag=flag, varname='cols1d_ityplun', xtype=ncd_int, & - dim1name='column', & - long_name='column landunit type (see global attributes)', units=' ', & - interpinic_flag='skip', readvar=readvar, data=icarr) - - call restartvar(ncid=ncid, flag=flag, varname='cols1d_ityp', xtype=ncd_int, & - dim1name='column', & - long_name='column type (see global attributes)', units=' ', & - interpinic_flag='skip', readvar=readvar, data=col%itype) - - do c=bounds%begc,bounds%endc - if (col%active(c)) then - icarr(c) = 1 - else - icarr(c) = 0 - end if - end do - call restartvar(ncid=ncid, flag=flag, varname='cols1d_active', xtype=ncd_int, & - dim1name='column', & - long_name='column active flag (1=active, 0=inactive)', units=' ', & - interpinic_flag='skip', readvar=readvar, data=icarr) - - call restartvar(ncid=ncid, flag=flag, varname='LEVGRND_CLASS', xtype=ncd_int, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='class in which each layer falls', units=' ', & - interpinic_flag='skip', readvar=readvar, data=col%levgrnd_class) - - allocate(temp2d_r(bounds%begc:bounds%endc, 1:nlevgrnd)) - temp2d_r(bounds%begc:bounds%endc, 1:nlevgrnd) = col%z(bounds%begc:bounds%endc, 1:nlevgrnd) - call restartvar(ncid=ncid, flag=flag, varname='COL_Z', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='layer depth, excluding snow layers', units='m', & - interpinic_flag='skip', readvar=readvar, data=temp2d_r) - deallocate(temp2d_r) - - deallocate(rcarr, icarr) - - !------------------------------------------------------------------ - ! Write patch info - !------------------------------------------------------------------ - - allocate(rparr(bounds%begp:bounds%endp), iparr(bounds%begp:bounds%endp)) - - do p=bounds%begp,bounds%endp - rparr(p) = grc%londeg(patch%gridcell(p)) - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_lon', xtype=ncd_double, & - dim1name='pft', & - long_name='pft longitude', units='degrees_east', & - interpinic_flag='skip', readvar=readvar, data=rparr) - - do p=bounds%begp,bounds%endp - rparr(p) = grc%latdeg(patch%gridcell(p)) - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_lat', xtype=ncd_double, & - dim1name='pft', & - long_name='pft latitude', units='degrees_north', & - interpinic_flag='skip', readvar=readvar, data=rparr) - - do p=bounds%begp,bounds%endp - iparr(p) = mod(ldecomp%gdc2glo(patch%gridcell(p))-1,ldomain%ni) + 1 - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_ixy', xtype=ncd_int, & - dim1name='pft', & - long_name='2d longitude index of corresponding pft', units='', & - interpinic_flag='skip', readvar=readvar, data=iparr) - - do p=bounds%begp,bounds%endp - iparr(p) = (ldecomp%gdc2glo(patch%gridcell(p))-1)/ldomain%ni + 1 - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_jxy', xtype=ncd_int, & - dim1name='pft', & - long_name='2d latitude index of corresponding pft', units='', & - interpinic_flag='skip', readvar=readvar, data=iparr) - - do p=bounds%begp,bounds%endp - iparr(p) = GetGlobalIndex(decomp_index=patch%gridcell(p), clmlevel=nameg) - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_gridcell_index', xtype=ncd_int, & - dim1name='pft', & - long_name='gridcell index of corresponding pft', & - interpinic_flag='skip', readvar=readvar, data=iparr) - - do p=bounds%begp,bounds%endp - iparr(p) = GetGlobalIndex(decomp_index=patch%landunit(p), clmlevel=namel) - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_landunit_index', xtype=ncd_int, & - dim1name='pft', & - long_name='landunit index of corresponding pft', & - interpinic_flag='skip', readvar=readvar, data=iparr) - - do p=bounds%begp,bounds%endp - iparr(p) = GetGlobalIndex(decomp_index=patch%column(p), clmlevel=namec) - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_column_index', xtype=ncd_int, & - dim1name='pft', & - long_name='column index of corresponding pft', & - interpinic_flag='skip', readvar=readvar, data=iparr) - - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_itypveg', xtype=ncd_int, & - dim1name='pft', & - long_name='pft vegetation type', units='', & - interpinic_flag='skip', readvar=readvar, data=patch%itype) - - do p=bounds%begp,bounds%endp - iparr(p) = col%itype(patch%column(p)) - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_itypcol', xtype=ncd_int, & - dim1name='pft', & - long_name='pft column type (see global attributes)', units='', & - interpinic_flag='skip', readvar=readvar, data=iparr) - - do p=bounds%begp,bounds%endp - iparr(p) = lun%itype(patch%landunit(p)) - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_ityplun', xtype=ncd_int, & - dim1name='pft', & - long_name='pft landunit type (see global attributes)', units='', & - interpinic_flag='skip', readvar=readvar, data=iparr) - - do p=bounds%begp,bounds%endp - if (patch%active(p)) then - iparr(p) = 1 - else - iparr(p) = 0 - end if - enddo - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_active', xtype=ncd_int, & - dim1name='pft', & - long_name='pft active flag (1=active, 0=inactive)', units='', & - interpinic_flag='skip', readvar=readvar, data=iparr) - - allocate(temp2d_i(bounds%begp:bounds%endp, 1:nlevgrnd)) - do p=bounds%begp,bounds%endp - c = patch%column(p) - temp2d_i(p, 1:nlevgrnd) = col%levgrnd_class(c, 1:nlevgrnd) - end do - call restartvar(ncid=ncid, flag=flag, varname='LEVGRND_CLASS_p', xtype=ncd_int, & - dim1name='pft', dim2name='levgrnd', switchdim=.true., & - long_name='class in which each layer falls, patch-level', units=' ', & - interpinic_flag='skip', readvar=readvar, data=temp2d_i) - deallocate(temp2d_i) - - allocate(temp2d_r(bounds%begp:bounds%endp, 1:nlevgrnd)) - do p=bounds%begp,bounds%endp - c = patch%column(p) - temp2d_r(p, 1:nlevgrnd) = col%z(c, 1:nlevgrnd) - end do - call restartvar(ncid=ncid, flag=flag, varname='COL_Z_p', xtype=ncd_double, & - dim1name='pft', dim2name='levgrnd', switchdim=.true., & - long_name='layer depth, excluding snow layers, patch-level', units='m', & - interpinic_flag='skip', readvar=readvar, data=temp2d_r) - deallocate(temp2d_r) - - deallocate(rparr, iparr) - end subroutine subgridRest_write_only - !----------------------------------------------------------------------- - subroutine subgridRest_write_and_read(bounds, ncid, flag) - ! - ! !DESCRIPTION: - ! - ! - ! !USES: - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds ! bounds - type(file_desc_t), intent(inout) :: ncid ! netCDF dataset id - character(len=*) , intent(in) :: flag ! flag to determine if define, write or read data - ! - ! !LOCAL VARIABLES: - logical :: readvar ! temporary - real(r8), pointer :: temp2d(:,:) ! temporary for sno column variables - - character(len=*), parameter :: subname = 'subgridRest_write_and_read' - !----------------------------------------------------------------------- - - if (flag == 'read') then - call save_old_weights(bounds) - end if - - call restartvar(ncid=ncid, flag=flag, varname='land1d_wtxy', xtype=ncd_double, & - dim1name='landunit', & - long_name='landunit weight relative to corresponding gridcell', & - interpinic_flag='skip', readvar=readvar, data=lun%wtgcell) - - call restartvar(ncid=ncid, flag=flag, varname='cols1d_wtxy', xtype=ncd_double, & - dim1name='column', & - long_name='column weight relative to corresponding gridcell', units=' ', & - interpinic_flag='skip', readvar=readvar, data=col%wtgcell) - - call restartvar(ncid=ncid, flag=flag, varname='cols1d_wtlnd', xtype=ncd_double, & - dim1name='column', & - long_name='column weight relative to corresponding landunit', units=' ', & - interpinic_flag='skip', readvar=readvar, data=col%wtlunit) - - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_wtxy', xtype=ncd_double, & - dim1name='pft', & - long_name='pft weight relative to corresponding gridcell', units='', & - interpinic_flag='skip', readvar=readvar, data=patch%wtgcell) - - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_wtlnd', xtype=ncd_double, & - dim1name='pft', & - long_name='pft weight relative to corresponding landunit', units='', & - interpinic_flag='skip', readvar=readvar, data=patch%wtlunit) - - call restartvar(ncid=ncid, flag=flag, varname='pfts1d_wtcol', xtype=ncd_double, & - dim1name='pft', & - long_name='pft weight relative to corresponding column', units='', & - interpinic_flag='skip', readvar=readvar, data=patch%wtcol) - - ! Snow column variables - - call restartvar(ncid=ncid, flag=flag, varname='SNLSNO', xtype=ncd_int, & - dim1name='column', & - long_name='negative number of snow layers', units='unitless', & - interpinic_flag='interp', readvar=readvar, data=col%snl) - - allocate(temp2d(bounds%begc:bounds%endc,-nlevsno+1:0)) - if (flag == 'write') then - temp2d(bounds%begc:bounds%endc,-nlevsno+1:0) = col%dz(bounds%begc:bounds%endc,-nlevsno+1:0) - end if - call restartvar(ncid=ncid, flag=flag, varname='DZSNO', xtype=ncd_double, & - dim1name='column', dim2name='levsno', switchdim=.true., lowerb2=-nlevsno+1, upperb2=0, & - long_name='snow layer thickness', units='m', & - interpinic_flag='interp', readvar=readvar, data=temp2d) - if (flag == 'read') then - col%dz(bounds%begc:bounds%endc,-nlevsno+1:0) = temp2d(bounds%begc:bounds%endc,-nlevsno+1:0) - end if - deallocate(temp2d) - - allocate(temp2d(bounds%begc:bounds%endc,-nlevsno+1:0)) - if (flag == 'write') then - temp2d(bounds%begc:bounds%endc,-nlevsno+1:0) = col%z(bounds%begc:bounds%endc,-nlevsno+1:0) - end if - call restartvar(ncid=ncid, flag=flag, varname='ZSNO', xtype=ncd_double, & - dim1name='column', dim2name='levsno', switchdim=.true., lowerb2=-nlevsno+1, upperb2=0, & - long_name='snow layer depth', units='m', & - interpinic_flag='interp', readvar=readvar, data=temp2d) - if (flag == 'read') then - col%z(bounds%begc:bounds%endc,-nlevsno+1:0) = temp2d(bounds%begc:bounds%endc,-nlevsno+1:0) - end if - deallocate(temp2d) - - allocate(temp2d(bounds%begc:bounds%endc,-nlevsno:-1)) - if (flag == 'write') then - temp2d(bounds%begc:bounds%endc,-nlevsno:-1) = col%zi(bounds%begc:bounds%endc,-nlevsno:-1) - end if - call restartvar(ncid=ncid, flag=flag, varname='ZISNO', xtype=ncd_double, & - dim1name='column', dim2name='levsno', switchdim=.true., lowerb2=-nlevsno, upperb2=-1, & - long_name='snow interface depth', units='m', & - interpinic_flag='interp', readvar=readvar, data=temp2d) - if (flag == 'read') then - col%zi(bounds%begc:bounds%endc,-nlevsno:-1) = temp2d(bounds%begc:bounds%endc,-nlevsno:-1) - end if - deallocate(temp2d) - - end subroutine subgridRest_write_and_read - - !----------------------------------------------------------------------- - subroutine save_old_weights(bounds) - ! - ! !DESCRIPTION: - ! Save old weights, from before the restart read, for later consistency checks. - ! - ! !USES: - type(bounds_type), intent(in) :: bounds ! bounds (expected to be proc-level) - ! - ! !ARGUMENTS: - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'save_old_weights' - !----------------------------------------------------------------------- - - SHR_ASSERT(bounds%level == BOUNDS_LEVEL_PROC, subname//' ERROR: expect proc-level bounds') - - allocate(pft_wtlunit_before_rest_read(bounds%begp:bounds%endp)) - pft_wtlunit_before_rest_read(bounds%begp:bounds%endp) = patch%wtlunit(bounds%begp:bounds%endp) - - end subroutine save_old_weights - - - !----------------------------------------------------------------------- - subroutine subgridRest_check_consistency(bounds) - ! - ! !DESCRIPTION: - ! Check consistency of variables read by subgridRest. - ! - ! This should be called AFTER subgridRest is called to read the restart file. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds ! bounds - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgridRest_check_consistency' - !----------------------------------------------------------------------- - - if (do_check_weights()) then - call check_weights(bounds) - end if - - contains - - !----------------------------------------------------------------------- - logical function do_check_weights() - ! - ! !DESCRIPTION: - ! Return true if we should check weights - ! - ! !USES: - use clm_varctl, only : nsrest, nsrContinue, use_cndv, use_fates - ! - ! !ARGUMENTS: - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'do_check_weights' - !----------------------------------------------------------------------- - - if (nsrest == nsrContinue) then - ! Don't check weights for a restart run - ! - ! WJS (3-25-14): I'm not sure why we don't do the check in this case, but I'm - ! maintaining the logic that used to be in BiogeophysRestMod regarding these - ! weight checks - do_check_weights = .false. - else if (use_cndv) then - ! Don't check weights for a cndv case, because the weights will almost certainly - ! differ from the surface dataset in this case - do_check_weights = .false. - else if (use_fates) then - ! Don't check weights for a fates case, because the weights will almost certainly - ! differ from the surface dataset in this case - do_check_weights = .false. - else - do_check_weights = .true. - end if - - end function do_check_weights - - !----------------------------------------------------------------------- - subroutine check_weights(bounds) - ! - ! !DESCRIPTION: - ! Make sure that patch weights on the landunit agree with the weights read from the - ! surface dataset, for the natural veg landunit. - ! - ! Note that we do NOT do a more general check of all subgrid weights, because it's - ! possible that some other subgrid weights have changed relative to the surface - ! dataset, e.g., due to dynamic landunits. It would probably be possible to do more - ! checking than is done here, but the check here should be sufficient to catch major - ! inconsistencies between the restart file and the surface dataset. - ! - ! !USES: - use landunit_varcon, only : istsoil - use clm_varctl, only : iulog - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds ! bounds - ! - ! !LOCAL VARIABLES: - integer :: p, l ! indices - real(r8) :: diff ! difference in weights - - real(r8), parameter :: tol = 5.e-3 ! tolerance for checking weights - - character(len=*), parameter :: subname = 'check_weights' - !----------------------------------------------------------------------- - - do p = bounds%begp, bounds%endp - l = patch%landunit(p) - if (lun%itype(l) == istsoil) then - diff = abs(patch%wtlunit(p) - pft_wtlunit_before_rest_read(p)) - if (diff > tol .and. patch%wtgcell(p) > 1.0e-16_r8) then - write(iulog,*) 'ERROR: PATCH weights are SIGNIFICANTLY different between :' - write(iulog,*) 'the restart (finidat) file : ', patch%wtlunit(p) - write(iulog,*) 'and the surface dataset (fsurdat): ', pft_wtlunit_before_rest_read(p) - write(iulog,*) 'weight gridcell: ', patch%wtgcell(p) - write(iulog,*) - write(iulog,*) 'Maximum allowed difference: ', tol - write(iulog,*) 'Difference found: ', diff - write(iulog,*) 'This match is a requirement for non-transient runs' - write(iulog,*) - write(iulog,*) 'Possible solutions to this problem:' - write(iulog,*) '(1) Make sure you are using the intended finidat and fsurdat files' - write(iulog,*) '(2) If you are running a present-day simulation, then make sure that your' - write(iulog,*) ' initial conditions file is from the END of a 20th century transient run' - write(iulog,*) '(3) If you are confident that you are using the correct finidat and fsurdat files,' - write(iulog,*) ' yet are still experiencing this error, then you can bypass this check by setting:' - write(iulog,*) ' check_finidat_pct_consistency = .false.' - write(iulog,*) ' in user_nl_clm' - write(iulog,*) ' In this case, CLM will take the weights from the initial conditions file.' - write(iulog,*) ' ' - call endrun(decomp_index=p, clmlevel=namep, msg=errMsg(sourcefile, __LINE__)) - end if - end if - end do - - end subroutine check_weights - - end subroutine subgridRest_check_consistency - - - !----------------------------------------------------------------------- - subroutine subgridRest_read_cleanup - ! - ! !DESCRIPTION: - ! Do cleanup of variables allocated when reading the restart file - ! - ! Should be called after subgridRest and subgridRest_check_consistency are complete. - ! Note that this must be called after subgridRest is called to read the restart file, - ! in order to avoid a memory leak. - ! - ! !USES: - ! - ! !ARGUMENTS: - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'subgridRest_read_cleanup' - !----------------------------------------------------------------------- - - deallocate(pft_wtlunit_before_rest_read) - - end subroutine subgridRest_read_cleanup - - end module subgridRestMod diff --git a/src/main/subgridWeightsMod.F90 b/src/main/subgridWeightsMod.F90 deleted file mode 100644 index d496c620..00000000 --- a/src/main/subgridWeightsMod.F90 +++ /dev/null @@ -1,859 +0,0 @@ -module subgridWeightsMod - -#include "shr_assert.h" - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Handles modifications, error-checks and diagnostics related to changing subgrid weights - ! - ! ----- Requirements for subgrid weights that are enforced here ----- - ! - ! (These requirements are checked in check_weights/weights_okay) - ! - ! Note: in the following, 'active' refers to a pft, column, landunit or grid cell over - ! which computations are performed, and 'inactive' refers to a pft, column or landunit - ! where computations are NOT performed (grid cells are always active). - ! - ! (1) For all columns, landunits and grid cells, the sum of all subgrid weights of its - ! children (or grandchildren, etc.) is equal to 1. For example: - ! - For all columns, the sum of all patch weights on the column equals 1 - ! - For all landunits, the sum of all col weights on the landunit equals 1 - ! - For all grid cells, the sum of all patch weights on the grid cell equals 1 - ! - etc. - ! - ! (2) For all ACTIVE columns, landunits and grid cells, the sum of all subgrid weights of - ! its ACTIVE children (or grandchildren, etc.) is equal to 1. For example: - ! - For all active columns, the sum of all patch weights on the column equals 1 when - ! just considering active pfts - ! - For all active landunits, the sum of all col weights on the landunit equals 1 when - ! just considering active cols - ! - For ALL grid cells, the sum of all patch weights on the grid cell equals 1 when - ! just considering active pfts -- note that all grid cells are considered active! - ! - etc. - ! - ! (3) For all INACTIVE columns, landunits and grid cells, the sum of all subgrid weights of - ! its ACTIVE children, grandchildren, etc. are equal to either 0 or 1. For example: - ! - For all inactive columns, the sum of all patch weights on the column equals either 0 - ! or 1 when just considering active pfts - ! - For all inactive landunits, the sum of all col weights on the landunit equals - ! either 0 or 1 when just considering active cols - ! - etc. - ! - ! Another way of stating (2) and (3) is that the sum of weights of all ACTIVE pfts, cols - ! or landunits on their parent/grandparent/etc. is always equal to either 0 or 1 -- and - ! must be equal to 1 if this parent/grandparent, etc. is itself active. - ! - ! Note that, together, conditions (1) and (2) imply that any pft, col or landunit whose - ! weight on the grid cell is non-zero must be active. In addition, these conditions imply - ! that any patch whose weight on the column is non-zero must be active if the column is - ! active (and similarly for any patch on an active landunit, and any col on an active - ! landunit). - ! - ! - ! ----- Implications of these requirements for computing subgrid averages ----- - ! - ! The preferred way to average from, say, patch to col is: - ! colval(c) = 0 - ! do p = pfti(c), pftf(c) - ! if (active(p)) colval(c) = colval(c) + pftval(p) * wtcol(p) - ! (where wtcol(p) is the weight of the patch on the column) - ! If column c is active, then the above conditions guarantee that the pwtcol values - ! included in the above sum will sum to 1. If column c is inactive, then the above - ! conditions guarantee that the pwtcol values included in the above sum will sum to - ! either 1 or 0; if they sum to 0, then colval(c) will remain 0. - ! - ! Another acceptable method is the following; this method accommodates some unknown - ! fraction of pftval's being set to spval, and leaves colval set at spval if there are no - ! valid patch values: - ! colval(c) = spval - ! sumwt(c) = 0 - ! do p = pfti(c), pftf(c) - ! if (active(p) .and. wtcol(p) /= 0) then - ! if (pftval(p) /= spval) then - ! if (sumwt(c) == 0) colval(c) = 0 - ! colval(c) = colval(c) + pftval(p) * wtcol(p) - ! sumwt(c) = sumwt(c) + wtcol(p) - ! end if - ! end if - ! end do - ! if (sumwt(c) /= 0) then - ! colval(c) = colval(c) / sumwt(c) - ! end if - ! Note that here we check the condition (active(p) .and. wtcol(p) /= 0). We need to - ! include a check for wtcol(p) /= 0 because we don't want to set colval(c) = 0 for zero- - ! weight pfts in this line: - ! if (sumwt(c) == 0) colval(c) = 0 - ! And we include a check for active(p) because we don't want to assume that pftval(p) has - ! been set to spval for inactive pfts -- we want to allow for the possibility that - ! pftval(p) will be NaN for inactive pfts. - ! - ! - ! !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, all_active, use_fates - use clm_varcon , only : nameg, namel, namec, namep - 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 - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: init_subgrid_weights_mod ! initialize stuff in this module - public :: compute_higher_order_weights ! given p2c, c2l and l2g weights, compute other weights - public :: set_active ! set 'active' flags at pft, column & landunit level - public :: check_weights ! check subgrid weights - public :: get_landunit_weight ! get the weight of a given landunit on a single grid cell - public :: set_landunit_weight ! set the weight of a given landunit on a single grid cell - public :: is_gcell_all_ltypeX ! determine whether a grid cell is 100% covered by the given landunit type - public :: set_subgrid_diagnostic_fields ! set all subgrid weights diagnostic fields - ! - ! !REVISION HISTORY: - ! Created by Bill Sacks - ! - ! !PRIVATE TYPES: - type subgrid_weights_diagnostics_type - ! This type contains diagnostics on subgrid weights, for output to the history file - real(r8), pointer :: pct_landunit(:,:) ! % of each landunit on the grid cell [begg:endg, 1:max_lunit] - real(r8), pointer :: pct_nat_pft(:,:) ! % of each pft, as % of landunit [begg:endg, natpft_lb:natpft_ub] - real(r8), pointer :: pct_cft(:,:) ! % of each crop functional type, as % of landunit [begg:endg, cft_lb:cft_ub] - real(r8), pointer :: pct_glc_mec(:,:) ! % of each glacier elevation class, as % of landunit [begg:endg, 1:maxpatch_glcmec] - end type subgrid_weights_diagnostics_type - - type(subgrid_weights_diagnostics_type) :: subgrid_weights_diagnostics - - ! - ! !PRIVATE MEMBER FUNCTIONS: - private :: is_active_l ! determine whether the given landunit is active - private :: is_active_c ! determine whether the given column is active - private :: is_active_p ! determine whether the given patch is active - private :: weights_okay ! determine if sum of weights satisfies requirements laid out above - private :: set_pct_landunit_diagnostics ! set pct_landunit diagnostic field - private :: set_pct_glc_mec_diagnostics ! set pct_glc_mec diagnostic field - private :: set_pct_pft_diagnostics ! set pct_nat_pft & pct_cft diagnostic fields - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine init_subgrid_weights_mod(bounds) - ! - ! !DESCRIPTION: - ! Initialize stuff in this module - ! - ! !USES: - use landunit_varcon, only : max_lunit - use clm_varpar , only : maxpatch_glcmec, natpft_size, cft_size - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use decompMod , only : BOUNDS_LEVEL_PROC - use histFileMod , only : hist_addfld2d - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds ! proc bounds - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'init_subgrid_weights_mod' - !----------------------------------------------------------------------- - - SHR_ASSERT(bounds%level == BOUNDS_LEVEL_PROC, errMsg(sourcefile, __LINE__)) - - ! ------------------------------------------------------------------------ - ! Allocate variables in subgrid_weights_diagnostics - ! ------------------------------------------------------------------------ - - ! Note that, because these variables are output to the history file, it appears that - ! their lower bounds need to start at 1 (e.g., 1:natpft_size rather than - ! natpft_lb:natpft_ub) - allocate(subgrid_weights_diagnostics%pct_landunit(bounds%begg:bounds%endg, 1:max_lunit)) - subgrid_weights_diagnostics%pct_landunit(:,:) = nan - allocate(subgrid_weights_diagnostics%pct_nat_pft(bounds%begg:bounds%endg, 1:natpft_size)) - subgrid_weights_diagnostics%pct_nat_pft(:,:) = nan - allocate(subgrid_weights_diagnostics%pct_cft(bounds%begg:bounds%endg, 1:cft_size)) - subgrid_weights_diagnostics%pct_cft(:,:) = nan - allocate(subgrid_weights_diagnostics%pct_glc_mec(bounds%begg:bounds%endg, 1:maxpatch_glcmec)) - subgrid_weights_diagnostics%pct_glc_mec(:,:) = nan - - ! ------------------------------------------------------------------------ - ! Add history fields - ! ------------------------------------------------------------------------ - - call hist_addfld2d (fname='PCT_LANDUNIT', units='%', type2d='ltype', & - avgflag='A', long_name='% of each landunit on grid cell', & - ptr_lnd=subgrid_weights_diagnostics%pct_landunit, default='inactive') - - if(.not.use_fates) then - call hist_addfld2d (fname='PCT_NAT_PFT', units='%', type2d='natpft', & - avgflag='A', long_name='% of each PFT on the natural vegetation (i.e., soil) landunit', & - ptr_lnd=subgrid_weights_diagnostics%pct_nat_pft, default='inactive') - end if - - if (cft_size > 0) then - call hist_addfld2d (fname='PCT_CFT', units='%', type2d='cft', & - avgflag='A', long_name='% of each crop on the crop landunit', & - ptr_lnd=subgrid_weights_diagnostics%pct_cft, default='inactive') - end if - - call hist_addfld2d (fname='PCT_GLC_MEC', units='%', type2d='glc_nec', & - avgflag='A', long_name='% of each GLC elevation class on the glc_mec landunit', & - ptr_lnd=subgrid_weights_diagnostics%pct_glc_mec, default='inactive') - - end subroutine init_subgrid_weights_mod - - - !----------------------------------------------------------------------- - subroutine compute_higher_order_weights(bounds) - ! - ! !DESCRIPTION: - ! Assuming patch%wtcol, col%wtlunit and lun%wtgcell have already been computed, compute - ! the "higher-order" weights: patch%wtlunit, patch%wtgcell and col%wtgcell, for all p and c - ! - ! !USES: - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! clump bounds - ! - ! !LOCAL VARIABLES: - integer :: p, c, l ! indices for pft, col & landunit - !------------------------------------------------------------------------ - - do c = bounds%begc, bounds%endc - l = col%landunit(c) - col%wtgcell(c) = col%wtlunit(c) * lun%wtgcell(l) - end do - - do p = bounds%begp, bounds%endp - c = patch%column(p) - patch%wtlunit(p) = patch%wtcol(p) * col%wtlunit(c) - patch%wtgcell(p) = patch%wtcol(p) * col%wtgcell(c) - end do - end subroutine compute_higher_order_weights - - !----------------------------------------------------------------------- - subroutine set_active(bounds, glc_behavior) - ! - ! !DESCRIPTION: - ! Set 'active' flags at the pft, column and landunit level - ! (note that grid cells are always active) - ! - ! This should be called whenever any weights change (e.g., patch weights on the column, - ! landunit weights on the grid cell, etc.). - ! - ! Ensures that we don't have any active patch on an inactive column, or an active column on an - ! inactive landunit (since these conditions could lead to garbage data) - ! - ! !USES: - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - type(glc_behavior_type), intent(in) :: glc_behavior - ! - ! !LOCAL VARIABLES: - integer :: l,c,p ! loop counters - - character(len=*), parameter :: subname = 'set_active' - !------------------------------------------------------------------------ - - do l = bounds%begl,bounds%endl - lun%active(l) = is_active_l(l, glc_behavior) - end do - - do c = bounds%begc,bounds%endc - l = col%landunit(c) - col%active(c) = is_active_c(c, glc_behavior) - if (col%active(c) .and. .not. lun%active(l)) then - write(iulog,*) trim(subname),' ERROR: active column found on inactive landunit', & - 'at c = ', c, ', l = ', l - call endrun(decomp_index=c, clmlevel=namec, msg=errMsg(sourcefile, __LINE__)) - end if - end do - - do p = bounds%begp,bounds%endp - c = patch%column(p) - patch%active(p) = is_active_p(p) - if (patch%active(p) .and. .not. col%active(c)) then - write(iulog,*) trim(subname),' ERROR: active patch found on inactive column', & - 'at p = ', p, ', c = ', c - call endrun(decomp_index=p, clmlevel=namep, msg=errMsg(sourcefile, __LINE__)) - end if - end do - - end subroutine set_active - - !----------------------------------------------------------------------- - logical function is_active_l(l, glc_behavior) - ! - ! !DESCRIPTION: - ! Determine whether the given landunit is active - ! - ! !USES: - use landunit_varcon, only : istsoil, istice_mec - ! - ! !ARGUMENTS: - implicit none - integer, intent(in) :: l ! landunit index - type(glc_behavior_type), intent(in) :: glc_behavior - ! - ! !LOCAL VARIABLES: - integer :: g ! grid cell index - !------------------------------------------------------------------------ - - if (all_active) then - is_active_l = .true. - - else - g =lun%gridcell(l) - - is_active_l = .false. - - ! ------------------------------------------------------------------------ - ! General conditions under which is_active_l NEEDS to be true in order to satisfy - ! the requirements laid out at the top of this module: - ! ------------------------------------------------------------------------ - if (lun%wtgcell(l) > 0) is_active_l = .true. - - ! ------------------------------------------------------------------------ - ! Conditions under which is_active_p is set to true because we want extra virtual landunits: - ! ------------------------------------------------------------------------ - - if (lun%itype(l) == istice_mec .and. & - glc_behavior%has_virtual_columns_grc(g)) then - is_active_l = .true. - end if - - ! In general, include a virtual natural vegetation landunit. This aids - ! initialization of a new landunit; and for runs that are coupled to CISM, this - ! provides bare land SMB forcing even if there is no vegetated area. - ! - ! Also (echoing the similar comment in glcBehaviorMod): We need all glacier and - ! vegetated points to be active in the icemask region for the sake of init_interp - - ! since we only interpolate onto active points, and we don't know which points will - ! have non-zero area until after initialization (as long as we can't send - ! information from glc to clm in initialization). (If we had an inactive vegetated - ! point in the icemask region, according to the weights on the surface dataset, and - ! ran init_interp, this point would keep its cold start initialization - ! values. Then, in the first time step of the run loop, it's possible that this - ! point would become active because, according to glc, there is actually > 0% bare - ! ground in that grid cell. We don't do any state / flux adjustments in the first - ! time step after init_interp due to glacier area changes, so this vegetated column - ! would remain at its cold start initialization values, which would be a Bad - ! Thing. Ensuring that all vegetated points within the icemask are active gets - ! around this problem - as well as having other benefits, as noted above.) - if (lun%itype(l) == istsoil) then - is_active_l = .true. - end if - - end if - - end function is_active_l - - !----------------------------------------------------------------------- - logical function is_active_c(c, glc_behavior) - ! - ! !DESCRIPTION: - ! Determine whether the given column is active - ! - ! !USES: - use landunit_varcon, only : istice_mec, isturb_MIN, isturb_MAX - ! - ! !ARGUMENTS: - implicit none - integer, intent(in) :: c ! column index - type(glc_behavior_type), intent(in) :: glc_behavior - ! - ! !LOCAL VARIABLES: - integer :: l ! landunit index - integer :: g ! grid cell index - !------------------------------------------------------------------------ - - if (all_active) then - is_active_c = .true. - - else - l =col%landunit(c) - g =col%gridcell(c) - - is_active_c = .false. - - ! ------------------------------------------------------------------------ - ! General conditions under which is_active_c NEEDS to be true in order to satisfy - ! the requirements laid out at the top of this module: - ! ------------------------------------------------------------------------ - if (lun%active(l) .and. col%wtlunit(c) > 0._r8) is_active_c = .true. - - ! ------------------------------------------------------------------------ - ! Conditions under which is_active_c is set to true because we want extra virtual columns: - ! ------------------------------------------------------------------------ - - if (lun%itype(l) == istice_mec .and. & - glc_behavior%has_virtual_columns_grc(g)) then - is_active_c = .true. - end if - - ! We don't really need to run over 0-weight urban columns. But because of some - ! messiness in the urban code (many loops are over the landunit filter, then drill - ! down to columns - so we would need to add 'col%active(c)' conditionals in many - ! places) it keeps the code cleaner to run over 0-weight urban columns. This generally - ! shouldn't add much computation time, since in most places, all urban columns are - ! non-zero weight if the landunit is non-zero weight. - if (lun%active(l) .and. (lun%itype(l) >= isturb_MIN .and. lun%itype(l) <= isturb_MAX)) then - is_active_c = .true. - end if - end if - - end function is_active_c - - !----------------------------------------------------------------------- - logical function is_active_p(p) - ! - ! !DESCRIPTION: - ! Determine whether the given patch is active - ! - ! !USES: - ! - ! !ARGUMENTS: - implicit none - integer, intent(in) :: p ! patch index - ! - ! !LOCAL VARIABLES: - integer :: c ! column index - !------------------------------------------------------------------------ - - if (all_active) then - is_active_p = .true. - - else - c =patch%column(p) - - is_active_p = .false. - - ! ------------------------------------------------------------------------ - ! General conditions under which is_active_p NEEDS to be true in order to satisfy - ! the requirements laid out at the top of this module: - ! ------------------------------------------------------------------------ - if (col%active(c) .and. patch%wtcol(p) > 0._r8) is_active_p = .true. - - end if - - end function is_active_p - - !----------------------------------------------------------------------- - function get_landunit_weight(g, ltype) result(weight) - ! - ! !DESCRIPTION: - ! Get the subgrid weight of a given landunit type on a single grid cell - ! - ! !USES: - use clm_varcon, only : ispval - ! - ! !ARGUMENTS: - real(r8) :: weight ! function result - integer , intent(in) :: g ! grid cell index - integer , intent(in) :: ltype ! landunit type of interest - ! - ! !LOCAL VARIABLES: - integer :: l ! landunit index - - character(len=*), parameter :: subname = 'get_landunit_weight' - !----------------------------------------------------------------------- - - l = grc%landunit_indices(ltype, g) - if (l == ispval) then - weight = 0._r8 - else - weight = lun%wtgcell(l) - end if - - end function get_landunit_weight - - !----------------------------------------------------------------------- - subroutine set_landunit_weight(g, ltype, weight) - ! - ! !DESCRIPTION: - ! Set the subgrid weight of a given landunit type on a single grid cell - ! - ! !USES: - use clm_varcon, only : ispval - ! - ! !ARGUMENTS: - integer , intent(in) :: g ! grid cell index - integer , intent(in) :: ltype ! landunit type of interest - real(r8), intent(in) :: weight ! new weight of this landunit - ! - ! !LOCAL VARIABLES: - integer :: l ! landunit index - - character(len=*), parameter :: subname = 'set_landunit_weight' - !----------------------------------------------------------------------- - - l = grc%landunit_indices(ltype, g) - if (l /= ispval) then - lun%wtgcell(l) = weight - else if (weight > 0._r8) then - write(iulog,*) subname//' ERROR: Attempt to assign non-zero weight to a non-existent landunit' - write(iulog,*) 'g, l, ltype, weight = ', g, l, ltype, weight - call endrun(decomp_index=l, clmlevel=namel, msg=errMsg(sourcefile, __LINE__)) - end if - - end subroutine set_landunit_weight - - - !----------------------------------------------------------------------- - function is_gcell_all_ltypeX(g, ltype) result(all_ltypeX) - ! - ! !DESCRIPTION: - ! Determine if the given grid cell is 100% covered by the landunit type given by ltype - ! - ! !USES: - ! - ! !ARGUMENTS: - implicit none - logical :: all_ltypeX ! function result - integer, intent(in) :: g ! grid cell index - integer, intent(in) :: ltype ! landunit type of interest - ! - ! !LOCAL VARIABLES: - real(r8) :: wt_lunit ! subgrid weight of the given landunit - - real(r8), parameter :: tolerance = 1.e-13_r8 ! tolerance for checking whether landunit's weight is 1 - character(len=*), parameter :: subname = 'is_gcell_all_ltypeX' - !------------------------------------------------------------------------------ - - wt_lunit = get_landunit_weight(g, ltype) - if (wt_lunit >= (1._r8 - tolerance)) then - all_ltypeX = .true. - else - all_ltypeX = .false. - end if - - end function is_gcell_all_ltypeX - - !------------------------------------------------------------------------------ - subroutine check_weights (bounds, active_only) - ! - ! !DESCRIPTION: - ! Check subgrid weights. - ! - ! This routine operates in two different modes, depending on the value of active_only. If - ! active_only is true, then we check the sum of weights of the ACTIVE children, - ! grandchildren, etc. of a given point. If active_only is false, then we check the sum of - ! weights of ALL children, grandchildren, etc. of a given point. - ! - ! Normally this routine will be called twice: once with active_only=false, and once with - ! active_only=true. - ! - ! !USES - ! - ! !ARGUMENTS - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - logical, intent(in) :: active_only ! true => check sum of weights just of ACTIVE children, grandchildren, etc. - ! - ! !LOCAL VARIABLES: - integer :: g,l,c,p ! loop counters - real(r8), allocatable :: sumwtcol(:), sumwtlunit(:), sumwtgcell(:) - logical :: error_found ! true if we find an error - character(len=*), parameter :: subname = 'check_weights' - !------------------------------------------------------------------------------ - - allocate(sumwtcol(bounds%begc:bounds%endc)) - allocate(sumwtlunit(bounds%begl:bounds%endl)) - allocate(sumwtgcell(bounds%begg:bounds%endg)) - - error_found = .false. - - ! Check patch-level weights - sumwtcol(bounds%begc : bounds%endc) = 0._r8 - sumwtlunit(bounds%begl : bounds%endl) = 0._r8 - sumwtgcell(bounds%begg : bounds%endg) = 0._r8 - - do p = bounds%begp,bounds%endp - c = patch%column(p) - l = patch%landunit(p) - g = patch%gridcell(p) - - if ((active_only .and. patch%active(p)) .or. .not. active_only) then - sumwtcol(c) = sumwtcol(c) + patch%wtcol(p) - sumwtlunit(l) = sumwtlunit(l) + patch%wtlunit(p) - sumwtgcell(g) = sumwtgcell(g) + patch%wtgcell(p) - end if - end do - - do c = bounds%begc,bounds%endc - if (.not. weights_okay(sumwtcol(c), active_only, col%active(c))) then - write(iulog,*) trim(subname),' ERROR: at c = ',c,'total PFT weight is ',sumwtcol(c), & - 'active_only = ', active_only - error_found = .true. - end if - end do - - do l = bounds%begl,bounds%endl - if (.not. weights_okay(sumwtlunit(l), active_only, lun%active(l))) then - write(iulog,*) trim(subname),' ERROR: at l = ',l,'total PFT weight is ',sumwtlunit(l), & - 'active_only = ', active_only - error_found = .true. - end if - end do - - do g = bounds%begg,bounds%endg - if (.not. weights_okay(sumwtgcell(g), active_only, i_am_active=.true.)) then - write(iulog,*) trim(subname),' ERROR: at g = ',g,'total PFT weight is ',sumwtgcell(g), & - 'active_only = ', active_only - error_found = .true. - end if - end do - - ! Check col-level weights - sumwtlunit(bounds%begl : bounds%endl) = 0._r8 - sumwtgcell(bounds%begg : bounds%endg) = 0._r8 - - do c = bounds%begc,bounds%endc - l = col%landunit(c) - g = col%gridcell(c) - - if ((active_only .and. col%active(c)) .or. .not. active_only) then - sumwtlunit(l) = sumwtlunit(l) + col%wtlunit(c) - sumwtgcell(g) = sumwtgcell(g) + col%wtgcell(c) - end if - end do - - do l = bounds%begl,bounds%endl - if (.not. weights_okay(sumwtlunit(l), active_only, lun%active(l))) then - write(iulog,*) trim(subname),' ERROR: at l = ',l,'total col weight is ',sumwtlunit(l), & - 'active_only = ', active_only - error_found = .true. - end if - end do - - do g = bounds%begg,bounds%endg - if (.not. weights_okay(sumwtgcell(g), active_only, i_am_active=.true.)) then - write(iulog,*) trim(subname),' ERROR: at g = ',g,'total col weight is ',sumwtgcell(g), & - 'active_only = ', active_only - error_found = .true. - end if - end do - - ! Check landunit-level weights - sumwtgcell(bounds%begg : bounds%endg) = 0._r8 - - do l = bounds%begl,bounds%endl - g = lun%gridcell(l) - if ((active_only .and. lun%active(l)) .or. .not. active_only) then - sumwtgcell(g) = sumwtgcell(g) + lun%wtgcell(l) - end if - end do - - do g = bounds%begg,bounds%endg - if (.not. weights_okay(sumwtgcell(g), active_only, i_am_active=.true.)) then - write(iulog,*) trim(subname),' ERROR: at g = ',g,'total lunit weight is ',sumwtgcell(g), & - 'active_only = ', active_only - error_found = .true. - end if - end do - - deallocate(sumwtcol, sumwtlunit, sumwtgcell) - - if (error_found) then - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Success - - end subroutine check_weights - - !----------------------------------------------------------------------- - logical function weights_okay(sumwts, active_weights_only, i_am_active) - ! - ! !DESCRIPTION: - ! Determine if sumwts (the sum of weights of children, grandchildren or - ! great-grandchildren of a column, landunit or grid cell) satisfies the requirements laid - ! out above. - ! - ! The way this is determined depends on the values of two other variables: - ! - active_weights_only: does sumwts just include weights of active children, - ! grandchildren or great-grandchilden? (alternative is that it includes weights of ALL - ! children, grandchildren or great-grandchildren) - ! - i_am_active: true if the column, landunit or grid cell of interest is active - ! - ! !ARGUMENTS: - implicit none - real(r8), intent(in) :: sumwts ! sum of weights of children, grandchildren or great-grandchildren - logical , intent(in) :: active_weights_only ! true if sumwts just includes active children, etc. - logical , intent(in) :: i_am_active ! true if the current point is active - ! - ! !LOCAL VARIABLES: - logical :: weights_equal_1 - real(r8), parameter :: tolerance = 1.e-12_r8 ! tolerance for checking whether weights sum to 1 - !------------------------------------------------------------------------ - - weights_equal_1 = (abs(sumwts - 1._r8) <= tolerance) - - if (active_weights_only) then - if (i_am_active) then ! condition (2) above - weights_okay = weights_equal_1 - else ! condition (3) above - weights_okay = (sumwts == 0._r8 .or. weights_equal_1) - end if - else ! condition (1) above - ! (note that i_am_active is irrelevant in this case) - weights_okay = weights_equal_1 - end if - - end function weights_okay - - !----------------------------------------------------------------------- - subroutine set_subgrid_diagnostic_fields(bounds) - ! - ! !DESCRIPTION: - ! Set history fields giving diagnostics about subgrid weights - ! - ! !USES: - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - - character(len=*), parameter :: subname = 'set_subgrid_diagnostic_fields' - !----------------------------------------------------------------------- - - call set_pct_landunit_diagnostics(bounds) - - ! Note: (MV, 10-17-14): The following has an use_fates if-block around it since - ! the pct_pft_diagnostics referens to patch%itype(p) which is not used by ED - ! Note: (SPM, 10-20-15): If this isn't set then debug mode with intel and - ! yellowstone will fail when trying to write pct_nat_pft since it contains - ! all NaN's. - call set_pct_pft_diagnostics(bounds) - - call set_pct_glc_mec_diagnostics(bounds) - - end subroutine set_subgrid_diagnostic_fields - - !----------------------------------------------------------------------- - subroutine set_pct_landunit_diagnostics(bounds) - ! - ! !DESCRIPTION: - ! Set pct_landunit diagnostic field: % of each landunit on the grid cell - ! - ! !USES: - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: g, l ! grid cell & landunit indices - integer :: ltype ! landunit type - - character(len=*), parameter :: subname = 'set_pct_landunit_diagnostics' - !----------------------------------------------------------------------- - - subgrid_weights_diagnostics%pct_landunit(bounds%begg:bounds%endg, :) = 0._r8 - - do l = bounds%begl, bounds%endl - g = lun%gridcell(l) - ltype = lun%itype(l) - subgrid_weights_diagnostics%pct_landunit(g, ltype) = lun%wtgcell(l) * 100._r8 - end do - - end subroutine set_pct_landunit_diagnostics - - !----------------------------------------------------------------------- - subroutine set_pct_glc_mec_diagnostics(bounds) - ! - ! !DESCRIPTION: - ! Set pct_glc_mec diagnostic field: % of each glc_mec column on the glc_mec landunit - ! - ! Note: it's safe to call this even if we're not running with glc_mec, but in that - ! case it won't do anything. - ! - ! Note that pct_glc_mec will be 0 for all elevation classes in a grid cell that does - ! not have a glc_mec landunit. However, it will still sum to 100% for a grid cell - ! that has a 0-weight (i.e., virtual) glc_mec landunit. - ! - ! !USES: - use landunit_varcon, only : istice_mec - use column_varcon, only : col_itype_to_icemec_class - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: c,l,g ! indices - integer :: icemec_class ! icemec class (1..maxpatch_glcmec) - - character(len=*), parameter :: subname = 'set_pct_glc_mec_diagnostics' - !----------------------------------------------------------------------- - - subgrid_weights_diagnostics%pct_glc_mec(bounds%begg:bounds%endg, :) = 0._r8 - - do c = bounds%begc, bounds%endc - g = col%gridcell(c) - l = col%landunit(c) - if (lun%itype(l) == istice_mec) then - icemec_class = col_itype_to_icemec_class(col%itype(c)) - subgrid_weights_diagnostics%pct_glc_mec(g, icemec_class) = col%wtlunit(c) * 100._r8 - end if - end do - - end subroutine set_pct_glc_mec_diagnostics - - !----------------------------------------------------------------------- - subroutine set_pct_pft_diagnostics(bounds) - ! - ! !DESCRIPTION: - ! Set pct_nat_pft & pct_cft diagnostic fields: % of PFTs on their landunit - ! - ! !USES: - use landunit_varcon, only : istsoil, istcrop - use clm_varpar, only : natpft_lb, cft_lb - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - ! - ! !LOCAL VARIABLES: - integer :: p,l,g ! indices - integer :: ptype ! patch itype - integer :: ptype_1indexing ! patch itype, translated into 1-indexing for the given landunit type - - character(len=*), parameter :: subname = 'set_pct_pft_diagnostics' - !----------------------------------------------------------------------- - - subgrid_weights_diagnostics%pct_nat_pft(bounds%begg:bounds%endg, :) = 0._r8 - - ! Note that pct_cft will be 0-size if cft_size is 0 (which can happen if we don't - ! have a crop landunit). But it doesn't hurt to have this line setting all elements - ! to 0, and doing this always allows us to avoid extra logic which could be a - ! maintenance problem. - subgrid_weights_diagnostics%pct_cft(bounds%begg:bounds%endg, :) = 0._r8 - - do p = bounds%begp,bounds%endp - g = patch%gridcell(p) - l = patch%landunit(p) - ptype = patch%itype(p) - if (lun%itype(l) == istsoil .and. (.not.use_fates) ) then - ptype_1indexing = ptype + (1 - natpft_lb) - subgrid_weights_diagnostics%pct_nat_pft(g, ptype_1indexing) = patch%wtlunit(p) * 100._r8 - else if (lun%itype(l) == istcrop) then - ptype_1indexing = ptype + (1 - cft_lb) - subgrid_weights_diagnostics%pct_cft(g, ptype_1indexing) = patch%wtlunit(p) * 100._r8 - end if - end do - - end subroutine set_pct_pft_diagnostics - -end module subgridWeightsMod diff --git a/src/main/surfrdMod.F90 b/src/main/surfrdMod.F90 index ef593b1a..13ebbced 100644 --- a/src/main/surfrdMod.F90 +++ b/src/main/surfrdMod.F90 @@ -5,19 +5,20 @@ module surfrdMod ! Contains methods for reading in surface data file and determining ! subgrid weights ! + ! !NOTES: + ! TODO Currently reading domain file, although this is done in surfrd. + ! In NUOPC version we will be reading ESMF mesh file. Until SLIM gets + ! updated to NUOPC, we are leaving the calls to surfrd unchanged. + ! ! !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 clm_varpar , only : nlevsoifl, numpft - use landunit_varcon , only : numurbl use clm_varcon , only : grlnd use clm_varctl , only : iulog, scmlat, scmlon, single_column - use clm_varctl , only : use_cndv, use_crop - use surfrdUtilsMod , only : check_sums_equal_1, collapse_crop_types use ncdio_pio , only : file_desc_t, var_desc_t, ncd_pio_openfile, ncd_pio_closefile - use ncdio_pio , only : ncd_io, check_var, ncd_inqfdims, check_dim, ncd_inqdid + use ncdio_pio , only : ncd_io, check_var, ncd_inqfdims, ncd_inqdid use pio use spmdMod ! @@ -28,18 +29,8 @@ module surfrdMod ! !PUBLIC MEMBER FUNCTIONS: public :: surfrd_get_globmask ! Reads global land mask (needed for setting domain decomp) public :: surfrd_get_grid ! Read grid/ladnfrac data into domain (after domain decomp) - public :: surfrd_get_data ! Read surface dataset and determine subgrid weights - ! - ! !PRIVATE MEMBER FUNCTIONS: - private :: surfrd_special ! Read the special landunits - private :: surfrd_veg_all ! Read all of the vegetated landunits - private :: surfrd_veg_dgvm ! Read vegetated landunits for DGVM mode - private :: surfrd_pftformat ! Read crop pfts in file format where they are part of the vegetated land unit - private :: surfrd_cftformat ! Read crop pfts in file format where they are on their own landunit ! ! !PRIVATE DATA MEMBERS: - ! default multiplication factor for epsilon for error checks - real(r8), private, parameter :: eps_fact = 2._r8 character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -132,7 +123,7 @@ subroutine surfrd_get_globmask(filename, mask, ni, nj) end subroutine surfrd_get_globmask !----------------------------------------------------------------------- - subroutine surfrd_get_grid(begg, endg, ldomain, filename, glcfilename) + subroutine surfrd_get_grid(begg, endg, ldomain, filename) ! ! !DESCRIPTION: ! THIS IS CALLED AFTER THE DOMAIN DECOMPOSITION HAS BEEN CREATED @@ -149,7 +140,6 @@ subroutine surfrd_get_grid(begg, endg, ldomain, filename, glcfilename) integer ,intent(in) :: begg, endg type(domain_type),intent(inout) :: ldomain ! domain to init character(len=*) ,intent(in) :: filename ! grid filename - character(len=*) ,optional, intent(in) :: glcfilename ! glc mask filename ! ! !LOCAL VARIABLES: type(file_desc_t) :: ncid ! netcdf id @@ -280,540 +270,4 @@ subroutine surfrd_get_grid(begg, endg, ldomain, filename, glcfilename) end subroutine surfrd_get_grid - !----------------------------------------------------------------------- - subroutine surfrd_get_data (begg, endg, ldomain, lfsurdat) - ! - ! !DESCRIPTION: - ! Read the surface dataset and create subgrid weights. - ! The model's surface dataset recognizes 6 basic land cover types within a grid - ! cell: lake, wetland, urban, glacier, glacier_mec and vegetated. The vegetated - ! portion of the grid cell is comprised of up to [maxpatch_pft] patches. These - ! subgrid patches are read in explicitly for each grid cell. This is in - ! contrast to LSMv1, where the patches were built implicitly from biome types. - ! o real latitude of grid cell (degrees) - ! o real longitude of grid cell (degrees) - ! o integer surface type: 0 = ocean or 1 = land - ! o integer soil color (1 to 20) for use with soil albedos - ! o real soil texture, %sand, for thermal and hydraulic properties - ! o real soil texture, %clay, for thermal and hydraulic properties - ! o real % of cell covered by lake for use as subgrid patch - ! o real % of cell covered by wetland for use as subgrid patch - ! o real % of cell that is urban for use as subgrid patch - ! o real % of cell that is glacier for use as subgrid patch - ! o real % of cell that is glacier_mec for use as subgrid patch - ! o integer PFTs - ! o real % abundance PFTs (as a percent of vegetated area) - ! - ! !USES: - use clm_varctl , only : create_crop_landunit - use fileutils , only : getfil - use domainMod , only : domain_type, domain_init, domain_clean - use clm_instur , only : wt_lunit, topo_glc_mec - ! - ! !ARGUMENTS: - integer, intent(in) :: begg, endg - type(domain_type),intent(in) :: ldomain ! land domain - character(len=*), intent(in) :: lfsurdat ! surface dataset filename - ! - ! !LOCAL VARIABLES: - type(var_desc_t) :: vardesc ! pio variable descriptor - type(domain_type) :: surfdata_domain ! local domain associated with surface dataset - character(len=256):: locfn ! local file name - integer :: n ! loop indices - integer :: ni,nj,ns ! domain sizes - character(len=16) :: lon_var, lat_var ! names of lat/lon on dataset - logical :: readvar ! true => variable is on dataset - real(r8) :: rmaxlon,rmaxlat ! local min/max vars - type(file_desc_t) :: ncid ! netcdf id - logical :: istype_domain ! true => input file is of type domain - logical :: isgrid2d ! true => intut grid is 2d - character(len=32) :: subname = 'surfrd_get_data' ! subroutine name - !----------------------------------------------------------------------- - - if (masterproc) then - write(iulog,*) 'Attempting to read surface boundary data .....' - if (lfsurdat == ' ') then - write(iulog,*)'lfsurdat must be specified' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - endif - - wt_lunit(:,:) = 0._r8 - topo_glc_mec(:,:) = 0._r8 - - ! Read surface data - - call getfil( lfsurdat, locfn, 0 ) - call ncd_pio_openfile (ncid, trim(locfn), 0) - - ! Read in patch mask - this variable is only on the surface dataset - but not - ! on the domain dataset - - call ncd_io(ncid=ncid, varname= 'PFTDATA_MASK', flag='read', data=ldomain%pftm, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: pftm NOT on surface dataset'//errMsg(sourcefile, __LINE__)) - - ! Check if fsurdat grid is "close" to fatmlndfrc grid, exit if lats/lon > 0.001 - - call check_var(ncid=ncid, varname='xc', vardesc=vardesc, readvar=readvar) - if (readvar) then - istype_domain = .true. - else - call check_var(ncid=ncid, varname='LONGXY', vardesc=vardesc, readvar=readvar) - if (readvar) then - istype_domain = .false. - else - call endrun( msg=' ERROR: unknown domain type'//errMsg(sourcefile, __LINE__)) - end if - end if - if (istype_domain) then - lon_var = 'xc' - lat_var = 'yc' - else - lon_var = 'LONGXY' - lat_var = 'LATIXY' - end if - if ( masterproc )then - write(iulog,*) trim(subname),' lon_var = ',trim(lon_var),' lat_var =',trim(lat_var) - end if - - call ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) - call domain_init(surfdata_domain, isgrid2d, ni, nj, begg, endg, clmlevel=grlnd) - - call ncd_io(ncid=ncid, varname=lon_var, flag='read', data=surfdata_domain%lonc, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: lon var NOT on surface dataset'//errMsg(sourcefile, __LINE__)) - - call ncd_io(ncid=ncid, varname=lat_var, flag='read', data=surfdata_domain%latc, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: lat var NOT on surface dataset'//errMsg(sourcefile, __LINE__)) - - rmaxlon = 0.0_r8 - rmaxlat = 0.0_r8 - do n = begg,endg - if (ldomain%lonc(n)-surfdata_domain%lonc(n) > 300.) then - rmaxlon = max(rmaxlon,abs(ldomain%lonc(n)-surfdata_domain%lonc(n)-360._r8)) - elseif (ldomain%lonc(n)-surfdata_domain%lonc(n) < -300.) then - rmaxlon = max(rmaxlon,abs(ldomain%lonc(n)-surfdata_domain%lonc(n)+360._r8)) - else - rmaxlon = max(rmaxlon,abs(ldomain%lonc(n)-surfdata_domain%lonc(n))) - endif - rmaxlat = max(rmaxlat,abs(ldomain%latc(n)-surfdata_domain%latc(n))) - enddo - if (rmaxlon > 0.001_r8 .or. rmaxlat > 0.001_r8) then - write(iulog,*)' ERROR: surfdata/fatmgrid lon/lat mismatch error', rmaxlon,rmaxlat - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - !~! TODO(SPM, 022015) - if we deallocate and clean ldomain here, then you - !~! get errors in htape_timeconst where the information is needed to write - !~! the *.h0* file - !~!call domain_clean(surfdata_domain) - - ! Obtain special landunit info - - call surfrd_special(begg, endg, ncid, ldomain%ns) - - ! Obtain vegetated landunit info - - call surfrd_veg_all(begg, endg, ncid, ldomain%ns) - - if (use_cndv) then - call surfrd_veg_dgvm(begg, endg) - end if - - call ncd_pio_closefile(ncid) - - call check_sums_equal_1(wt_lunit, begg, 'wt_lunit', subname) - - if ( masterproc )then - write(iulog,*) 'Successfully read surface boundary data' - write(iulog,*) - end if - - end subroutine surfrd_get_data - -!----------------------------------------------------------------------- - subroutine surfrd_special(begg, endg, ncid, ns) - ! - ! !DESCRIPTION: - ! Determine weight with respect to gridcell of all special "patches" as well - ! as soil color and percent sand and clay - ! - ! !USES: - use clm_varpar , only : maxpatch_glcmec, nlevurb - use landunit_varcon , only : isturb_MIN, isturb_MAX, istdlak, istwet, istice_mec - use clm_instur , only : wt_lunit, urban_valid, wt_glc_mec, topo_glc_mec - use UrbanParamsType , only : CheckUrban - ! - ! !ARGUMENTS: - integer , intent(in) :: begg, endg - type(file_desc_t), intent(inout) :: ncid ! netcdf id - integer , intent(in) :: ns ! domain size - ! - ! !LOCAL VARIABLES: - integer :: n,nl,nurb,g ! indices - integer :: dimid,varid ! netCDF id's - real(r8) :: nlevsoidata(nlevsoifl) - logical :: found ! temporary for error check - integer :: nindx ! temporary for error check - integer :: ier ! error status - logical :: readvar - real(r8),pointer :: pctgla(:) ! percent of grid cell is glacier - real(r8),pointer :: pctlak(:) ! percent of grid cell is lake - real(r8),pointer :: pctwet(:) ! percent of grid cell is wetland - real(r8),pointer :: pcturb(:,:) ! percent of grid cell is urbanized - integer ,pointer :: urban_region_id(:) - real(r8),pointer :: pcturb_tot(:) ! percent of grid cell is urban (sum over density classes) - real(r8),pointer :: pctspec(:) ! percent of spec lunits wrt gcell - integer :: dens_index ! urban density index - character(len=32) :: subname = 'surfrd_special' ! subroutine name - real(r8) closelat,closelon - integer, parameter :: urban_invalid_region = 0 ! urban_region_id indicating invalid point -!----------------------------------------------------------------------- - - allocate(pctgla(begg:endg)) - allocate(pctlak(begg:endg)) - allocate(pctwet(begg:endg)) - allocate(pcturb(begg:endg,numurbl)) - allocate(pcturb_tot(begg:endg)) - allocate(urban_region_id(begg:endg)) - allocate(pctspec(begg:endg)) - - call check_dim(ncid, 'nlevsoi', nlevsoifl) - - ! Obtain non-grid surface properties of surface dataset other than percent patch - - call ncd_io(ncid=ncid, varname='PCT_WETLAND', flag='read', data=pctwet, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_WETLAND NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - - call ncd_io(ncid=ncid, varname='PCT_LAKE' , flag='read', data=pctlak, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_LAKE NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - - call ncd_io(ncid=ncid, varname='PCT_GLACIER', flag='read', data=pctgla, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_GLACIER NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - - ! Read urban info - if (nlevurb == 0) then - ! If PCT_URBAN is not multi-density then set pcturb to zero - pcturb = 0._r8 - urban_valid(begg:endg) = .false. - write(iulog,*)'PCT_URBAN is not multi-density, pcturb set to 0' - else - call ncd_io(ncid=ncid, varname='PCT_URBAN' , flag='read', data=pcturb, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_URBAN NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - - call ncd_io(ncid=ncid, varname='URBAN_REGION_ID', flag='read', data=urban_region_id, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg= ' ERROR: URBAN_REGION_ID NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - where (urban_region_id == urban_invalid_region) - urban_valid = .false. - elsewhere - urban_valid = .true. - end where - end if - if ( nlevurb == 0 )then - if ( any(pcturb > 0.0_r8) ) then - call endrun( msg=' ERROR: PCT_URBAN MUST be zero when nlevurb=0'//errMsg(sourcefile, __LINE__)) - end if - end if - - pcturb_tot(:) = 0._r8 - do n = 1, numurbl - do nl = begg,endg - pcturb_tot(nl) = pcturb_tot(nl) + pcturb(nl,n) - enddo - enddo - - ! Read glacier info - - call check_dim(ncid, 'nglcec', maxpatch_glcmec ) - call check_dim(ncid, 'nglcecp1', maxpatch_glcmec+1 ) - - call ncd_io(ncid=ncid, varname='PCT_GLC_MEC', flag='read', data=wt_glc_mec, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_GLC_MEC NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - - wt_glc_mec(:,:) = wt_glc_mec(:,:) / 100._r8 - call check_sums_equal_1(wt_glc_mec, begg, 'wt_glc_mec', subname) - - call ncd_io(ncid=ncid, varname='TOPO_GLC_MEC', flag='read', data=topo_glc_mec, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: TOPO_GLC_MEC NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - - topo_glc_mec(:,:) = max(topo_glc_mec(:,:), 0._r8) - - pctspec = pctwet + pctlak + pcturb_tot + pctgla - - ! Error check: glacier, lake, wetland, urban sum must be less than 100 - - found = .false. - do nl = begg,endg - if (pctspec(nl) > 100._r8+1.e-04_r8) then - found = .true. - nindx = nl - exit - end if - if (found) exit - end do - if ( found ) then - write(iulog,*)'surfrd error: patch cover>100 for nl=',nindx - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Determine wt_lunit for special landunits - - do nl = begg,endg - - wt_lunit(nl,istdlak) = pctlak(nl)/100._r8 - - wt_lunit(nl,istwet) = pctwet(nl)/100._r8 - - wt_lunit(nl,istice_mec) = pctgla(nl)/100._r8 - - do n = isturb_MIN, isturb_MAX - dens_index = n - isturb_MIN + 1 - wt_lunit(nl,n) = pcturb(nl,dens_index) / 100._r8 - end do - - end do - - call CheckUrban(begg, endg, pcturb(begg:endg,:), subname) - - deallocate(pctgla,pctlak,pctwet,pcturb,pcturb_tot,urban_region_id,pctspec) - - end subroutine surfrd_special - -!----------------------------------------------------------------------- - subroutine surfrd_cftformat( ncid, begg, endg, wt_cft, cftsize, natpft_size ) - ! - ! !DESCRIPTION: - ! Handle generic crop types for file format where they are on their own - ! crop landunit and read in as Crop Function Types. - ! !USES: - use clm_instur , only : fert_cft, wt_nat_patch - use clm_varpar , only : cft_size, cft_lb, natpft_lb - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf id - integer , intent(in) :: begg, endg - integer , intent(in) :: cftsize ! CFT size - real(r8), pointer, intent(inout) :: wt_cft(:,:) ! CFT weights - integer , intent(in) :: natpft_size ! natural PFT size - ! - ! !LOCAL VARIABLES: - logical :: readvar ! is variable on dataset - real(r8),pointer :: array2D(:,:) ! local array - character(len=32) :: subname = 'surfrd_cftformat'! subroutine name -!----------------------------------------------------------------------- - SHR_ASSERT_ALL((lbound(wt_cft) == (/begg, cft_lb/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(wt_cft, dim=1) == (/endg/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(wt_cft, dim=2) >= (/cftsize+1-cft_lb/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(wt_nat_patch) >= (/endg,natpft_size-1+natpft_lb/)), errMsg(sourcefile, __LINE__)) - - call check_dim(ncid, 'cft', cftsize) - call check_dim(ncid, 'natpft', natpft_size) - - call ncd_io(ncid=ncid, varname='PCT_CFT', flag='read', data=wt_cft, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_CFT NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - - if ( cft_size > 0 )then - call ncd_io(ncid=ncid, varname='CONST_FERTNITRO_CFT', flag='read', data=fert_cft, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) then - if ( masterproc ) & - write(iulog,*) ' WARNING: CONST_FERTNITRO_CFT NOT on surfdata file zero out' - fert_cft = 0.0_r8 - end if - else - fert_cft = 0.0_r8 - end if - - allocate( array2D(begg:endg,1:natpft_size) ) - call ncd_io(ncid=ncid, varname='PCT_NAT_PFT', flag='read', data=array2D, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_NAT_PFT NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - wt_nat_patch(begg:,natpft_lb:natpft_size-1+natpft_lb) = array2D(begg:,:) - deallocate( array2D ) - - end subroutine surfrd_cftformat - -!----------------------------------------------------------------------- - subroutine surfrd_pftformat( begg, endg, ncid ) - ! - ! !DESCRIPTION: - ! Handle generic crop types for file format where they are part of the - ! natural vegetation landunit. - ! !USES: - use clm_instur , only : fert_cft, wt_nat_patch - use clm_varpar , only : natpft_size, cft_size, natpft_lb - ! !ARGUMENTS: - implicit none - integer, intent(in) :: begg, endg - type(file_desc_t), intent(inout) :: ncid ! netcdf id - ! - ! !LOCAL VARIABLES: - logical :: cft_dim_exists ! does the dimension 'cft' exist on the dataset? - integer :: dimid ! netCDF id's - logical :: readvar ! is variable on dataset - character(len=32) :: subname = 'surfrd_pftformat'! subroutine name -!----------------------------------------------------------------------- - SHR_ASSERT_ALL((ubound(wt_nat_patch) == (/endg, natpft_size-1+natpft_lb/)), errMsg(sourcefile, __LINE__)) - - call check_dim(ncid, 'natpft', natpft_size) - ! If cft_size == 0, then we expect to be running with a surface dataset - ! that does - ! NOT have a PCT_CFT array (or CONST_FERTNITRO_CFT array), and thus does not have a 'cft' dimension. - ! Make sure - ! that's the case. - call ncd_inqdid(ncid, 'cft', dimid, cft_dim_exists) - if (cft_dim_exists) then - call endrun( msg= ' ERROR: unexpectedly found cft dimension on dataset when cft_size=0'// & - ' (if the surface dataset has a separate crop landunit, then the code'// & - ' must also have a separate crop landunit, and vice versa)'//& - errMsg(sourcefile, __LINE__)) - end if - call ncd_io(ncid=ncid, varname='CONST_FERTNITRO_CFT', flag='read', data=fert_cft, & - dim1name=grlnd, readvar=readvar) - if (readvar) then - call endrun( msg= ' ERROR: unexpectedly found CONST_FERTNITRO_CFT on dataset when cft_size=0'// & - ' (if the surface dataset has a separate crop landunit, then the code'// & - ' must also have a separate crop landunit, and vice versa)'//& - errMsg(sourcefile, __LINE__)) - end if - fert_cft = 0.0_r8 - - call ncd_io(ncid=ncid, varname='PCT_NAT_PFT', flag='read', data=wt_nat_patch, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_NAT_PFT NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - - end subroutine surfrd_pftformat - -!----------------------------------------------------------------------- - subroutine surfrd_veg_all(begg, endg, ncid, ns) - ! - ! !DESCRIPTION: - ! Determine weight arrays for non-dynamic landuse mode - ! - ! !USES: - use clm_varctl , only : create_crop_landunit, use_fates - use clm_varpar , only : natpft_lb, natpft_ub, natpft_size, cft_size, cft_lb - use clm_instur , only : wt_lunit, wt_nat_patch, wt_cft, fert_cft - use landunit_varcon , only : istsoil, istcrop - use surfrdUtilsMod , only : convert_cft_to_pft - ! - ! !ARGUMENTS: - implicit none - integer, intent(in) :: begg, endg - type(file_desc_t),intent(inout) :: ncid ! netcdf id - integer ,intent(in) :: ns ! domain size - ! - ! !LOCAL VARIABLES: - integer :: dimid ! netCDF id's - integer :: cftsize ! size of CFT's - logical :: readvar ! is variable on dataset - logical :: cft_dim_exists ! does the dimension 'cft' exist on the dataset? - real(r8),pointer :: arrayl(:) ! local array - real(r8),pointer :: array2D(:,:) ! local 2D array - character(len=32) :: subname = 'surfrd_veg_all' ! subroutine name -!----------------------------------------------------------------------- - ! - ! Read in variables that are handled the same for all formats - ! - ! Check dimension size - call check_dim(ncid, 'lsmpft', numpft+1) - - ! This temporary array is needed because ncd_io expects a pointer, so we can't - ! directly pass wt_lunit(begg:endg,istsoil) - allocate(arrayl(begg:endg)) - - call ncd_io(ncid=ncid, varname='PCT_NATVEG', flag='read', data=arrayl, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_NATVEG NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - wt_lunit(begg:endg,istsoil) = arrayl(begg:endg) - - call ncd_io(ncid=ncid, varname='PCT_CROP', flag='read', data=arrayl, & - dim1name=grlnd, readvar=readvar) - if (.not. readvar) call endrun( msg=' ERROR: PCT_CROP NOT on surfdata file'//errMsg(sourcefile, __LINE__)) - wt_lunit(begg:endg,istcrop) = arrayl(begg:endg) - - deallocate(arrayl) - - ! Check the file format for CFT's and handle accordingly - call ncd_inqdid(ncid, 'cft', dimid, cft_dim_exists) - if ( cft_dim_exists .and. create_crop_landunit )then - call surfrd_cftformat( ncid, begg, endg, wt_cft, cft_size, natpft_size ) ! Format where CFT's is read in a seperate landunit - else if ( (.not. cft_dim_exists) .and. (.not. create_crop_landunit) )then - if ( masterproc ) write(iulog,*) "WARNING: The PFT format is an unsupported format that will be removed in th future!" - call surfrd_pftformat( begg, endg, ncid ) ! Format where crop is part of the natural veg. landunit - else if ( cft_dim_exists .and. .not. create_crop_landunit )then - if ( masterproc ) write(iulog,*) "WARNING: New CFT-based format surface datasets should be run with create_crop_landunit=T" - if ( use_fates ) then - if ( masterproc ) write(iulog,*) "WARNING: When fates is on we allow new CFT based surface datasets ", & - "to be used with create_crop_land FALSE" - cftsize = 2 - allocate(array2D(begg:endg,cft_lb:cftsize-1+cft_lb)) - call surfrd_cftformat( ncid, begg, endg, array2D, cftsize, natpft_size-cftsize ) ! Read crops in as CFT's - call convert_cft_to_pft( begg, endg, cftsize, array2D ) ! Convert from CFT to natural veg. landunit - deallocate(array2D) - else - call endrun( msg=' ERROR: New format surface datasets require create_crop_landunit TRUE'//errMsg(sourcefile, __LINE__)) - end if - end if - - ! Do some checking - - if ( (cft_size == 0) .and. any(wt_lunit(begg:endg,istcrop) > 0._r8) ) then - call endrun( msg=' ERROR: if PCT_CROP > 0 anywhere, then cft_size must be > 0'// & - ' (if the surface dataset has a separate crop landunit, then the code'// & - ' must also have a separate crop landunit, and vice versa)'//& - errMsg(sourcefile, __LINE__)) - end if - ! Convert from percent to fraction, check sums of nat vegetation add to 1 - if ( cft_size > 0 )then - wt_cft(begg:endg,:) = wt_cft(begg:endg,:) / 100._r8 - call check_sums_equal_1(wt_cft, begg, 'wt_cft', subname) - end if - wt_lunit(begg:endg,istsoil) = wt_lunit(begg:endg,istsoil) / 100._r8 - wt_lunit(begg:endg,istcrop) = wt_lunit(begg:endg,istcrop) / 100._r8 - wt_nat_patch(begg:endg,:) = wt_nat_patch(begg:endg,:) / 100._r8 - call check_sums_equal_1(wt_nat_patch, begg, 'wt_nat_patch', subname) - - ! Collapse crop landunits down when prognostic crops are on - if (use_crop) then - call collapse_crop_types(wt_cft(begg:endg, :), fert_cft(begg:endg, :), begg, endg, verbose=.true.) - end if - - end subroutine surfrd_veg_all - - !----------------------------------------------------------------------- - subroutine surfrd_veg_dgvm(begg, endg) - ! - ! !DESCRIPTION: - ! Determine weights for CNDV mode. - ! - ! !USES: - use pftconMod , only : noveg - use clm_instur, only : wt_nat_patch - ! - ! !ARGUMENTS: - integer, intent(in) :: begg, endg - ! - ! !LOCAL VARIABLES: - character(len=*), parameter :: subname = 'surfrd_veg_dgvm' - !----------------------------------------------------------------------- - - ! Bare ground gets 100% weight; all other natural patches are zeroed out - wt_nat_patch(begg:endg, :) = 0._r8 - wt_nat_patch(begg:endg, noveg) = 1._r8 - - call check_sums_equal_1(wt_nat_patch, begg, 'wt_nat_patch', subname) - - end subroutine surfrd_veg_dgvm - end module surfrdMod diff --git a/src/main/surfrdUtilsMod.F90 b/src/main/surfrdUtilsMod.F90 deleted file mode 100644 index 45fbf9eb..00000000 --- a/src/main/surfrdUtilsMod.F90 +++ /dev/null @@ -1,243 +0,0 @@ -module surfrdUtilsMod - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Contains utility methods that can be used when reading surface datasets or similar - ! datasets (such as the landuse_timeseries dataset) - ! - ! !USES: -#include "shr_assert.h" - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog - use abortutils , only : endrun - use shr_log_mod , only : errMsg => shr_log_errMsg - use spmdMod , only : masterproc - ! - ! !PUBLIC TYPES: - implicit none - private - save - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: check_sums_equal_1 ! Confirm that sum(arr(n,:)) == 1 for all n - public :: renormalize ! Renormalize an array - public :: convert_cft_to_pft ! Conversion of crop CFT to natural veg PFT:w - public :: collapse_crop_types ! Collapse unused crop types into types used in this run - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - subroutine check_sums_equal_1(arr, lb, name, caller, ier) - ! - ! !DESCRIPTION: - ! Confirm that sum(arr(n,:)) == 1 for all n. If this isn't true for any n, abort with a message. - ! - ! !ARGUMENTS: - integer , intent(in) :: lb ! lower bound of the first dimension of arr - real(r8) , intent(in) :: arr(lb:,:) ! array to check - character(len=*), intent(in) :: name ! name of array - character(len=*), intent(in) :: caller ! identifier of caller, for more meaningful error messages - integer, optional, intent(out):: ier ! Return an error code rather than abort - ! - ! !LOCAL VARIABLES: - logical :: found - integer :: nl - integer :: nindx - real(r8), parameter :: eps = 1.e-13_r8 - !----------------------------------------------------------------------- - - if( present(ier) ) ier = 0 - found = .false. - - do nl = lbound(arr, 1), ubound(arr, 1) - if (abs(sum(arr(nl,:)) - 1._r8) > eps) then - found = .true. - nindx = nl - exit - end if - end do - - if (found) then - write(iulog,*) trim(caller), ' ERROR: sum of ', trim(name), ' not 1.0 at nl=', nindx - write(iulog,*) 'sum is: ', sum(arr(nindx,:)) - if( present(ier) ) then - ier = -10 - else - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end subroutine check_sums_equal_1 - - !----------------------------------------------------------------------- - subroutine renormalize(arr, lb, normal) - ! - ! !DESCRIPTION: - ! Re normalize an array so that it sums to the input value - ! - ! !ARGUMENTS: - integer , intent(in) :: lb ! lower bound of the first dimension of arr - real(r8) , intent(inout) :: arr(lb:,:) ! array to check - real(r8) , intent(in) :: normal ! normal to sum to - ! - ! !LOCAL VARIABLES: - integer :: nl ! Array index - real(r8) :: arr_sum ! sum of array - real(r8) :: ratio ! ratio to multiply by - !----------------------------------------------------------------------- - - do nl = lbound(arr, 1), ubound(arr, 1) - arr_sum = sum(arr(nl,:)) - if ( arr_sum /= 0.0_r8 )then - ratio = normal / arr_sum - arr(nl,:) = arr(nl,:) * ratio - end if - end do - - end subroutine renormalize - -!----------------------------------------------------------------------- - subroutine convert_cft_to_pft( begg, endg, cftsize, wt_cft ) - ! - ! !DESCRIPTION: - ! Convert generic crop types that were read in as seperate CFT's on - ! a crop landunit, and put them on the vegetated landunit. - ! !USES: - use clm_instur , only : wt_lunit, wt_nat_patch, fert_cft - use clm_varpar , only : cft_size, natpft_size - use pftconMod , only : nc3crop - use landunit_varcon , only : istsoil, istcrop - ! !ARGUMENTS: - implicit none - integer , intent(in) :: begg, endg - integer , intent(in) :: cftsize ! CFT size - real(r8) , intent(inout) :: wt_cft(begg:,:) ! CFT weights - ! - ! !LOCAL VARIABLES: - integer :: g ! index -!----------------------------------------------------------------------- - SHR_ASSERT_ALL((ubound(wt_cft) == (/endg, cftsize/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(wt_nat_patch) == (/endg, nc3crop+cftsize-1/)), errMsg(sourcefile, __LINE__)) - - do g = begg, endg - if ( wt_lunit(g,istcrop) > 0.0_r8 )then - ! Move CFT over to PFT and do weighted average of the crop and soil parts - wt_nat_patch(g,:) = wt_nat_patch(g,:) * wt_lunit(g,istsoil) - wt_cft(g,:) = wt_cft(g,:) * wt_lunit(g,istcrop) - wt_nat_patch(g,nc3crop:) = wt_cft(g,:) ! Add crop CFT's to end of natural veg PFT's - wt_lunit(g,istsoil) = (wt_lunit(g,istsoil) + wt_lunit(g,istcrop)) ! Add crop landunit to soil landunit - wt_nat_patch(g,:) = wt_nat_patch(g,:) / wt_lunit(g,istsoil) - wt_lunit(g,istcrop) = 0.0_r8 ! Zero out crop CFT's - else - wt_nat_patch(g,nc3crop:) = 0.0_r8 ! Make sure generic crops are zeroed out - end if - end do - - end subroutine convert_cft_to_pft - - !----------------------------------------------------------------------- - subroutine collapse_crop_types(wt_cft, fert_cft, begg, endg, verbose) - ! - ! !DESCRIPTION: - ! Collapse unused crop types into types used in this run. - ! - ! Should only be called if using prognostic crops - otherwise, wt_cft is meaningless - ! - ! !USES: - use clm_varctl , only : irrigate - use clm_varpar , only : cft_lb, cft_ub, cft_size - use pftconMod , only : nc3crop, nc3irrig, npcropmax, pftcon - ! - ! !ARGUMENTS: - - ! Note that we use begg and endg rather than 'bounds', because bounds may not be - ! available yet when this is called - integer, intent(in) :: begg ! Beginning grid cell index - integer, intent(in) :: endg ! Ending grid cell index - - ! Weight and fertilizer of each CFT in each grid cell; dimensioned [g, cft_lb:cft_ub] - ! This array is modified in-place - real(r8), intent(inout) :: wt_cft(begg:, cft_lb:) - real(r8), intent(inout) :: fert_cft(begg:, cft_lb:) - - logical, intent(in) :: verbose ! If true, print some extra information - ! - ! !LOCAL VARIABLES: - integer :: g - integer :: m - real(r8) :: wt_cft_to - real(r8) :: wt_cft_from - real(r8) :: wt_cft_merge - - character(len=*), parameter :: subname = 'collapse_crop_types' - !----------------------------------------------------------------------- - - SHR_ASSERT_ALL((ubound(wt_cft) == (/endg, cft_ub/)), errMsg(sourcefile, __LINE__)) - - if (cft_size <= 0) then - call endrun(msg = subname//' can only be called if cft_size > 0' // & - errMsg(sourcefile, __LINE__)) - end if - - ! ------------------------------------------------------------------------ - ! If not using irrigation, merge irrigated CFTs into rainfed CFTs - ! ------------------------------------------------------------------------ - - if (.not. irrigate) then - if (verbose .and. masterproc) then - write(iulog,*) trim(subname)//' crop=.T. and irrigate=.F., so merging irrigated pfts with rainfed' - end if - - do g = begg, endg - ! Left Hand Side: merged rainfed+irrigated crop pfts from nc3crop to - ! npcropmax-1, stride 2 - ! Right Hand Side: rainfed crop pfts from nc3crop to npcropmax-1, - ! stride 2 - ! plus irrigated crop pfts from nc3irrig to npcropmax, - ! stride 2 - ! where stride 2 means "every other" - wt_cft(g, nc3crop:npcropmax-1:2) = & - wt_cft(g, nc3crop:npcropmax-1:2) + wt_cft(g, nc3irrig:npcropmax:2) - wt_cft(g, nc3irrig:npcropmax:2) = 0._r8 - end do - - call check_sums_equal_1(wt_cft, begg, 'wt_cft', subname//': irrigation') - end if - - ! ------------------------------------------------------------------------ - ! Merge CFTs into the list of crops that CLM knows how to model - ! ------------------------------------------------------------------------ - - if (verbose .and. masterproc) then - write(iulog, *) trim(subname) // ' merging wheat, barley, and rye into temperate cereals' - write(iulog, *) trim(subname) // ' clm knows how to model corn, temperate cereals, and soybean' - write(iulog, *) trim(subname) // ' all other crops are lumped with the generic crop pft' - end if - - do g = begg, endg - do m = 1, npcropmax - if (m /= pftcon%mergetoclmpft(m)) then - wt_cft_to = wt_cft(g, pftcon%mergetoclmpft(m)) - wt_cft_from = wt_cft(g, m) - wt_cft_merge = wt_cft_to + wt_cft_from - wt_cft(g, pftcon%mergetoclmpft(m)) = wt_cft_merge - wt_cft(g, m) = 0._r8 - if (wt_cft_merge > 0._r8) then - fert_cft(g,pftcon%mergetoclmpft(m)) = (wt_cft_to * fert_cft(g,pftcon%mergetoclmpft(m)) + & - wt_cft_from * fert_cft(g,m)) / wt_cft_merge - end if - end if - end do - - end do - - call check_sums_equal_1(wt_cft, begg, 'wt_cft', subname//': mergetoclmpft') - - end subroutine collapse_crop_types - - -end module surfrdUtilsMod diff --git a/src/soilbiogeochem/SoilBiogeochemCarbonFluxType.F90 b/src/soilbiogeochem/SoilBiogeochemCarbonFluxType.F90 deleted file mode 100644 index d4d29625..00000000 --- a/src/soilbiogeochem/SoilBiogeochemCarbonFluxType.F90 +++ /dev/null @@ -1,825 +0,0 @@ -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 - use clm_varpar , only : nlevdecomp_full, nlevgrnd, nlevdecomp, nlevsoi - use clm_varcon , only : spval, ispval, dzsoi_decomp - use landunit_varcon , only : istsoil, istcrop, istdlak - use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con - use ColumnType , only : col - use LandunitType , only : lun - use clm_varctl , only : use_fates - - ! - ! !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) - 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 - - 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 - !------------------------------------------------------------------------ - - 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_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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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 ! 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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 - - 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/src/soilbiogeochem/SoilBiogeochemCarbonStateType.F90 b/src/soilbiogeochem/SoilBiogeochemCarbonStateType.F90 deleted file mode 100644 index 7d2c814a..00000000 --- a/src/soilbiogeochem/SoilBiogeochemCarbonStateType.F90 +++ /dev/null @@ -1,942 +0,0 @@ -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 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 - ! - ! !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 :: 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 - - contains - - procedure , public :: Init - procedure , public :: SetValues - procedure , public :: Restart - procedure , public :: Summary - procedure , public :: SetTotVgCThresh - 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 - - 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 - - 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 - - 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, default='inactive') - 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, default='inactive') - - 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 - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - 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 - - 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 - - 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, default='inactive') - - 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, default='inactive') - - 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 - - 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 - - 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, default='inactive') - - 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, default='inactive') - - 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) - - 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) - else - this%decomp_cpools_vr_col(c,j,k) = 0._r8 - 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 - 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) - - 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 - 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 - 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 - end do - - endif - 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 - 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. - ! flags for comparing the model and restart decomposition cascades - integer :: decomp_cascade_state, restart_file_decomp_cascade_state - !------------------------------------------------------------------------ - - 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_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) - 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 - 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 - end do - end do - end if - end do - - 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) - 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 - 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 - end do - end do - end if - end do - - 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 - 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 - end do - end do - end do - - 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 - 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) - 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 - - ! 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 - -end module SoilBiogeochemCarbonStateType diff --git a/src/soilbiogeochem/SoilBiogeochemDecompCascadeBGCMod.F90 b/src/soilbiogeochem/SoilBiogeochemDecompCascadeBGCMod.F90 deleted file mode 100644 index e636fd30..00000000 --- a/src/soilbiogeochem/SoilBiogeochemDecompCascadeBGCMod.F90 +++ /dev/null @@ -1,578 +0,0 @@ -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_vertsoilc, use_fates - use clm_varcon , only : zsoi - use decompMod , only : bounds_type - use spmdMod , only : masterproc - use abortutils , only : endrun - use CNSharedParamsMod , only : CNParamsShareInst, anoxia_wtsat, 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 CanopyStateType , only : canopystate_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 :: readParams ! Read in parameters from params file - public :: init_decompcascade_bgc ! Initialization - ! - ! !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 ! turnover time of litter 1 (yr) - real(r8):: tau_l2_l3_bgc ! turnover time of litter 2 and litter 3 (yr) - real(r8):: tau_s1_bgc ! turnover time of SOM 1 (yr) - real(r8):: tau_s2_bgc ! turnover time of SOM 2 (yr) - real(r8):: tau_s3_bgc ! turnover time of SOM 3 (yr) - real(r8):: tau_cwd_bgc ! corrected fragmentation rate constant CWD - - 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 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: - use clm_time_manager , only : get_step_size - ! - ! !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_step_name => decomp_cascade_con%cascade_step_name , & ! Output: [character(len=8) (:) ] name of transition - 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 - decomp_pool_name_restart => decomp_cascade_con%decomp_pool_name_restart , & ! Output: [character(len=8) (:) ] name of pool for restart files - decomp_pool_name_history => decomp_cascade_con%decomp_pool_name_history , & ! Output: [character(len=8) (:) ] name of pool for history files - decomp_pool_name_long => decomp_cascade_con%decomp_pool_name_long , & ! Output: [character(len=20) (:) ] name of pool for netcdf long names - decomp_pool_name_short => decomp_cascade_con%decomp_pool_name_short , & ! Output: [character(len=8) (:) ] name of pool for netcdf short names - 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_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. - - 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. - - 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. - - if (.not. use_fates) then - ! CWD - 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) = 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_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) = 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_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) = 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_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) = 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 - 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 - 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 - 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 - 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) - - i_s1s3 = 5 - 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 - 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 - 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 - 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 - 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 - 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 - - deallocate(rf_s1s2) - deallocate(rf_s1s3) - deallocate(f_s1s2) - deallocate(f_s1s3) - - end associate - - end subroutine init_decompcascade_bgc - -end module SoilBiogeochemDecompCascadeBGCMod diff --git a/src/soilbiogeochem/SoilBiogeochemDecompCascadeCNMod.F90 b/src/soilbiogeochem/SoilBiogeochemDecompCascadeCNMod.F90 deleted file mode 100644 index 2c4d3b18..00000000 --- a/src/soilbiogeochem/SoilBiogeochemDecompCascadeCNMod.F90 +++ /dev/null @@ -1,894 +0,0 @@ -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_vertsoilc, use_fates - use clm_varcon , only : zsoi - use decompMod , only : bounds_type - use abortutils , only : endrun - use CNSharedParamsMod , only : CNParamsShareInst, anoxia_wtsat, 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 CanopyStateType , only : canopystate_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 - ! - ! !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_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 - !----------------------------------------------------------------------- - - 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_step_name => decomp_cascade_con%cascade_step_name , & ! Output: [character(len=8) (:) ] name of transition - 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 - decomp_pool_name_restart => decomp_cascade_con%decomp_pool_name_restart , & ! Output: [character(len=8) (:) ] name of pool for restart files - decomp_pool_name_history => decomp_cascade_con%decomp_pool_name_history , & ! Output: [character(len=8) (:) ] name of pool for history files - decomp_pool_name_long => decomp_cascade_con%decomp_pool_name_long , & ! Output: [character(len=20) (:) ] name of pool for netcdf long names - decomp_pool_name_short => decomp_cascade_con%decomp_pool_name_short , & ! Output: [character(len=8) (:) ] name of pool for netcdf short names - 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_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. - - if (.not. use_fates) then - 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. - end if - - if ( .not. use_fates ) then - i_soil1 = 5 - else - i_soil1 = 4 - endif - 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. - - if ( .not. use_fates ) then - i_soil2 = 6 - else - i_soil2 = 5 - endif - 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. - - if ( .not. use_fates ) then - i_soil3 = 7 - else - i_soil3 = 6 - endif - 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. - - if ( .not. use_fates ) then - i_soil4 = 8 - else - i_soil4 = 7 - endif - 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 - 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 - 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 - 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 - 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 - - i_s1s2 = 4 - 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 - 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 - 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 - 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 - 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 - 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 associate - - end subroutine init_decompcascade_cn - - !----------------------------------------------------------------------- - subroutine decomp_rate_constants_cn(bounds, & - num_soilc, filter_soilc, & - canopystate_inst, 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 - 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(canopystate_type) , intent(in) :: canopystate_inst - 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) - - alt_indx => canopystate_inst%alt_indx_col , & ! Input: [integer (:) ] current depth of thaw - - 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) - ) - - mino2lim = CNParamsShareInst%mino2lim - - ! 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=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 10.0. - - 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 - - o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 - - 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 - - o_scalar(bounds%begc:bounds%endc,1:nlevdecomp) = 1._r8 - - 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 - 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 - 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 - 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 - end do - end do - end if - end if - - end associate - - end subroutine decomp_rate_constants_cn - - end module SoilBiogeochemDecompCascadeCNMod diff --git a/src/soilbiogeochem/SoilBiogeochemDecompCascadeConType.F90 b/src/soilbiogeochem/SoilBiogeochemDecompCascadeConType.F90 deleted file mode 100644 index 8a8e2f8d..00000000 --- a/src/soilbiogeochem/SoilBiogeochemDecompCascadeConType.F90 +++ /dev/null @@ -1,104 +0,0 @@ -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 - ! - implicit none - private - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: init_decomp_cascade_constants - ! - 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 - end type decomp_cascade_type - - type(decomp_cascade_type), public :: decomp_cascade_con - !------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------ - subroutine init_decomp_cascade_constants() - ! - ! !DESCRIPTION: - ! Initialize decomposition cascade state - !------------------------------------------------------------------------ - - !-- 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)) - - ! NOTE(bja, 2015-10) according to Dave Lawrence and Charlie Koven, - ! the indexing of decomposing pools from 0:ndecomp_pools is a - ! bug. The lower bound should be 1. The index zero data shouldn't - ! be used. - - !-- 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(1: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 - - !-- first initialization of 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%initial_stock_soildepth = 0.3 - 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(1:ndecomp_pools) = nan - - end subroutine init_decomp_cascade_constants - -end module SoilBiogeochemDecompCascadeConType diff --git a/src/soilbiogeochem/SoilBiogeochemDecompMod.F90 b/src/soilbiogeochem/SoilBiogeochemDecompMod.F90 deleted file mode 100644 index 7906d8a8..00000000 --- a/src/soilbiogeochem/SoilBiogeochemDecompMod.F90 +++ /dev/null @@ -1,245 +0,0 @@ -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_fates - 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: - ! - ! !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 - integer, parameter :: i_atm = 0 !TODO - this appears in two places - move it to 1 - ! 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((ubound(cn_decomp_pools) == (/endc,nlevdecomp,ndecomp_pools/)) , errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(p_decomp_cpool_loss) == (/endc,nlevdecomp,ndecomp_cascade_transitions/)) , errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(pmnf_decomp_cascade) == (/endc,nlevdecomp,ndecomp_cascade_transitions/)) , errMsg(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 - ) - - ! 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 (.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 - - - ! 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/src/soilbiogeochem/SoilBiogeochemLittVertTranspMod.F90 b/src/soilbiogeochem/SoilBiogeochemLittVertTranspMod.F90 deleted file mode 100644 index c9482667..00000000 --- a/src/soilbiogeochem/SoilBiogeochemLittVertTranspMod.F90 +++ /dev/null @@ -1,494 +0,0 @@ -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, spinup_state, use_vertsoilc, use_fates, use_cn - use clm_varcon , only : secspday - use decompMod , only : bounds_type - use abortutils , only : endrun - use CanopyStateType , only : canopystate_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__)) - !soilbiogeochem_litt_verttransp_params_inst%som_diffus=tempr - ! FIX(SPM,032414) - can't be pulled out since division makes things not bfb - params_inst%som_diffus = 1e-4_r8 / (secspday * 365._r8) - - 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__)) - !soilbiogeochem_litt_verttransp_params_inst%cryoturb_diffusion_k=tempr - !FIX(SPM,032414) Todo. This constant cannot be on file since the divide makes things - !SPM Todo. This constant cannot be on file since the divide makes things - !not bfb - params_inst%cryoturb_diffusion_k = 5e-4_r8 / (secspday * 365._r8) ! [m^2/sec] = 5 cm^2 / yr = 1m^2 / 200 yr - - 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, & - canopystate_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 - 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(canopystate_type) , intent(in) :: canopystate_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 ! 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) - !----------------------------------------------------------------------- - - ! 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 => canopystate_inst%altmax_col , & ! Input: [real(r8) (:) ] maximum annual depth of thaw - altmax_lastyear => canopystate_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) - ) - - !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() - - ntype = 2 - 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 - 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 - endif - case (3) - write(iulog,*) 'error. ncase = 4, but c13 and c14 not both enabled.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case (4) - write(iulog,*) 'error. ncase = 4, but c13 and c14 not both enabled.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - if (use_vertsoilc) then - - do s = 1, ndecomp_pools - - if ( .not. is_cwd(s) ) 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 - - - ! 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 < 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(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 - ! 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) - 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 - - 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 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/src/soilbiogeochem/SoilBiogeochemNLeachingMod.F90 b/src/soilbiogeochem/SoilBiogeochemNLeachingMod.F90 deleted file mode 100644 index 3a0cb0c9..00000000 --- a/src/soilbiogeochem/SoilBiogeochemNLeachingMod.F90 +++ /dev/null @@ -1,289 +0,0 @@ -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 WaterStateType , only : waterstate_type - use WaterFluxType , only : waterflux_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, & - waterstate_inst, waterflux_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 - ! - ! !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(waterstate_type) , intent(in) :: waterstate_inst - type(waterflux_type) , intent(in) :: waterflux_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 => waterstate_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd) - - qflx_drain => waterflux_inst%qflx_drain_col , & ! Input: [real(r8) (:) ] sub-surface runoff (mm H2O /s) - qflx_surf => waterflux_inst%qflx_surf_col , & ! Input: [real(r8) (:) ] 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 = real( get_step_size(), r8 ) - - 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/src/soilbiogeochem/SoilBiogeochemNitrifDenitrifMod.F90 b/src/soilbiogeochem/SoilBiogeochemNitrifDenitrifMod.F90 deleted file mode 100644 index 08bbac92..00000000 --- a/src/soilbiogeochem/SoilBiogeochemNitrifDenitrifMod.F90 +++ /dev/null @@ -1,337 +0,0 @@ -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 abortutils , only : endrun - use decompMod , only : bounds_type - use SoilStatetype , only : soilstate_type - use WaterStateType , only : waterstate_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 ! maximum nitrification rate constant (1/s) - 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 - - end subroutine readParams - - !----------------------------------------------------------------------- - subroutine SoilBiogeochemNitrifDenitrif(bounds, num_soilc, filter_soilc, & - soilstate_inst, waterstate_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, get_step_size - use CNSharedParamsMod , only : anoxia_wtsat, 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(waterstate_type) , intent(in) :: waterstate_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 => waterstate_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (nlevgrnd) - h2osoi_liq => waterstate_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 => params_inst%k_nitr_max , & ! Input: - - 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 - - ! 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__) ) - - - !---------------- 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)/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) > 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) - - ! 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/src/soilbiogeochem/SoilBiogeochemNitrogenFluxType.F90 b/src/soilbiogeochem/SoilBiogeochemNitrogenFluxType.F90 deleted file mode 100644 index cf962de9..00000000 --- a/src/soilbiogeochem/SoilBiogeochemNitrogenFluxType.F90 +++ /dev/null @@ -1,1099 +0,0 @@ -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 - use clm_varpar , only : nlevdecomp_full, nlevdecomp - 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 CNSharedParamsMod , only : use_fun - use SoilBiogeochemDecompCascadeConType , only : decomp_cascade_con - use abortutils , only : endrun - use LandunitType , only : lun - use ColumnType , only : col - ! - ! !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) - contains - - procedure , public :: Init - procedure , public :: Restart - procedure , public :: SetValues - 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 -! integer :: begp,endp - !------------------------------------------------------------------------ - - begc = bounds%begc; endc = bounds%endc -! begp = bounds%begp; endp = bounds%endp - 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 - - 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 - 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, default='inactive') - - 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='inactive') - - 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='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - 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, default='inactive') - 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, default='inactive') - 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, default='inactive') - 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, default='inactive') - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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 Restart (this, bounds, ncid, flag ) - ! - ! !DESCRIPTION: - ! Read/write CN restart data for carbon state - ! - ! !USES: - use restUtilMod - use ncdio_pio - ! - ! !ARGUMENTS: - class(soilbiogeochem_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_nitrif_denitrif) then - ! pot_f_nit_vr - if (use_vertsoilc) then - ptr2d => this%pot_f_nit_vr_col(:,:) - call restartvar(ncid=ncid, flag=flag, varname='pot_f_nit_vr_vr', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='potential soil nitrification flux', units='gN/m3/s', & - interpinic_flag='interp', readvar=readvar, data=ptr2d) - else - ptr1d => this%pot_f_nit_vr_col(:,1) - call restartvar(ncid=ncid, flag=flag, varname='pot_f_nit_vr', xtype=ncd_double, & - dim1name='column', & - long_name='soil nitrification flux', units='gN/m3/s', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - end if - if (flag=='read' .and. .not. readvar) then - call endrun(msg= 'ERROR:: pot_f_nit_vr'//' is required on an initialization dataset' ) - end if - end if - - if (use_nitrif_denitrif) then - ! f_nit_vr - if (use_vertsoilc) then - ptr2d => this%f_nit_vr_col(:,:) - call restartvar(ncid=ncid, flag=flag, varname='f_nit_vr_vr', xtype=ncd_double, & - dim1name='column', dim2name='levgrnd', switchdim=.true., & - long_name='soil nitrification flux', units='gN/m3/s', & - interpinic_flag='interp', readvar=readvar, data=ptr2d) - else - ptr1d => this%f_nit_vr_col(:,1) - call restartvar(ncid=ncid, flag=flag, varname='f_nit_vr', xtype=ncd_double, & - dim1name='column', & - long_name='soil nitrification flux', units='gN/m3/s', & - interpinic_flag='interp', readvar=readvar, data=ptr1d) - end if - if (flag=='read' .and. .not. readvar) then - call endrun(msg='ERROR:: f_nit_vr'//' is required on an initialization dataset'//& - errMsg(sourcefile, __LINE__)) - end if - end if - - end subroutine Restart - - !----------------------------------------------------------------------- - 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 - - 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 - -end module soilbiogeochemNitrogenFluxType - diff --git a/src/soilbiogeochem/SoilBiogeochemNitrogenStateType.F90 b/src/soilbiogeochem/SoilBiogeochemNitrogenStateType.F90 deleted file mode 100644 index 9403bd6c..00000000 --- a/src/soilbiogeochem/SoilBiogeochemNitrogenStateType.F90 +++ /dev/null @@ -1,717 +0,0 @@ -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 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 - ! - ! !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 :: 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 - - contains - - procedure , public :: Init - procedure , public :: Restart - procedure , public :: SetValues - 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 - - allocate(this%decomp_npools_vr_col(begc:endc,1:nlevdecomp_full,1:ndecomp_pools)); - this%decomp_npools_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_npools_vr_col(begc:endc,:,:) = spval - this%decomp_npools_1m_col(begc:endc,:) = spval - end if - this%decomp_npools_col(begc:endc,:) = spval - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - - 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, default='inactive') - 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, default='inactive') - 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, default='inactive') - - 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, default='inactive') - - 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((ubound(decomp_cpools_col) == (/bounds%endc,ndecomp_pools/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(decomp_cpools_1m_col) == (/bounds%endc,ndecomp_pools/)), errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(decomp_cpools_vr_col) == (/bounds%endc,nlevdecomp_full,ndecomp_pools/)), errMsg(sourcefile, __LINE__)) - - do c = bounds%begc, bounds%endc - l = col%landunit(c) - 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) - end do - this%sminn_vr_col(c,j) = 0._r8 - this%ntrunc_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_npools_vr_col(c,j,k) = 0._r8 - end do - 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) - 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 - logical :: readvar - integer :: idata - logical :: exit_spinup = .false. - logical :: enter_spinup = .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 - !------------------------------------------------------------------------ - - ! 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 (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 - 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 - end do - end do - end do - - end subroutine SetValues - -end module SoilBiogeochemNitrogenStateType diff --git a/src/soilbiogeochem/SoilBiogeochemPotentialMod.F90 b/src/soilbiogeochem/SoilBiogeochemPotentialMod.F90 deleted file mode 100644 index 2349a63f..00000000 --- a/src/soilbiogeochem/SoilBiogeochemPotentialMod.F90 +++ /dev/null @@ -1,266 +0,0 @@ -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 - ! - ! !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 - integer, parameter :: i_atm = 0 !TODO - this appears in two places - move it to 1 - !----------------------------------------------------------------------- - - begc = bounds%begc; endc = bounds%endc - - SHR_ASSERT_ALL((ubound(cn_decomp_pools) == (/endc,nlevdecomp,ndecomp_pools/)) , errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(p_decomp_cpool_loss) == (/endc,nlevdecomp,ndecomp_cascade_transitions/)) , errMsg(sourcefile, __LINE__)) - SHR_ASSERT_ALL((ubound(pmnf_decomp_cascade) == (/endc,nlevdecomp,ndecomp_cascade_transitions/)) , errMsg(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/src/soilbiogeochem/SoilBiogeochemPrecisionControlMod.F90 b/src/soilbiogeochem/SoilBiogeochemPrecisionControlMod.F90 deleted file mode 100644 index c50bbd49..00000000 --- a/src/soilbiogeochem/SoilBiogeochemPrecisionControlMod.F90 +++ /dev/null @@ -1,173 +0,0 @@ -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: - ! - ! !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 = 0.1_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 ) - !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_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 - 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 - - 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 - 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/src/soilbiogeochem/SoilBiogeochemStateType.F90 b/src/soilbiogeochem/SoilBiogeochemStateType.F90 deleted file mode 100644 index 46586ef3..00000000 --- a/src/soilbiogeochem/SoilBiogeochemStateType.F90 +++ /dev/null @@ -1,336 +0,0 @@ -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, default='inactive') - 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, default='inactive') - 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 spmdMod , only : masterproc - use abortutils , only : endrun - 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: - integer, pointer :: temp1d(:) ! temporary - integer :: p,j,c,i ! 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_vertsoilc) then - ptr2d => this%fpi_vr_col - call restartvar(ncid=ncid, flag=flag, varname='fpi_vr', xtype=ncd_double, & - dim1name='column',dim2name='levgrnd', switchdim=.true., & - long_name='fraction of potential immobilization', units='unitless', & - interpinic_flag='interp', readvar=readvar, data=ptr2d) - else - ptr1d => this%fpi_vr_col(:,1) ! nlevdecomp = 1; so treat as 1D variable - call restartvar(ncid=ncid, flag=flag, varname='fpi', xtype=ncd_double, & - dim1name='column', & - long_name='fraction of potential immobilization', units='unitless', & - interpinic_flag='interp' , readvar=readvar, data=ptr1d) - end if - - if (use_vertsoilc) then - ptr2d => this%som_adv_coef_col - call restartvar(ncid=ncid, flag=flag, varname='som_adv_coef_vr', xtype=ncd_double, & - dim1name='column',dim2name='levgrnd', switchdim=.true., & - long_name='SOM advective flux', units='m/s', fill_value=spval, & - interpinic_flag='interp', readvar=readvar, data=ptr2d) - end if - - if (use_vertsoilc) then - ptr2d => this%som_diffus_coef_col - call restartvar(ncid=ncid, flag=flag, varname='som_diffus_coef_vr', xtype=ncd_double, & - dim1name='column',dim2name='levgrnd', switchdim=.true., & - long_name='SOM diffusivity due to bio/cryo-turbation', units='m^2/s', fill_value=spval, & - interpinic_flag='interp', readvar=readvar, data=ptr2d) - end if - - 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/src/soilbiogeochem/SoilBiogeochemVerticalProfileMod.F90 b/src/soilbiogeochem/SoilBiogeochemVerticalProfileMod.F90 deleted file mode 100644 index 94c8c55d..00000000 --- a/src/soilbiogeochem/SoilBiogeochemVerticalProfileMod.F90 +++ /dev/null @@ -1,277 +0,0 @@ -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, & - canopystate_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, maxpatch_pft - use clm_varctl , only : use_vertsoilc, iulog, use_bedrock - use pftconMod , only : noveg, pftcon - use SoilBiogeochemStateType , only : soilbiogeochem_state_type - use CanopyStateType , only : canopystate_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(canopystate_type) , intent(in) :: canopystate_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 => canopystate_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,maxpatch_pft - 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/src/utils/domainMod.F90 b/src/utils/domainMod.F90 index 7cdd62b4..980df227 100644 --- a/src/utils/domainMod.F90 +++ b/src/utils/domainMod.F90 @@ -31,7 +31,6 @@ module domainMod real(r8),pointer :: latc(:) ! latitude of grid cell (deg) real(r8),pointer :: lonc(:) ! longitude of grid cell (deg) real(r8),pointer :: area(:) ! grid cell area (km**2) - integer ,pointer :: pftm(:) ! pft mask: 1=real, 0=fake, -1=notset character*16 :: set ! flag to check if domain is set logical :: decomped ! decomposed locally or global copy end type domain_type @@ -102,7 +101,7 @@ subroutine domain_init(domain,isgrid2d,ni,nj,nbeg,nend,clmlevel) call domain_clean(domain) endif allocate(domain%mask(nb:ne),domain%frac(nb:ne),domain%latc(nb:ne), & - domain%pftm(nb:ne),domain%area(nb:ne),domain%lonc(nb:ne), & + domain%area(nb:ne),domain%lonc(nb:ne), & stat=ier) if (ier /= 0) then call shr_sys_abort('domain_init ERROR: allocate mask, frac, lat, lon, area ') @@ -131,8 +130,6 @@ subroutine domain_init(domain,isgrid2d,ni,nj,nbeg,nend,clmlevel) domain%decomped = .true. endif - domain%pftm = -9999 - end subroutine domain_init !------------------------------------------------------------------------------ !BOP @@ -163,7 +160,7 @@ subroutine domain_clean(domain) write(iulog,*) 'domain_clean: cleaning ',domain%ni,domain%nj endif deallocate(domain%mask,domain%frac,domain%latc, & - domain%lonc,domain%area,domain%pftm, & + domain%lonc,domain%area, & stat=ier) if (ier /= 0) then call shr_sys_abort('domain_clean ERROR: deallocate mask, frac, lat, lon, area ') @@ -222,7 +219,6 @@ subroutine domain_check(domain) write(iulog,*) ' domain_check mask = ',minval(domain%mask),maxval(domain%mask) write(iulog,*) ' domain_check frac = ',minval(domain%frac),maxval(domain%frac) write(iulog,*) ' domain_check area = ',minval(domain%area),maxval(domain%area) - write(iulog,*) ' domain_check pftm = ',minval(domain%pftm),maxval(domain%pftm) write(iulog,*) ' ' endif diff --git a/src/utils/restUtilMod.F90.in b/src/utils/restUtilMod.F90.in index cda77ccd..4c19343a 100644 --- a/src/utils/restUtilMod.F90.in +++ b/src/utils/restUtilMod.F90.in @@ -564,9 +564,6 @@ contains ! gridcell-level field from a patch-, column- or landunit-level field - and maybe ! also set a column-level field from a patch-level field, etc. ! - ! !USES: - use subgridAveMod, only : c2g - ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds type(file_desc_t) , intent(inout) :: ncid ! netcdf file id @@ -582,18 +579,6 @@ contains SHR_ASSERT_ALL((ubound(data_grc) == (/bounds%endg/)), errMsg(sourcefile, __LINE__)) - allocate(data_col(bounds%begc:bounds%endc)) - call ncd_io(varname=trim(varname), data=data_col, & - dim1name='column', & - ncid=ncid, flag='read', readvar=readvar) - - if (readvar) then - call c2g(bounds, data_col, data_grc, & - c2l_scale_type = 'unity', & - l2g_scale_type = 'unity') - end if - - deallocate(data_col) end subroutine set_grc_field_from_col_field !----------------------------------------------------------------------- diff --git a/tools/README b/tools/README new file mode 100644 index 00000000..2efe3a51 --- /dev/null +++ b/tools/README @@ -0,0 +1,29 @@ +$SLIMROOT/tools/README Feb/28/2023 + +SLIM tools for analysis of SLIM history files or + for creation or modification of SLIM input files. + +I. General directory structure: + + $SLIMROOT/tools + mksurdat Create SLIM surface dataset (surdat file) from CTSM + history output files. TOOL NOT AVAILABLE + + modify_input_files Scripts to modify SLIM input files. Currently + there is one available tool and it can modify + SLIM surdat files. + + cime-tools ($CIMEROOT/tools/) (CIMEROOT is ../cime for a SLIM checkout and ../../../cime for a CESM checkout) + $CIMEROOT/mapping/gen_domain_files + gen_domain ------- Create data model domain datasets from SCRIP mapping datasets. + +II. Notes on building/running for each of the above tools: + + Refer to each tool's README for more information. + +III. Create input datasets needed to run SLIM + + 1.) Create surface dataset with mksurdat.ipynb. Detailed instructions here: +/glade/work/slevis/git_slim/surdat_modifier/tools/mksurdat/README.mksurdat + + 2.) Add the new file to XML data or using user_nl_clm (optional) diff --git a/tools/mksurdat/README.mksurdat b/tools/mksurdat/README.mksurdat new file mode 100644 index 00000000..f0d58382 --- /dev/null +++ b/tools/mksurdat/README.mksurdat @@ -0,0 +1,42 @@ +mksurdat is a jupyter notebook tool that generates SLIM surdat files. +It reads pre-averaged ctsm and cpl history files and outputs a SLIM +surdat file. + +Files involved +-------------- +python/slim/mksurdat/mksurdat.ipynb + +Instructions +------------ +To run on Cheyenne/Casper +1) Before starting the jupyter session for the first time, set up your +conda environment: + +> cd /path/to/your_checked_out_ctsm_directory +> ./py_env_create # needed the first time & periodically for environment updates +> conda activate ctsm_pylib +> pip install ipykernel + +Also you need the next line to use nco (netcdf operators) a bit later: +> module load nco + +2) On your browser go here: +https://jupyterhub.hpc.ucar.edu/ + +a) Start default server +b) Launch server +c) Use jupyter's file navigation to get to +your_checked_out_ctsm_directory/python/slim/mksurdat +d) Open mksurdat.ipynb +e) Use the menu to select Kernel --> Change Kernel --> ctsm_pylib +f) In the notebook's second cell, modify the following settings: +- casename +- start_yr +- surfdat_file (not required; tool will work without this file) +g) In the notebook's third cell, find a suggestion for generating +concatenated ctsm and cpl history files using nco + +9) Using the menu, select Run, Run all cells + +10) You should have a new surdat file in the same directory as the .ipynb +file (see Files involved above) in less than a minute diff --git a/tools/modify_input_files/README.surdat_modifier b/tools/modify_input_files/README.surdat_modifier new file mode 100644 index 00000000..82bdfe26 --- /dev/null +++ b/tools/modify_input_files/README.surdat_modifier @@ -0,0 +1,28 @@ +surdat_modifier is a tool that modifies SLIM surdat files. It reads a surface +dataset (surdat file) and outputs a modified copy of the same file. + +SLIM's surdat_modifier used CTSM's fsurdat_modifier as a design template. + +Files involved +-------------- +python/slim/modify_input_files/surdat_modifier.py +python/slim/modify_input_files/modify_surdat.py +tools/modify_input_files/surdat_modifier +tools/modify_input_files/modify_surdat_template.cfg + +Instructions +------------ +To run on Cheyenne/Casper/Izumi +1) (Un)load, execute, and activate the following: +module unload python +module load conda +./py_env_create +conda activate slim_pylib # conda activate ctsm_pylib UNTIL slim separates from ctsm +(Use "deactivate" to reverse the latter.) +2) Copy, then modify the configure file named modify_surdat_template.cfg, which +contains all the arguments needed by the script. +3) Run the script ./surdat_modifier pointing to the copied/modified .cfg file, +e.g. modify_users_copy.cfg +./surdat_modifier modify_users_copy.cfg +See modify_surdat_template.cfg for required and optional settings. +4) Use the --verbose option to see progress output on your screen diff --git a/tools/modify_input_files/modify_surdat_defaults.cfg b/tools/modify_input_files/modify_surdat_defaults.cfg new file mode 100644 index 00000000..c61d3e00 --- /dev/null +++ b/tools/modify_input_files/modify_surdat_defaults.cfg @@ -0,0 +1,25 @@ +[modify_input] + +# ------------------------------------------------------------------------ +# .cfg file with defaults for surdat_modifier. +# ------------------------------------------------------------------------ + +glc_mask = 0 0 0 0 0 0 0 0 0 0 0 0 +alb_gvd = 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 +alb_svd = 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 +alb_gnd = 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 +alb_snd = 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 +alb_gvf = 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 +alb_svf = 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 0.8 +alb_gnf = 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3 +alb_snf = 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 0.6 +bucketdepth = 200 200 200 200 200 200 200 200 200 200 200 200 +emissivity = 1 1 1 1 1 1 1 1 1 1 1 1 +snowmask = 50 50 50 50 50 50 50 50 50 50 50 50 +roughness = 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 0.1 +evap_res = 100 100 100 100 100 100 100 100 100 100 100 100 +soil_type = 0 0 0 0 0 0 0 0 0 0 0 0 +soil_tk_1d = 1.5 1.5 1.5 1.5 1.5 1.5 1.5 1.5 1.5 1.5 1.5 1.5 +soil_cv_1d = 2e6 2e6 2e6 2e6 2e6 2e6 2e6 2e6 2e6 2e6 2e6 2e6 +glc_tk_1d = 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 2.4 +glc_cv_1d = 1.9e6 1.9e6 1.9e6 1.9e6 1.9e6 1.9e6 1.9e6 1.9e6 1.9e6 1.9e6 1.9e6 1.9e6 diff --git a/tools/modify_input_files/modify_surdat_template.cfg b/tools/modify_input_files/modify_surdat_template.cfg new file mode 100644 index 00000000..413d1cbb --- /dev/null +++ b/tools/modify_input_files/modify_surdat_template.cfg @@ -0,0 +1,103 @@ +[modify_input] + +# ------------------------------------------------------------------------ +# .cfg file with inputs for surdat_modifier. +# +# We advise users to make a copy of this file that they can change freely, +# rather than changing this "template" file. +# +# Variables with FILL_THIS_IN must be specified. +# Variables with UNSET may be specified; if not and +# - defaults = False, they will remain unused +# - defaults = True, they will take on default values hardwired in the +# code. Details in comments below. +# Variables with values already set, may be changed to other values. If +# they get omitted, they will obtain the same default values found here. +# ------------------------------------------------------------------------ + +# Path and name of input surface dataset (str) +surdat_in = FILL_THIS_IN + +# Path and name of output surface dataset (str) +surdat_out = FILL_THIS_IN + +# defaults (bool) +# When user wants existing values in surdat to persist in all except the +# variables that they explicitly request to change, then set this to False. +# When user wants default representation of the land by resetting all +# surdat variables, some through this file and others by using hardwired +# defaults, then set this to True. Hardwired values are as follows: +# glc_mask = [0] * self.months +# alb_gvd = [0.2] * self.months +# alb_svd = [0.8] * self.months +# alb_gnd = [0.3] * self.months +# alb_snd = [0.6] * self.months +# alb_gvf = [0.2] * self.months +# alb_svf = [0.8] * self.months +# alb_gnf = [0.3] * self.months +# alb_snf = [0.6] * self.months +# bucketdepth = [200] * self.months +# emissivity = [1] * self.months +# snowmask = [50] * self.months +# roughness = [0.1] * self.months +# evap_res = [100] * self.months +# soil_type = [0] * self.months +# soil_tk_1d = [1.5] * self.months +# soil_cv_1d = [2e6] * self.months +# glc_tk_1d = [2.4] * self.months +# glc_cv_1d = [1.9e6] * self.months +defaults = False + +# Boundaries of user-defined rectangle (float) +# If lat_1 > lat_2, the code creates two rectangles, one in the north and +# one in the south. +# If lon_1 > lon_2, the rectangle wraps around the 0-degree meridian. +# Alternatively, user may specify a custom area in a .nc landmask_file +# below. If set, this will override the lat/lon settings. +# ----------------------------------- +# southernmost latitude for rectangle +lnd_lat_1 = -90 +# northernmost latitude for rectangle +lnd_lat_2 = 90 +# westernmost longitude for rectangle +lnd_lon_1 = 0 +# easternmost longitude for rectangle +lnd_lon_2 = 360 +# User-defined mask in a file, as alternative to setting lat/lon values. +# If set, lat_dimname and lon_dimname should likely also be set. IMPORTANT: +# - lat_dimname and lon_dimname may be left UNSET if they match the expected +# default values 'lsmlat' and 'lsmlon' +landmask_file = UNSET +lat_dimname = UNSET +lon_dimname = UNSET + +# Monthly values over the user-defined mask. +# Space-delimited list of 12 floats or int without brackets +# e.g., glc_mask = 1 1 1 1 1 1 1 1 1 1 1 1 +# Any of the variables updated below by the user will be +# updated in the surdat_out file in the user-defined mask. +# if defaults = True and some of the following variables are UNSET, then they +# will default to the corresponding values listed above in the "defaults" +# comments, again only in the user-defined mask. +# if defaults = False and some of the following variables are UNSET, then they +# will remain unchanged from the surdat_in file. +# SOIL_TYPE accepts integer values from ? to ?. +glc_mask = UNSET +alb_gvd = UNSET +alb_svd = UNSET +alb_gnd = UNSET +alb_snd = UNSET +alb_gvf = UNSET +alb_svf = UNSET +alb_gnf = UNSET +alb_snf = UNSET +bucketdepth = UNSET +emissivity = UNSET +snowmask = UNSET +roughness = UNSET +evap_res = UNSET +soil_type = UNSET +soil_tk_1d = UNSET +soil_cv_1d = UNSET +glc_tk_1d = UNSET +glc_cv_1d = UNSET diff --git a/tools/modify_input_files/surdat_modifier b/tools/modify_input_files/surdat_modifier new file mode 100755 index 00000000..ed36a2b0 --- /dev/null +++ b/tools/modify_input_files/surdat_modifier @@ -0,0 +1,18 @@ +#!/usr/bin/env python3 +""" +For description and instructions, please see README. +""" + +import os +import sys + +_SLIM_PYTHON = os.path.join(os.path.dirname(os.path.realpath(__file__)), + os.pardir, + os.pardir, + 'python') +sys.path.insert(1, _SLIM_PYTHON) + +from slim.modify_input_files.surdat_modifier import main + +if __name__ == "__main__": + main()